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
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.
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
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * Note that during the build of miniperl, a temporary copy of this file
26 * is made, called opmini.c.
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.
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):
44 * newBINOP(OP_ADD, flags,
46 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
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
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:
65 * with the intended execution order being:
67 * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT]
69 * At this point all the nodes' op_next pointers will have been set,
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
84 * [*] => A; A => B; B => [*]
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.
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.
97 * In summary: given a subtree, its top-level node's op_next will either
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
106 Here's an older description from Larry.
108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
112 An execution-order pass
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
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.
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.
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.
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.
164 #include "keywords.h"
167 #include "invlist_inline.h"
169 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
170 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
171 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
173 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
175 /* remove any leading "empty" ops from the op_next chain whose first
176 * node's address is stored in op_p. Store the updated address of the
177 * first node in op_p.
181 S_prune_chain_head(OP** op_p)
184 && ( (*op_p)->op_type == OP_NULL
185 || (*op_p)->op_type == OP_SCOPE
186 || (*op_p)->op_type == OP_SCALAR
187 || (*op_p)->op_type == OP_LINESEQ)
189 *op_p = (*op_p)->op_next;
193 /* See the explanatory comments above struct opslab in op.h. */
195 #ifdef PERL_DEBUG_READONLY_OPS
196 # define PERL_SLAB_SIZE 128
197 # define PERL_MAX_SLAB_SIZE 4096
198 # include <sys/mman.h>
201 #ifndef PERL_SLAB_SIZE
202 # define PERL_SLAB_SIZE 64
204 #ifndef PERL_MAX_SLAB_SIZE
205 # define PERL_MAX_SLAB_SIZE 2048
208 /* rounds up to nearest pointer */
209 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
212 (assert(((char *)(p) - (char *)(o)) % sizeof(I32**) == 0), \
213 ((size_t)((I32 **)(p) - (I32**)(o))))
215 /* requires double parens and aTHX_ */
216 #define DEBUG_S_warn(args) \
218 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
221 /* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
222 #define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OPSLOT)))
224 /* the number of bytes to allocate for a slab with sz * sizeof(I32 **) space for op */
225 #define OpSLABSizeBytes(sz) \
226 ((sz) * sizeof(I32 *) + STRUCT_OFFSET(OPSLAB, opslab_slots))
228 /* malloc a new op slab (suitable for attaching to PL_compcv).
229 * sz is in units of pointers from the beginning of opslab_opslots */
232 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
235 size_t sz_bytes = OpSLABSizeBytes(sz);
237 /* opslot_offset is only U16 */
238 assert(sz < U16_MAX);
239 /* room for at least one op */
240 assert(sz >= OPSLOT_SIZE_BASE);
242 #ifdef PERL_DEBUG_READONLY_OPS
243 slab = (OPSLAB *) mmap(0, sz_bytes,
244 PROT_READ|PROT_WRITE,
245 MAP_ANON|MAP_PRIVATE, -1, 0);
246 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
247 (unsigned long) sz, slab));
248 if (slab == MAP_FAILED) {
249 perror("mmap failed");
253 slab = (OPSLAB *)PerlMemShared_malloc(sz_bytes);
254 Zero(slab, sz_bytes, char);
256 slab->opslab_size = (U16)sz;
259 /* The context is unused in non-Windows */
262 slab->opslab_free_space = sz;
263 slab->opslab_head = head ? head : slab;
264 DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
265 (unsigned int)slab->opslab_size, (void*)slab,
266 (void*)(slab->opslab_head)));
270 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
272 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
274 S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) {
275 U16 sz = OpSLOT(o)->opslot_size;
276 U16 index = OPSLOT_SIZE_TO_INDEX(sz);
278 assert(sz >= OPSLOT_SIZE_BASE);
279 /* make sure the array is large enough to include ops this large */
280 if (!slab->opslab_freed) {
281 /* we don't have a free list array yet, make a new one */
282 slab->opslab_freed_size = index+1;
283 slab->opslab_freed = (OP**)PerlMemShared_calloc((slab->opslab_freed_size), sizeof(OP*));
285 if (!slab->opslab_freed)
288 else if (index >= slab->opslab_freed_size) {
289 /* It's probably not worth doing exponential expansion here, the number of op sizes
292 /* We already have a list that isn't large enough, expand it */
293 size_t newsize = index+1;
294 OP **p = (OP **)PerlMemShared_realloc(slab->opslab_freed, newsize * sizeof(OP*));
299 Zero(p+slab->opslab_freed_size, newsize - slab->opslab_freed_size, OP *);
301 slab->opslab_freed = p;
302 slab->opslab_freed_size = newsize;
305 o->op_next = slab->opslab_freed[index];
306 slab->opslab_freed[index] = o;
309 /* Returns a sz-sized block of memory (suitable for holding an op) from
310 * a free slot in the chain of op slabs attached to PL_compcv.
311 * Allocates a new slab if necessary.
312 * if PL_compcv isn't compiling, malloc() instead.
316 Perl_Slab_Alloc(pTHX_ size_t sz)
318 OPSLAB *head_slab; /* first slab in the chain */
322 size_t sz_in_p; /* size in pointer units, including the OPSLOT header */
324 /* We only allocate ops from the slab during subroutine compilation.
325 We find the slab via PL_compcv, hence that must be non-NULL. It could
326 also be pointing to a subroutine which is now fully set up (CvROOT()
327 pointing to the top of the optree for that sub), or a subroutine
328 which isn't using the slab allocator. If our sanity checks aren't met,
329 don't use a slab, but allocate the OP directly from the heap. */
330 if (!PL_compcv || CvROOT(PL_compcv)
331 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
333 o = (OP*)PerlMemShared_calloc(1, sz);
337 /* While the subroutine is under construction, the slabs are accessed via
338 CvSTART(), to avoid needing to expand PVCV by one pointer for something
339 unneeded at runtime. Once a subroutine is constructed, the slabs are
340 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
341 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
343 if (!CvSTART(PL_compcv)) {
345 (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
346 CvSLABBED_on(PL_compcv);
347 head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
349 else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
351 sz_in_p = SIZE_TO_PSIZE(sz + OPSLOT_HEADER);
353 /* The head slab for each CV maintains a free list of OPs. In particular, constant folding
354 will free up OPs, so it makes sense to re-use them where possible. A
355 freed up slot is used in preference to a new allocation. */
356 if (head_slab->opslab_freed &&
357 OPSLOT_SIZE_TO_INDEX(sz_in_p) < head_slab->opslab_freed_size) {
360 /* look for a large enough size with any freed ops */
361 for (base_index = OPSLOT_SIZE_TO_INDEX(sz_in_p);
362 base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
366 if (base_index < head_slab->opslab_freed_size) {
367 /* found a freed op */
368 o = head_slab->opslab_freed[base_index];
370 DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p",
371 (void *)o, (void *)OpMySLAB(o), (void *)head_slab));
372 head_slab->opslab_freed[base_index] = o->op_next;
379 #define INIT_OPSLOT(s) \
380 slot->opslot_offset = DIFF(&slab2->opslab_slots, slot) ; \
381 slot->opslot_size = s; \
382 slab2->opslab_free_space -= s; \
383 o = &slot->opslot_op; \
386 /* The partially-filled slab is next in the chain. */
387 slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
388 if (slab2->opslab_free_space < sz_in_p) {
389 /* Remaining space is too small. */
390 /* If we can fit a BASEOP, add it to the free chain, so as not
392 if (slab2->opslab_free_space >= OPSLOT_SIZE_BASE) {
393 slot = &slab2->opslab_slots;
394 INIT_OPSLOT(slab2->opslab_free_space);
395 o->op_type = OP_FREED;
396 DEBUG_S_warn((aTHX_ "linked unused op space at %p, slab %p, head slab %p",
397 (void *)o, (void *)slab2, (void *)head_slab));
398 link_freed_op(head_slab, o);
401 /* Create a new slab. Make this one twice as big. */
402 slab2 = S_new_slab(aTHX_ head_slab,
403 slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2
405 : slab2->opslab_size * 2);
406 slab2->opslab_next = head_slab->opslab_next;
407 head_slab->opslab_next = slab2;
409 assert(slab2->opslab_size >= sz_in_p);
411 /* Create a new op slot */
412 slot = OpSLOToff(slab2, slab2->opslab_free_space - sz_in_p);
413 assert(slot >= &slab2->opslab_slots);
414 INIT_OPSLOT(sz_in_p);
415 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
416 (void*)o, (void*)slab2, (void*)head_slab));
419 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
420 assert(!o->op_moresib);
421 assert(!o->op_sibparent);
428 #ifdef PERL_DEBUG_READONLY_OPS
430 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
432 PERL_ARGS_ASSERT_SLAB_TO_RO;
434 if (slab->opslab_readonly) return;
435 slab->opslab_readonly = 1;
436 for (; slab; slab = slab->opslab_next) {
437 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
438 (unsigned long) slab->opslab_size, (void *)slab));*/
439 if (mprotect(slab, OpSLABSizeBytes(slab->opslab_size), PROT_READ))
440 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", (void *)slab,
441 (unsigned long)slab->opslab_size, errno);
446 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
450 PERL_ARGS_ASSERT_SLAB_TO_RW;
452 if (!slab->opslab_readonly) return;
454 for (; slab2; slab2 = slab2->opslab_next) {
455 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
456 (unsigned long) size, (void *)slab2));*/
457 if (mprotect((void *)slab2, OpSLABSizeBytes(slab2->opslab_size),
458 PROT_READ|PROT_WRITE)) {
459 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", (void *)slab,
460 (unsigned long)slab2->opslab_size, errno);
463 slab->opslab_readonly = 0;
467 # define Slab_to_rw(op) NOOP
470 /* make freed ops die if they're inadvertently executed */
475 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
480 /* Return the block of memory used by an op to the free list of
481 * the OP slab associated with that op.
485 Perl_Slab_Free(pTHX_ void *op)
487 OP * const o = (OP *)op;
490 PERL_ARGS_ASSERT_SLAB_FREE;
493 o->op_ppaddr = S_pp_freed;
496 if (!o->op_slabbed) {
498 PerlMemShared_free(op);
503 /* If this op is already freed, our refcount will get screwy. */
504 assert(o->op_type != OP_FREED);
505 o->op_type = OP_FREED;
506 link_freed_op(slab, o);
507 DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p",
508 (void*)o, (void *)OpMySLAB(o), (void*)slab));
509 OpslabREFCNT_dec_padok(slab);
513 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
515 const bool havepad = !!PL_comppad;
516 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
519 PAD_SAVE_SETNULLPAD();
525 /* Free a chain of OP slabs. Should only be called after all ops contained
526 * in it have been freed. At this point, its reference count should be 1,
527 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
528 * and just directly calls opslab_free().
529 * (Note that the reference count which PL_compcv held on the slab should
530 * have been removed once compilation of the sub was complete).
536 Perl_opslab_free(pTHX_ OPSLAB *slab)
539 PERL_ARGS_ASSERT_OPSLAB_FREE;
541 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
542 assert(slab->opslab_refcnt == 1);
543 PerlMemShared_free(slab->opslab_freed);
545 slab2 = slab->opslab_next;
547 slab->opslab_refcnt = ~(size_t)0;
549 #ifdef PERL_DEBUG_READONLY_OPS
550 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
552 if (munmap(slab, OpSLABSizeBytes(slab->opslab_size))) {
553 perror("munmap failed");
557 PerlMemShared_free(slab);
563 /* like opslab_free(), but first calls op_free() on any ops in the slab
564 * not marked as OP_FREED
568 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
572 size_t savestack_count = 0;
574 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
577 OPSLOT *slot = OpSLOToff(slab2, slab2->opslab_free_space);
578 OPSLOT *end = OpSLOToff(slab2, slab2->opslab_size);
580 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
582 if (slot->opslot_op.op_type != OP_FREED
583 && !(slot->opslot_op.op_savefree
589 assert(slot->opslot_op.op_slabbed);
590 op_free(&slot->opslot_op);
591 if (slab->opslab_refcnt == 1) goto free;
594 } while ((slab2 = slab2->opslab_next));
595 /* > 1 because the CV still holds a reference count. */
596 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
598 assert(savestack_count == slab->opslab_refcnt-1);
600 /* Remove the CV’s reference count. */
601 slab->opslab_refcnt--;
608 #ifdef PERL_DEBUG_READONLY_OPS
610 Perl_op_refcnt_inc(pTHX_ OP *o)
613 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
614 if (slab && slab->opslab_readonly) {
627 Perl_op_refcnt_dec(pTHX_ OP *o)
630 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
632 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
634 if (slab && slab->opslab_readonly) {
636 result = --o->op_targ;
639 result = --o->op_targ;
645 * In the following definition, the ", (OP*)0" is just to make the compiler
646 * think the expression is of the right type: croak actually does a Siglongjmp.
648 #define CHECKOP(type,o) \
649 ((PL_op_mask && PL_op_mask[type]) \
650 ? ( op_free((OP*)o), \
651 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
653 : PL_check[type](aTHX_ (OP*)o))
655 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
657 #define OpTYPE_set(o,type) \
659 o->op_type = (OPCODE)type; \
660 o->op_ppaddr = PL_ppaddr[type]; \
664 S_no_fh_allowed(pTHX_ OP *o)
666 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
668 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
674 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
676 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
677 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
682 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
684 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
686 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
691 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
693 PERL_ARGS_ASSERT_BAD_TYPE_PV;
695 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
696 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
700 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
702 SV * const namesv = cv_name((CV *)gv, NULL, 0);
703 PERL_ARGS_ASSERT_BAD_TYPE_GV;
705 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
706 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
710 S_no_bareword_allowed(pTHX_ OP *o)
712 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
714 qerror(Perl_mess(aTHX_
715 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
717 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
721 Perl_no_bareword_filehandle(pTHX_ const char *fhname) {
722 PERL_ARGS_ASSERT_NO_BAREWORD_FILEHANDLE;
724 if (strNE(fhname, "STDERR")
725 && strNE(fhname, "STDOUT")
726 && strNE(fhname, "STDIN")
727 && strNE(fhname, "_")
728 && strNE(fhname, "ARGV")
729 && strNE(fhname, "ARGVOUT")
730 && strNE(fhname, "DATA")) {
731 qerror(Perl_mess(aTHX_ "Bareword filehandle \"%s\" not allowed under 'no feature \"bareword_filehandles\"'", fhname));
735 /* "register" allocation */
738 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
741 bool is_idfirst, is_default;
742 const bool is_our = (PL_parser->in_my == KEY_our);
744 PERL_ARGS_ASSERT_ALLOCMY;
746 if (flags & ~SVf_UTF8)
747 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
750 is_idfirst = flags & SVf_UTF8
751 ? isIDFIRST_utf8_safe((U8*)name + 1, name + len)
752 : isIDFIRST_A(name[1]);
755 is_default = len == 2 && name[1] == '_';
757 /* complain about "my $<special_var>" etc etc */
758 if (!is_our && (!is_idfirst || is_default)) {
759 const char * const type =
760 PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
761 PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
763 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
765 && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) {
766 /* diag_listed_as: Can't use global %s in %s */
767 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
768 name[0], toCTRL(name[1]),
769 (int)(len - 2), name + 2,
772 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
774 type), flags & SVf_UTF8);
778 /* allocate a spare slot and store the name in that slot */
780 off = pad_add_name_pvn(name, len,
781 (is_our ? padadd_OUR :
782 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
783 PL_parser->in_my_stash,
785 /* $_ is always in main::, even with our */
786 ? (PL_curstash && !memEQs(name,len,"$_")
792 /* anon sub prototypes contains state vars should always be cloned,
793 * otherwise the state var would be shared between anon subs */
795 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
796 CvCLONE_on(PL_compcv);
802 =for apidoc_section $optree_manipulation
804 =for apidoc alloccopstash
806 Available only under threaded builds, this function allocates an entry in
807 C<PL_stashpad> for the stash passed to it.
814 Perl_alloccopstash(pTHX_ HV *hv)
816 PADOFFSET off = 0, o = 1;
817 bool found_slot = FALSE;
819 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
821 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
823 for (; o < PL_stashpadmax; ++o) {
824 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
825 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
826 found_slot = TRUE, off = o;
829 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
830 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
831 off = PL_stashpadmax;
832 PL_stashpadmax += 10;
835 PL_stashpad[PL_stashpadix = off] = hv;
840 /* free the body of an op without examining its contents.
841 * Always use this rather than FreeOp directly */
844 S_op_destroy(pTHX_ OP *o)
854 Free an op and its children. Only use this when an op is no longer linked
861 Perl_op_free(pTHX_ OP *o)
866 bool went_up = FALSE; /* whether we reached the current node by
867 following the parent pointer from a child, and
868 so have already seen this node */
870 if (!o || o->op_type == OP_FREED)
873 if (o->op_private & OPpREFCOUNTED) {
874 /* if base of tree is refcounted, just decrement */
875 switch (o->op_type) {
885 refcnt = OpREFCNT_dec(o);
888 /* Need to find and remove any pattern match ops from
889 * the list we maintain for reset(). */
890 find_and_forget_pmops(o);
903 /* free child ops before ourself, (then free ourself "on the
906 if (!went_up && o->op_flags & OPf_KIDS) {
907 next_op = cUNOPo->op_first;
911 /* find the next node to visit, *then* free the current node
912 * (can't rely on o->op_* fields being valid after o has been
915 /* The next node to visit will be either the sibling, or the
916 * parent if no siblings left, or NULL if we've worked our way
917 * back up to the top node in the tree */
918 next_op = (o == top_op) ? NULL : o->op_sibparent;
919 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
921 /* Now process the current node */
923 /* Though ops may be freed twice, freeing the op after its slab is a
925 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
926 /* During the forced freeing of ops after compilation failure, kidops
927 may be freed before their parents. */
928 if (!o || o->op_type == OP_FREED)
933 /* an op should only ever acquire op_private flags that we know about.
934 * If this fails, you may need to fix something in regen/op_private.
935 * Don't bother testing if:
936 * * the op_ppaddr doesn't match the op; someone may have
937 * overridden the op and be doing strange things with it;
938 * * we've errored, as op flags are often left in an
939 * inconsistent state then. Note that an error when
940 * compiling the main program leaves PL_parser NULL, so
941 * we can't spot faults in the main code, only
942 * evaled/required code;
943 * * it's a banned op - we may be croaking before the op is
944 * fully formed. - see CHECKOP. */
946 if ( o->op_ppaddr == PL_ppaddr[type]
948 && !PL_parser->error_count
949 && !(PL_op_mask && PL_op_mask[type])
952 assert(!(o->op_private & ~PL_op_private_valid[type]));
957 /* Call the op_free hook if it has been set. Do it now so that it's called
958 * at the right time for refcounted ops, but still before all of the kids
963 type = (OPCODE)o->op_targ;
966 Slab_to_rw(OpSLAB(o));
968 /* COP* is not cleared by op_clear() so that we may track line
969 * numbers etc even after null() */
970 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
982 /* S_op_clear_gv(): free a GV attached to an OP */
986 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
988 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
992 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
993 || o->op_type == OP_MULTIDEREF)
996 ? ((GV*)PAD_SVl(*ixp)) : NULL;
998 ? (GV*)(*svp) : NULL;
1000 /* It's possible during global destruction that the GV is freed
1001 before the optree. Whilst the SvREFCNT_inc is happy to bump from
1002 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
1003 will trigger an assertion failure, because the entry to sv_clear
1004 checks that the scalar is not already freed. A check of for
1005 !SvIS_FREED(gv) turns out to be invalid, because during global
1006 destruction the reference count can be forced down to zero
1007 (with SVf_BREAK set). In which case raising to 1 and then
1008 dropping to 0 triggers cleanup before it should happen. I
1009 *think* that this might actually be a general, systematic,
1010 weakness of the whole idea of SVf_BREAK, in that code *is*
1011 allowed to raise and lower references during global destruction,
1012 so any *valid* code that happens to do this during global
1013 destruction might well trigger premature cleanup. */
1014 bool still_valid = gv && SvREFCNT(gv);
1017 SvREFCNT_inc_simple_void(gv);
1020 pad_swipe(*ixp, TRUE);
1028 int try_downgrade = SvREFCNT(gv) == 2;
1029 SvREFCNT_dec_NN(gv);
1031 gv_try_downgrade(gv);
1037 Perl_op_clear(pTHX_ OP *o)
1041 PERL_ARGS_ASSERT_OP_CLEAR;
1043 switch (o->op_type) {
1044 case OP_NULL: /* Was holding old type, if any. */
1047 case OP_ENTEREVAL: /* Was holding hints. */
1048 case OP_ARGDEFELEM: /* Was holding signature index. */
1052 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1059 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1061 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1064 case OP_METHOD_REDIR:
1065 case OP_METHOD_REDIR_SUPER:
1067 if (cMETHOPx(o)->op_rclass_targ) {
1068 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1069 cMETHOPx(o)->op_rclass_targ = 0;
1072 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1073 cMETHOPx(o)->op_rclass_sv = NULL;
1076 case OP_METHOD_NAMED:
1077 case OP_METHOD_SUPER:
1078 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1079 cMETHOPx(o)->op_u.op_meth_sv = NULL;
1082 pad_swipe(o->op_targ, 1);
1089 SvREFCNT_dec(cSVOPo->op_sv);
1090 cSVOPo->op_sv = NULL;
1093 Even if op_clear does a pad_free for the target of the op,
1094 pad_free doesn't actually remove the sv that exists in the pad;
1095 instead it lives on. This results in that it could be reused as
1096 a target later on when the pad was reallocated.
1099 pad_swipe(o->op_targ,1);
1109 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1114 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1115 && (o->op_private & OPpTRANS_USE_SVOP))
1118 if (cPADOPo->op_padix > 0) {
1119 pad_swipe(cPADOPo->op_padix, TRUE);
1120 cPADOPo->op_padix = 0;
1123 SvREFCNT_dec(cSVOPo->op_sv);
1124 cSVOPo->op_sv = NULL;
1128 PerlMemShared_free(cPVOPo->op_pv);
1129 cPVOPo->op_pv = NULL;
1133 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1137 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1138 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1140 if (o->op_private & OPpSPLIT_LEX)
1141 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1144 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1146 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1153 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1154 op_free(cPMOPo->op_code_list);
1155 cPMOPo->op_code_list = NULL;
1156 forget_pmop(cPMOPo);
1157 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1158 /* we use the same protection as the "SAFE" version of the PM_ macros
1159 * here since sv_clean_all might release some PMOPs
1160 * after PL_regex_padav has been cleared
1161 * and the clearing of PL_regex_padav needs to
1162 * happen before sv_clean_all
1165 if(PL_regex_pad) { /* We could be in destruction */
1166 const IV offset = (cPMOPo)->op_pmoffset;
1167 ReREFCNT_dec(PM_GETRE(cPMOPo));
1168 PL_regex_pad[offset] = &PL_sv_undef;
1169 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1173 ReREFCNT_dec(PM_GETRE(cPMOPo));
1174 PM_SETRE(cPMOPo, NULL);
1180 PerlMemShared_free(cUNOP_AUXo->op_aux);
1183 case OP_MULTICONCAT:
1185 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1186 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1187 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1188 * utf8 shared strings */
1189 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1190 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1192 PerlMemShared_free(p1);
1194 PerlMemShared_free(p2);
1195 PerlMemShared_free(aux);
1201 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1202 UV actions = items->uv;
1204 bool is_hash = FALSE;
1207 switch (actions & MDEREF_ACTION_MASK) {
1210 actions = (++items)->uv;
1213 case MDEREF_HV_padhv_helem:
1216 case MDEREF_AV_padav_aelem:
1217 pad_free((++items)->pad_offset);
1220 case MDEREF_HV_gvhv_helem:
1223 case MDEREF_AV_gvav_aelem:
1225 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1227 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1231 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1234 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1236 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1238 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1240 goto do_vivify_rv2xv_elem;
1242 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1245 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1246 pad_free((++items)->pad_offset);
1247 goto do_vivify_rv2xv_elem;
1249 case MDEREF_HV_pop_rv2hv_helem:
1250 case MDEREF_HV_vivify_rv2hv_helem:
1253 do_vivify_rv2xv_elem:
1254 case MDEREF_AV_pop_rv2av_aelem:
1255 case MDEREF_AV_vivify_rv2av_aelem:
1257 switch (actions & MDEREF_INDEX_MASK) {
1258 case MDEREF_INDEX_none:
1261 case MDEREF_INDEX_const:
1265 pad_swipe((++items)->pad_offset, 1);
1267 SvREFCNT_dec((++items)->sv);
1273 case MDEREF_INDEX_padsv:
1274 pad_free((++items)->pad_offset);
1276 case MDEREF_INDEX_gvsv:
1278 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1280 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1285 if (actions & MDEREF_FLAG_last)
1298 actions >>= MDEREF_SHIFT;
1301 /* start of malloc is at op_aux[-1], where the length is
1303 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1308 if (o->op_targ > 0) {
1309 pad_free(o->op_targ);
1315 S_cop_free(pTHX_ COP* cop)
1317 PERL_ARGS_ASSERT_COP_FREE;
1319 /* If called during global destruction PL_defstash might be NULL and there
1320 shouldn't be any code running that will trip over the bad cop address.
1321 This also avoids uselessly creating the AV after it's been destroyed.
1323 if (cop->op_type == OP_DBSTATE && PL_phase != PERL_PHASE_DESTRUCT) {
1324 /* Remove the now invalid op from the line number information.
1325 This could cause a freed memory overwrite if the debugger tried to
1326 set a breakpoint on this line.
1328 AV *av = CopFILEAVn(cop);
1330 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
1331 if (svp && *svp != &PL_sv_undef && SvIVX(*svp) == PTR2IV(cop) ) {
1332 (void)SvIOK_off(*svp);
1338 if (! specialWARN(cop->cop_warnings))
1339 PerlMemShared_free(cop->cop_warnings);
1340 cophh_free(CopHINTHASH_get(cop));
1341 if (PL_curcop == cop)
1346 S_forget_pmop(pTHX_ PMOP *const o)
1348 HV * const pmstash = PmopSTASH(o);
1350 PERL_ARGS_ASSERT_FORGET_PMOP;
1352 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1353 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1355 PMOP **const array = (PMOP**) mg->mg_ptr;
1356 U32 count = mg->mg_len / sizeof(PMOP**);
1360 if (array[i] == o) {
1361 /* Found it. Move the entry at the end to overwrite it. */
1362 array[i] = array[--count];
1363 mg->mg_len = count * sizeof(PMOP**);
1364 /* Could realloc smaller at this point always, but probably
1365 not worth it. Probably worth free()ing if we're the
1368 Safefree(mg->mg_ptr);
1382 S_find_and_forget_pmops(pTHX_ OP *o)
1386 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1389 switch (o->op_type) {
1394 forget_pmop((PMOP*)o);
1397 if (o->op_flags & OPf_KIDS) {
1398 o = cUNOPo->op_first;
1404 return; /* at top; no parents/siblings to try */
1405 if (OpHAS_SIBLING(o)) {
1406 o = o->op_sibparent; /* process next sibling */
1409 o = o->op_sibparent; /*try parent's next sibling */
1418 Neutralizes an op when it is no longer needed, but is still linked to from
1425 Perl_op_null(pTHX_ OP *o)
1428 PERL_ARGS_ASSERT_OP_NULL;
1430 if (o->op_type == OP_NULL)
1433 o->op_targ = o->op_type;
1434 OpTYPE_set(o, OP_NULL);
1438 =for apidoc op_refcnt_lock
1440 Implements the C<OP_REFCNT_LOCK> macro which you should use instead.
1446 Perl_op_refcnt_lock(pTHX)
1447 PERL_TSA_ACQUIRE(PL_op_mutex)
1449 PERL_UNUSED_CONTEXT;
1454 =for apidoc op_refcnt_unlock
1456 Implements the C<OP_REFCNT_UNLOCK> macro which you should use instead.
1462 Perl_op_refcnt_unlock(pTHX)
1463 PERL_TSA_RELEASE(PL_op_mutex)
1465 PERL_UNUSED_CONTEXT;
1471 =for apidoc op_sibling_splice
1473 A general function for editing the structure of an existing chain of
1474 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1475 you to delete zero or more sequential nodes, replacing them with zero or
1476 more different nodes. Performs the necessary op_first/op_last
1477 housekeeping on the parent node and op_sibling manipulation on the
1478 children. The last deleted node will be marked as the last node by
1479 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1481 Note that op_next is not manipulated, and nodes are not freed; that is the
1482 responsibility of the caller. It also won't create a new list op for an
1483 empty list etc; use higher-level functions like op_append_elem() for that.
1485 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1486 the splicing doesn't affect the first or last op in the chain.
1488 C<start> is the node preceding the first node to be spliced. Node(s)
1489 following it will be deleted, and ops will be inserted after it. If it is
1490 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1493 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1494 If -1 or greater than or equal to the number of remaining kids, all
1495 remaining kids are deleted.
1497 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1498 If C<NULL>, no nodes are inserted.
1500 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1505 action before after returns
1506 ------ ----- ----- -------
1509 splice(P, A, 2, X-Y-Z) | | B-C
1513 splice(P, NULL, 1, X-Y) | | A
1517 splice(P, NULL, 3, NULL) | | A-B-C
1521 splice(P, B, 0, X-Y) | | NULL
1525 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1526 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1532 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1536 OP *last_del = NULL;
1537 OP *last_ins = NULL;
1540 first = OpSIBLING(start);
1544 first = cLISTOPx(parent)->op_first;
1546 assert(del_count >= -1);
1548 if (del_count && first) {
1550 while (--del_count && OpHAS_SIBLING(last_del))
1551 last_del = OpSIBLING(last_del);
1552 rest = OpSIBLING(last_del);
1553 OpLASTSIB_set(last_del, NULL);
1560 while (OpHAS_SIBLING(last_ins))
1561 last_ins = OpSIBLING(last_ins);
1562 OpMAYBESIB_set(last_ins, rest, NULL);
1568 OpMAYBESIB_set(start, insert, NULL);
1572 cLISTOPx(parent)->op_first = insert;
1574 parent->op_flags |= OPf_KIDS;
1576 parent->op_flags &= ~OPf_KIDS;
1580 /* update op_last etc */
1587 /* ought to use OP_CLASS(parent) here, but that can't handle
1588 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1590 type = parent->op_type;
1591 if (type == OP_CUSTOM) {
1593 type = XopENTRYCUSTOM(parent, xop_class);
1596 if (type == OP_NULL)
1597 type = parent->op_targ;
1598 type = PL_opargs[type] & OA_CLASS_MASK;
1601 lastop = last_ins ? last_ins : start ? start : NULL;
1602 if ( type == OA_BINOP
1603 || type == OA_LISTOP
1607 cLISTOPx(parent)->op_last = lastop;
1610 OpLASTSIB_set(lastop, parent);
1612 return last_del ? first : NULL;
1615 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1619 =for apidoc op_parent
1621 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1627 Perl_op_parent(OP *o)
1629 PERL_ARGS_ASSERT_OP_PARENT;
1630 while (OpHAS_SIBLING(o))
1632 return o->op_sibparent;
1635 /* replace the sibling following start with a new UNOP, which becomes
1636 * the parent of the original sibling; e.g.
1638 * op_sibling_newUNOP(P, A, unop-args...)
1646 * where U is the new UNOP.
1648 * parent and start args are the same as for op_sibling_splice();
1649 * type and flags args are as newUNOP().
1651 * Returns the new UNOP.
1655 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1659 kid = op_sibling_splice(parent, start, 1, NULL);
1660 newop = newUNOP(type, flags, kid);
1661 op_sibling_splice(parent, start, 0, newop);
1666 /* lowest-level newLOGOP-style function - just allocates and populates
1667 * the struct. Higher-level stuff should be done by S_new_logop() /
1668 * newLOGOP(). This function exists mainly to avoid op_first assignment
1669 * being spread throughout this file.
1673 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1677 NewOp(1101, logop, 1, LOGOP);
1678 OpTYPE_set(logop, type);
1679 logop->op_first = first;
1680 logop->op_other = other;
1682 logop->op_flags = OPf_KIDS;
1683 while (kid && OpHAS_SIBLING(kid))
1684 kid = OpSIBLING(kid);
1686 OpLASTSIB_set(kid, (OP*)logop);
1691 /* Contextualizers */
1694 =for apidoc op_contextualize
1696 Applies a syntactic context to an op tree representing an expression.
1697 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_LIST>,
1698 or C<G_VOID> to specify the context to apply. The modified op tree
1705 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1707 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1709 case G_SCALAR: return scalar(o);
1710 case G_LIST: return list(o);
1711 case G_VOID: return scalarvoid(o);
1713 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1720 =for apidoc op_linklist
1721 This function is the implementation of the L</LINKLIST> macro. It should
1722 not be called directly.
1729 Perl_op_linklist(pTHX_ OP *o)
1736 PERL_ARGS_ASSERT_OP_LINKLIST;
1739 /* Descend down the tree looking for any unprocessed subtrees to
1742 if (o->op_flags & OPf_KIDS) {
1743 o = cUNOPo->op_first;
1746 o->op_next = o; /* leaf node; link to self initially */
1749 /* if we're at the top level, there either weren't any children
1750 * to process, or we've worked our way back to the top. */
1754 /* o is now processed. Next, process any sibling subtrees */
1756 if (OpHAS_SIBLING(o)) {
1761 /* Done all the subtrees at this level. Go back up a level and
1762 * link the parent in with all its (processed) children.
1765 o = o->op_sibparent;
1766 assert(!o->op_next);
1767 prevp = &(o->op_next);
1768 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1770 *prevp = kid->op_next;
1771 prevp = &(kid->op_next);
1772 kid = OpSIBLING(kid);
1780 S_scalarkids(pTHX_ OP *o)
1782 if (o && o->op_flags & OPf_KIDS) {
1784 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1791 S_scalarboolean(pTHX_ OP *o)
1793 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1795 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1796 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1797 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1798 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1799 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1800 if (ckWARN(WARN_SYNTAX)) {
1801 const line_t oldline = CopLINE(PL_curcop);
1803 if (PL_parser && PL_parser->copline != NOLINE) {
1804 /* This ensures that warnings are reported at the first line
1805 of the conditional, not the last. */
1806 CopLINE_set(PL_curcop, PL_parser->copline);
1808 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1809 CopLINE_set(PL_curcop, oldline);
1816 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1819 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1820 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1822 const char funny = o->op_type == OP_PADAV
1823 || o->op_type == OP_RV2AV ? '@' : '%';
1824 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1826 if (cUNOPo->op_first->op_type != OP_GV
1827 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1829 return varname(gv, funny, 0, NULL, 0, subscript_type);
1832 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1837 S_op_varname(pTHX_ const OP *o)
1839 return S_op_varname_subscript(aTHX_ o, 1);
1844 Warns that an access of a single element from a named container variable in
1845 scalar context might not be what the programmer wanted. The container
1846 variable's (sigiled, full) name is given by C<name>, and the key to access
1847 it is given by the C<SVOP_sv> of the C<OP_CONST> op given by C<o>.
1848 C<is_hash> selects whether it prints using {KEY} or [KEY] brackets.
1850 C<is_slice> selects between two different messages used in different places.
1853 S_warn_elem_scalar_context(pTHX_ const OP *o, SV *name, bool is_hash, bool is_slice)
1856 const char *keypv = NULL;
1858 const char lbrack = is_hash ? '{' : '[';
1859 const char rbrack = is_hash ? '}' : ']';
1861 if (o->op_type == OP_CONST) {
1865 keysv = sv_newmortal();
1866 pv_pretty(keysv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1867 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1869 else if (!SvOK(keysv))
1874 assert(SvPOK(name));
1875 sv_chop(name,SvPVX(name)+1);
1881 "Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c" :
1882 "%%%" SVf "%c%s%c in scalar context better written as $%" SVf "%c%s%c";
1883 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1884 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1885 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1886 SVfARG(name), lbrack, keypv, rbrack,
1887 SVfARG(name), lbrack, keypv, rbrack);
1891 "Scalar value @%" SVf "%c%" SVf "%c better written as $%" SVf "%c%" SVf "%c" :
1892 "%%%" SVf "%c%" SVf "%c in scalar context better written as $%" SVf "%c%" SVf "%c";
1893 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1894 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1895 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1896 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1897 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1902 S_scalar_slice_warning(pTHX_ const OP *o)
1905 const bool is_hash = o->op_type == OP_HSLICE
1906 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1909 if (!(o->op_private & OPpSLICEWARNING))
1911 if (PL_parser && PL_parser->error_count)
1912 /* This warning can be nonsensical when there is a syntax error. */
1915 kid = cLISTOPo->op_first;
1916 kid = OpSIBLING(kid); /* get past pushmark */
1917 /* weed out false positives: any ops that can return lists */
1918 switch (kid->op_type) {
1944 /* Don't warn if we have a nulled list either. */
1945 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1948 assert(OpSIBLING(kid));
1949 name = S_op_varname(aTHX_ OpSIBLING(kid));
1950 if (!name) /* XS module fiddling with the op tree */
1952 S_warn_elem_scalar_context(aTHX_ kid, name, is_hash, true);
1957 /* apply scalar context to the o subtree */
1960 Perl_scalar(pTHX_ OP *o)
1965 OP *next_kid = NULL; /* what op (if any) to process next */
1968 /* assumes no premature commitment */
1969 if (!o || (PL_parser && PL_parser->error_count)
1970 || (o->op_flags & OPf_WANT)
1971 || o->op_type == OP_RETURN)
1976 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1978 switch (o->op_type) {
1980 scalar(cBINOPo->op_first);
1981 /* convert what initially looked like a list repeat into a
1982 * scalar repeat, e.g. $s = (1) x $n
1984 if (o->op_private & OPpREPEAT_DOLIST) {
1985 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1986 assert(kid->op_type == OP_PUSHMARK);
1987 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1988 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1989 o->op_private &=~ OPpREPEAT_DOLIST;
1997 /* impose scalar context on everything except the condition */
1998 next_kid = OpSIBLING(cUNOPo->op_first);
2002 if (o->op_flags & OPf_KIDS)
2003 next_kid = cUNOPo->op_first; /* do all kids */
2006 /* the children of these ops are usually a list of statements,
2007 * except the leaves, whose first child is a corresponding enter
2012 kid = cLISTOPo->op_first;
2016 kid = cLISTOPo->op_first;
2018 kid = OpSIBLING(kid);
2021 OP *sib = OpSIBLING(kid);
2022 /* Apply void context to all kids except the last, which
2023 * is scalar (ignoring a trailing ex-nextstate in determining
2024 * if it's the last kid). E.g.
2025 * $scalar = do { void; void; scalar }
2026 * Except that 'when's are always scalar, e.g.
2027 * $scalar = do { given(..) {
2028 * when (..) { scalar }
2029 * when (..) { scalar }
2034 || ( !OpHAS_SIBLING(sib)
2035 && sib->op_type == OP_NULL
2036 && ( sib->op_targ == OP_NEXTSTATE
2037 || sib->op_targ == OP_DBSTATE )
2041 /* tail call optimise calling scalar() on the last kid */
2045 else if (kid->op_type == OP_LEAVEWHEN)
2051 NOT_REACHED; /* NOTREACHED */
2055 Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR), "Useless use of %s in scalar context", "sort");
2061 /* Warn about scalar context */
2064 /* This warning can be nonsensical when there is a syntax error. */
2065 if (PL_parser && PL_parser->error_count)
2068 if (!ckWARN(WARN_SYNTAX)) break;
2070 kid = cLISTOPo->op_first;
2071 kid = OpSIBLING(kid); /* get past pushmark */
2072 assert(OpSIBLING(kid));
2073 name = S_op_varname(aTHX_ OpSIBLING(kid));
2074 if (!name) /* XS module fiddling with the op tree */
2076 S_warn_elem_scalar_context(aTHX_ kid, name, o->op_type == OP_KVHSLICE, false);
2080 /* If next_kid is set, someone in the code above wanted us to process
2081 * that kid and all its remaining siblings. Otherwise, work our way
2082 * back up the tree */
2086 return top_op; /* at top; no parents/siblings to try */
2087 if (OpHAS_SIBLING(o))
2088 next_kid = o->op_sibparent;
2090 o = o->op_sibparent; /*try parent's next sibling */
2091 switch (o->op_type) {
2097 /* should really restore PL_curcop to its old value, but
2098 * setting it to PL_compiling is better than do nothing */
2099 PL_curcop = &PL_compiling;
2108 /* apply void context to the optree arg */
2111 Perl_scalarvoid(pTHX_ OP *arg)
2117 PERL_ARGS_ASSERT_SCALARVOID;
2121 SV *useless_sv = NULL;
2122 const char* useless = NULL;
2123 OP * next_kid = NULL;
2125 if (o->op_type == OP_NEXTSTATE
2126 || o->op_type == OP_DBSTATE
2127 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2128 || o->op_targ == OP_DBSTATE)))
2129 PL_curcop = (COP*)o; /* for warning below */
2131 /* assumes no premature commitment */
2132 want = o->op_flags & OPf_WANT;
2133 if ((want && want != OPf_WANT_SCALAR)
2134 || (PL_parser && PL_parser->error_count)
2135 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2140 if ((o->op_private & OPpTARGET_MY)
2141 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2143 /* newASSIGNOP has already applied scalar context, which we
2144 leave, as if this op is inside SASSIGN. */
2148 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2150 switch (o->op_type) {
2152 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2156 if (o->op_flags & OPf_STACKED)
2158 if (o->op_type == OP_REPEAT)
2159 scalar(cBINOPo->op_first);
2162 if ((o->op_flags & OPf_STACKED) &&
2163 !(o->op_private & OPpCONCAT_NESTED))
2167 if (o->op_private == 4)
2202 case OP_GETSOCKNAME:
2203 case OP_GETPEERNAME:
2208 case OP_GETPRIORITY:
2233 useless = OP_DESC(o);
2243 case OP_AELEMFAST_LEX:
2247 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2248 /* Otherwise it's "Useless use of grep iterator" */
2249 useless = OP_DESC(o);
2253 if (!(o->op_private & OPpSPLIT_ASSIGN))
2254 useless = OP_DESC(o);
2258 kid = cUNOPo->op_first;
2259 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2260 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2263 useless = "negative pattern binding (!~)";
2267 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2268 useless = "non-destructive substitution (s///r)";
2272 useless = "non-destructive transliteration (tr///r)";
2279 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2280 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2281 useless = "a variable";
2286 if (cSVOPo->op_private & OPpCONST_STRICT)
2287 no_bareword_allowed(o);
2289 if (ckWARN(WARN_VOID)) {
2291 /* don't warn on optimised away booleans, eg
2292 * use constant Foo, 5; Foo || print; */
2293 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2295 /* the constants 0 and 1 are permitted as they are
2296 conventionally used as dummies in constructs like
2297 1 while some_condition_with_side_effects; */
2298 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2300 else if (SvPOK(sv)) {
2301 SV * const dsv = newSVpvs("");
2303 = Perl_newSVpvf(aTHX_
2305 pv_pretty(dsv, SvPVX_const(sv),
2306 SvCUR(sv), 32, NULL, NULL,
2308 | PERL_PV_ESCAPE_NOCLEAR
2309 | PERL_PV_ESCAPE_UNI_DETECT));
2310 SvREFCNT_dec_NN(dsv);
2312 else if (SvOK(sv)) {
2313 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2316 useless = "a constant (undef)";
2319 op_null(o); /* don't execute or even remember it */
2323 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2327 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2331 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2335 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2340 UNOP *refgen, *rv2cv;
2343 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2346 rv2gv = ((BINOP *)o)->op_last;
2347 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2350 refgen = (UNOP *)((BINOP *)o)->op_first;
2352 if (!refgen || (refgen->op_type != OP_REFGEN
2353 && refgen->op_type != OP_SREFGEN))
2356 exlist = (LISTOP *)refgen->op_first;
2357 if (!exlist || exlist->op_type != OP_NULL
2358 || exlist->op_targ != OP_LIST)
2361 if (exlist->op_first->op_type != OP_PUSHMARK
2362 && exlist->op_first != exlist->op_last)
2365 rv2cv = (UNOP*)exlist->op_last;
2367 if (rv2cv->op_type != OP_RV2CV)
2370 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2371 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2372 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2374 o->op_private |= OPpASSIGN_CV_TO_GV;
2375 rv2gv->op_private |= OPpDONT_INIT_GV;
2376 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2388 kid = cLOGOPo->op_first;
2389 if (kid->op_type == OP_NOT
2390 && (kid->op_flags & OPf_KIDS)) {
2391 if (o->op_type == OP_AND) {
2392 OpTYPE_set(o, OP_OR);
2394 OpTYPE_set(o, OP_AND);
2404 next_kid = OpSIBLING(cUNOPo->op_first);
2408 if (o->op_flags & OPf_STACKED)
2415 if (!(o->op_flags & OPf_KIDS))
2426 next_kid = cLISTOPo->op_first;
2429 /* If the first kid after pushmark is something that the padrange
2430 optimisation would reject, then null the list and the pushmark.
2432 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2433 && ( !(kid = OpSIBLING(kid))
2434 || ( kid->op_type != OP_PADSV
2435 && kid->op_type != OP_PADAV
2436 && kid->op_type != OP_PADHV)
2437 || kid->op_private & ~OPpLVAL_INTRO
2438 || !(kid = OpSIBLING(kid))
2439 || ( kid->op_type != OP_PADSV
2440 && kid->op_type != OP_PADAV
2441 && kid->op_type != OP_PADHV)
2442 || kid->op_private & ~OPpLVAL_INTRO)
2444 op_null(cUNOPo->op_first); /* NULL the pushmark */
2445 op_null(o); /* NULL the list */
2457 /* mortalise it, in case warnings are fatal. */
2458 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2459 "Useless use of %" SVf " in void context",
2460 SVfARG(sv_2mortal(useless_sv)));
2463 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2464 "Useless use of %s in void context",
2469 /* if a kid hasn't been nominated to process, continue with the
2470 * next sibling, or if no siblings left, go back to the parent's
2471 * siblings and so on
2475 return arg; /* at top; no parents/siblings to try */
2476 if (OpHAS_SIBLING(o))
2477 next_kid = o->op_sibparent;
2479 o = o->op_sibparent; /*try parent's next sibling */
2489 S_listkids(pTHX_ OP *o)
2491 if (o && o->op_flags & OPf_KIDS) {
2493 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2500 /* apply list context to the o subtree */
2503 Perl_list(pTHX_ OP *o)
2508 OP *next_kid = NULL; /* what op (if any) to process next */
2512 /* assumes no premature commitment */
2513 if (!o || (o->op_flags & OPf_WANT)
2514 || (PL_parser && PL_parser->error_count)
2515 || o->op_type == OP_RETURN)
2520 if ((o->op_private & OPpTARGET_MY)
2521 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2523 goto do_next; /* As if inside SASSIGN */
2526 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2528 switch (o->op_type) {
2530 if (o->op_private & OPpREPEAT_DOLIST
2531 && !(o->op_flags & OPf_STACKED))
2533 list(cBINOPo->op_first);
2534 kid = cBINOPo->op_last;
2535 /* optimise away (.....) x 1 */
2536 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2537 && SvIVX(kSVOP_sv) == 1)
2539 op_null(o); /* repeat */
2540 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2542 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2550 /* impose list context on everything except the condition */
2551 next_kid = OpSIBLING(cUNOPo->op_first);
2555 if (!(o->op_flags & OPf_KIDS))
2557 /* possibly flatten 1..10 into a constant array */
2558 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2559 list(cBINOPo->op_first);
2560 gen_constant_list(o);
2563 next_kid = cUNOPo->op_first; /* do all kids */
2567 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2568 op_null(cUNOPo->op_first); /* NULL the pushmark */
2569 op_null(o); /* NULL the list */
2571 if (o->op_flags & OPf_KIDS)
2572 next_kid = cUNOPo->op_first; /* do all kids */
2575 /* the children of these ops are usually a list of statements,
2576 * except the leaves, whose first child is a corresponding enter
2580 kid = cLISTOPo->op_first;
2584 kid = cLISTOPo->op_first;
2586 kid = OpSIBLING(kid);
2589 OP *sib = OpSIBLING(kid);
2590 /* Apply void context to all kids except the last, which
2592 * @a = do { void; void; list }
2593 * Except that 'when's are always list context, e.g.
2594 * @a = do { given(..) {
2595 * when (..) { list }
2596 * when (..) { list }
2601 /* tail call optimise calling list() on the last kid */
2605 else if (kid->op_type == OP_LEAVEWHEN)
2611 NOT_REACHED; /* NOTREACHED */
2616 /* If next_kid is set, someone in the code above wanted us to process
2617 * that kid and all its remaining siblings. Otherwise, work our way
2618 * back up the tree */
2622 return top_op; /* at top; no parents/siblings to try */
2623 if (OpHAS_SIBLING(o))
2624 next_kid = o->op_sibparent;
2626 o = o->op_sibparent; /*try parent's next sibling */
2627 switch (o->op_type) {
2633 /* should really restore PL_curcop to its old value, but
2634 * setting it to PL_compiling is better than do nothing */
2635 PL_curcop = &PL_compiling;
2645 /* apply void context to non-final ops of a sequence */
2648 S_voidnonfinal(pTHX_ OP *o)
2651 const OPCODE type = o->op_type;
2653 if (type == OP_LINESEQ || type == OP_SCOPE ||
2654 type == OP_LEAVE || type == OP_LEAVETRY)
2656 OP *kid = cLISTOPo->op_first, *sib;
2657 if(type == OP_LEAVE) {
2658 /* Don't put the OP_ENTER in void context */
2659 assert(kid->op_type == OP_ENTER);
2660 kid = OpSIBLING(kid);
2662 for (; kid; kid = sib) {
2663 if ((sib = OpSIBLING(kid))
2664 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2665 || ( sib->op_targ != OP_NEXTSTATE
2666 && sib->op_targ != OP_DBSTATE )))
2671 PL_curcop = &PL_compiling;
2673 o->op_flags &= ~OPf_PARENS;
2674 if (PL_hints & HINT_BLOCK_SCOPE)
2675 o->op_flags |= OPf_PARENS;
2678 o = newOP(OP_STUB, 0);
2683 S_modkids(pTHX_ OP *o, I32 type)
2685 if (o && o->op_flags & OPf_KIDS) {
2687 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2688 op_lvalue(kid, type);
2694 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2695 * const fields. Also, convert CONST keys to HEK-in-SVs.
2696 * rop is the op that retrieves the hash;
2697 * key_op is the first key
2698 * real if false, only check (and possibly croak); don't update op
2702 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2708 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2710 if (rop->op_first->op_type == OP_PADSV)
2711 /* @$hash{qw(keys here)} */
2712 rop = (UNOP*)rop->op_first;
2714 /* @{$hash}{qw(keys here)} */
2715 if (rop->op_first->op_type == OP_SCOPE
2716 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2718 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2725 lexname = NULL; /* just to silence compiler warnings */
2726 fields = NULL; /* just to silence compiler warnings */
2730 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2731 SvPAD_TYPED(lexname))
2732 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2733 && isGV(*fields) && GvHV(*fields);
2735 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2737 if (key_op->op_type != OP_CONST)
2739 svp = cSVOPx_svp(key_op);
2741 /* make sure it's not a bareword under strict subs */
2742 if (key_op->op_private & OPpCONST_BARE &&
2743 key_op->op_private & OPpCONST_STRICT)
2745 no_bareword_allowed((OP*)key_op);
2748 /* Make the CONST have a shared SV */
2749 if ( !SvIsCOW_shared_hash(sv = *svp)
2750 && SvTYPE(sv) < SVt_PVMG
2756 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2757 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2758 SvREFCNT_dec_NN(sv);
2763 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2765 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2766 "in variable %" PNf " of type %" HEKf,
2767 SVfARG(*svp), PNfARG(lexname),
2768 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2773 /* info returned by S_sprintf_is_multiconcatable() */
2775 struct sprintf_ismc_info {
2776 SSize_t nargs; /* num of args to sprintf (not including the format) */
2777 char *start; /* start of raw format string */
2778 char *end; /* bytes after end of raw format string */
2779 STRLEN total_len; /* total length (in bytes) of format string, not
2780 including '%s' and half of '%%' */
2781 STRLEN variant; /* number of bytes by which total_len_p would grow
2782 if upgraded to utf8 */
2783 bool utf8; /* whether the format is utf8 */
2787 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2788 * i.e. its format argument is a const string with only '%s' and '%%'
2789 * formats, and the number of args is known, e.g.
2790 * sprintf "a=%s f=%s", $a[0], scalar(f());
2792 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2794 * If successful, the sprintf_ismc_info struct pointed to by info will be
2799 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2801 OP *pm, *constop, *kid;
2804 SSize_t nargs, nformats;
2805 STRLEN cur, total_len, variant;
2808 /* if sprintf's behaviour changes, die here so that someone
2809 * can decide whether to enhance this function or skip optimising
2810 * under those new circumstances */
2811 assert(!(o->op_flags & OPf_STACKED));
2812 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2813 assert(!(o->op_private & ~OPpARG4_MASK));
2815 pm = cUNOPo->op_first;
2816 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2818 constop = OpSIBLING(pm);
2819 if (!constop || constop->op_type != OP_CONST)
2821 sv = cSVOPx_sv(constop);
2822 if (SvMAGICAL(sv) || !SvPOK(sv))
2828 /* Scan format for %% and %s and work out how many %s there are.
2829 * Abandon if other format types are found.
2836 for (p = s; p < e; p++) {
2839 if (!UTF8_IS_INVARIANT(*p))
2845 return FALSE; /* lone % at end gives "Invalid conversion" */
2854 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2857 utf8 = cBOOL(SvUTF8(sv));
2861 /* scan args; they must all be in scalar cxt */
2864 kid = OpSIBLING(constop);
2867 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2870 kid = OpSIBLING(kid);
2873 if (nargs != nformats)
2874 return FALSE; /* e.g. sprintf("%s%s", $a); */
2877 info->nargs = nargs;
2880 info->total_len = total_len;
2881 info->variant = variant;
2889 /* S_maybe_multiconcat():
2891 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2892 * convert it (and its children) into an OP_MULTICONCAT. See the code
2893 * comments just before pp_multiconcat() for the full details of what
2894 * OP_MULTICONCAT supports.
2896 * Basically we're looking for an optree with a chain of OP_CONCATS down
2897 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2898 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2906 * STRINGIFY -- PADSV[$x]
2909 * ex-PUSHMARK -- CONCAT/S
2911 * CONCAT/S -- PADSV[$d]
2913 * CONCAT -- CONST["-"]
2915 * PADSV[$a] -- PADSV[$b]
2917 * Note that at this stage the OP_SASSIGN may have already been optimised
2918 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2922 S_maybe_multiconcat(pTHX_ OP *o)
2924 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2925 OP *topop; /* the top-most op in the concat tree (often equals o,
2926 unless there are assign/stringify ops above it */
2927 OP *parentop; /* the parent op of topop (or itself if no parent) */
2928 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2929 OP *targetop; /* the op corresponding to target=... or target.=... */
2930 OP *stringop; /* the OP_STRINGIFY op, if any */
2931 OP *nextop; /* used for recreating the op_next chain without consts */
2932 OP *kid; /* general-purpose op pointer */
2934 UNOP_AUX_item *lenp;
2935 char *const_str, *p;
2936 struct sprintf_ismc_info sprintf_info;
2938 /* store info about each arg in args[];
2939 * toparg is the highest used slot; argp is a general
2940 * pointer to args[] slots */
2942 void *p; /* initially points to const sv (or null for op);
2943 later, set to SvPV(constsv), with ... */
2944 STRLEN len; /* ... len set to SvPV(..., len) */
2945 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2949 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2952 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2953 the last-processed arg will the LHS of one,
2954 as args are processed in reverse order */
2955 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2956 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2957 U8 flags = 0; /* what will become the op_flags and ... */
2958 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2959 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2960 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2961 bool prev_was_const = FALSE; /* previous arg was a const */
2963 /* -----------------------------------------------------------------
2966 * Examine the optree non-destructively to determine whether it's
2967 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2968 * information about the optree in args[].
2978 assert( o->op_type == OP_SASSIGN
2979 || o->op_type == OP_CONCAT
2980 || o->op_type == OP_SPRINTF
2981 || o->op_type == OP_STRINGIFY);
2983 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2985 /* first see if, at the top of the tree, there is an assign,
2986 * append and/or stringify */
2988 if (topop->op_type == OP_SASSIGN) {
2990 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2992 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2994 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2997 topop = cBINOPo->op_first;
2998 targetop = OpSIBLING(topop);
2999 if (!targetop) /* probably some sort of syntax error */
3002 /* don't optimise away assign in 'local $foo = ....' */
3003 if ( (targetop->op_private & OPpLVAL_INTRO)
3004 /* these are the common ops which do 'local', but
3006 && ( targetop->op_type == OP_GVSV
3007 || targetop->op_type == OP_RV2SV
3008 || targetop->op_type == OP_AELEM
3009 || targetop->op_type == OP_HELEM
3014 else if ( topop->op_type == OP_CONCAT
3015 && (topop->op_flags & OPf_STACKED)
3016 && (!(topop->op_private & OPpCONCAT_NESTED))
3021 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
3022 * decide what to do about it */
3023 assert(!(o->op_private & OPpTARGET_MY));
3025 /* barf on unknown flags */
3026 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
3027 private_flags |= OPpMULTICONCAT_APPEND;
3028 targetop = cBINOPo->op_first;
3030 topop = OpSIBLING(targetop);
3032 /* $x .= <FOO> gets optimised to rcatline instead */
3033 if (topop->op_type == OP_READLINE)
3038 /* Can targetop (the LHS) if it's a padsv, be optimised
3039 * away and use OPpTARGET_MY instead?
3041 if ( (targetop->op_type == OP_PADSV)
3042 && !(targetop->op_private & OPpDEREF)
3043 && !(targetop->op_private & OPpPAD_STATE)
3044 /* we don't support 'my $x .= ...' */
3045 && ( o->op_type == OP_SASSIGN
3046 || !(targetop->op_private & OPpLVAL_INTRO))
3051 if (topop->op_type == OP_STRINGIFY) {
3052 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
3056 /* barf on unknown flags */
3057 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
3059 if ((topop->op_private & OPpTARGET_MY)) {
3060 if (o->op_type == OP_SASSIGN)
3061 return; /* can't have two assigns */
3065 private_flags |= OPpMULTICONCAT_STRINGIFY;
3067 topop = cBINOPx(topop)->op_first;
3068 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
3069 topop = OpSIBLING(topop);
3072 if (topop->op_type == OP_SPRINTF) {
3073 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
3075 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
3076 nargs = sprintf_info.nargs;
3077 total_len = sprintf_info.total_len;
3078 variant = sprintf_info.variant;
3079 utf8 = sprintf_info.utf8;
3081 private_flags |= OPpMULTICONCAT_FAKE;
3083 /* we have an sprintf op rather than a concat optree.
3084 * Skip most of the code below which is associated with
3085 * processing that optree. We also skip phase 2, determining
3086 * whether its cost effective to optimise, since for sprintf,
3087 * multiconcat is *always* faster */
3090 /* note that even if the sprintf itself isn't multiconcatable,
3091 * the expression as a whole may be, e.g. in
3092 * $x .= sprintf("%d",...)
3093 * the sprintf op will be left as-is, but the concat/S op may
3094 * be upgraded to multiconcat
3097 else if (topop->op_type == OP_CONCAT) {
3098 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
3101 if ((topop->op_private & OPpTARGET_MY)) {
3102 if (o->op_type == OP_SASSIGN || targmyop)
3103 return; /* can't have two assigns */
3108 /* Is it safe to convert a sassign/stringify/concat op into
3110 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
3111 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
3112 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3113 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
3114 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
3115 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3116 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
3117 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3119 /* Now scan the down the tree looking for a series of
3120 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3121 * stacked). For example this tree:
3126 * CONCAT/STACKED -- EXPR5
3128 * CONCAT/STACKED -- EXPR4
3134 * corresponds to an expression like
3136 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3138 * Record info about each EXPR in args[]: in particular, whether it is
3139 * a stringifiable OP_CONST and if so what the const sv is.
3141 * The reason why the last concat can't be STACKED is the difference
3144 * ((($a .= $a) .= $a) .= $a) .= $a
3147 * $a . $a . $a . $a . $a
3149 * The main difference between the optrees for those two constructs
3150 * is the presence of the last STACKED. As well as modifying $a,
3151 * the former sees the changed $a between each concat, so if $s is
3152 * initially 'a', the first returns 'a' x 16, while the latter returns
3153 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3163 if ( kid->op_type == OP_CONCAT
3167 k1 = cUNOPx(kid)->op_first;
3169 /* shouldn't happen except maybe after compile err? */
3173 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3174 if (kid->op_private & OPpTARGET_MY)
3177 stacked_last = (kid->op_flags & OPf_STACKED);
3189 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3190 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3192 /* At least two spare slots are needed to decompose both
3193 * concat args. If there are no slots left, continue to
3194 * examine the rest of the optree, but don't push new values
3195 * on args[]. If the optree as a whole is legal for conversion
3196 * (in particular that the last concat isn't STACKED), then
3197 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3198 * can be converted into an OP_MULTICONCAT now, with the first
3199 * child of that op being the remainder of the optree -
3200 * which may itself later be converted to a multiconcat op
3204 /* the last arg is the rest of the optree */
3209 else if ( argop->op_type == OP_CONST
3210 && ((sv = cSVOPx_sv(argop)))
3211 /* defer stringification until runtime of 'constant'
3212 * things that might stringify variantly, e.g. the radix
3213 * point of NVs, or overloaded RVs */
3214 && (SvPOK(sv) || SvIOK(sv))
3215 && (!SvGMAGICAL(sv))
3217 if (argop->op_private & OPpCONST_STRICT)
3218 no_bareword_allowed(argop);
3220 utf8 |= cBOOL(SvUTF8(sv));
3223 /* this const may be demoted back to a plain arg later;
3224 * make sure we have enough arg slots left */
3226 prev_was_const = !prev_was_const;
3231 prev_was_const = FALSE;
3241 return; /* we don't support ((A.=B).=C)...) */
3243 /* look for two adjacent consts and don't fold them together:
3246 * $o->concat("a")->concat("b")
3249 * (but $o .= "a" . "b" should still fold)
3252 bool seen_nonconst = FALSE;
3253 for (argp = toparg; argp >= args; argp--) {
3254 if (argp->p == NULL) {
3255 seen_nonconst = TRUE;
3261 /* both previous and current arg were constants;
3262 * leave the current OP_CONST as-is */
3270 /* -----------------------------------------------------------------
3273 * At this point we have determined that the optree *can* be converted
3274 * into a multiconcat. Having gathered all the evidence, we now decide
3275 * whether it *should*.
3279 /* we need at least one concat action, e.g.:
3285 * otherwise we could be doing something like $x = "foo", which
3286 * if treated as a concat, would fail to COW.
3288 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3291 /* Benchmarking seems to indicate that we gain if:
3292 * * we optimise at least two actions into a single multiconcat
3293 * (e.g concat+concat, sassign+concat);
3294 * * or if we can eliminate at least 1 OP_CONST;
3295 * * or if we can eliminate a padsv via OPpTARGET_MY
3299 /* eliminated at least one OP_CONST */
3301 /* eliminated an OP_SASSIGN */
3302 || o->op_type == OP_SASSIGN
3303 /* eliminated an OP_PADSV */
3304 || (!targmyop && is_targable)
3306 /* definitely a net gain to optimise */
3309 /* ... if not, what else? */
3311 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3312 * multiconcat is faster (due to not creating a temporary copy of
3313 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3319 && topop->op_type == OP_CONCAT
3321 PADOFFSET t = targmyop->op_targ;
3322 OP *k1 = cBINOPx(topop)->op_first;
3323 OP *k2 = cBINOPx(topop)->op_last;
3324 if ( k2->op_type == OP_PADSV
3326 && ( k1->op_type != OP_PADSV
3327 || k1->op_targ != t)
3332 /* need at least two concats */
3333 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3338 /* -----------------------------------------------------------------
3341 * At this point the optree has been verified as ok to be optimised
3342 * into an OP_MULTICONCAT. Now start changing things.
3347 /* stringify all const args and determine utf8ness */
3350 for (argp = args; argp <= toparg; argp++) {
3351 SV *sv = (SV*)argp->p;
3353 continue; /* not a const op */
3354 if (utf8 && !SvUTF8(sv))
3355 sv_utf8_upgrade_nomg(sv);
3356 argp->p = SvPV_nomg(sv, argp->len);
3357 total_len += argp->len;
3359 /* see if any strings would grow if converted to utf8 */
3361 variant += variant_under_utf8_count((U8 *) argp->p,
3362 (U8 *) argp->p + argp->len);
3366 /* create and populate aux struct */
3370 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3371 sizeof(UNOP_AUX_item)
3373 PERL_MULTICONCAT_HEADER_SIZE
3374 + ((nargs + 1) * (variant ? 2 : 1))
3377 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3379 /* Extract all the non-const expressions from the concat tree then
3380 * dispose of the old tree, e.g. convert the tree from this:
3384 * STRINGIFY -- TARGET
3386 * ex-PUSHMARK -- CONCAT
3401 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3403 * except that if EXPRi is an OP_CONST, it's discarded.
3405 * During the conversion process, EXPR ops are stripped from the tree
3406 * and unshifted onto o. Finally, any of o's remaining original
3407 * childen are discarded and o is converted into an OP_MULTICONCAT.
3409 * In this middle of this, o may contain both: unshifted args on the
3410 * left, and some remaining original args on the right. lastkidop
3411 * is set to point to the right-most unshifted arg to delineate
3412 * between the two sets.
3417 /* create a copy of the format with the %'s removed, and record
3418 * the sizes of the const string segments in the aux struct */
3420 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3422 p = sprintf_info.start;
3425 for (; p < sprintf_info.end; p++) {
3429 (lenp++)->ssize = q - oldq;
3436 lenp->ssize = q - oldq;
3437 assert((STRLEN)(q - const_str) == total_len);
3439 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3440 * may or may not be topop) The pushmark and const ops need to be
3441 * kept in case they're an op_next entry point.
3443 lastkidop = cLISTOPx(topop)->op_last;
3444 kid = cUNOPx(topop)->op_first; /* pushmark */
3446 op_null(OpSIBLING(kid)); /* const */
3448 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3449 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3450 lastkidop->op_next = o;
3455 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3459 /* Concatenate all const strings into const_str.
3460 * Note that args[] contains the RHS args in reverse order, so
3461 * we scan args[] from top to bottom to get constant strings
3464 for (argp = toparg; argp >= args; argp--) {
3466 /* not a const op */
3467 (++lenp)->ssize = -1;
3469 STRLEN l = argp->len;
3470 Copy(argp->p, p, l, char);
3472 if (lenp->ssize == -1)
3483 for (argp = args; argp <= toparg; argp++) {
3484 /* only keep non-const args, except keep the first-in-next-chain
3485 * arg no matter what it is (but nulled if OP_CONST), because it
3486 * may be the entry point to this subtree from the previous
3489 bool last = (argp == toparg);
3492 /* set prev to the sibling *before* the arg to be cut out,
3493 * e.g. when cutting EXPR:
3498 * prev= CONCAT -- EXPR
3501 if (argp == args && kid->op_type != OP_CONCAT) {
3502 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3503 * so the expression to be cut isn't kid->op_last but
3506 /* find the op before kid */
3508 o2 = cUNOPx(parentop)->op_first;
3509 while (o2 && o2 != kid) {
3517 else if (kid == o && lastkidop)
3518 prev = last ? lastkidop : OpSIBLING(lastkidop);
3520 prev = last ? NULL : cUNOPx(kid)->op_first;
3522 if (!argp->p || last) {
3524 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3525 /* and unshift to front of o */
3526 op_sibling_splice(o, NULL, 0, aop);
3527 /* record the right-most op added to o: later we will
3528 * free anything to the right of it */
3531 aop->op_next = nextop;
3534 /* null the const at start of op_next chain */
3538 nextop = prev->op_next;
3541 /* the last two arguments are both attached to the same concat op */
3542 if (argp < toparg - 1)
3547 /* Populate the aux struct */
3549 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3550 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3551 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3552 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3553 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3555 /* if variant > 0, calculate a variant const string and lengths where
3556 * the utf8 version of the string will take 'variant' more bytes than
3560 char *p = const_str;
3561 STRLEN ulen = total_len + variant;
3562 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3563 UNOP_AUX_item *ulens = lens + (nargs + 1);
3564 char *up = (char*)PerlMemShared_malloc(ulen);
3567 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3568 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3570 for (n = 0; n < (nargs + 1); n++) {
3572 char * orig_up = up;
3573 for (i = (lens++)->ssize; i > 0; i--) {
3575 append_utf8_from_native_byte(c, (U8**)&up);
3577 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3582 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3583 * that op's first child - an ex-PUSHMARK - because the op_next of
3584 * the previous op may point to it (i.e. it's the entry point for
3589 ? op_sibling_splice(o, lastkidop, 1, NULL)
3590 : op_sibling_splice(stringop, NULL, 1, NULL);
3591 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3592 op_sibling_splice(o, NULL, 0, pmop);
3599 * target .= A.B.C...
3605 if (o->op_type == OP_SASSIGN) {
3606 /* Move the target subtree from being the last of o's children
3607 * to being the last of o's preserved children.
3608 * Note the difference between 'target = ...' and 'target .= ...':
3609 * for the former, target is executed last; for the latter,
3612 kid = OpSIBLING(lastkidop);
3613 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3614 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3615 lastkidop->op_next = kid->op_next;
3616 lastkidop = targetop;
3619 /* Move the target subtree from being the first of o's
3620 * original children to being the first of *all* o's children.
3623 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3624 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3627 /* if the RHS of .= doesn't contain a concat (e.g.
3628 * $x .= "foo"), it gets missed by the "strip ops from the
3629 * tree and add to o" loop earlier */
3630 assert(topop->op_type != OP_CONCAT);
3632 /* in e.g. $x .= "$y", move the $y expression
3633 * from being a child of OP_STRINGIFY to being the
3634 * second child of the OP_CONCAT
3636 assert(cUNOPx(stringop)->op_first == topop);
3637 op_sibling_splice(stringop, NULL, 1, NULL);
3638 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3640 assert(topop == OpSIBLING(cBINOPo->op_first));
3649 * my $lex = A.B.C...
3652 * The original padsv op is kept but nulled in case it's the
3653 * entry point for the optree (which it will be for
3656 private_flags |= OPpTARGET_MY;
3657 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3658 o->op_targ = targetop->op_targ;
3659 targetop->op_targ = 0;
3663 flags |= OPf_STACKED;
3665 else if (targmyop) {
3666 private_flags |= OPpTARGET_MY;
3667 if (o != targmyop) {
3668 o->op_targ = targmyop->op_targ;
3669 targmyop->op_targ = 0;
3673 /* detach the emaciated husk of the sprintf/concat optree and free it */
3675 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3681 /* and convert o into a multiconcat */
3683 o->op_flags = (flags|OPf_KIDS|stacked_last
3684 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3685 o->op_private = private_flags;
3686 o->op_type = OP_MULTICONCAT;
3687 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3688 cUNOP_AUXo->op_aux = aux;
3692 /* do all the final processing on an optree (e.g. running the peephole
3693 * optimiser on it), then attach it to cv (if cv is non-null)
3697 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3701 /* XXX for some reason, evals, require and main optrees are
3702 * never attached to their CV; instead they just hang off
3703 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3704 * and get manually freed when appropriate */
3706 startp = &CvSTART(cv);
3708 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3711 optree->op_private |= OPpREFCOUNTED;
3712 OpREFCNT_set(optree, 1);
3713 optimize_optree(optree);
3715 finalize_optree(optree);
3716 S_prune_chain_head(startp);
3719 /* now that optimizer has done its work, adjust pad values */
3720 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3721 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3727 =for apidoc optimize_optree
3729 This function applies some optimisations to the optree in top-down order.
3730 It is called before the peephole optimizer, which processes ops in
3731 execution order. Note that finalize_optree() also does a top-down scan,
3732 but is called *after* the peephole optimizer.
3738 Perl_optimize_optree(pTHX_ OP* o)
3740 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3743 SAVEVPTR(PL_curcop);
3751 #define warn_implicit_snail_cvsig(o) S_warn_implicit_snail_cvsig(aTHX_ o)
3753 S_warn_implicit_snail_cvsig(pTHX_ OP *o)
3756 while(cv && CvEVAL(cv))
3759 if(cv && CvSIGNATURE(cv))
3760 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__ARGS_ARRAY_WITH_SIGNATURES),
3761 "Implicit use of @_ in %s with signatured subroutine is experimental", OP_DESC(o));
3764 #define OP_ZOOM(o) (OP_TYPE_IS(o, OP_NULL) ? cUNOPx(o)->op_first : (o))
3766 /* helper for optimize_optree() which optimises one op then recurses
3767 * to optimise any children.
3771 S_optimize_op(pTHX_ OP* o)
3775 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3778 OP * next_kid = NULL;
3780 assert(o->op_type != OP_FREED);
3782 switch (o->op_type) {
3785 PL_curcop = ((COP*)o); /* for warnings */
3793 S_maybe_multiconcat(aTHX_ o);
3797 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3798 /* we can't assume that op_pmreplroot->op_sibparent == o
3799 * and that it is thus possible to walk back up the tree
3800 * past op_pmreplroot. So, although we try to avoid
3801 * recursing through op trees, do it here. After all,
3802 * there are unlikely to be many nested s///e's within
3803 * the replacement part of a s///e.
3805 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3811 OP *first = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
3813 while(cv && CvEVAL(cv))
3816 if(cv && CvSIGNATURE(cv) &&
3817 OP_TYPE_IS(first, OP_GV) && cGVOPx_gv(first) == PL_defgv) {
3818 OP *parent = op_parent(o);
3819 while(OP_TYPE_IS(parent, OP_NULL))
3820 parent = op_parent(parent);
3822 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__ARGS_ARRAY_WITH_SIGNATURES),
3823 "Use of @_ in %s with signatured subroutine is experimental", OP_DESC(parent));
3830 if(!CvUNIQUE(PL_compcv) && !(o->op_flags & OPf_KIDS))
3831 warn_implicit_snail_cvsig(o);
3835 if(!(o->op_flags & OPf_STACKED))
3836 warn_implicit_snail_cvsig(o);
3841 OP *first = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
3843 if(OP_TYPE_IS(first, OP_SREFGEN) &&
3844 (ffirst = OP_ZOOM(cUNOPx(first)->op_first)) &&
3845 OP_TYPE_IS(ffirst, OP_RV2CV))
3846 warn_implicit_snail_cvsig(o);
3854 if (o->op_flags & OPf_KIDS)
3855 next_kid = cUNOPo->op_first;
3857 /* if a kid hasn't been nominated to process, continue with the
3858 * next sibling, or if no siblings left, go back to the parent's
3859 * siblings and so on
3863 return; /* at top; no parents/siblings to try */
3864 if (OpHAS_SIBLING(o))
3865 next_kid = o->op_sibparent;
3867 o = o->op_sibparent; /*try parent's next sibling */
3870 /* this label not yet used. Goto here if any code above sets
3880 =for apidoc finalize_optree
3882 This function finalizes the optree. Should be called directly after
3883 the complete optree is built. It does some additional
3884 checking which can't be done in the normal C<ck_>xxx functions and makes
3885 the tree thread-safe.
3890 Perl_finalize_optree(pTHX_ OP* o)
3892 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3895 SAVEVPTR(PL_curcop);
3903 /* Relocate sv to the pad for thread safety.
3904 * Despite being a "constant", the SV is written to,
3905 * for reference counts, sv_upgrade() etc. */
3906 PERL_STATIC_INLINE void
3907 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3910 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3912 ix = pad_alloc(OP_CONST, SVf_READONLY);
3913 SvREFCNT_dec(PAD_SVl(ix));
3914 PAD_SETSV(ix, *svp);
3915 /* XXX I don't know how this isn't readonly already. */
3916 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3923 =for apidoc traverse_op_tree
3925 Return the next op in a depth-first traversal of the op tree,
3926 returning NULL when the traversal is complete.
3928 The initial call must supply the root of the tree as both top and o.
3930 For now it's static, but it may be exposed to the API in the future.
3936 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3939 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3941 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3942 return cUNOPo->op_first;
3944 else if ((sib = OpSIBLING(o))) {
3948 OP *parent = o->op_sibparent;
3949 assert(!(o->op_moresib));
3950 while (parent && parent != top) {
3951 OP *sib = OpSIBLING(parent);
3954 parent = parent->op_sibparent;
3962 S_finalize_op(pTHX_ OP* o)
3965 PERL_ARGS_ASSERT_FINALIZE_OP;
3968 assert(o->op_type != OP_FREED);
3970 switch (o->op_type) {
3973 PL_curcop = ((COP*)o); /* for warnings */
3976 if (OpHAS_SIBLING(o)) {
3977 OP *sib = OpSIBLING(o);
3978 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3979 && ckWARN(WARN_EXEC)
3980 && OpHAS_SIBLING(sib))
3982 const OPCODE type = OpSIBLING(sib)->op_type;
3983 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3984 const line_t oldline = CopLINE(PL_curcop);
3985 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3986 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3987 "Statement unlikely to be reached");
3988 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3989 "\t(Maybe you meant system() when you said exec()?)\n");
3990 CopLINE_set(PL_curcop, oldline);
3997 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3998 GV * const gv = cGVOPo_gv;
3999 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
4000 /* XXX could check prototype here instead of just carping */
4001 SV * const sv = sv_newmortal();
4002 gv_efullname3(sv, gv, NULL);
4003 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4004 "%" SVf "() called too early to check prototype",
4011 if (cSVOPo->op_private & OPpCONST_STRICT)
4012 no_bareword_allowed(o);
4016 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
4021 /* Relocate all the METHOP's SVs to the pad for thread safety. */
4022 case OP_METHOD_NAMED:
4023 case OP_METHOD_SUPER:
4024 case OP_METHOD_REDIR:
4025 case OP_METHOD_REDIR_SUPER:
4026 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
4035 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
4038 rop = (UNOP*)((BINOP*)o)->op_first;
4043 S_scalar_slice_warning(aTHX_ o);
4047 kid = OpSIBLING(cLISTOPo->op_first);
4048 if (/* I bet there's always a pushmark... */
4049 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
4050 && OP_TYPE_ISNT_NN(kid, OP_CONST))
4055 key_op = (SVOP*)(kid->op_type == OP_CONST
4057 : OpSIBLING(kLISTOP->op_first));
4059 rop = (UNOP*)((LISTOP*)o)->op_last;
4062 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
4064 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
4068 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
4072 S_scalar_slice_warning(aTHX_ o);
4076 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
4077 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
4085 if (o->op_flags & OPf_KIDS) {
4088 /* check that op_last points to the last sibling, and that
4089 * the last op_sibling/op_sibparent field points back to the
4090 * parent, and that the only ops with KIDS are those which are
4091 * entitled to them */
4092 U32 type = o->op_type;
4096 if (type == OP_NULL) {
4098 /* ck_glob creates a null UNOP with ex-type GLOB
4099 * (which is a list op. So pretend it wasn't a listop */
4100 if (type == OP_GLOB)
4103 family = PL_opargs[type] & OA_CLASS_MASK;
4105 has_last = ( family == OA_BINOP
4106 || family == OA_LISTOP
4107 || family == OA_PMOP
4108 || family == OA_LOOP
4110 assert( has_last /* has op_first and op_last, or ...
4111 ... has (or may have) op_first: */
4112 || family == OA_UNOP
4113 || family == OA_UNOP_AUX
4114 || family == OA_LOGOP
4115 || family == OA_BASEOP_OR_UNOP
4116 || family == OA_FILESTATOP
4117 || family == OA_LOOPEXOP
4118 || family == OA_METHOP
4119 || type == OP_CUSTOM
4120 || type == OP_NULL /* new_logop does this */
4123 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
4124 if (!OpHAS_SIBLING(kid)) {
4126 assert(kid == cLISTOPo->op_last);
4127 assert(kid->op_sibparent == o);
4132 } while (( o = traverse_op_tree(top, o)) != NULL);
4136 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
4139 PadnameLVALUE_on(pn);
4140 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
4142 /* RT #127786: cv can be NULL due to an eval within the DB package
4143 * called from an anon sub - anon subs don't have CvOUTSIDE() set
4144 * unless they contain an eval, but calling eval within DB
4145 * pretends the eval was done in the caller's scope.
4149 assert(CvPADLIST(cv));
4151 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
4152 assert(PadnameLEN(pn));
4153 PadnameLVALUE_on(pn);
4158 S_vivifies(const OPCODE type)
4161 case OP_RV2AV: case OP_ASLICE:
4162 case OP_RV2HV: case OP_KVASLICE:
4163 case OP_RV2SV: case OP_HSLICE:
4164 case OP_AELEMFAST: case OP_KVHSLICE:
4173 /* apply lvalue reference (aliasing) context to the optree o.
4176 * o would be the list ($x,$y) and type would be OP_AASSIGN.
4177 * It may descend and apply this to children too, for example in
4178 * \( $cond ? $x, $y) = (...)
4182 S_lvref(pTHX_ OP *o, I32 type)
4188 switch (o->op_type) {
4190 o = OpSIBLING(cUNOPo->op_first);
4197 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4198 o->op_flags |= OPf_STACKED;
4199 if (o->op_flags & OPf_PARENS) {
4200 if (o->op_private & OPpLVAL_INTRO) {
4201 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4202 "localized parenthesized array in list assignment"));
4206 OpTYPE_set(o, OP_LVAVREF);
4207 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4208 o->op_flags |= OPf_MOD|OPf_REF;
4211 o->op_private |= OPpLVREF_AV;
4215 kid = cUNOPo->op_first;
4216 if (kid->op_type == OP_NULL)
4217 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4219 o->op_private = OPpLVREF_CV;
4220 if (kid->op_type == OP_GV)
4221 o->op_flags |= OPf_STACKED;
4222 else if (kid->op_type == OP_PADCV) {
4223 o->op_targ = kid->op_targ;
4225 op_free(cUNOPo->op_first);
4226 cUNOPo->op_first = NULL;
4227 o->op_flags &=~ OPf_KIDS;
4233 if (o->op_flags & OPf_PARENS) {
4235 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4236 "parenthesized hash in list assignment"));
4239 o->op_private |= OPpLVREF_HV;
4243 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4244 o->op_flags |= OPf_STACKED;
4248 if (o->op_flags & OPf_PARENS) goto parenhash;
4249 o->op_private |= OPpLVREF_HV;
4252 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4256 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4257 if (o->op_flags & OPf_PARENS) goto slurpy;
4258 o->op_private |= OPpLVREF_AV;
4263 o->op_private |= OPpLVREF_ELEM;
4264 o->op_flags |= OPf_STACKED;
4269 OpTYPE_set(o, OP_LVREFSLICE);
4270 o->op_private &= OPpLVAL_INTRO;
4274 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4276 else if (!(o->op_flags & OPf_KIDS))
4279 /* the code formerly only recursed into the first child of
4280 * a non ex-list OP_NULL. if we ever encounter such a null op with
4281 * more than one child, need to decide whether its ok to process
4282 * *all* its kids or not */
4283 assert(o->op_targ == OP_LIST
4284 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4287 o = cLISTOPo->op_first;
4291 if (o->op_flags & OPf_PARENS)
4296 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4297 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4298 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4305 OpTYPE_set(o, OP_LVREF);
4307 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4308 if (type == OP_ENTERLOOP)
4309 o->op_private |= OPpLVREF_ITER;
4314 return; /* at top; no parents/siblings to try */
4315 if (OpHAS_SIBLING(o)) {
4316 o = o->op_sibparent;
4319 o = o->op_sibparent; /*try parent's next sibling */
4325 PERL_STATIC_INLINE bool
4326 S_potential_mod_type(I32 type)
4328 /* Types that only potentially result in modification. */
4329 return type == OP_GREPSTART || type == OP_ENTERSUB
4330 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4335 =for apidoc op_lvalue
4337 Propagate lvalue ("modifiable") context to an op and its children.
4338 C<type> represents the context type, roughly based on the type of op that
4339 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4340 because it has no op type of its own (it is signalled by a flag on
4343 This function detects things that can't be modified, such as C<$x+1>, and
4344 generates errors for them. For example, C<$x+1 = 2> would cause it to be
4345 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4347 It also flags things that need to behave specially in an lvalue context,
4348 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4352 Perl_op_lvalue_flags() is a non-API lower-level interface to
4353 op_lvalue(). The flags param has these bits:
4354 OP_LVALUE_NO_CROAK: return rather than croaking on error
4359 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4363 if (!o || (PL_parser && PL_parser->error_count))
4368 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4370 OP *next_kid = NULL;
4372 if ((o->op_private & OPpTARGET_MY)
4373 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4378 /* elements of a list might be in void context because the list is
4379 in scalar context or because they are attribute sub calls */
4380 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4383 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4385 switch (o->op_type) {
4387 if (type == OP_SASSIGN)
4393 if ((o->op_flags & OPf_PARENS))
4398 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4399 !(o->op_flags & OPf_STACKED)) {
4400 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4401 assert(cUNOPo->op_first->op_type == OP_NULL);
4402 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4405 else { /* lvalue subroutine call */
4406 o->op_private |= OPpLVAL_INTRO;
4407 PL_modcount = RETURN_UNLIMITED_NUMBER;
4408 if (S_potential_mod_type(type)) {
4409 o->op_private |= OPpENTERSUB_INARGS;
4412 else { /* Compile-time error message: */
4413 OP *kid = cUNOPo->op_first;
4418 if (kid->op_type != OP_PUSHMARK) {
4419 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4421 "panic: unexpected lvalue entersub "
4422 "args: type/targ %ld:%" UVuf,
4423 (long)kid->op_type, (UV)kid->op_targ);
4424 kid = kLISTOP->op_first;
4426 while (OpHAS_SIBLING(kid))
4427 kid = OpSIBLING(kid);
4428 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4429 break; /* Postpone until runtime */
4432 kid = kUNOP->op_first;
4433 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4434 kid = kUNOP->op_first;
4435 if (kid->op_type == OP_NULL)
4437 "panic: unexpected constant lvalue entersub "
4438 "entry via type/targ %ld:%" UVuf,
4439 (long)kid->op_type, (UV)kid->op_targ);
4440 if (kid->op_type != OP_GV) {
4447 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4448 ? MUTABLE_CV(SvRV(gv))
4454 if (flags & OP_LVALUE_NO_CROAK)
4457 namesv = cv_name(cv, NULL, 0);
4458 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4459 "subroutine call of &%" SVf " in %s",
4460 SVfARG(namesv), PL_op_desc[type]),
4468 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4469 /* grep, foreach, subcalls, refgen */
4470 if (S_potential_mod_type(type))
4472 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4473 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4476 type ? PL_op_desc[type] : "local"));
4489 case OP_RIGHT_SHIFT:
4498 if (!(o->op_flags & OPf_STACKED))
4504 if (o->op_flags & OPf_STACKED) {
4508 if (!(o->op_private & OPpREPEAT_DOLIST))
4511 const I32 mods = PL_modcount;
4512 /* we recurse rather than iterate here because we need to
4513 * calculate and use the delta applied to PL_modcount by the
4514 * first child. So in something like
4515 * ($x, ($y) x 3) = split;
4516 * split knows that 4 elements are wanted
4518 modkids(cBINOPo->op_first, type);
4519 if (type != OP_AASSIGN)
4521 kid = cBINOPo->op_last;
4522 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4523 const IV iv = SvIV(kSVOP_sv);
4524 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4526 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4529 PL_modcount = RETURN_UNLIMITED_NUMBER;
4535 next_kid = OpSIBLING(cUNOPo->op_first);
4540 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4541 PL_modcount = RETURN_UNLIMITED_NUMBER;
4542 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4543 fiable since some contexts need to know. */
4544 o->op_flags |= OPf_MOD;
4549 if (scalar_mod_type(o, type))
4551 ref(cUNOPo->op_first, o->op_type);
4558 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4559 if (type == OP_LEAVESUBLV && (
4560 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4561 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4563 o->op_private |= OPpMAYBE_LVSUB;
4567 PL_modcount = RETURN_UNLIMITED_NUMBER;
4573 if (type == OP_LEAVESUBLV)
4574 o->op_private |= OPpMAYBE_LVSUB;
4578 if (type == OP_LEAVESUBLV
4579 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4580 o->op_private |= OPpMAYBE_LVSUB;
4584 PL_hints |= HINT_BLOCK_SCOPE;
4585 if (type == OP_LEAVESUBLV)
4586 o->op_private |= OPpMAYBE_LVSUB;
4591 ref(cUNOPo->op_first, o->op_type);
4595 PL_hints |= HINT_BLOCK_SCOPE;
4605 case OP_AELEMFAST_LEX:
4612 PL_modcount = RETURN_UNLIMITED_NUMBER;
4613 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4615 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4616 fiable since some contexts need to know. */
4617 o->op_flags |= OPf_MOD;
4620 if (scalar_mod_type(o, type))
4622 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4623 && type == OP_LEAVESUBLV)
4624 o->op_private |= OPpMAYBE_LVSUB;
4628 if (!type) /* local() */
4629 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4630 PNfARG(PAD_COMPNAME(o->op_targ)));
4631 if (!(o->op_private & OPpLVAL_INTRO)
4632 || ( type != OP_SASSIGN && type != OP_AASSIGN
4633 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4634 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4642 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4646 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4652 if (type == OP_LEAVESUBLV)
4653 o->op_private |= OPpMAYBE_LVSUB;
4654 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4655 /* we recurse rather than iterate here because the child
4656 * needs to be processed with a different 'type' parameter */
4658 /* substr and vec */
4659 /* If this op is in merely potential (non-fatal) modifiable
4660 context, then apply OP_ENTERSUB context to
4661 the kid op (to avoid croaking). Other-
4662 wise pass this op’s own type so the correct op is mentioned
4663 in error messages. */
4664 op_lvalue(OpSIBLING(cBINOPo->op_first),
4665 S_potential_mod_type(type)
4673 ref(cBINOPo->op_first, o->op_type);
4674 if (type == OP_ENTERSUB &&
4675 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4676 o->op_private |= OPpLVAL_DEFER;
4677 if (type == OP_LEAVESUBLV)
4678 o->op_private |= OPpMAYBE_LVSUB;
4685 o->op_private |= OPpLVALUE;
4691 if (o->op_flags & OPf_KIDS)
4692 next_kid = cLISTOPo->op_last;
4697 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4699 else if (!(o->op_flags & OPf_KIDS))
4702 if (o->op_targ != OP_LIST) {
4703 OP *sib = OpSIBLING(cLISTOPo->op_first);
4704 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4711 * compared with things like OP_MATCH which have the argument
4717 * so handle specially to correctly get "Can't modify" croaks etc
4720 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4722 /* this should trigger a "Can't modify transliteration" err */
4723 op_lvalue(sib, type);
4725 next_kid = cBINOPo->op_first;
4726 /* we assume OP_NULLs which aren't ex-list have no more than 2
4727 * children. If this assumption is wrong, increase the scan
4729 assert( !OpHAS_SIBLING(next_kid)
4730 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4736 next_kid = cLISTOPo->op_first;
4744 if (type == OP_LEAVESUBLV
4745 || !S_vivifies(cLOGOPo->op_first->op_type))
4746 next_kid = cLOGOPo->op_first;
4747 else if (type == OP_LEAVESUBLV
4748 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4749 next_kid = OpSIBLING(cLOGOPo->op_first);
4753 if (type == OP_NULL) { /* local */
4755 if (!FEATURE_MYREF_IS_ENABLED)
4756 Perl_croak(aTHX_ "The experimental declared_refs "
4757 "feature is not enabled");
4758 Perl_ck_warner_d(aTHX_
4759 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4760 "Declaring references is experimental");
4761 next_kid = cUNOPo->op_first;
4764 if (type != OP_AASSIGN && type != OP_SASSIGN
4765 && type != OP_ENTERLOOP)
4767 /* Don’t bother applying lvalue context to the ex-list. */
4768 kid = cUNOPx(cUNOPo->op_first)->op_first;
4769 assert (!OpHAS_SIBLING(kid));
4772 if (type == OP_NULL) /* local */
4774 if (type != OP_AASSIGN) goto nomod;
4775 kid = cUNOPo->op_first;
4778 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4779 S_lvref(aTHX_ kid, type);
4780 if (!PL_parser || PL_parser->error_count == ec) {
4781 if (!FEATURE_REFALIASING_IS_ENABLED)
4783 "Experimental aliasing via reference not enabled");
4784 Perl_ck_warner_d(aTHX_
4785 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4786 "Aliasing via reference is experimental");
4789 if (o->op_type == OP_REFGEN)
4790 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4795 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4796 /* This is actually @array = split. */
4797 PL_modcount = RETURN_UNLIMITED_NUMBER;
4803 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4807 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4808 their argument is a filehandle; thus \stat(".") should not set
4810 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4813 if (type != OP_LEAVESUBLV)
4814 o->op_flags |= OPf_MOD;
4816 if (type == OP_AASSIGN || type == OP_SASSIGN)
4817 o->op_flags |= OPf_SPECIAL
4818 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4819 else if (!type) { /* local() */
4822 o->op_private |= OPpLVAL_INTRO;
4823 o->op_flags &= ~OPf_SPECIAL;
4824 PL_hints |= HINT_BLOCK_SCOPE;
4829 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4830 "Useless localization of %s", OP_DESC(o));
4833 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4834 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4835 o->op_flags |= OPf_REF;
4840 return top_op; /* at top; no parents/siblings to try */
4841 if (OpHAS_SIBLING(o)) {
4842 next_kid = o->op_sibparent;
4843 if (!OpHAS_SIBLING(next_kid)) {
4844 /* a few node types don't recurse into their second child */
4845 OP *parent = next_kid->op_sibparent;
4846 I32 ptype = parent->op_type;
4847 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
4848 || ( (ptype == OP_AND || ptype == OP_OR)
4849 && (type != OP_LEAVESUBLV
4850 && S_vivifies(next_kid->op_type))
4853 /*try parent's next sibling */
4860 o = o->op_sibparent; /*try parent's next sibling */
4871 S_scalar_mod_type(const OP *o, I32 type)
4876 if (o && o->op_type == OP_RV2GV)
4900 case OP_RIGHT_SHIFT:
4929 S_is_handle_constructor(const OP *o, I32 numargs)
4931 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4933 switch (o->op_type) {
4941 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4954 S_refkids(pTHX_ OP *o, I32 type)
4956 if (o && o->op_flags & OPf_KIDS) {
4958 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4965 /* Apply reference (autovivification) context to the subtree at o.
4967 * push @{expression}, ....;
4968 * o will be the head of 'expression' and type will be OP_RV2AV.
4969 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4971 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4972 * set_op_ref is true.
4974 * Also calls scalar(o).
4978 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4982 PERL_ARGS_ASSERT_DOREF;
4984 if (PL_parser && PL_parser->error_count)
4988 switch (o->op_type) {
4990 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4991 !(o->op_flags & OPf_STACKED)) {
4992 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4993 assert(cUNOPo->op_first->op_type == OP_NULL);
4994 /* disable pushmark */
4995 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4996 o->op_flags |= OPf_SPECIAL;
4998 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4999 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
5000 : type == OP_RV2HV ? OPpDEREF_HV
5002 o->op_flags |= OPf_MOD;
5008 o = OpSIBLING(cUNOPo->op_first);
5012 if (type == OP_DEFINED)
5013 o->op_flags |= OPf_SPECIAL; /* don't create GV */
5016 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5017 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
5018 : type == OP_RV2HV ? OPpDEREF_HV
5020 o->op_flags |= OPf_MOD;
5022 if (o->op_flags & OPf_KIDS) {
5024 o = cUNOPo->op_first;
5032 o->op_flags |= OPf_REF;
5035 if (type == OP_DEFINED)
5036 o->op_flags |= OPf_SPECIAL; /* don't create GV */
5038 o = cUNOPo->op_first;
5044 o->op_flags |= OPf_REF;
5049 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
5051 o = cBINOPo->op_first;
5056 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5057 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
5058 : type == OP_RV2HV ? OPpDEREF_HV
5060 o->op_flags |= OPf_MOD;
5063 o = cBINOPo->op_first;
5072 if (!(o->op_flags & OPf_KIDS))
5074 o = cLISTOPo->op_last;
5083 return scalar(top_op); /* at top; no parents/siblings to try */
5084 if (OpHAS_SIBLING(o)) {
5085 o = o->op_sibparent;
5086 /* Normally skip all siblings and go straight to the parent;
5087 * the only op that requires two children to be processed
5088 * is OP_COND_EXPR */
5089 if (!OpHAS_SIBLING(o)
5090 && o->op_sibparent->op_type == OP_COND_EXPR)
5094 o = o->op_sibparent; /*try parent's next sibling */
5101 S_dup_attrlist(pTHX_ OP *o)
5105 PERL_ARGS_ASSERT_DUP_ATTRLIST;
5107 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
5108 * where the first kid is OP_PUSHMARK and the remaining ones
5109 * are OP_CONST. We need to push the OP_CONST values.
5111 if (o->op_type == OP_CONST)
5112 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
5114 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5116 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
5117 if (o->op_type == OP_CONST)
5118 rop = op_append_elem(OP_LIST, rop,
5119 newSVOP(OP_CONST, o->op_flags,
5120 SvREFCNT_inc_NN(cSVOPo->op_sv)));
5127 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
5129 PERL_ARGS_ASSERT_APPLY_ATTRS;
5131 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
5133 /* fake up C<use attributes $pkg,$rv,@attrs> */
5135 #define ATTRSMODULE "attributes"
5136 #define ATTRSMODULE_PM "attributes.pm"
5139 aTHX_ PERL_LOADMOD_IMPORT_OPS,
5140 newSVpvs(ATTRSMODULE),
5142 op_prepend_elem(OP_LIST,
5143 newSVOP(OP_CONST, 0, stashsv),
5144 op_prepend_elem(OP_LIST,
5145 newSVOP(OP_CONST, 0,
5147 dup_attrlist(attrs))));
5152 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
5154 OP *pack, *imop, *arg;
5155 SV *meth, *stashsv, **svp;
5157 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
5162 assert(target->op_type == OP_PADSV ||
5163 target->op_type == OP_PADHV ||
5164 target->op_type == OP_PADAV);
5166 /* Ensure that attributes.pm is loaded. */
5167 /* Don't force the C<use> if we don't need it. */
5168 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
5169 if (svp && *svp != &PL_sv_undef)
5170 NOOP; /* already in %INC */
5172 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5173 newSVpvs(ATTRSMODULE), NULL);
5175 /* Need package name for method call. */
5176 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
5178 /* Build up the real arg-list. */
5179 stashsv = newSVhek(HvNAME_HEK(stash));
5181 arg = newOP(OP_PADSV, 0);
5182 arg->op_targ = target->op_targ;
5183 arg = op_prepend_elem(OP_LIST,
5184 newSVOP(OP_CONST, 0, stashsv),
5185 op_prepend_elem(OP_LIST,
5186 newUNOP(OP_REFGEN, 0,
5188 dup_attrlist(attrs)));
5190 /* Fake up a method call to import */
5191 meth = newSVpvs_share("import");
5192 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
5193 op_append_elem(OP_LIST,
5194 op_prepend_elem(OP_LIST, pack, arg),
5195 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5197 /* Combine the ops. */
5198 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
5202 =notfor apidoc apply_attrs_string
5204 Attempts to apply a list of attributes specified by the C<attrstr> and
5205 C<len> arguments to the subroutine identified by the C<cv> argument which
5206 is expected to be associated with the package identified by the C<stashpv>
5207 argument (see L<attributes>). It gets this wrong, though, in that it
5208 does not correctly identify the boundaries of the individual attribute
5209 specifications within C<attrstr>. This is not really intended for the
5210 public API, but has to be listed here for systems such as AIX which
5211 need an explicit export list for symbols. (It's called from XS code
5212 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
5213 to respect attribute syntax properly would be welcome.
5219 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
5220 const char *attrstr, STRLEN len)
5224 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
5227 len = strlen(attrstr);
5231 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
5233 const char * const sstr = attrstr;
5234 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
5235 attrs = op_append_elem(OP_LIST, attrs,
5236 newSVOP(OP_CONST, 0,
5237 newSVpvn(sstr, attrstr-sstr)));
5241 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5242 newSVpvs(ATTRSMODULE),
5243 NULL, op_prepend_elem(OP_LIST,
5244 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5245 op_prepend_elem(OP_LIST,
5246 newSVOP(OP_CONST, 0,
5247 newRV(MUTABLE_SV(cv))),
5252 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5255 OP *new_proto = NULL;
5260 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5266 if (o->op_type == OP_CONST) {
5267 pv = SvPV(cSVOPo_sv, pvlen);
5268 if (memBEGINs(pv, pvlen, "prototype(")) {
5269 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5270 SV ** const tmpo = cSVOPx_svp(o);
5271 SvREFCNT_dec(cSVOPo_sv);
5276 } else if (o->op_type == OP_LIST) {
5278 assert(o->op_flags & OPf_KIDS);
5279 lasto = cLISTOPo->op_first;
5280 assert(lasto->op_type == OP_PUSHMARK);
5281 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5282 if (o->op_type == OP_CONST) {
5283 pv = SvPV(cSVOPo_sv, pvlen);
5284 if (memBEGINs(pv, pvlen, "prototype(")) {
5285 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5286 SV ** const tmpo = cSVOPx_svp(o);
5287 SvREFCNT_dec(cSVOPo_sv);
5289 if (new_proto && ckWARN(WARN_MISC)) {
5291 const char * newp = SvPV(cSVOPo_sv, new_len);
5292 Perl_warner(aTHX_ packWARN(WARN_MISC),
5293 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5294 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5300 /* excise new_proto from the list */
5301 op_sibling_splice(*attrs, lasto, 1, NULL);
5308 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5309 would get pulled in with no real need */
5310 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5319 svname = sv_newmortal();
5320 gv_efullname3(svname, name, NULL);
5322 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5323 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5325 svname = (SV *)name;
5326 if (ckWARN(WARN_ILLEGALPROTO))
5327 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5329 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5330 STRLEN old_len, new_len;
5331 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5332 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5334 if (curstash && svname == (SV *)name
5335 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5336 svname = sv_2mortal(newSVsv(PL_curstname));
5337 sv_catpvs(svname, "::");
5338 sv_catsv(svname, (SV *)name);
5341 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5342 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5344 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5345 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5355 S_cant_declare(pTHX_ OP *o)
5357 if (o->op_type == OP_NULL
5358 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5359 o = cUNOPo->op_first;
5360 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5361 o->op_type == OP_NULL
5362 && o->op_flags & OPf_SPECIAL
5365 PL_parser->in_my == KEY_our ? "our" :
5366 PL_parser->in_my == KEY_state ? "state" :
5371 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5374 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5376 PERL_ARGS_ASSERT_MY_KID;
5378 if (!o || (PL_parser && PL_parser->error_count))
5383 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5385 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5386 my_kid(kid, attrs, imopsp);
5388 } else if (type == OP_UNDEF || type == OP_STUB) {
5390 } else if (type == OP_RV2SV || /* "our" declaration */
5393 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5394 S_cant_declare(aTHX_ o);
5396 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5398 PL_parser->in_my = FALSE;
5399 PL_parser->in_my_stash = NULL;
5400 apply_attrs(GvSTASH(gv),
5401 (type == OP_RV2SV ? GvSVn(gv) :
5402 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5403 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5406 o->op_private |= OPpOUR_INTRO;
5409 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5410 if (!FEATURE_MYREF_IS_ENABLED)
5411 Perl_croak(aTHX_ "The experimental declared_refs "
5412 "feature is not enabled");
5413 Perl_ck_warner_d(aTHX_
5414 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5415 "Declaring references is experimental");
5416 /* Kid is a nulled OP_LIST, handled above. */
5417 my_kid(cUNOPo->op_first, attrs, imopsp);
5420 else if (type != OP_PADSV &&
5423 type != OP_PUSHMARK)
5425 S_cant_declare(aTHX_ o);
5428 else if (attrs && type != OP_PUSHMARK) {
5432 PL_parser->in_my = FALSE;
5433 PL_parser->in_my_stash = NULL;
5435 /* check for C<my Dog $spot> when deciding package */
5436 stash = PAD_COMPNAME_TYPE(o->op_targ);
5438 stash = PL_curstash;
5439 apply_attrs_my(stash, o, attrs, imopsp);
5441 o->op_flags |= OPf_MOD;
5442 o->op_private |= OPpLVAL_INTRO;
5444 o->op_private |= OPpPAD_STATE;
5449 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5452 int maybe_scalar = 0;
5454 PERL_ARGS_ASSERT_MY_ATTRS;
5456 /* [perl #17376]: this appears to be premature, and results in code such as
5457 C< our(%x); > executing in list mode rather than void mode */
5459 if (o->op_flags & OPf_PARENS)
5469 o = my_kid(o, attrs, &rops);
5471 if (maybe_scalar && o->op_type == OP_PADSV) {
5472 o = scalar(op_append_list(OP_LIST, rops, o));
5473 o->op_private |= OPpLVAL_INTRO;
5476 /* The listop in rops might have a pushmark at the beginning,
5477 which will mess up list assignment. */
5478 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5479 if (rops->op_type == OP_LIST &&
5480 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5482 OP * const pushmark = lrops->op_first;
5483 /* excise pushmark */
5484 op_sibling_splice(rops, NULL, 1, NULL);
5487 o = op_append_list(OP_LIST, o, rops);
5490 PL_parser->in_my = FALSE;
5491 PL_parser->in_my_stash = NULL;
5496 Perl_sawparens(pTHX_ OP *o)
5498 PERL_UNUSED_CONTEXT;
5500 o->op_flags |= OPf_PARENS;
5505 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5509 const OPCODE ltype = left->op_type;
5510 const OPCODE rtype = right->op_type;
5512 PERL_ARGS_ASSERT_BIND_MATCH;
5514 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5515 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5517 const char * const desc
5519 rtype == OP_SUBST || rtype == OP_TRANS
5520 || rtype == OP_TRANSR
5522 ? (int)rtype : OP_MATCH];
5523 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5525 S_op_varname(aTHX_ left);
5527 Perl_warner(aTHX_ packWARN(WARN_MISC),
5528 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5529 desc, SVfARG(name), SVfARG(name));
5531 const char * const sample = (isary
5532 ? "@array" : "%hash");
5533 Perl_warner(aTHX_ packWARN(WARN_MISC),
5534 "Applying %s to %s will act on scalar(%s)",
5535 desc, sample, sample);
5539 if (rtype == OP_CONST &&
5540 cSVOPx(right)->op_private & OPpCONST_BARE &&
5541 cSVOPx(right)->op_private & OPpCONST_STRICT)
5543 no_bareword_allowed(right);
5546 /* !~ doesn't make sense with /r, so error on it for now */
5547 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5549 /* diag_listed_as: Using !~ with %s doesn't make sense */
5550 yyerror("Using !~ with s///r doesn't make sense");
5551 if (rtype == OP_TRANSR && type == OP_NOT)
5552 /* diag_listed_as: Using !~ with %s doesn't make sense */
5553 yyerror("Using !~ with tr///r doesn't make sense");
5555 ismatchop = (rtype == OP_MATCH ||
5556 rtype == OP_SUBST ||
5557 rtype == OP_TRANS || rtype == OP_TRANSR)
5558 && !(right->op_flags & OPf_SPECIAL);
5559 if (ismatchop && right->op_private & OPpTARGET_MY) {
5561 right->op_private &= ~OPpTARGET_MY;
5563 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5564 if (left->op_type == OP_PADSV
5565 && !(left->op_private & OPpLVAL_INTRO))
5567 right->op_targ = left->op_targ;
5572 right->op_flags |= OPf_STACKED;
5573 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5574 ! (rtype == OP_TRANS &&
5575 right->op_private & OPpTRANS_IDENTICAL) &&
5576 ! (rtype == OP_SUBST &&
5577 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5578 left = op_lvalue(left, rtype);
5579 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5580 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5582 o = op_prepend_elem(rtype, scalar(left), right);
5585 return newUNOP(OP_NOT, 0, scalar(o));
5589 return bind_match(type, left,
5590 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5594 Perl_invert(pTHX_ OP *o)
5598 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5602 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
5608 left = newOP(OP_NULL, 0);
5610 right = newOP(OP_NULL, 0);
5613 NewOp(0, bop, 1, BINOP);
5615 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5616 OpTYPE_set(op, type);
5617 cBINOPx(op)->op_flags = OPf_KIDS;
5618 cBINOPx(op)->op_private = 2;
5619 cBINOPx(op)->op_first = left;
5620 cBINOPx(op)->op_last = right;
5621 OpMORESIB_set(left, right);
5622 OpLASTSIB_set(right, op);
5627 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
5632 PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
5634 right = newOP(OP_NULL, 0);
5636 NewOp(0, bop, 1, BINOP);
5638 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5639 OpTYPE_set(op, type);
5640 if (ch->op_type != OP_NULL) {
5642 OP *nch, *cleft, *cright;
5643 NewOp(0, lch, 1, UNOP);
5645 OpTYPE_set(nch, OP_NULL);
5646 nch->op_flags = OPf_KIDS;
5647 cleft = cBINOPx(ch)->op_first;
5648 cright = cBINOPx(ch)->op_last;
5649 cBINOPx(ch)->op_first = NULL;
5650 cBINOPx(ch)->op_last = NULL;
5651 cBINOPx(ch)->op_private = 0;
5652 cBINOPx(ch)->op_flags = 0;
5653 cUNOPx(nch)->op_first = cright;
5654 OpMORESIB_set(cright, ch);
5655 OpMORESIB_set(ch, cleft);
5656 OpLASTSIB_set(cleft, nch);
5659 OpMORESIB_set(right, op);
5660 OpMORESIB_set(op, cUNOPx(ch)->op_first);
5661 cUNOPx(ch)->op_first = right;
5666 Perl_cmpchain_finish(pTHX_ OP *ch)
5669 PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
5670 if (ch->op_type != OP_NULL) {
5671 OPCODE cmpoptype = ch->op_type;
5672 ch = CHECKOP(cmpoptype, ch);
5673 if(!ch->op_next && ch->op_type == cmpoptype)
5674 ch = fold_constants(op_integerize(op_std_init(ch)));
5678 OP *rightarg = cUNOPx(ch)->op_first;
5679 cUNOPx(ch)->op_first = OpSIBLING(rightarg);
5680 OpLASTSIB_set(rightarg, NULL);
5682 OP *cmpop = cUNOPx(ch)->op_first;
5683 OP *leftarg = OpSIBLING(cmpop);
5684 OPCODE cmpoptype = cmpop->op_type;
5687 is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
5688 OpLASTSIB_set(cmpop, NULL);
5689 OpLASTSIB_set(leftarg, NULL);
5693 nextrightarg = NULL;
5695 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
5696 leftarg = newOP(OP_NULL, 0);
5698 cBINOPx(cmpop)->op_first = leftarg;
5699 cBINOPx(cmpop)->op_last = rightarg;
5700 OpMORESIB_set(leftarg, rightarg);
5701 OpLASTSIB_set(rightarg, cmpop);
5702 cmpop->op_flags = OPf_KIDS;
5703 cmpop->op_private = 2;
5704 cmpop = CHECKOP(cmpoptype, cmpop);
5705 if(!cmpop->op_next && cmpop->op_type == cmpoptype)
5706 cmpop = op_integerize(op_std_init(cmpop));
5707 condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
5711 rightarg = nextrightarg;
5717 =for apidoc op_scope
5719 Wraps up an op tree with some additional ops so that at runtime a dynamic
5720 scope will be created. The original ops run in the new dynamic scope,
5721 and then, provided that they exit normally, the scope will be unwound.
5722 The additional ops used to create and unwind the dynamic scope will
5723 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5724 instead if the ops are simple enough to not need the full dynamic scope
5731 Perl_op_scope(pTHX_ OP *o)
5734 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5735 o = op_prepend_elem(OP_LINESEQ,
5736 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
5737 OpTYPE_set(o, OP_LEAVE);
5739 else if (o->op_type == OP_LINESEQ) {
5741 OpTYPE_set(o, OP_SCOPE);
5742 kid = ((LISTOP*)o)->op_first;
5743 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5746 /* The following deals with things like 'do {1 for 1}' */
5747 kid = OpSIBLING(kid);
5749 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5754 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5760 Perl_op_unscope(pTHX_ OP *o)
5762 if (o && o->op_type == OP_LINESEQ) {
5763 OP *kid = cLISTOPo->op_first;
5764 for(; kid; kid = OpSIBLING(kid))
5765 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5772 =for apidoc block_start
5774 Handles compile-time scope entry.
5775 Arranges for hints to be restored on block
5776 exit and also handles pad sequence numbers to make lexical variables scope
5777 right. Returns a savestack index for use with C<block_end>.
5783 Perl_block_start(pTHX_ int full)
5785 const int retval = PL_savestack_ix;
5787 PL_compiling.cop_seq = PL_cop_seqmax;
5789 pad_block_start(full);
5791 PL_hints &= ~HINT_BLOCK_SCOPE;
5792 SAVECOMPILEWARNINGS();
5793 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5794 SAVEI32(PL_compiling.cop_seq);
5795 PL_compiling.cop_seq = 0;
5797 CALL_BLOCK_HOOKS(bhk_start, full);
5803 =for apidoc block_end
5805 Handles compile-time scope exit. C<floor>
5806 is the savestack index returned by
5807 C<block_start>, and C<seq> is the body of the block. Returns the block,
5814 Perl_block_end(pTHX_ I32 floor, OP *seq)
5816 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5817 OP* retval = voidnonfinal(seq);
5820 /* XXX Is the null PL_parser check necessary here? */
5821 assert(PL_parser); /* Let’s find out under debugging builds. */
5822 if (PL_parser && PL_parser->parsed_sub) {
5823 o = newSTATEOP(0, NULL, NULL);
5825 retval = op_append_elem(OP_LINESEQ, retval, o);
5828 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5832 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5836 /* pad_leavemy has created a sequence of introcv ops for all my
5837 subs declared in the block. We have to replicate that list with
5838 clonecv ops, to deal with this situation:
5843 sub s1 { state sub foo { \&s2 } }
5846 Originally, I was going to have introcv clone the CV and turn
5847 off the stale flag. Since &s1 is declared before &s2, the
5848 introcv op for &s1 is executed (on sub entry) before the one for
5849 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5850 cloned, since it is a state sub) closes over &s2 and expects
5851 to see it in its outer CV’s pad. If the introcv op clones &s1,
5852 then &s2 is still marked stale. Since &s1 is not active, and
5853 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5854 ble will not stay shared’ warning. Because it is the same stub
5855 that will be used when the introcv op for &s2 is executed, clos-
5856 ing over it is safe. Hence, we have to turn off the stale flag
5857 on all lexical subs in the block before we clone any of them.
5858 Hence, having introcv clone the sub cannot work. So we create a
5859 list of ops like this:
5883 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5884 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5885 for (;; kid = OpSIBLING(kid)) {
5886 OP *newkid = newOP(OP_CLONECV, 0);
5887 newkid->op_targ = kid->op_targ;
5888 o = op_append_elem(OP_LINESEQ, o, newkid);
5889 if (kid == last) break;
5891 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5894 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5900 =for apidoc_section $scope
5902 =for apidoc blockhook_register
5904 Register a set of hooks to be called when the Perl lexical scope changes
5905 at compile time. See L<perlguts/"Compile-time scope hooks">.
5911 Perl_blockhook_register(pTHX_ BHK *hk)
5913 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5915 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5919 Perl_newPROG(pTHX_ OP *o)
5923 PERL_ARGS_ASSERT_NEWPROG;
5930 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5931 ((PL_in_eval & EVAL_KEEPERR)
5932 ? OPf_SPECIAL : 0), o);
5935 assert(CxTYPE(cx) == CXt_EVAL);
5937 if ((cx->blk_gimme & G_WANT) == G_VOID)
5938 scalarvoid(PL_eval_root);
5939 else if ((cx->blk_gimme & G_WANT) == G_LIST)
5942 scalar(PL_eval_root);
5944 start = op_linklist(PL_eval_root);
5945 PL_eval_root->op_next = 0;
5946 i = PL_savestack_ix;
5949 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5951 PL_savestack_ix = i;
5954 if (o->op_type == OP_STUB) {
5955 /* This block is entered if nothing is compiled for the main
5956 program. This will be the case for an genuinely empty main
5957 program, or one which only has BEGIN blocks etc, so already
5960 Historically (5.000) the guard above was !o. However, commit
5961 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5962 c71fccf11fde0068, changed perly.y so that newPROG() is now
5963 called with the output of block_end(), which returns a new
5964 OP_STUB for the case of an empty optree. ByteLoader (and
5965 maybe other things) also take this path, because they set up
5966 PL_main_start and PL_main_root directly, without generating an
5969 If the parsing the main program aborts (due to parse errors,
5970 or due to BEGIN or similar calling exit), then newPROG()
5971 isn't even called, and hence this code path and its cleanups
5972 are skipped. This shouldn't make a make a difference:
5973 * a non-zero return from perl_parse is a failure, and
5974 perl_destruct() should be called immediately.
5975 * however, if exit(0) is called during the parse, then
5976 perl_parse() returns 0, and perl_run() is called. As
5977 PL_main_start will be NULL, perl_run() will return
5978 promptly, and the exit code will remain 0.
5981 PL_comppad_name = 0;
5983 S_op_destroy(aTHX_ o);
5986 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5987 PL_curcop = &PL_compiling;
5988 start = LINKLIST(PL_main_root);
5989 PL_main_root->op_next = 0;
5990 S_process_optree(aTHX_ NULL, PL_main_root, start);
5991 if (!PL_parser->error_count)
5992 /* on error, leave CV slabbed so that ops left lying around
5993 * will eb cleaned up. Else unslab */
5994 cv_forget_slab(PL_compcv);
5997 /* Register with debugger */
5999 CV * const cv = get_cvs("DB::postponed", 0);
6003 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
6005 call_sv(MUTABLE_SV(cv), G_DISCARD);
6012 Perl_localize(pTHX_ OP *o, I32 lex)
6014 PERL_ARGS_ASSERT_LOCALIZE;
6016 if (o->op_flags & OPf_PARENS)
6017 /* [perl #17376]: this appears to be premature, and results in code such as
6018 C< our(%x); > executing in list mode rather than void mode */
6025 if ( PL_parser->bufptr > PL_parser->oldbufptr
6026 && PL_parser->bufptr[-1] == ','
6027 && ckWARN(WARN_PARENTHESIS))
6029 char *s = PL_parser->bufptr;
6032 /* some heuristics to detect a potential error */
6033 while (*s && (memCHRs(", \t\n", *s)))
6037 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
6039 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
6042 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
6044 while (*s && (memCHRs(", \t\n", *s)))
6050 if (sigil && (*s == ';' || *s == '=')) {
6051 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
6052 "Parentheses missing around \"%s\" list",
6054 ? (PL_parser->in_my == KEY_our
6056 : PL_parser->in_my == KEY_state
6066 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
6067 PL_parser->in_my = FALSE;
6068 PL_parser->in_my_stash = NULL;
6073 Perl_jmaybe(pTHX_ OP *o)
6075 PERL_ARGS_ASSERT_JMAYBE;
6077 if (o->op_type == OP_LIST) {
6078 if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
6080 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
6081 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
6084 /* If the user disables this, then a warning might not be enough to alert
6085 them to a possible change of behaviour here, so throw an exception.
6087 yyerror("Multidimensional hash lookup is disabled");
6093 PERL_STATIC_INLINE OP *
6094 S_op_std_init(pTHX_ OP *o)
6096 I32 type = o->op_type;
6098 PERL_ARGS_ASSERT_OP_STD_INIT;
6100 if (PL_opargs[type] & OA_RETSCALAR)
6102 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
6103 o->op_targ = pad_alloc(type, SVs_PADTMP);
6108 PERL_STATIC_INLINE OP *
6109 S_op_integerize(pTHX_ OP *o)
6111 I32 type = o->op_type;
6113 PERL_ARGS_ASSERT_OP_INTEGERIZE;
6115 /* integerize op. */
6116 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
6118 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
6121 if (type == OP_NEGATE)
6122 /* XXX might want a ck_negate() for this */
6123 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
6128 /* This function exists solely to provide a scope to limit
6129 setjmp/longjmp() messing with auto variables. It cannot be inlined because
6133 S_fold_constants_eval(pTHX) {
6149 S_fold_constants(pTHX_ OP *const o)
6153 I32 type = o->op_type;
6158 SV * const oldwarnhook = PL_warnhook;
6159 SV * const olddiehook = PL_diehook;
6161 U8 oldwarn = PL_dowarn;
6164 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
6166 if (!(PL_opargs[type] & OA_FOLDCONST))
6175 #ifdef USE_LOCALE_CTYPE
6176 if (IN_LC_COMPILETIME(LC_CTYPE))
6185 #ifdef USE_LOCALE_COLLATE
6186 if (IN_LC_COMPILETIME(LC_COLLATE))
6191 /* XXX what about the numeric ops? */
6192 #ifdef USE_LOCALE_NUMERIC
6193 if (IN_LC_COMPILETIME(LC_NUMERIC))
6198 if (!OpHAS_SIBLING(cLISTOPo->op_first)
6199 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
6202 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
6203 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
6205 const char *s = SvPVX_const(sv);
6206 while (s < SvEND(sv)) {
6207 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
6214 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
6217 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
6218 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
6222 if (PL_parser && PL_parser->error_count)
6223 goto nope; /* Don't try to run w/ errors */
6225 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
6226 switch (curop->op_type) {
6228 if ( (curop->op_private & OPpCONST_BARE)
6229 && (curop->op_private & OPpCONST_STRICT)) {
6230 no_bareword_allowed(curop);
6238 /* Foldable; move to next op in list */
6242 /* No other op types are considered foldable */
6247 curop = LINKLIST(o);
6248 old_next = o->op_next;
6252 old_cxix = cxstack_ix;
6253 create_eval_scope(NULL, G_FAKINGEVAL);
6255 /* Verify that we don't need to save it: */
6256 assert(PL_curcop == &PL_compiling);
6257 StructCopy(&PL_compiling, ¬_compiling, COP);
6258 PL_curcop = ¬_compiling;
6259 /* The above ensures that we run with all the correct hints of the
6260 currently compiling COP, but that IN_PERL_RUNTIME is true. */
6261 assert(IN_PERL_RUNTIME);
6262 PL_warnhook = PERL_WARNHOOK_FATAL;
6265 /* Effective $^W=1. */
6266 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6267 PL_dowarn |= G_WARN_ON;
6269 ret = S_fold_constants_eval(aTHX);
6273 sv = *(PL_stack_sp--);
6274 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
6275 pad_swipe(o->op_targ, FALSE);
6277 else if (SvTEMP(sv)) { /* grab mortal temp? */
6278 SvREFCNT_inc_simple_void(sv);
6281 else { assert(SvIMMORTAL(sv)); }
6284 /* Something tried to die. Abandon constant folding. */
6285 /* Pretend the error never happened. */
6287 o->op_next = old_next;
6290 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
6291 PL_warnhook = oldwarnhook;
6292 PL_diehook = olddiehook;
6293 /* XXX note that this croak may fail as we've already blown away
6294 * the stack - eg any nested evals */
6295 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6297 PL_dowarn = oldwarn;
6298 PL_warnhook = oldwarnhook;
6299 PL_diehook = olddiehook;
6300 PL_curcop = &PL_compiling;
6302 /* if we croaked, depending on how we croaked the eval scope
6303 * may or may not have already been popped */
6304 if (cxstack_ix > old_cxix) {
6305 assert(cxstack_ix == old_cxix + 1);
6306 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6307 delete_eval_scope();
6312 /* OP_STRINGIFY and constant folding are used to implement qq.
6313 Here the constant folding is an implementation detail that we
6314 want to hide. If the stringify op is itself already marked
6315 folded, however, then it is actually a folded join. */
6316 is_stringify = type == OP_STRINGIFY && !o->op_folded;
6321 else if (!SvIMMORTAL(sv)) {
6325 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6326 if (!is_stringify) newop->op_folded = 1;
6333 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6334 * the constant value being an AV holding the flattened range.
6338 S_gen_constant_list(pTHX_ OP *o)
6340 OP *curop, *old_next;
6341 SV * const oldwarnhook = PL_warnhook;
6342 SV * const olddiehook = PL_diehook;
6344 U8 oldwarn = PL_dowarn;
6354 if (PL_parser && PL_parser->error_count)
6355 return; /* Don't attempt to run with errors */
6357 curop = LINKLIST(o);
6358 old_next = o->op_next;
6360 op_was_null = o->op_type == OP_NULL;
6361 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6362 o->op_type = OP_CUSTOM;
6365 o->op_type = OP_NULL;
6366 S_prune_chain_head(&curop);
6369 old_cxix = cxstack_ix;
6370 create_eval_scope(NULL, G_FAKINGEVAL);
6372 old_curcop = PL_curcop;
6373 StructCopy(old_curcop, ¬_compiling, COP);
6374 PL_curcop = ¬_compiling;
6375 /* The above ensures that we run with all the correct hints of the
6376 current COP, but that IN_PERL_RUNTIME is true. */
6377 assert(IN_PERL_RUNTIME);
6378 PL_warnhook = PERL_WARNHOOK_FATAL;
6382 /* Effective $^W=1. */
6383 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6384 PL_dowarn |= G_WARN_ON;
6388 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6389 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6391 Perl_pp_pushmark(aTHX);
6394 assert (!(curop->op_flags & OPf_SPECIAL));
6395 assert(curop->op_type == OP_RANGE);
6396 Perl_pp_anonlist(aTHX);
6400 o->op_next = old_next;
6404 PL_warnhook = oldwarnhook;
6405 PL_diehook = olddiehook;
6406 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6411 PL_dowarn = oldwarn;
6412 PL_warnhook = oldwarnhook;
6413 PL_diehook = olddiehook;
6414 PL_curcop = old_curcop;
6416 if (cxstack_ix > old_cxix) {
6417 assert(cxstack_ix == old_cxix + 1);
6418 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6419 delete_eval_scope();
6424 OpTYPE_set(o, OP_RV2AV);
6425 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6426 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6427 o->op_opt = 0; /* needs to be revisited in rpeep() */
6428 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6430 /* replace subtree with an OP_CONST */
6431 curop = ((UNOP*)o)->op_first;
6432 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6435 if (AvFILLp(av) != -1)
6436 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6439 SvREADONLY_on(*svp);
6447 =for apidoc_section $optree_manipulation
6450 /* List constructors */
6453 =for apidoc op_append_elem
6455 Append an item to the list of ops contained directly within a list-type
6456 op, returning the lengthened list. C<first> is the list-type op,
6457 and C<last> is the op to append to the list. C<optype> specifies the
6458 intended opcode for the list. If C<first> is not already a list of the
6459 right type, it will be upgraded into one. If either C<first> or C<last>
6460 is null, the other is returned unchanged.
6466 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6474 if (first->op_type != (unsigned)type
6475 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6477 return newLISTOP(type, 0, first, last);
6480 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6481 first->op_flags |= OPf_KIDS;
6486 =for apidoc op_append_list
6488 Concatenate the lists of ops contained directly within two list-type ops,
6489 returning the combined list. C<first> and C<last> are the list-type ops
6490 to concatenate. C<optype> specifies the intended opcode for the list.
6491 If either C<first> or C<last> is not already a list of the right type,
6492 it will be upgraded into one. If either C<first> or C<last> is null,
6493 the other is returned unchanged.
6499 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6507 if (first->op_type != (unsigned)type)
6508 return op_prepend_elem(type, first, last);
6510 if (last->op_type != (unsigned)type)
6511 return op_append_elem(type, first, last);
6513 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6514 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6515 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6516 first->op_flags |= (last->op_flags & OPf_KIDS);
6518 S_op_destroy(aTHX_ last);
6524 =for apidoc op_prepend_elem
6526 Prepend an item to the list of ops contained directly within a list-type
6527 op, returning the lengthened list. C<first> is the op to prepend to the
6528 list, and C<last> is the list-type op. C<optype> specifies the intended
6529 opcode for the list. If C<last> is not already a list of the right type,
6530 it will be upgraded into one. If either C<first> or C<last> is null,
6531 the other is returned unchanged.
6537 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6545 if (last->op_type == (unsigned)type) {
6546 if (type == OP_LIST) { /* already a PUSHMARK there */
6547 /* insert 'first' after pushmark */
6548 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6549 if (!(first->op_flags & OPf_PARENS))
6550 last->op_flags &= ~OPf_PARENS;
6553 op_sibling_splice(last, NULL, 0, first);
6554 last->op_flags |= OPf_KIDS;
6558 return newLISTOP(type, 0, first, last);
6562 =for apidoc op_convert_list
6564 Converts C<o> into a list op if it is not one already, and then converts it
6565 into the specified C<type>, calling its check function, allocating a target if
6566 it needs one, and folding constants.
6568 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6569 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6570 C<op_convert_list> to make it the right type.
6576 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6578 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6579 if (!o || o->op_type != OP_LIST)
6580 o = force_list(o, FALSE);
6583 o->op_flags &= ~OPf_WANT;
6584 o->op_private &= ~OPpLVAL_INTRO;
6587 if (!(PL_opargs[type] & OA_MARK))
6588 op_null(cLISTOPo->op_first);
6590 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6591 if (kid2 && kid2->op_type == OP_COREARGS) {
6592 op_null(cLISTOPo->op_first);
6593 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6597 if (type != OP_SPLIT)
6598 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6599 * ck_split() create a real PMOP and leave the op's type as listop
6600 * for now. Otherwise op_free() etc will crash.
6602 OpTYPE_set(o, type);
6604 o->op_flags |= flags;
6605 if (flags & OPf_FOLDED)
6608 o = CHECKOP(type, o);
6609 if (o->op_type != (unsigned)type)
6612 return fold_constants(op_integerize(op_std_init(o)));
6619 =for apidoc_section $optree_construction
6621 =for apidoc newNULLLIST
6623 Constructs, checks, and returns a new C<stub> op, which represents an
6624 empty list expression.
6630 Perl_newNULLLIST(pTHX)
6632 return newOP(OP_STUB, 0);
6635 /* promote o and any siblings to be a list if its not already; i.e.
6643 * pushmark - o - A - B
6645 * If nullit it true, the list op is nulled.
6649 S_force_list(pTHX_ OP *o, bool nullit)
6651 if (!o || o->op_type != OP_LIST) {
6654 /* manually detach any siblings then add them back later */
6655 rest = OpSIBLING(o);
6656 OpLASTSIB_set(o, NULL);
6658 o = newLISTOP(OP_LIST, 0, o, NULL);
6660 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6668 =for apidoc newLISTOP
6670 Constructs, checks, and returns an op of any list type. C<type> is
6671 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6672 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6673 supply up to two ops to be direct children of the list op; they are
6674 consumed by this function and become part of the constructed op tree.
6676 For most list operators, the check function expects all the kid ops to be
6677 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6678 appropriate. What you want to do in that case is create an op of type
6679 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6680 See L</op_convert_list> for more information.
6687 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6690 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6691 * pushmark is banned. So do it now while existing ops are in a
6692 * consistent state, in case they suddenly get freed */
6693 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6695 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6696 || type == OP_CUSTOM);
6698 NewOp(1101, listop, 1, LISTOP);
6699 OpTYPE_set(listop, type);
6702 listop->op_flags = (U8)flags;
6706 else if (!first && last)
6709 OpMORESIB_set(first, last);
6710 listop->op_first = first;
6711 listop->op_last = last;
6714 OpMORESIB_set(pushop, first);
6715 listop->op_first = pushop;
6716 listop->op_flags |= OPf_KIDS;
6718 listop->op_last = pushop;
6720 if (listop->op_last)
6721 OpLASTSIB_set(listop->op_last, (OP*)listop);
6723 return CHECKOP(type, listop);
6729 Constructs, checks, and returns an op of any base type (any type that
6730 has no extra fields). C<type> is the opcode. C<flags> gives the
6731 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6738 Perl_newOP(pTHX_ I32 type, I32 flags)
6742 if (type == -OP_ENTEREVAL) {
6743 type = OP_ENTEREVAL;
6744 flags |= OPpEVAL_BYTES<<8;
6747 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6748 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6749 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6750 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6752 NewOp(1101, o, 1, OP);
6753 OpTYPE_set(o, type);
6754 o->op_flags = (U8)flags;
6757 o->op_private = (U8)(0 | (flags >> 8));
6758 if (PL_opargs[type] & OA_RETSCALAR)
6760 if (PL_opargs[type] & OA_TARGET)
6761 o->op_targ = pad_alloc(type, SVs_PADTMP);
6762 return CHECKOP(type, o);
6768 Constructs, checks, and returns an op of any unary type. C<type> is
6769 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6770 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6771 bits, the eight bits of C<op_private>, except that the bit with value 1
6772 is automatically set. C<first> supplies an optional op to be the direct
6773 child of the unary op; it is consumed by this function and become part
6774 of the constructed op tree.
6776 =for apidoc Amnh||OPf_KIDS
6782 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6786 if (type == -OP_ENTEREVAL) {
6787 type = OP_ENTEREVAL;
6788 flags |= OPpEVAL_BYTES<<8;
6791 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6792 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6793 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6794 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6795 || type == OP_SASSIGN
6796 || type == OP_ENTERTRY
6797 || type == OP_ENTERTRYCATCH
6798 || type == OP_CUSTOM
6799 || type == OP_NULL );
6802 first = newOP(OP_STUB, 0);
6803 if (PL_opargs[type] & OA_MARK)
6804 first = force_list(first, TRUE);
6806 NewOp(1101, unop, 1, UNOP);
6807 OpTYPE_set(unop, type);
6808 unop->op_first = first;
6809 unop->op_flags = (U8)(flags | OPf_KIDS);
6810 unop->op_private = (U8)(1 | (flags >> 8));
6812 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6813 OpLASTSIB_set(first, (OP*)unop);
6815 unop = (UNOP*) CHECKOP(type, unop);
6819 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6823 =for apidoc newUNOP_AUX
6825 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6826 initialised to C<aux>
6832 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6836 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6837 || type == OP_CUSTOM);
6839 NewOp(1101, unop, 1, UNOP_AUX);
6840 unop->op_type = (OPCODE)type;
6841 unop->op_ppaddr = PL_ppaddr[type];
6842 unop->op_first = first;
6843 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6844 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6847 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6848 OpLASTSIB_set(first, (OP*)unop);
6850 unop = (UNOP_AUX*) CHECKOP(type, unop);
6852 return op_std_init((OP *) unop);
6856 =for apidoc newMETHOP
6858 Constructs, checks, and returns an op of method type with a method name
6859 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6860 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6861 and, shifted up eight bits, the eight bits of C<op_private>, except that
6862 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6863 op which evaluates method name; it is consumed by this function and
6864 become part of the constructed op tree.
6865 Supported optypes: C<OP_METHOD>.
6871 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6874 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6875 || type == OP_CUSTOM);
6877 NewOp(1101, methop, 1, METHOP);
6879 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, TRUE);
6880 methop->op_flags = (U8)(flags | OPf_KIDS);
6881 methop->op_u.op_first = dynamic_meth;
6882 methop->op_private = (U8)(1 | (flags >> 8));
6884 if (!OpHAS_SIBLING(dynamic_meth))
6885 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6889 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6890 methop->op_u.op_meth_sv = const_meth;
6891 methop->op_private = (U8)(0 | (flags >> 8));
6892 methop->op_next = (OP*)methop;
6896 methop->op_rclass_targ = 0;
6898 methop->op_rclass_sv = NULL;
6901 OpTYPE_set(methop, type);
6902 return CHECKOP(type, methop);
6906 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6907 PERL_ARGS_ASSERT_NEWMETHOP;
6908 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6912 =for apidoc newMETHOP_named
6914 Constructs, checks, and returns an op of method type with a constant
6915 method name. C<type> is the opcode. C<flags> gives the eight bits of
6916 C<op_flags>, and, shifted up eight bits, the eight bits of
6917 C<op_private>. C<const_meth> supplies a constant method name;
6918 it must be a shared COW string.
6919 Supported optypes: C<OP_METHOD_NAMED>.
6925 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6926 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6927 return newMETHOP_internal(type, flags, NULL, const_meth);
6931 =for apidoc newBINOP
6933 Constructs, checks, and returns an op of any binary type. C<type>
6934 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6935 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6936 the eight bits of C<op_private>, except that the bit with value 1 or
6937 2 is automatically set as required. C<first> and C<last> supply up to
6938 two ops to be the direct children of the binary op; they are consumed
6939 by this function and become part of the constructed op tree.
6945 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6949 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6950 || type == OP_NULL || type == OP_CUSTOM);
6952 NewOp(1101, binop, 1, BINOP);
6955 first = newOP(OP_NULL, 0);
6957 OpTYPE_set(binop, type);
6958 binop->op_first = first;
6959 binop->op_flags = (U8)(flags | OPf_KIDS);
6962 binop->op_private = (U8)(1 | (flags >> 8));
6965 binop->op_private = (U8)(2 | (flags >> 8));
6966 OpMORESIB_set(first, last);
6969 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6970 OpLASTSIB_set(last, (OP*)binop);
6972 binop->op_last = OpSIBLING(binop->op_first);
6974 OpLASTSIB_set(binop->op_last, (OP*)binop);
6976 binop = (BINOP*)CHECKOP(type, binop);
6977 if (binop->op_next || binop->op_type != (OPCODE)type)
6980 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6984 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
6986 const char indent[] = " ";
6988 UV len = _invlist_len(invlist);
6989 UV * array = invlist_array(invlist);
6992 PERL_ARGS_ASSERT_INVMAP_DUMP;
6994 for (i = 0; i < len; i++) {
6995 UV start = array[i];
6996 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
6998 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
6999 if (end == IV_MAX) {
7000 PerlIO_printf(Perl_debug_log, " .. INFTY");
7002 else if (end != start) {
7003 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
7006 PerlIO_printf(Perl_debug_log, " ");
7009 PerlIO_printf(Perl_debug_log, "\t");
7011 if (map[i] == TR_UNLISTED) {
7012 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
7014 else if (map[i] == TR_SPECIAL_HANDLING) {
7015 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
7018 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
7023 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
7024 * containing the search and replacement strings, assemble into
7025 * a translation table attached as o->op_pv.
7026 * Free expr and repl.
7027 * It expects the toker to have already set the
7028 * OPpTRANS_COMPLEMENT
7031 * flags as appropriate; this function may add
7033 * OPpTRANS_CAN_FORCE_UTF8
7034 * OPpTRANS_IDENTICAL
7040 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
7042 /* This function compiles a tr///, from data gathered from toke.c, into a
7043 * form suitable for use by do_trans() in doop.c at runtime.
7045 * It first normalizes the data, while discarding extraneous inputs; then
7046 * writes out the compiled data. The normalization allows for complete
7047 * analysis, and avoids some false negatives and positives earlier versions
7050 * The normalization form is an inversion map (described below in detail).
7051 * This is essentially the compiled form for tr///'s that require UTF-8,
7052 * and its easy to use it to write the 257-byte table for tr///'s that
7053 * don't need UTF-8. That table is identical to what's been in use for
7054 * many perl versions, except that it doesn't handle some edge cases that
7055 * it used to, involving code points above 255. The UTF-8 form now handles
7056 * these. (This could be changed with extra coding should it shown to be
7059 * If the complement (/c) option is specified, the lhs string (tstr) is
7060 * parsed into an inversion list. Complementing these is trivial. Then a
7061 * complemented tstr is built from that, and used thenceforth. This hides
7062 * the fact that it was complemented from almost all successive code.
7064 * One of the important characteristics to know about the input is whether
7065 * the transliteration may be done in place, or does a temporary need to be
7066 * allocated, then copied. If the replacement for every character in every
7067 * possible string takes up no more bytes than the character it
7068 * replaces, then it can be edited in place. Otherwise the replacement
7069 * could overwrite a byte we are about to read, depending on the strings
7070 * being processed. The comments and variable names here refer to this as
7071 * "growing". Some inputs won't grow, and might even shrink under /d, but
7072 * some inputs could grow, so we have to assume any given one might grow.
7073 * On very long inputs, the temporary could eat up a lot of memory, so we
7074 * want to avoid it if possible. For non-UTF-8 inputs, everything is
7075 * single-byte, so can be edited in place, unless there is something in the
7076 * pattern that could force it into UTF-8. The inversion map makes it
7077 * feasible to determine this. Previous versions of this code pretty much
7078 * punted on determining if UTF-8 could be edited in place. Now, this code
7079 * is rigorous in making that determination.
7081 * Another characteristic we need to know is whether the lhs and rhs are
7082 * identical. If so, and no other flags are present, the only effect of
7083 * the tr/// is to count the characters present in the input that are
7084 * mentioned in the lhs string. The implementation of that is easier and
7085 * runs faster than the more general case. Normalizing here allows for
7086 * accurate determination of this. Previously there were false negatives
7089 * Instead of 'transliterated', the comments here use 'unmapped' for the
7090 * characters that are left unchanged by the operation; otherwise they are
7093 * The lhs of the tr/// is here referred to as the t side.
7094 * The rhs of the tr/// is here referred to as the r side.
7097 SV * const tstr = ((SVOP*)expr)->op_sv;
7098 SV * const rstr = ((SVOP*)repl)->op_sv;
7101 const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
7102 const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
7105 UV t_count = 0, r_count = 0; /* Number of characters in search and
7106 replacement lists */
7108 /* khw thinks some of the private flags for this op are quaintly named.
7109 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
7110 * character when represented in UTF-8 is longer than the original
7111 * character's UTF-8 representation */
7112 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
7113 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
7114 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
7116 /* Set to true if there is some character < 256 in the lhs that maps to
7117 * above 255. If so, a non-UTF-8 match string can be forced into being in
7118 * UTF-8 by a tr/// operation. */
7119 bool can_force_utf8 = FALSE;
7121 /* What is the maximum expansion factor in UTF-8 transliterations. If a
7122 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
7123 * expansion factor is 1.5. This number is used at runtime to calculate
7124 * how much space to allocate for non-inplace transliterations. Without
7125 * this number, the worst case is 14, which is extremely unlikely to happen
7126 * in real life, and could require significant memory overhead. */
7127 NV max_expansion = 1.;
7129 UV t_range_count, r_range_count, min_range_count;
7133 UV r_cp = 0, t_cp = 0;
7134 UV t_cp_end = (UV) -1;
7138 UV final_map = TR_UNLISTED; /* The final character in the replacement
7139 list, updated as we go along. Initialize
7140 to something illegal */
7142 bool rstr_utf8 = cBOOL(SvUTF8(rstr));
7143 bool tstr_utf8 = cBOOL(SvUTF8(tstr));
7145 const U8* tend = t + tlen;
7146 const U8* rend = r + rlen;
7148 SV * inverted_tstr = NULL;
7153 /* This routine implements detection of a transliteration having a longer
7154 * UTF-8 representation than its source, by partitioning all the possible
7155 * code points of the platform into equivalence classes of the same UTF-8
7156 * byte length in the first pass. As it constructs the mappings, it carves
7157 * these up into smaller chunks, but doesn't merge any together. This
7158 * makes it easy to find the instances it's looking for. A second pass is
7159 * done after this has been determined which merges things together to
7160 * shrink the table for runtime. The table below is used for both ASCII
7161 * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically
7162 * increasing for code points below 256. To correct for that, the macro
7163 * CP_ADJUST defined below converts those code points to ASCII in the first
7164 * pass, and we use the ASCII partition values. That works because the
7165 * growth factor will be unaffected, which is all that is calculated during
7166 * the first pass. */
7167 UV PL_partition_by_byte_length[] = {
7169 0x80, /* Below this is 1 byte representations */
7170 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */
7171 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */
7172 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */
7173 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */
7174 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */
7178 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */
7183 PERL_ARGS_ASSERT_PMTRANS;
7185 PL_hints |= HINT_BLOCK_SCOPE;
7187 /* If /c, the search list is sorted and complemented. This is now done by
7188 * creating an inversion list from it, and then trivially inverting that.
7189 * The previous implementation used qsort, but creating the list
7190 * automatically keeps it sorted as we go along */
7193 SV * inverted_tlist = _new_invlist(tlen);
7196 DEBUG_y(PerlIO_printf(Perl_debug_log,
7197 "%s: %d: tstr before inversion=\n%s\n",
7198 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7202 /* Non-utf8 strings don't have ranges, so each character is listed
7205 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
7208 else { /* But UTF-8 strings have been parsed in toke.c to have
7209 * ranges if appropriate. */
7213 /* Get the first character */
7214 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7217 /* If the next byte indicates that this wasn't the first
7218 * element of a range, the range is just this one */
7219 if (t >= tend || *t != RANGE_INDICATOR) {
7220 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
7222 else { /* Otherwise, ignore the indicator byte, and get the
7223 final element, and add the whole range */
7225 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
7228 inverted_tlist = _add_range_to_invlist(inverted_tlist,
7232 } /* End of parse through tstr */
7234 /* The inversion list is done; now invert it */
7235 _invlist_invert(inverted_tlist);
7237 /* Now go through the inverted list and create a new tstr for the rest
7238 * of the routine to use. Since the UTF-8 version can have ranges, and
7239 * can be much more compact than the non-UTF-8 version, we create the
7240 * string in UTF-8 even if not necessary. (This is just an intermediate
7241 * value that gets thrown away anyway.) */
7242 invlist_iterinit(inverted_tlist);
7243 inverted_tstr = newSVpvs("");
7244 while (invlist_iternext(inverted_tlist, &start, &end)) {
7245 U8 temp[UTF8_MAXBYTES];
7248 /* IV_MAX keeps things from going out of bounds */
7249 start = MIN(IV_MAX, start);
7250 end = MIN(IV_MAX, end);
7252 temp_end_pos = uvchr_to_utf8(temp, start);
7253 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7256 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
7257 temp_end_pos = uvchr_to_utf8(temp, end);
7258 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7262 /* Set up so the remainder of the routine uses this complement, instead
7263 * of the actual input */
7264 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
7265 tend = t0 + temp_len;
7268 SvREFCNT_dec_NN(inverted_tlist);
7271 /* For non-/d, an empty rhs means to use the lhs */
7272 if (rlen == 0 && ! del) {
7275 rstr_utf8 = tstr_utf8;
7278 t_invlist = _new_invlist(1);
7280 /* Initialize to a single range */
7281 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7283 /* For the first pass, the lhs is partitioned such that the
7284 * number of UTF-8 bytes required to represent a code point in each
7285 * partition is the same as the number for any other code point in
7286 * that partion. We copy the pre-compiled partion. */
7287 len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
7288 invlist_extend(t_invlist, len);
7289 t_array = invlist_array(t_invlist);
7290 Copy(PL_partition_by_byte_length, t_array, len, UV);
7291 invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
7292 Newx(r_map, len + 1, UV);
7294 /* Parse the (potentially adjusted) input, creating the inversion map.
7295 * This is done in two passes. The first pass is to determine if the
7296 * transliteration can be done in place. The inversion map it creates
7297 * could be used, but generally would be larger and slower to run than the
7298 * output of the second pass, which starts with a more compact table and
7299 * allows more ranges to be merged */
7300 for (pass2 = 0; pass2 < 2; pass2++) {
7302 /* Initialize to a single range */
7303 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7305 /* In the second pass, we just have the single range */
7307 t_array = invlist_array(t_invlist);
7310 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
7311 * so as to get the well-behaved length 1 vs length 2 boundary. Only code
7312 * points below 256 differ between the two character sets in this regard. For
7313 * these, we also can't have any ranges, as they have to be individually
7316 # define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x))
7317 # define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256))
7318 # define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
7320 # define CP_ADJUST(x) (x)
7321 # define FORCE_RANGE_LEN_1(x) 0
7322 # define CP_SKIP(x) UVCHR_SKIP(x)
7325 /* And the mapping of each of the ranges is initialized. Initially,
7326 * everything is TR_UNLISTED. */
7327 for (i = 0; i < len; i++) {
7328 r_map[i] = TR_UNLISTED;
7335 t_range_count = r_range_count = 0;
7337 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
7338 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7339 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
7340 _byte_dump_string(r, rend - r, 0)));
7341 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
7342 complement, squash, del));
7343 DEBUG_y(invmap_dump(t_invlist, r_map));
7345 /* Now go through the search list constructing an inversion map. The
7346 * input is not necessarily in any particular order. Making it an
7347 * inversion map orders it, potentially simplifying, and makes it easy
7348 * to deal with at run time. This is the only place in core that
7349 * generates an inversion map; if others were introduced, it might be
7350 * better to create general purpose routines to handle them.
7351 * (Inversion maps are created in perl in other places.)
7353 * An inversion map consists of two parallel arrays. One is
7354 * essentially an inversion list: an ordered list of code points such
7355 * that each element gives the first code point of a range of
7356 * consecutive code points that map to the element in the other array
7357 * that has the same index as this one (in other words, the
7358 * corresponding element). Thus the range extends up to (but not
7359 * including) the code point given by the next higher element. In a
7360 * true inversion map, the corresponding element in the other array
7361 * gives the mapping of the first code point in the range, with the
7362 * understanding that the next higher code point in the inversion
7363 * list's range will map to the next higher code point in the map.
7365 * So if at element [i], let's say we have:
7370 * This means that A => a, B => b, C => c.... Let's say that the
7371 * situation is such that:
7375 * This means the sequence that started at [i] stops at K => k. This
7376 * illustrates that you need to look at the next element to find where
7377 * a sequence stops. Except, the highest element in the inversion list
7378 * begins a range that is understood to extend to the platform's
7381 * This routine modifies traditional inversion maps to reserve two
7384 * TR_UNLISTED (or -1) indicates that no code point in the range
7385 * is listed in the tr/// searchlist. At runtime, these are
7386 * always passed through unchanged. In the inversion map, all
7387 * points in the range are mapped to -1, instead of increasing,
7388 * like the 'L' in the example above.
7390 * We start the parse with every code point mapped to this, and as
7391 * we parse and find ones that are listed in the search list, we
7392 * carve out ranges as we go along that override that.
7394 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
7395 * range needs special handling. Again, all code points in the
7396 * range are mapped to -2, instead of increasing.
7398 * Under /d this value means the code point should be deleted from
7399 * the transliteration when encountered.
7401 * Otherwise, it marks that every code point in the range is to
7402 * map to the final character in the replacement list. This
7403 * happens only when the replacement list is shorter than the
7404 * search one, so there are things in the search list that have no
7405 * correspondence in the replacement list. For example, in
7406 * tr/a-z/A/, 'A' is the final value, and the inversion map
7407 * generated for this would be like this:
7412 * 'A' appears once, then the remainder of the range maps to -2.
7413 * The use of -2 isn't strictly necessary, as an inversion map is
7414 * capable of representing this situation, but not nearly so
7415 * compactly, and this is actually quite commonly encountered.
7416 * Indeed, the original design of this code used a full inversion
7417 * map for this. But things like
7419 * generated huge data structures, slowly, and the execution was
7420 * also slow. So the current scheme was implemented.
7422 * So, if the next element in our example is:
7426 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next
7430 * [i+4] S TR_UNLISTED
7432 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is
7433 * the final element in the arrays, every code point from S to infinity
7434 * maps to TR_UNLISTED.
7437 /* Finish up range started in what otherwise would
7438 * have been the final iteration */
7439 while (t < tend || t_range_count > 0) {
7440 bool adjacent_to_range_above = FALSE;
7441 bool adjacent_to_range_below = FALSE;
7443 bool merge_with_range_above = FALSE;
7444 bool merge_with_range_below = FALSE;
7446 UV span, invmap_range_length_remaining;
7450 /* If we are in the middle of processing a range in the 'target'
7451 * side, the previous iteration has set us up. Otherwise, look at
7452 * the next character in the search list */
7453 if (t_range_count <= 0) {
7456 /* Here, not in the middle of a range, and not UTF-8. The
7457 * next code point is the single byte where we're at */
7458 t_cp = CP_ADJUST(*t);
7465 /* Here, not in the middle of a range, and is UTF-8. The
7466 * next code point is the next UTF-8 char in the input. We
7467 * know the input is valid, because the toker constructed
7469 t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
7472 /* UTF-8 strings (only) have been parsed in toke.c to have
7473 * ranges. See if the next byte indicates that this was
7474 * the first element of a range. If so, get the final
7475 * element and calculate the range size. If not, the range
7477 if ( t < tend && *t == RANGE_INDICATOR
7478 && ! FORCE_RANGE_LEN_1(t_cp))
7481 t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
7490 /* Count the total number of listed code points * */
7491 t_count += t_range_count;
7494 /* Similarly, get the next character in the replacement list */
7495 if (r_range_count <= 0) {
7498 /* But if we've exhausted the rhs, there is nothing to map
7499 * to, except the special handling one, and we make the
7500 * range the same size as the lhs one. */
7501 r_cp = TR_SPECIAL_HANDLING;
7502 r_range_count = t_range_count;
7505 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7506 "final_map =%" UVXf "\n", final_map));
7511 r_cp = CP_ADJUST(*r);
7518 r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
7520 if ( r < rend && *r == RANGE_INDICATOR
7521 && ! FORCE_RANGE_LEN_1(r_cp))
7524 r_range_count = valid_utf8_to_uvchr(r,
7525 &r_char_len) - r_cp + 1;
7533 if (r_cp == TR_SPECIAL_HANDLING) {
7534 r_range_count = t_range_count;
7537 /* This is the final character so far */
7538 final_map = r_cp + r_range_count - 1;
7540 r_count += r_range_count;
7544 /* Here, we have the next things ready in both sides. They are
7545 * potentially ranges. We try to process as big a chunk as
7546 * possible at once, but the lhs and rhs must be synchronized, so
7547 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
7549 min_range_count = MIN(t_range_count, r_range_count);
7551 /* Search the inversion list for the entry that contains the input
7552 * code point <cp>. The inversion map was initialized to cover the
7553 * entire range of possible inputs, so this should not fail. So
7554 * the return value is the index into the list's array of the range
7555 * that contains <cp>, that is, 'i' such that array[i] <= cp <
7557 j = _invlist_search(t_invlist, t_cp);
7561 /* Here, the data structure might look like:
7564 * [i-1] J j # J-L => j-l
7565 * [i] M -1 # M => default; as do N, O, P, Q
7566 * [i+1] R x # R => x, S => x+1, T => x+2
7567 * [i+2] U y # U => y, V => y+1, ...
7569 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7571 * where 'x' and 'y' above are not to be taken literally.
7573 * The maximum chunk we can handle in this loop iteration, is the
7574 * smallest of the three components: the lhs 't_', the rhs 'r_',
7575 * and the remainder of the range in element [i]. (In pass 1, that
7576 * range will have everything in it be of the same class; we can't
7577 * cross into another class.) 'min_range_count' already contains
7578 * the smallest of the first two values. The final one is
7579 * irrelevant if the map is to the special indicator */
7581 invmap_range_length_remaining = (i + 1 < len)
7582 ? t_array[i+1] - t_cp
7584 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
7586 /* The end point of this chunk is where we are, plus the span, but
7587 * never larger than the platform's infinity */
7588 t_cp_end = MIN(IV_MAX, t_cp + span - 1);
7590 if (r_cp == TR_SPECIAL_HANDLING) {
7592 /* If unmatched lhs code points map to the final map, use that
7593 * value. This being set to TR_SPECIAL_HANDLING indicates that
7594 * we don't have a final map: unmatched lhs code points are
7596 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
7599 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
7601 /* If something on the lhs is below 256, and something on the
7602 * rhs is above, there is a potential mapping here across that
7603 * boundary. Indeed the only way there isn't is if both sides
7604 * start at the same point. That means they both cross at the
7605 * same time. But otherwise one crosses before the other */
7606 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
7607 can_force_utf8 = TRUE;
7611 /* If a character appears in the search list more than once, the
7612 * 2nd and succeeding occurrences are ignored, so only do this
7613 * range if haven't already processed this character. (The range
7614 * has been set up so that all members in it will be of the same
7616 if (r_map[i] == TR_UNLISTED) {
7617 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7618 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
7619 t_cp, t_cp_end, r_cp, r_cp_end));
7621 /* This is the first definition for this chunk, hence is valid
7622 * and needs to be processed. Here and in the comments below,
7623 * we use the above sample data. The t_cp chunk must be any
7624 * contiguous subset of M, N, O, P, and/or Q.
7626 * In the first pass, calculate if there is any possible input
7627 * string that has a character whose transliteration will be
7628 * longer than it. If none, the transliteration may be done
7629 * in-place, as it can't write over a so-far unread byte.
7630 * Otherwise, a copy must first be made. This could be
7631 * expensive for long inputs.
7633 * In the first pass, the t_invlist has been partitioned so
7634 * that all elements in any single range have the same number
7635 * of bytes in their UTF-8 representations. And the r space is
7636 * either a single byte, or a range of strictly monotonically
7637 * increasing code points. So the final element in the range
7638 * will be represented by no fewer bytes than the initial one.
7639 * That means that if the final code point in the t range has
7640 * at least as many bytes as the final code point in the r,
7641 * then all code points in the t range have at least as many
7642 * bytes as their corresponding r range element. But if that's
7643 * not true, the transliteration of at least the final code
7644 * point grows in length. As an example, suppose we had
7645 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
7646 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
7647 * platforms. We have deliberately set up the data structure
7648 * so that any range in the lhs gets split into chunks for
7649 * processing, such that every code point in a chunk has the
7650 * same number of UTF-8 bytes. We only have to check the final
7651 * code point in the rhs against any code point in the lhs. */
7653 && r_cp_end != TR_SPECIAL_HANDLING
7654 && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
7656 /* Here, we will need to make a copy of the input string
7657 * before doing the transliteration. The worst possible
7658 * case is an expansion ratio of 14:1. This is rare, and
7659 * we'd rather allocate only the necessary amount of extra
7660 * memory for that copy. We can calculate the worst case
7661 * for this particular transliteration is by keeping track
7662 * of the expansion factor for each range.
7664 * Consider tr/\xCB/\X{E000}/. The maximum expansion
7665 * factor is 1 byte going to 3 if the target string is not
7666 * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We
7667 * could pass two different values so doop could choose
7668 * based on the UTF-8ness of the target. But khw thinks
7669 * (perhaps wrongly) that is overkill. It is used only to
7670 * make sure we malloc enough space.
7672 * If no target string can force the result to be UTF-8,
7673 * then we don't have to worry about the case of the target
7674 * string not being UTF-8 */
7675 NV t_size = (can_force_utf8 && t_cp < 256)
7677 : CP_SKIP(t_cp_end);
7678 NV ratio = CP_SKIP(r_cp_end) / t_size;
7680 o->op_private |= OPpTRANS_GROWS;
7682 /* Now that we know it grows, we can keep track of the
7684 if (ratio > max_expansion) {
7685 max_expansion = ratio;
7686 DEBUG_y(PerlIO_printf(Perl_debug_log,
7687 "New expansion factor: %" NVgf "\n",
7692 /* The very first range is marked as adjacent to the
7693 * non-existent range below it, as it causes things to "just
7696 * If the lowest code point in this chunk is M, it adjoins the
7698 if (t_cp == t_array[i]) {
7699 adjacent_to_range_below = TRUE;
7701 /* And if the map has the same offset from the beginning of
7702 * the range as does this new code point (or both are for
7703 * TR_SPECIAL_HANDLING), this chunk can be completely
7704 * merged with the range below. EXCEPT, in the first pass,
7705 * we don't merge ranges whose UTF-8 byte representations
7706 * have different lengths, so that we can more easily
7707 * detect if a replacement is longer than the source, that
7708 * is if it 'grows'. But in the 2nd pass, there's no
7709 * reason to not merge */
7710 if ( (i > 0 && ( pass2
7711 || CP_SKIP(t_array[i-1])
7713 && ( ( r_cp == TR_SPECIAL_HANDLING
7714 && r_map[i-1] == TR_SPECIAL_HANDLING)
7715 || ( r_cp != TR_SPECIAL_HANDLING
7716 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
7718 merge_with_range_below = TRUE;
7722 /* Similarly, if the highest code point in this chunk is 'Q',
7723 * it adjoins the range above, and if the map is suitable, can
7724 * be merged with it */
7725 if ( t_cp_end >= IV_MAX - 1
7727 && t_cp_end + 1 == t_array[i+1]))
7729 adjacent_to_range_above = TRUE;
7732 || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
7733 && ( ( r_cp == TR_SPECIAL_HANDLING
7734 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
7735 || ( r_cp != TR_SPECIAL_HANDLING
7736 && r_cp_end == r_map[i+1] - 1)))
7738 merge_with_range_above = TRUE;
7742 if (merge_with_range_below && merge_with_range_above) {
7744 /* Here the new chunk looks like M => m, ... Q => q; and
7745 * the range above is like R => r, .... Thus, the [i-1]
7746 * and [i+1] ranges should be seamlessly melded so the
7749 * [i-1] J j # J-T => j-t
7750 * [i] U y # U => y, V => y+1, ...
7752 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7754 Move(t_array + i + 2, t_array + i, len - i - 2, UV);
7755 Move(r_map + i + 2, r_map + i, len - i - 2, UV);
7757 invlist_set_len(t_invlist,
7759 *(get_invlist_offset_addr(t_invlist)));
7761 else if (merge_with_range_below) {
7763 /* Here the new chunk looks like M => m, .... But either
7764 * (or both) it doesn't extend all the way up through Q; or
7765 * the range above doesn't start with R => r. */
7766 if (! adjacent_to_range_above) {
7768 /* In the first case, let's say the new chunk extends
7769 * through O. We then want:
7771 * [i-1] J j # J-O => j-o
7772 * [i] P -1 # P => -1, Q => -1
7773 * [i+1] R x # R => x, S => x+1, T => x+2
7774 * [i+2] U y # U => y, V => y+1, ...
7776 * [-1] Z -1 # Z => default; as do Z+1, ...
7779 t_array[i] = t_cp_end + 1;
7780 r_map[i] = TR_UNLISTED;
7782 else { /* Adjoins the range above, but can't merge with it
7783 (because 'x' is not the next map after q) */
7785 * [i-1] J j # J-Q => j-q
7786 * [i] R x # R => x, S => x+1, T => x+2
7787 * [i+1] U y # U => y, V => y+1, ...
7789 * [-1] Z -1 # Z => default; as do Z+1, ...
7793 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7794 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7796 invlist_set_len(t_invlist, len,
7797 *(get_invlist_offset_addr(t_invlist)));
7800 else if (merge_with_range_above) {
7802 /* Here the new chunk ends with Q => q, and the range above
7803 * must start with R => r, so the two can be merged. But
7804 * either (or both) the new chunk doesn't extend all the
7805 * way down to M; or the mapping of the final code point
7806 * range below isn't m */
7807 if (! adjacent_to_range_below) {
7809 /* In the first case, let's assume the new chunk starts
7810 * with P => p. Then, because it's merge-able with the
7811 * range above, that range must be R => r. We want:
7813 * [i-1] J j # J-L => j-l
7814 * [i] M -1 # M => -1, N => -1
7815 * [i+1] P p # P-T => p-t
7816 * [i+2] U y # U => y, V => y+1, ...
7818 * [-1] Z -1 # Z => default; as do Z+1, ...
7821 t_array[i+1] = t_cp;
7824 else { /* Adjoins the range below, but can't merge with it
7827 * [i-1] J j # J-L => j-l
7828 * [i] M x # M-T => x-5 .. x+2
7829 * [i+1] U y # U => y, V => y+1, ...
7831 * [-1] Z -1 # Z => default; as do Z+1, ...
7834 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7835 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7839 invlist_set_len(t_invlist, len,
7840 *(get_invlist_offset_addr(t_invlist)));
7843 else if (adjacent_to_range_below && adjacent_to_range_above) {
7844 /* The new chunk completely fills the gap between the
7845 * ranges on either side, but can't merge with either of
7848 * [i-1] J j # J-L => j-l
7849 * [i] M z # M => z, N => z+1 ... Q => z+4
7850 * [i+1] R x # R => x, S => x+1, T => x+2
7851 * [i+2] U y # U => y, V => y+1, ...
7853 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7857 else if (adjacent_to_range_below) {
7858 /* The new chunk adjoins the range below, but not the range
7859 * above, and can't merge. Let's assume the chunk ends at
7862 * [i-1] J j # J-L => j-l
7863 * [i] M z # M => z, N => z+1, O => z+2
7864 * [i+1] P -1 # P => -1, Q => -1
7865 * [i+2] R x # R => x, S => x+1, T => x+2
7866 * [i+3] U y # U => y, V => y+1, ...
7868 * [-w] Z -1 # Z => default; as do Z+1, ... infinity
7870 invlist_extend(t_invlist, len + 1);
7871 t_array = invlist_array(t_invlist);
7872 Renew(r_map, len + 1, UV);
7874 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7875 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7877 t_array[i+1] = t_cp_end + 1;
7878 r_map[i+1] = TR_UNLISTED;
7880 invlist_set_len(t_invlist, len,
7881 *(get_invlist_offset_addr(t_invlist)));
7883 else if (adjacent_to_range_above) {
7884 /* The new chunk adjoins the range above, but not the range
7885 * below, and can't merge. Let's assume the new chunk
7888 * [i-1] J j # J-L => j-l
7889 * [i] M -1 # M => default, N => default
7890 * [i+1] O z # O => z, P => z+1, Q => z+2
7891 * [i+2] R x # R => x, S => x+1, T => x+2
7892 * [i+3] U y # U => y, V => y+1, ...
7894 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7896 invlist_extend(t_invlist, len + 1);
7897 t_array = invlist_array(t_invlist);
7898 Renew(r_map, len + 1, UV);
7900 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7901 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7902 t_array[i+1] = t_cp;
7905 invlist_set_len(t_invlist, len,
7906 *(get_invlist_offset_addr(t_invlist)));
7909 /* The new chunk adjoins neither the range above, nor the
7910 * range below. Lets assume it is N..P => n..p
7912 * [i-1] J j # J-L => j-l
7913 * [i] M -1 # M => default
7914 * [i+1] N n # N..P => n..p
7915 * [i+2] Q -1 # Q => default
7916 * [i+3] R x # R => x, S => x+1, T => x+2
7917 * [i+4] U y # U => y, V => y+1, ...
7919 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7922 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7923 "Before fixing up: len=%d, i=%d\n",
7924 (int) len, (int) i));
7925 DEBUG_yv(invmap_dump(t_invlist, r_map));
7927 invlist_extend(t_invlist, len + 2);
7928 t_array = invlist_array(t_invlist);
7929 Renew(r_map, len + 2, UV);
7931 Move(t_array + i + 1,
7932 t_array + i + 2 + 1, len - i - (2 - 1), UV);
7934 r_map + i + 2 + 1, len - i - (2 - 1), UV);
7937 invlist_set_len(t_invlist, len,
7938 *(get_invlist_offset_addr(t_invlist)));
7940 t_array[i+1] = t_cp;
7943 t_array[i+2] = t_cp_end + 1;
7944 r_map[i+2] = TR_UNLISTED;
7946 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7947 "After iteration: span=%" UVuf ", t_range_count=%"
7948 UVuf " r_range_count=%" UVuf "\n",
7949 span, t_range_count, r_range_count));
7950 DEBUG_yv(invmap_dump(t_invlist, r_map));
7951 } /* End of this chunk needs to be processed */
7953 /* Done with this chunk. */
7955 if (t_cp >= IV_MAX) {
7958 t_range_count -= span;
7959 if (r_cp != TR_SPECIAL_HANDLING) {
7961 r_range_count -= span;
7967 } /* End of loop through the search list */
7969 /* We don't need an exact count, but we do need to know if there is
7970 * anything left over in the replacement list. So, just assume it's
7971 * one byte per character */
7975 } /* End of passes */
7977 SvREFCNT_dec(inverted_tstr);
7979 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
7980 DEBUG_y(invmap_dump(t_invlist, r_map));
7982 /* We now have normalized the input into an inversion map.
7984 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op
7985 * except for the count, and streamlined runtime code can be used */
7986 if (!del && !squash) {
7988 /* They are identical if they point to same address, or if everything
7989 * maps to UNLISTED or to itself. This catches things that not looking
7990 * at the normalized inversion map doesn't catch, like tr/aa/ab/ or
7991 * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */
7993 for (i = 0; i < len; i++) {
7994 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
7995 goto done_identical_check;
8000 /* Here have gone through entire list, and didn't find any
8001 * non-identical mappings */
8002 o->op_private |= OPpTRANS_IDENTICAL;
8004 done_identical_check: ;
8007 t_array = invlist_array(t_invlist);
8009 /* If has components above 255, we generally need to use the inversion map
8013 && t_array[len-1] > 255
8014 /* If the final range is 0x100-INFINITY and is a special
8015 * mapping, the table implementation can handle it */
8016 && ! ( t_array[len-1] == 256
8017 && ( r_map[len-1] == TR_UNLISTED
8018 || r_map[len-1] == TR_SPECIAL_HANDLING))))
8023 /* A UTF-8 op is generated, indicated by this flag. This op is an
8025 o->op_private |= OPpTRANS_USE_SVOP;
8027 if (can_force_utf8) {
8028 o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
8031 /* The inversion map is pushed; first the list. */
8032 invmap = MUTABLE_AV(newAV());
8034 SvREADONLY_on(t_invlist);
8035 av_push(invmap, t_invlist);
8037 /* 2nd is the mapping */
8038 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
8039 SvREADONLY_on(r_map_sv);
8040 av_push(invmap, r_map_sv);
8042 /* 3rd is the max possible expansion factor */
8043 temp_sv = newSVnv(max_expansion);
8044 SvREADONLY_on(temp_sv);
8045 av_push(invmap, temp_sv);
8047 /* Characters that are in the search list, but not in the replacement
8048 * list are mapped to the final character in the replacement list */
8049 if (! del && r_count < t_count) {
8050 temp_sv = newSVuv(final_map);
8051 SvREADONLY_on(temp_sv);
8052 av_push(invmap, temp_sv);
8056 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
8057 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
8058 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
8059 SvPADTMP_on(invmap);
8060 SvREADONLY_on(invmap);
8062 cSVOPo->op_sv = (SV *) invmap;
8070 /* The OPtrans_map struct already contains one slot; hence the -1. */
8071 SSize_t struct_size = sizeof(OPtrans_map)
8072 + (256 - 1 + 1)*sizeof(short);
8074 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
8075 * table. Entries with the value TR_UNMAPPED indicate chars not to be
8076 * translated, while TR_DELETE indicates a search char without a
8077 * corresponding replacement char under /d.
8079 * In addition, an extra slot at the end is used to store the final
8080 * repeating char, or TR_R_EMPTY under an empty replacement list, or
8081 * TR_DELETE under /d; which makes the runtime code easier.
8084 /* Indicate this is an op_pv */
8085 o->op_private &= ~OPpTRANS_USE_SVOP;
8087 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
8089 cPVOPo->op_pv = (char*)tbl;
8091 for (i = 0; i < len; i++) {
8092 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
8093 short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
8094 short to = (short) r_map[i];
8096 bool do_increment = TRUE;
8098 /* Any code points above our limit should be irrelevant */
8099 if (t_array[i] >= tbl->size) break;
8101 /* Set up the map */
8102 if (to == (short) TR_SPECIAL_HANDLING && ! del) {
8103 to = (short) final_map;
8104 do_increment = FALSE;
8107 do_increment = FALSE;
8110 /* Create a map for everything in this range. The value increases
8111 * except for the special cases */
8112 for (j = (short) t_array[i]; j < upper; j++) {
8114 if (do_increment) to++;
8118 tbl->map[tbl->size] = del
8122 : (short) TR_R_EMPTY;
8123 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
8124 for (i = 0; i < tbl->size; i++) {
8125 if (tbl->map[i] < 0) {
8126 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
8127 (unsigned) i, tbl->map[i]));
8130 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
8131 (unsigned) i, tbl->map[i]));
8133 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
8134 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
8137 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
8138 (unsigned) tbl->size, tbl->map[tbl->size]));
8140 SvREFCNT_dec(t_invlist);
8142 #if 0 /* code that added excess above-255 chars at the end of the table, in
8143 case we ever want to not use the inversion map implementation for
8150 /* More replacement chars than search chars:
8151 * store excess replacement chars at end of main table.
8154 struct_size += excess;
8155 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
8156 struct_size + excess * sizeof(short));
8157 tbl->size += excess;
8158 cPVOPo->op_pv = (char*)tbl;
8160 for (i = 0; i < excess; i++)
8161 tbl->map[i + 256] = r[j+i];
8164 /* no more replacement chars than search chars */
8170 DEBUG_y(PerlIO_printf(Perl_debug_log,
8171 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
8172 " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
8173 del, squash, complement,
8174 cBOOL(o->op_private & OPpTRANS_IDENTICAL),
8175 cBOOL(o->op_private & OPpTRANS_USE_SVOP),
8176 cBOOL(o->op_private & OPpTRANS_GROWS),
8177 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
8182 if(del && rlen != 0 && r_count == t_count) {
8183 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
8184 } else if(r_count > t_count) {
8185 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
8198 Constructs, checks, and returns an op of any pattern matching type.
8199 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
8200 and, shifted up eight bits, the eight bits of C<op_private>.
8206 Perl_newPMOP(pTHX_ I32 type, I32 flags)
8210 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
8211 || type == OP_CUSTOM);
8213 NewOp(1101, pmop, 1, PMOP);
8214 OpTYPE_set(pmop, type);
8215 pmop->op_flags = (U8)flags;
8216 pmop->op_private = (U8)(0 | (flags >> 8));
8217 if (PL_opargs[type] & OA_RETSCALAR)
8220 if (PL_hints & HINT_RE_TAINT)
8221 pmop->op_pmflags |= PMf_RETAINT;
8222 #ifdef USE_LOCALE_CTYPE
8223 if (IN_LC_COMPILETIME(LC_CTYPE)) {
8224 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
8229 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
8231 if (PL_hints & HINT_RE_FLAGS) {
8232 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8233 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
8235 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
8236 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8237 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
8239 if (reflags && SvOK(reflags)) {
8240 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
8246 assert(SvPOK(PL_regex_pad[0]));
8247 if (SvCUR(PL_regex_pad[0])) {
8248 /* Pop off the "packed" IV from the end. */
8249 SV *const repointer_list = PL_regex_pad[0];
8250 const char *p = SvEND(repointer_list) - sizeof(IV);
8251 const IV offset = *((IV*)p);
8253 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
8255 SvEND_set(repointer_list, p);
8257 pmop->op_pmoffset = offset;
8258 /* This slot should be free, so assert this: */
8259 assert(PL_regex_pad[offset] == &PL_sv_undef);
8261 SV * const repointer = &PL_sv_undef;
8262 av_push(PL_regex_padav, repointer);
8263 pmop->op_pmoffset = av_top_index(PL_regex_padav);
8264 PL_regex_pad = AvARRAY(PL_regex_padav);
8268 return CHECKOP(type, pmop);
8276 /* Any pad names in scope are potentially lvalues. */
8277 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
8278 PADNAME *pn = PAD_COMPNAME_SV(i);
8279 if (!pn || !PadnameLEN(pn))
8281 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
8282 S_mark_padname_lvalue(aTHX_ pn);
8286 /* Given some sort of match op o, and an expression expr containing a
8287 * pattern, either compile expr into a regex and attach it to o (if it's
8288 * constant), or convert expr into a runtime regcomp op sequence (if it's
8291 * Flags currently has 2 bits of meaning:
8292 * 1: isreg indicates that the pattern is part of a regex construct, eg
8293 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
8294 * split "pattern", which aren't. In the former case, expr will be a list
8295 * if the pattern contains more than one term (eg /a$b/).
8296 * 2: The pattern is for a split.
8298 * When the pattern has been compiled within a new anon CV (for
8299 * qr/(?{...})/ ), then floor indicates the savestack level just before
8300 * the new sub was created
8302 * tr/// is also handled.
8306 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
8310 I32 repl_has_vars = 0;
8311 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
8312 bool is_compiletime;
8314 bool isreg = cBOOL(flags & 1);
8315 bool is_split = cBOOL(flags & 2);
8317 PERL_ARGS_ASSERT_PMRUNTIME;
8320 return pmtrans(o, expr, repl);
8323 /* find whether we have any runtime or code elements;
8324 * at the same time, temporarily set the op_next of each DO block;
8325 * then when we LINKLIST, this will cause the DO blocks to be excluded
8326 * from the op_next chain (and from having LINKLIST recursively
8327 * applied to them). We fix up the DOs specially later */
8331 if (expr->op_type == OP_LIST) {
8333 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8334 if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
8336 assert(!child->op_next);
8337 if (UNLIKELY(!OpHAS_SIBLING(child))) {
8338 assert(PL_parser && PL_parser->error_count);
8339 /* This can happen with qr/ (?{(^{})/. Just fake up
8340 the op we were expecting to see, to avoid crashing
8342 op_sibling_splice(expr, child, 0,
8343 newSVOP(OP_CONST, 0, &PL_sv_no));
8345 child->op_next = OpSIBLING(child);
8347 else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
8351 else if (expr->op_type != OP_CONST)
8356 /* fix up DO blocks; treat each one as a separate little sub;
8357 * also, mark any arrays as LIST/REF */
8359 if (expr->op_type == OP_LIST) {
8361 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8363 if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
8364 assert( !(child->op_flags & OPf_WANT));
8365 /* push the array rather than its contents. The regex
8366 * engine will retrieve and join the elements later */
8367 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
8371 if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
8373 child->op_next = NULL; /* undo temporary hack from above */
8376 if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
8377 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
8379 assert(leaveop->op_first->op_type == OP_ENTER);
8380 assert(OpHAS_SIBLING(leaveop->op_first));
8381 child->op_next = OpSIBLING(leaveop->op_first);
8383 assert(leaveop->op_flags & OPf_KIDS);
8384 assert(leaveop->op_last->op_next == (OP*)leaveop);
8385 leaveop->op_next = NULL; /* stop on last op */
8386 op_null((OP*)leaveop);
8390 OP *scope = cLISTOPx(child)->op_first;
8391 assert(scope->op_type == OP_SCOPE);
8392 assert(scope->op_flags & OPf_KIDS);
8393 scope->op_next = NULL; /* stop on last op */
8397 /* XXX optimize_optree() must be called on o before
8398 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
8399 * currently cope with a peephole-optimised optree.
8400 * Calling optimize_optree() here ensures that condition
8401 * is met, but may mean optimize_optree() is applied
8402 * to the same optree later (where hopefully it won't do any
8403 * harm as it can't convert an op to multiconcat if it's
8404 * already been converted */
8405 optimize_optree(child);
8407 /* have to peep the DOs individually as we've removed it from
8408 * the op_next chain */
8410 S_prune_chain_head(&(child->op_next));
8412 /* runtime finalizes as part of finalizing whole tree */
8413 finalize_optree(child);
8416 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
8417 assert( !(expr->op_flags & OPf_WANT));
8418 /* push the array rather than its contents. The regex
8419 * engine will retrieve and join the elements later */
8420 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
8423 PL_hints |= HINT_BLOCK_SCOPE;
8425 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
8427 if (is_compiletime) {
8428 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
8429 regexp_engine const *eng = current_re_engine();
8432 /* make engine handle split ' ' specially */
8433 pm->op_pmflags |= PMf_SPLIT;
8434 rx_flags |= RXf_SPLIT;
8437 if (!has_code || !eng->op_comp) {
8438 /* compile-time simple constant pattern */
8440 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
8441 /* whoops! we guessed that a qr// had a code block, but we
8442 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
8443 * that isn't required now. Note that we have to be pretty
8444 * confident that nothing used that CV's pad while the
8445 * regex was parsed, except maybe op targets for \Q etc.
8446 * If there were any op targets, though, they should have
8447 * been stolen by constant folding.
8451 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
8452 while (++i <= AvFILLp(PL_comppad)) {
8453 # ifdef USE_PAD_RESET
8454 /* under USE_PAD_RESET, pad swipe replaces a swiped
8455 * folded constant with a fresh padtmp */
8456 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
8458 assert(!PL_curpad[i]);
8462 /* This LEAVE_SCOPE will restore PL_compcv to point to the
8463 * outer CV (the one whose slab holds the pm op). The
8464 * inner CV (which holds expr) will be freed later, once
8465 * all the entries on the parse stack have been popped on
8466 * return from this function. Which is why its safe to
8467 * call op_free(expr) below.
8470 pm->op_pmflags &= ~PMf_HAS_CV;
8473 /* Skip compiling if parser found an error for this pattern */
8474 if (pm->op_pmflags & PMf_HAS_ERROR) {
8480 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8481 rx_flags, pm->op_pmflags)
8482 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8483 rx_flags, pm->op_pmflags)
8488 /* compile-time pattern that includes literal code blocks */
8492 /* Skip compiling if parser found an error for this pattern */
8493 if (pm->op_pmflags & PMf_HAS_ERROR) {
8497 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8500 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
8503 if (pm->op_pmflags & PMf_HAS_CV) {
8505 /* this QR op (and the anon sub we embed it in) is never
8506 * actually executed. It's just a placeholder where we can
8507 * squirrel away expr in op_code_list without the peephole
8508 * optimiser etc processing it for a second time */
8509 OP *qr = newPMOP(OP_QR, 0);
8510 ((PMOP*)qr)->op_code_list = expr;
8512 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
8513 SvREFCNT_inc_simple_void(PL_compcv);
8514 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8515 ReANY(re)->qr_anoncv = cv;
8517 /* attach the anon CV to the pad so that
8518 * pad_fixup_inner_anons() can find it */
8519 (void)pad_add_anon(cv, o->op_type);
8520 SvREFCNT_inc_simple_void(cv);
8523 pm->op_code_list = expr;
8528 /* runtime pattern: build chain of regcomp etc ops */
8530 PADOFFSET cv_targ = 0;
8532 reglist = isreg && expr->op_type == OP_LIST;
8537 pm->op_code_list = expr;
8538 /* don't free op_code_list; its ops are embedded elsewhere too */
8539 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
8543 /* make engine handle split ' ' specially */
8544 pm->op_pmflags |= PMf_SPLIT;
8546 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
8547 * to allow its op_next to be pointed past the regcomp and
8548 * preceding stacking ops;
8549 * OP_REGCRESET is there to reset taint before executing the
8551 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
8552 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
8554 if (pm->op_pmflags & PMf_HAS_CV) {
8555 /* we have a runtime qr with literal code. This means
8556 * that the qr// has been wrapped in a new CV, which
8557 * means that runtime consts, vars etc will have been compiled
8558 * against a new pad. So... we need to execute those ops
8559 * within the environment of the new CV. So wrap them in a call
8560 * to a new anon sub. i.e. for
8564 * we build an anon sub that looks like
8566 * sub { "a", $b, '(?{...})' }
8568 * and call it, passing the returned list to regcomp.
8569 * Or to put it another way, the list of ops that get executed
8573 * ------ -------------------
8574 * pushmark (for regcomp)
8575 * pushmark (for entersub)
8579 * regcreset regcreset
8581 * const("a") const("a")
8583 * const("(?{...})") const("(?{...})")
8588 SvREFCNT_inc_simple_void(PL_compcv);
8589 CvLVALUE_on(PL_compcv);
8590 /* these lines are just an unrolled newANONATTRSUB */
8591 expr = newSVOP(OP_ANONCODE, 0,
8592 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
8593 cv_targ = expr->op_targ;
8594 expr = newUNOP(OP_REFGEN, 0, expr);
8596 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), TRUE));
8599 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
8600 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
8601 | (reglist ? OPf_STACKED : 0);
8602 rcop->op_targ = cv_targ;
8604 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
8605 if (PL_hints & HINT_RE_EVAL)
8606 S_set_haseval(aTHX);
8608 /* establish postfix order */
8609 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
8611 rcop->op_next = expr;
8612 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
8615 rcop->op_next = LINKLIST(expr);
8616 expr->op_next = (OP*)rcop;
8619 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
8625 /* If we are looking at s//.../e with a single statement, get past
8626 the implicit do{}. */
8627 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
8628 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
8629 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
8632 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
8633 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
8634 && !OpHAS_SIBLING(sib))
8637 if (curop->op_type == OP_CONST)
8639 else if (( (curop->op_type == OP_RV2SV ||
8640 curop->op_type == OP_RV2AV ||
8641 curop->op_type == OP_RV2HV ||
8642 curop->op_type == OP_RV2GV)
8643 && cUNOPx(curop)->op_first
8644 && cUNOPx(curop)->op_first->op_type == OP_GV )
8645 || curop->op_type == OP_PADSV
8646 || curop->op_type == OP_PADAV
8647 || curop->op_type == OP_PADHV
8648 || curop->op_type == OP_PADANY) {
8656 || !RX_PRELEN(PM_GETRE(pm))
8657 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
8659 pm->op_pmflags |= PMf_CONST; /* const for long enough */
8660 op_prepend_elem(o->op_type, scalar(repl), o);
8663 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
8664 rcop->op_private = 1;
8666 /* establish postfix order */
8667 rcop->op_next = LINKLIST(repl);
8668 repl->op_next = (OP*)rcop;
8670 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
8671 assert(!(pm->op_pmflags & PMf_ONCE));
8672 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
8683 Constructs, checks, and returns an op of any type that involves an
8684 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
8685 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
8686 takes ownership of one reference to it.
8692 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
8696 PERL_ARGS_ASSERT_NEWSVOP;
8698 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8699 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8700 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8701 || type == OP_CUSTOM);
8703 NewOp(1101, svop, 1, SVOP);
8704 OpTYPE_set(svop, type);
8706 svop->op_next = (OP*)svop;
8707 svop->op_flags = (U8)flags;
8708 svop->op_private = (U8)(0 | (flags >> 8));
8709 if (PL_opargs[type] & OA_RETSCALAR)
8711 if (PL_opargs[type] & OA_TARGET)
8712 svop->op_targ = pad_alloc(type, SVs_PADTMP);
8713 return CHECKOP(type, svop);
8717 =for apidoc newDEFSVOP
8719 Constructs and returns an op to access C<$_>.
8725 Perl_newDEFSVOP(pTHX)
8727 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
8733 =for apidoc newPADOP
8735 Constructs, checks, and returns an op of any type that involves a
8736 reference to a pad element. C<type> is the opcode. C<flags> gives the
8737 eight bits of C<op_flags>. A pad slot is automatically allocated, and
8738 is populated with C<sv>; this function takes ownership of one reference
8741 This function only exists if Perl has been compiled to use ithreads.
8747 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
8751 PERL_ARGS_ASSERT_NEWPADOP;
8753 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8754 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8755 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8756 || type == OP_CUSTOM);
8758 NewOp(1101, padop, 1, PADOP);
8759 OpTYPE_set(padop, type);
8761 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
8762 SvREFCNT_dec(PAD_SVl(padop->op_padix));
8763 PAD_SETSV(padop->op_padix, sv);
8765 padop->op_next = (OP*)padop;
8766 padop->op_flags = (U8)flags;
8767 if (PL_opargs[type] & OA_RETSCALAR)
8769 if (PL_opargs[type] & OA_TARGET)
8770 padop->op_targ = pad_alloc(type, SVs_PADTMP);
8771 return CHECKOP(type, padop);
8774 #endif /* USE_ITHREADS */
8779 Constructs, checks, and returns an op of any type that involves an
8780 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
8781 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
8782 reference; calling this function does not transfer ownership of any
8789 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
8791 PERL_ARGS_ASSERT_NEWGVOP;
8794 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8796 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8803 Constructs, checks, and returns an op of any type that involves an
8804 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
8805 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
8806 Depending on the op type, the memory referenced by C<pv> may be freed
8807 when the op is destroyed. If the op is of a freeing type, C<pv> must
8808 have been allocated using C<PerlMemShared_malloc>.
8814 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
8816 const bool utf8 = cBOOL(flags & SVf_UTF8);
8821 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8822 || type == OP_RUNCV || type == OP_CUSTOM
8823 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
8825 NewOp(1101, pvop, 1, PVOP);
8826 OpTYPE_set(pvop, type);
8828 pvop->op_next = (OP*)pvop;
8829 pvop->op_flags = (U8)flags;
8830 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
8831 if (PL_opargs[type] & OA_RETSCALAR)
8833 if (PL_opargs[type] & OA_TARGET)
8834 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
8835 return CHECKOP(type, pvop);
8839 Perl_package(pTHX_ OP *o)
8841 SV *const sv = cSVOPo->op_sv;
8843 PERL_ARGS_ASSERT_PACKAGE;
8845 SAVEGENERICSV(PL_curstash);
8846 save_item(PL_curstname);
8848 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
8850 sv_setsv(PL_curstname, sv);
8852 PL_hints |= HINT_BLOCK_SCOPE;
8853 PL_parser->copline = NOLINE;
8859 Perl_package_version( pTHX_ OP *v )
8861 U32 savehints = PL_hints;
8862 PERL_ARGS_ASSERT_PACKAGE_VERSION;
8863 PL_hints &= ~HINT_STRICT_VARS;
8864 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
8865 PL_hints = savehints;
8869 /* Extract the first two components of a "version" object as two 8bit integers
8870 * and return them packed into a single U16 in the format of PL_prevailing_version.
8871 * This function only ever has to cope with version objects already known
8872 * bounded by the current perl version, so we know its components will fit
8873 * (Up until we reach perl version 5.256 anyway) */
8874 static U16 S_extract_shortver(pTHX_ SV *sv)
8877 if(!SvRV(sv) || !SvOBJECT(rv = SvRV(sv)) || !sv_derived_from(sv, "version"))
8880 AV *av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rv), "version", 0)));
8884 IV major = av_count(av) > 0 ? SvIV(*av_fetch(av, 0, false)) : 0;
8886 shortver |= 255 << 8;
8888 shortver |= major << 8;
8890 IV minor = av_count(av) > 1 ? SvIV(*av_fetch(av, 1, false)) : 0;
8898 #define SHORTVER(maj,min) ((maj << 8) | min)
8901 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
8906 SV *use_version = NULL;
8908 PERL_ARGS_ASSERT_UTILIZE;
8910 if (idop->op_type != OP_CONST)
8911 Perl_croak(aTHX_ "Module name must be constant");
8916 SV * const vesv = ((SVOP*)version)->op_sv;
8918 if (!arg && !SvNIOKp(vesv)) {
8925 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
8926 Perl_croak(aTHX_ "Version number must be a constant number");
8928 /* Make copy of idop so we don't free it twice */
8929 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8931 /* Fake up a method call to VERSION */
8932 meth = newSVpvs_share("VERSION");
8933 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8934 op_append_elem(OP_LIST,
8935 op_prepend_elem(OP_LIST, pack, version),
8936 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
8940 /* Fake up an import/unimport */
8941 if (arg && arg->op_type == OP_STUB) {
8942 imop = arg; /* no import on explicit () */
8944 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
8945 imop = NULL; /* use 5.0; */
8947 use_version = ((SVOP*)idop)->op_sv;
8949 idop->op_private |= OPpCONST_NOVER;
8954 /* Make copy of idop so we don't free it twice */
8955 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8957 /* Fake up a method call to import/unimport */
8959 ? newSVpvs_share("import") : newSVpvs_share("unimport");
8960 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8961 op_append_elem(OP_LIST,
8962 op_prepend_elem(OP_LIST, pack, arg),
8963 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
8967 /* Fake up the BEGIN {}, which does its thing immediately. */
8969 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
8972 op_append_elem(OP_LINESEQ,
8973 op_append_elem(OP_LINESEQ,
8974 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
8975 newSTATEOP(0, NULL, veop)),
8976 newSTATEOP(0, NULL, imop) ));
8980 * feature bundle that corresponds to the required version. */
8981 use_version = sv_2mortal(new_version(use_version));
8982 S_enable_feature_bundle(aTHX_ use_version);
8984 U16 shortver = S_extract_shortver(aTHX_ use_version);
8986 /* If a version >= 5.11.0 is requested, strictures are on by default! */
8987 if (shortver >= SHORTVER(5, 11)) {
8988 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8989 PL_hints |= HINT_STRICT_REFS;
8990 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8991 PL_hints |= HINT_STRICT_SUBS;
8992 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8993 PL_hints |= HINT_STRICT_VARS;
8995 if (shortver >= SHORTVER(5, 35))
8996 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
8998 /* otherwise they are off */
9000 if(PL_prevailing_version >= SHORTVER(5, 11))
9001 deprecate_fatal_in("5.40",
9002 "Downgrading a use VERSION declaration to below v5.11");
9004 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
9005 PL_hints &= ~HINT_STRICT_REFS;
9006 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
9007 PL_hints &= ~HINT_STRICT_SUBS;
9008 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
9009 PL_hints &= ~HINT_STRICT_VARS;
9012 PL_prevailing_version = shortver;
9015 /* The "did you use incorrect case?" warning used to be here.
9016 * The problem is that on case-insensitive filesystems one
9017 * might get false positives for "use" (and "require"):
9018 * "use Strict" or "require CARP" will work. This causes
9019 * portability problems for the script: in case-strict
9020 * filesystems the script will stop working.
9022 * The "incorrect case" warning checked whether "use Foo"
9023 * imported "Foo" to your namespace, but that is wrong, too:
9024 * there is no requirement nor promise in the language that
9025 * a Foo.pm should or would contain anything in package "Foo".
9027 * There is very little Configure-wise that can be done, either:
9028 * the case-sensitivity of the build filesystem of Perl does not
9029 * help in guessing the case-sensitivity of the runtime environment.
9032 PL_hints |= HINT_BLOCK_SCOPE;
9033 PL_parser->copline = NOLINE;
9034 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
9038 =for apidoc_section $embedding
9040 =for apidoc load_module
9041 =for apidoc_item load_module_nocontext
9043 These load the module whose name is pointed to by the string part of C<name>.
9044 Note that the actual module name, not its filename, should be given.
9045 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
9046 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
9047 trailing arguments can be used to specify arguments to the module's C<import()>
9048 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
9049 on the flags. The flags argument is a bitwise-ORed collection of any of
9050 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
9051 (or 0 for no flags).
9053 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
9054 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
9055 the trailing optional arguments may be omitted entirely. Otherwise, if
9056 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
9057 exactly one C<OP*>, containing the op tree that produces the relevant import
9058 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
9059 will be used as import arguments; and the list must be terminated with C<(SV*)
9060 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
9061 set, the trailing C<NULL> pointer is needed even if no import arguments are
9062 desired. The reference count for each specified C<SV*> argument is
9063 decremented. In addition, the C<name> argument is modified.
9065 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
9068 C<load_module> and C<load_module_nocontext> have the same apparent signature,
9069 but the former hides the fact that it is accessing a thread context parameter.
9070 So use the latter when you get a compilation error about C<pTHX>.
9072 =for apidoc Amnh||PERL_LOADMOD_DENY
9073 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
9074 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
9076 =for apidoc vload_module
9077 Like C<L</load_module>> but the arguments are an encapsulated argument list.
9082 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
9086 PERL_ARGS_ASSERT_LOAD_MODULE;
9088 va_start(args, ver);
9089 vload_module(flags, name, ver, &args);
9095 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
9099 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
9100 va_start(args, ver);
9101 vload_module(flags, name, ver, &args);
9107 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
9113 PERL_ARGS_ASSERT_VLOAD_MODULE;
9115 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
9116 * that it has a PL_parser to play with while doing that, and also
9117 * that it doesn't mess with any existing parser, by creating a tmp
9118 * new parser with lex_start(). This won't actually be used for much,
9119 * since pp_require() will create another parser for the real work.
9120 * The ENTER/LEAVE pair protect callers from any side effects of use.
9122 * start_subparse() creates a new PL_compcv. This means that any ops
9123 * allocated below will be allocated from that CV's op slab, and so
9124 * will be automatically freed if the utilise() fails
9128 SAVEVPTR(PL_curcop);
9129 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
9130 floor = start_subparse(FALSE, 0);
9132 modname = newSVOP(OP_CONST, 0, name);
9133 modname->op_private |= OPpCONST_BARE;
9135 veop = newSVOP(OP_CONST, 0, ver);
9139 if (flags & PERL_LOADMOD_NOIMPORT) {
9140 imop = sawparens(newNULLLIST());
9142 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
9143 imop = va_arg(*args, OP*);
9148 sv = va_arg(*args, SV*);
9150 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
9151 sv = va_arg(*args, SV*);
9155 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
9159 PERL_STATIC_INLINE OP *
9160 S_new_entersubop(pTHX_ GV *gv, OP *arg)
9162 return newUNOP(OP_ENTERSUB, OPf_STACKED,
9163 newLISTOP(OP_LIST, 0, arg,
9164 newUNOP(OP_RV2CV, 0,
9165 newGVOP(OP_GV, 0, gv))));
9169 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
9174 PERL_ARGS_ASSERT_DOFILE;
9176 if (!force_builtin && (gv = gv_override("do", 2))) {
9177 doop = S_new_entersubop(aTHX_ gv, term);
9180 doop = newUNOP(OP_DOFILE, 0, scalar(term));
9186 =for apidoc_section $optree_construction
9188 =for apidoc newSLICEOP
9190 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
9191 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
9192 be set automatically, and, shifted up eight bits, the eight bits of
9193 C<op_private>, except that the bit with value 1 or 2 is automatically
9194 set as required. C<listval> and C<subscript> supply the parameters of
9195 the slice; they are consumed by this function and become part of the
9196 constructed op tree.
9202 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
9204 return newBINOP(OP_LSLICE, flags,
9205 list(force_list(subscript, TRUE)),
9206 list(force_list(listval, TRUE)));
9209 #define ASSIGN_SCALAR 0
9210 #define ASSIGN_LIST 1
9211 #define ASSIGN_REF 2
9213 /* given the optree o on the LHS of an assignment, determine whether its:
9214 * ASSIGN_SCALAR $x = ...
9215 * ASSIGN_LIST ($x) = ...
9216 * ASSIGN_REF \$x = ...
9220 S_assignment_type(pTHX_ const OP *o)
9229 if (o->op_type == OP_SREFGEN)
9231 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
9232 type = kid->op_type;
9233 flags = o->op_flags | kid->op_flags;
9234 if (!(flags & OPf_PARENS)
9235 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
9236 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
9240 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
9241 o = cUNOPo->op_first;
9242 flags = o->op_flags;
9244 ret = ASSIGN_SCALAR;
9247 if (type == OP_COND_EXPR) {
9248 OP * const sib = OpSIBLING(cLOGOPo->op_first);
9249 const I32 t = assignment_type(sib);
9250 const I32 f = assignment_type(OpSIBLING(sib));
9252 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
9254 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
9255 yyerror("Assignment to both a list and a scalar");
9256 return ASSIGN_SCALAR;
9259 if (type == OP_LIST &&
9260 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
9261 o->op_private & OPpLVAL_INTRO)
9264 if (type == OP_LIST || flags & OPf_PARENS ||
9265 type == OP_RV2AV || type == OP_RV2HV ||
9266 type == OP_ASLICE || type == OP_HSLICE ||
9267 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
9270 if (type == OP_PADAV || type == OP_PADHV)
9273 if (type == OP_RV2SV)
9280 S_newONCEOP(pTHX_ OP *initop, OP *padop)
9282 const PADOFFSET target = padop->op_targ;
9283 OP *const other = newOP(OP_PADSV,
9285 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
9286 OP *const first = newOP(OP_NULL, 0);
9287 OP *const nullop = newCONDOP(0, first, initop, other);
9288 /* XXX targlex disabled for now; see ticket #124160
9289 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
9291 OP *const condop = first->op_next;
9293 OpTYPE_set(condop, OP_ONCE);
9294 other->op_targ = target;
9295 nullop->op_flags |= OPf_WANT_SCALAR;
9297 /* Store the initializedness of state vars in a separate
9300 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
9301 /* hijacking PADSTALE for uninitialized state variables */
9302 SvPADSTALE_on(PAD_SVl(condop->op_targ));
9308 =for apidoc newASSIGNOP
9310 Constructs, checks, and returns an assignment op. C<left> and C<right>
9311 supply the parameters of the assignment; they are consumed by this
9312 function and become part of the constructed op tree.
9314 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
9315 a suitable conditional optree is constructed. If C<optype> is the opcode
9316 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
9317 performs the binary operation and assigns the result to the left argument.
9318 Either way, if C<optype> is non-zero then C<flags> has no effect.
9320 If C<optype> is zero, then a plain scalar or list assignment is
9321 constructed. Which type of assignment it is is automatically determined.
9322 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9323 will be set automatically, and, shifted up eight bits, the eight bits
9324 of C<op_private>, except that the bit with value 1 or 2 is automatically
9331 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
9341 right = scalar(right);
9342 return newLOGOP(optype, 0,
9343 op_lvalue(scalar(left), optype),
9344 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
9346 return newBINOP(optype, OPf_STACKED,
9347 op_lvalue(scalar(left), optype), scalar(right));
9350 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
9351 OP *state_var_op = NULL;
9352 static const char no_list_state[] = "Initialization of state variables"
9353 " in list currently forbidden";
9356 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
9357 left->op_private &= ~ OPpSLICEWARNING;
9360 left = op_lvalue(left, OP_AASSIGN);
9361 curop = list(force_list(left, TRUE));
9362 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, TRUE)), curop);
9363 o->op_private = (U8)(0 | (flags >> 8));
9365 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
9367 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
9368 if (!(left->op_flags & OPf_PARENS) &&
9369 lop->op_type == OP_PUSHMARK &&
9370 (vop = OpSIBLING(lop)) &&
9371 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
9372 !(vop->op_flags & OPf_PARENS) &&
9373 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
9374 (OPpLVAL_INTRO|OPpPAD_STATE) &&
9375 (eop = OpSIBLING(vop)) &&
9376 eop->op_type == OP_ENTERSUB &&
9377 !OpHAS_SIBLING(eop)) {
9381 if ((lop->op_type == OP_PADSV ||
9382 lop->op_type == OP_PADAV ||
9383 lop->op_type == OP_PADHV ||
9384 lop->op_type == OP_PADANY)
9385 && (lop->op_private & OPpPAD_STATE)
9387 yyerror(no_list_state);
9388 lop = OpSIBLING(lop);
9392 else if ( (left->op_private & OPpLVAL_INTRO)
9393 && (left->op_private & OPpPAD_STATE)
9394 && ( left->op_type == OP_PADSV
9395 || left->op_type == OP_PADAV
9396 || left->op_type == OP_PADHV
9397 || left->op_type == OP_PADANY)
9399 /* All single variable list context state assignments, hence
9409 if (left->op_flags & OPf_PARENS)
9410 yyerror(no_list_state);
9412 state_var_op = left;
9415 /* optimise @a = split(...) into:
9416 * @{expr}: split(..., @{expr}) (where @a is not flattened)
9417 * @a, my @a, local @a: split(...) (where @a is attached to
9418 * the split op itself)
9422 && right->op_type == OP_SPLIT
9423 /* don't do twice, e.g. @b = (@a = split) */
9424 && !(right->op_private & OPpSPLIT_ASSIGN))
9428 if ( ( left->op_type == OP_RV2AV
9429 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
9430 || left->op_type == OP_PADAV)
9432 /* @pkg or @lex or local @pkg' or 'my @lex' */
9436 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
9437 = cPADOPx(gvop)->op_padix;
9438 cPADOPx(gvop)->op_padix = 0; /* steal it */
9440 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
9441 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
9442 cSVOPx(gvop)->op_sv = NULL; /* steal it */
9444 right->op_private |=
9445 left->op_private & OPpOUR_INTRO;
9448 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
9449 left->op_targ = 0; /* steal it */
9450 right->op_private |= OPpSPLIT_LEX;
9452 right->op_private |= left->op_private & OPpLVAL_INTRO;
9455 tmpop = cUNOPo->op_first; /* to list (nulled) */
9456 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
9457 assert(OpSIBLING(tmpop) == right);
9458 assert(!OpHAS_SIBLING(right));
9459 /* detach the split subtreee from the o tree,
9460 * then free the residual o tree */
9461 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
9462 op_free(o); /* blow off assign */
9463 right->op_private |= OPpSPLIT_ASSIGN;
9464 right->op_flags &= ~OPf_WANT;
9465 /* "I don't know and I don't care." */
9468 else if (left->op_type == OP_RV2AV) {
9471 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
9472 assert(OpSIBLING(pushop) == left);
9473 /* Detach the array ... */
9474 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
9475 /* ... and attach it to the split. */
9476 op_sibling_splice(right, cLISTOPx(right)->op_last,
9478 right->op_flags |= OPf_STACKED;
9479 /* Detach split and expunge aassign as above. */
9482 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
9483 ((LISTOP*)right)->op_last->op_type == OP_CONST)
9485 /* convert split(...,0) to split(..., PL_modcount+1) */
9487 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
9488 SV * const sv = *svp;
9489 if (SvIOK(sv) && SvIVX(sv) == 0)
9491 if (right->op_private & OPpSPLIT_IMPLIM) {
9492 /* our own SV, created in ck_split */
9494 sv_setiv(sv, PL_modcount+1);
9497 /* SV may belong to someone else */
9499 *svp = newSViv(PL_modcount+1);
9506 o = S_newONCEOP(aTHX_ o, state_var_op);
9509 if (assign_type == ASSIGN_REF)
9510 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
9512 right = newOP(OP_UNDEF, 0);
9513 if (right->op_type == OP_READLINE) {
9514 right->op_flags |= OPf_STACKED;
9515 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
9519 o = newBINOP(OP_SASSIGN, flags,
9520 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
9526 =for apidoc newSTATEOP
9528 Constructs a state op (COP). The state op is normally a C<nextstate> op,
9529 but will be a C<dbstate> op if debugging is enabled for currently-compiled
9530 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
9531 If C<label> is non-null, it supplies the name of a label to attach to
9532 the state op; this function takes ownership of the memory pointed at by
9533 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
9536 If C<o> is null, the state op is returned. Otherwise the state op is
9537 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
9538 is consumed by this function and becomes part of the returned op tree.
9544 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
9546 const U32 seq = intro_my();
9547 const U32 utf8 = flags & SVf_UTF8;
9551 PL_parser->parsed_sub = 0;
9555 NewOp(1101, cop, 1, COP);
9556 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
9557 OpTYPE_set(cop, OP_DBSTATE);
9560 OpTYPE_set(cop, OP_NEXTSTATE);
9562 cop->op_flags = (U8)flags;
9563 CopHINTS_set(cop, PL_hints);
9565 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
9567 cop->op_next = (OP*)cop;
9570 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9571 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
9573 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
9575 PL_hints |= HINT_BLOCK_SCOPE;
9576 /* It seems that we need to defer freeing this pointer, as other parts
9577 of the grammar end up wanting to copy it after this op has been
9582 if (PL_parser->preambling != NOLINE) {
9583 CopLINE_set(cop, PL_parser->preambling);
9584 PL_parser->copline = NOLINE;
9586 else if (PL_parser->copline == NOLINE)
9587 CopLINE_set(cop, CopLINE(PL_curcop));
9589 CopLINE_set(cop, PL_parser->copline);
9590 PL_parser->copline = NOLINE;
9593 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
9595 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
9597 CopSTASH_set(cop, PL_curstash);
9599 if (cop->op_type == OP_DBSTATE) {
9600 /* this line can have a breakpoint - store the cop in IV */
9601 AV *av = CopFILEAVx(PL_curcop);
9603 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
9604 if (svp && *svp != &PL_sv_undef ) {
9605 (void)SvIOK_on(*svp);
9606 SvIV_set(*svp, PTR2IV(cop));
9611 if (flags & OPf_SPECIAL)
9613 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
9617 =for apidoc newLOGOP
9619 Constructs, checks, and returns a logical (flow control) op. C<type>
9620 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
9621 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
9622 the eight bits of C<op_private>, except that the bit with value 1 is
9623 automatically set. C<first> supplies the expression controlling the
9624 flow, and C<other> supplies the side (alternate) chain of ops; they are
9625 consumed by this function and become part of the constructed op tree.
9631 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
9633 PERL_ARGS_ASSERT_NEWLOGOP;
9635 return new_logop(type, flags, &first, &other);
9639 /* See if the optree o contains a single OP_CONST (plus possibly
9640 * surrounding enter/nextstate/null etc). If so, return it, else return
9645 S_search_const(pTHX_ OP *o)
9647 PERL_ARGS_ASSERT_SEARCH_CONST;
9650 switch (o->op_type) {
9654 if (o->op_flags & OPf_KIDS) {
9655 o = cUNOPo->op_first;
9664 if (!(o->op_flags & OPf_KIDS))
9666 kid = cLISTOPo->op_first;
9669 switch (kid->op_type) {
9673 kid = OpSIBLING(kid);
9676 if (kid != cLISTOPo->op_last)
9683 kid = cLISTOPo->op_last;
9695 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
9702 int prepend_not = 0;
9704 PERL_ARGS_ASSERT_NEW_LOGOP;
9709 /* [perl #59802]: Warn about things like "return $a or $b", which
9710 is parsed as "(return $a) or $b" rather than "return ($a or
9711 $b)". NB: This also applies to xor, which is why we do it
9714 switch (first->op_type) {
9718 /* XXX: Perhaps we should emit a stronger warning for these.
9719 Even with the high-precedence operator they don't seem to do
9722 But until we do, fall through here.
9728 /* XXX: Currently we allow people to "shoot themselves in the
9729 foot" by explicitly writing "(return $a) or $b".
9731 Warn unless we are looking at the result from folding or if
9732 the programmer explicitly grouped the operators like this.
9733 The former can occur with e.g.
9735 use constant FEATURE => ( $] >= ... );
9736 sub { not FEATURE and return or do_stuff(); }
9738 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
9739 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9740 "Possible precedence issue with control flow operator");
9741 /* XXX: Should we optimze this to "return $a;" (i.e. remove
9747 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
9748 return newBINOP(type, flags, scalar(first), scalar(other));
9750 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
9751 || type == OP_CUSTOM);
9753 scalarboolean(first);
9755 /* search for a constant op that could let us fold the test */
9756 if ((cstop = search_const(first))) {
9757 if (cstop->op_private & OPpCONST_STRICT)
9758 no_bareword_allowed(cstop);
9759 else if ((cstop->op_private & OPpCONST_BARE))
9760 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
9761 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
9762 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
9763 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
9764 /* Elide the (constant) lhs, since it can't affect the outcome */
9766 if (other->op_type == OP_CONST)
9767 other->op_private |= OPpCONST_SHORTCIRCUIT;
9769 if (other->op_type == OP_LEAVE)
9770 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
9771 else if (other->op_type == OP_MATCH
9772 || other->op_type == OP_SUBST
9773 || other->op_type == OP_TRANSR
9774 || other->op_type == OP_TRANS)
9775 /* Mark the op as being unbindable with =~ */
9776 other->op_flags |= OPf_SPECIAL;
9778 other->op_folded = 1;
9782 /* Elide the rhs, since the outcome is entirely determined by
9783 * the (constant) lhs */
9785 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
9786 const OP *o2 = other;
9787 if ( ! (o2->op_type == OP_LIST
9788 && (( o2 = cUNOPx(o2)->op_first))
9789 && o2->op_type == OP_PUSHMARK
9790 && (( o2 = OpSIBLING(o2))) )
9793 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
9794 || o2->op_type == OP_PADHV)
9795 && o2->op_private & OPpLVAL_INTRO
9796 && !(o2->op_private & OPpPAD_STATE))
9798 Perl_croak(aTHX_ "This use of my() in false conditional is "
9799 "no longer allowed");
9803 if (cstop->op_type == OP_CONST)
9804 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
9809 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
9810 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
9812 const OP * const k1 = ((UNOP*)first)->op_first;
9813 const OP * const k2 = OpSIBLING(k1);
9815 switch (first->op_type)
9818 if (k2 && k2->op_type == OP_READLINE
9819 && (k2->op_flags & OPf_STACKED)
9820 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9822 warnop = k2->op_type;
9827 if (k1->op_type == OP_READDIR
9828 || k1->op_type == OP_GLOB
9829 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9830 || k1->op_type == OP_EACH
9831 || k1->op_type == OP_AEACH)
9833 warnop = ((k1->op_type == OP_NULL)
9834 ? (OPCODE)k1->op_targ : k1->op_type);
9839 const line_t oldline = CopLINE(PL_curcop);
9840 /* This ensures that warnings are reported at the first line
9841 of the construction, not the last. */
9842 CopLINE_set(PL_curcop, PL_parser->copline);
9843 Perl_warner(aTHX_ packWARN(WARN_MISC),
9844 "Value of %s%s can be \"0\"; test with defined()",
9846 ((warnop == OP_READLINE || warnop == OP_GLOB)
9847 ? " construct" : "() operator"));
9848 CopLINE_set(PL_curcop, oldline);
9852 /* optimize AND and OR ops that have NOTs as children */
9853 if (first->op_type == OP_NOT
9854 && (first->op_flags & OPf_KIDS)
9855 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
9856 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
9858 if (type == OP_AND || type == OP_OR) {
9864 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
9866 prepend_not = 1; /* prepend a NOT op later */
9871 logop = alloc_LOGOP(type, first, LINKLIST(other));
9872 logop->op_flags |= (U8)flags;
9873 logop->op_private = (U8)(1 | (flags >> 8));
9875 /* establish postfix order */
9876 logop->op_next = LINKLIST(first);
9877 first->op_next = (OP*)logop;
9878 assert(!OpHAS_SIBLING(first));
9879 op_sibling_splice((OP*)logop, first, 0, other);
9881 CHECKOP(type,logop);
9883 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
9884 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
9892 =for apidoc newCONDOP
9894 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
9895 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9896 will be set automatically, and, shifted up eight bits, the eight bits of
9897 C<op_private>, except that the bit with value 1 is automatically set.
9898 C<first> supplies the expression selecting between the two branches,
9899 and C<trueop> and C<falseop> supply the branches; they are consumed by
9900 this function and become part of the constructed op tree.
9906 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
9913 PERL_ARGS_ASSERT_NEWCONDOP;
9916 return newLOGOP(OP_AND, 0, first, trueop);
9918 return newLOGOP(OP_OR, 0, first, falseop);
9920 scalarboolean(first);
9921 if ((cstop = search_const(first))) {
9922 /* Left or right arm of the conditional? */
9923 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
9924 OP *live = left ? trueop : falseop;
9925 OP *const dead = left ? falseop : trueop;
9926 if (cstop->op_private & OPpCONST_BARE &&
9927 cstop->op_private & OPpCONST_STRICT) {
9928 no_bareword_allowed(cstop);
9932 if (live->op_type == OP_LEAVE)
9933 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
9934 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
9935 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
9936 /* Mark the op as being unbindable with =~ */
9937 live->op_flags |= OPf_SPECIAL;
9938 live->op_folded = 1;
9941 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
9942 logop->op_flags |= (U8)flags;
9943 logop->op_private = (U8)(1 | (flags >> 8));
9944 logop->op_next = LINKLIST(falseop);
9946 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
9949 /* establish postfix order */
9950 start = LINKLIST(first);
9951 first->op_next = (OP*)logop;
9953 /* make first, trueop, falseop siblings */
9954 op_sibling_splice((OP*)logop, first, 0, trueop);
9955 op_sibling_splice((OP*)logop, trueop, 0, falseop);
9957 o = newUNOP(OP_NULL, 0, (OP*)logop);
9959 trueop->op_next = falseop->op_next = o;
9966 =for apidoc newTRYCATCHOP
9968 Constructs and returns a conditional execution statement that implements
9969 the C<try>/C<catch> semantics. First the op tree in C<tryblock> is executed,
9970 inside a context that traps exceptions. If an exception occurs then the
9971 optree in C<catchblock> is executed, with the trapped exception set into the
9972 lexical variable given by C<catchvar> (which must be an op of type
9973 C<OP_PADSV>). All the optrees are consumed by this function and become part
9974 of the returned op tree.
9976 The C<flags> argument is currently ignored.
9982 Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock)
9986 PERL_ARGS_ASSERT_NEWTRYCATCHOP;
9987 assert(catchvar->op_type == OP_PADSV);
9989 PERL_UNUSED_ARG(flags);
9991 /* The returned optree is shaped as:
9992 * LISTOP leavetrycatch
9993 * LOGOP entertrycatch
10000 if(tryblock->op_type != OP_LINESEQ)
10001 tryblock = op_convert_list(OP_LINESEQ, 0, tryblock);
10002 OpTYPE_set(tryblock, OP_POPTRY);
10004 /* Manually construct a naked LOGOP.
10005 * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL)
10006 * containing the LOGOP we wanted as its op_first */
10007 catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock);
10008 OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock);
10009 OpLASTSIB_set(catchblock, catchop);
10011 /* Inject the catchvar's pad offset into the OP_CATCH targ */
10012 cLOGOPx(catchop)->op_targ = catchvar->op_targ;
10015 /* Build the optree structure */
10016 o = newLISTOP(OP_LIST, 0, tryblock, catchop);
10017 o = op_convert_list(OP_ENTERTRYCATCH, 0, o);
10023 =for apidoc newRANGE
10025 Constructs and returns a C<range> op, with subordinate C<flip> and
10026 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
10027 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
10028 for both the C<flip> and C<range> ops, except that the bit with value
10029 1 is automatically set. C<left> and C<right> supply the expressions
10030 controlling the endpoints of the range; they are consumed by this function
10031 and become part of the constructed op tree.
10037 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
10045 PERL_ARGS_ASSERT_NEWRANGE;
10047 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
10048 range->op_flags = OPf_KIDS;
10049 leftstart = LINKLIST(left);
10050 range->op_private = (U8)(1 | (flags >> 8));
10052 /* make left and right siblings */
10053 op_sibling_splice((OP*)range, left, 0, right);
10055 range->op_next = (OP*)range;
10056 flip = newUNOP(OP_FLIP, flags, (OP*)range);
10057 flop = newUNOP(OP_FLOP, 0, flip);
10058 o = newUNOP(OP_NULL, 0, flop);
10060 range->op_next = leftstart;
10062 left->op_next = flip;
10063 right->op_next = flop;
10066 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
10067 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
10069 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
10070 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
10071 SvPADTMP_on(PAD_SV(flip->op_targ));
10073 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
10074 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
10076 /* check barewords before they might be optimized aways */
10077 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
10078 no_bareword_allowed(left);
10079 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
10080 no_bareword_allowed(right);
10083 if (!flip->op_private || !flop->op_private)
10084 LINKLIST(o); /* blow off optimizer unless constant */
10090 =for apidoc newLOOPOP
10092 Constructs, checks, and returns an op tree expressing a loop. This is
10093 only a loop in the control flow through the op tree; it does not have
10094 the heavyweight loop structure that allows exiting the loop by C<last>
10095 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
10096 top-level op, except that some bits will be set automatically as required.
10097 C<expr> supplies the expression controlling loop iteration, and C<block>
10098 supplies the body of the loop; they are consumed by this function and
10099 become part of the constructed op tree. C<debuggable> is currently
10100 unused and should always be 1.
10106 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
10110 const bool once = block && block->op_flags & OPf_SPECIAL &&
10111 block->op_type == OP_NULL;
10113 PERL_UNUSED_ARG(debuggable);
10117 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
10118 || ( expr->op_type == OP_NOT
10119 && cUNOPx(expr)->op_first->op_type == OP_CONST
10120 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
10123 /* Return the block now, so that S_new_logop does not try to
10127 return block; /* do {} while 0 does once */
10130 if (expr->op_type == OP_READLINE
10131 || expr->op_type == OP_READDIR
10132 || expr->op_type == OP_GLOB
10133 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
10134 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
10135 expr = newUNOP(OP_DEFINED, 0,
10136 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
10137 } else if (expr->op_flags & OPf_KIDS) {
10138 const OP * const k1 = ((UNOP*)expr)->op_first;
10139 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
10140 switch (expr->op_type) {
10142 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
10143 && (k2->op_flags & OPf_STACKED)
10144 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
10145 expr = newUNOP(OP_DEFINED, 0, expr);
10149 if (k1 && (k1->op_type == OP_READDIR
10150 || k1->op_type == OP_GLOB
10151 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
10152 || k1->op_type == OP_EACH
10153 || k1->op_type == OP_AEACH))
10154 expr = newUNOP(OP_DEFINED, 0, expr);
10160 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
10161 * op, in listop. This is wrong. [perl #27024] */
10163 block = newOP(OP_NULL, 0);
10164 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
10165 o = new_logop(OP_AND, 0, &expr, &listop);
10172 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
10174 if (once && o != listop)
10176 assert(cUNOPo->op_first->op_type == OP_AND
10177 || cUNOPo->op_first->op_type == OP_OR);
10178 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
10182 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
10184 o->op_flags |= flags;
10186 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
10191 =for apidoc newWHILEOP
10193 Constructs, checks, and returns an op tree expressing a C<while> loop.
10194 This is a heavyweight loop, with structure that allows exiting the loop
10195 by C<last> and suchlike.
10197 C<loop> is an optional preconstructed C<enterloop> op to use in the
10198 loop; if it is null then a suitable op will be constructed automatically.
10199 C<expr> supplies the loop's controlling expression. C<block> supplies the
10200 main body of the loop, and C<cont> optionally supplies a C<continue> block
10201 that operates as a second half of the body. All of these optree inputs
10202 are consumed by this function and become part of the constructed op tree.
10204 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10205 op and, shifted up eight bits, the eight bits of C<op_private> for
10206 the C<leaveloop> op, except that (in both cases) some bits will be set
10207 automatically. C<debuggable> is currently unused and should always be 1.
10208 C<has_my> can be supplied as true to force the
10209 loop body to be enclosed in its own scope.
10215 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
10216 OP *expr, OP *block, OP *cont, I32 has_my)
10224 PERL_UNUSED_ARG(debuggable);
10227 if (expr->op_type == OP_READLINE
10228 || expr->op_type == OP_READDIR
10229 || expr->op_type == OP_GLOB
10230 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
10231 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
10232 expr = newUNOP(OP_DEFINED, 0,
10233 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
10234 } else if (expr->op_flags & OPf_KIDS) {
10235 const OP * const k1 = ((UNOP*)expr)->op_first;
10236 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
10237 switch (expr->op_type) {
10239 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
10240 && (k2->op_flags & OPf_STACKED)
10241 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
10242 expr = newUNOP(OP_DEFINED, 0, expr);
10246 if (k1 && (k1->op_type == OP_READDIR
10247 || k1->op_type == OP_GLOB
10248 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
10249 || k1->op_type == OP_EACH
10250 || k1->op_type == OP_AEACH))
10251 expr = newUNOP(OP_DEFINED, 0, expr);
10258 block = newOP(OP_NULL, 0);
10259 else if (cont || has_my) {
10260 block = op_scope(block);
10264 next = LINKLIST(cont);
10267 OP * const unstack = newOP(OP_UNSTACK, 0);
10270 cont = op_append_elem(OP_LINESEQ, cont, unstack);
10274 listop = op_append_list(OP_LINESEQ, block, cont);
10276 redo = LINKLIST(listop);
10280 o = new_logop(OP_AND, 0, &expr, &listop);
10281 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
10282 op_free((OP*)loop);
10283 return expr; /* listop already freed by new_logop */
10286 ((LISTOP*)listop)->op_last->op_next =
10287 (o == listop ? redo : LINKLIST(o));
10293 NewOp(1101,loop,1,LOOP);
10294 OpTYPE_set(loop, OP_ENTERLOOP);
10295 loop->op_private = 0;
10296 loop->op_next = (OP*)loop;
10299 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
10301 loop->op_redoop = redo;
10302 loop->op_lastop = o;
10303 o->op_private |= loopflags;
10306 loop->op_nextop = next;
10308 loop->op_nextop = o;
10310 o->op_flags |= flags;
10311 o->op_private |= (flags >> 8);
10316 =for apidoc newFOROP
10318 Constructs, checks, and returns an op tree expressing a C<foreach>
10319 loop (iteration through a list of values). This is a heavyweight loop,
10320 with structure that allows exiting the loop by C<last> and suchlike.
10322 C<sv> optionally supplies the variable(s) that will be aliased to each
10323 item in turn; if null, it defaults to C<$_>.
10324 C<expr> supplies the list of values to iterate over. C<block> supplies
10325 the main body of the loop, and C<cont> optionally supplies a C<continue>
10326 block that operates as a second half of the body. All of these optree
10327 inputs are consumed by this function and become part of the constructed
10330 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10331 op and, shifted up eight bits, the eight bits of C<op_private> for
10332 the C<leaveloop> op, except that (in both cases) some bits will be set
10339 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
10343 PADOFFSET padoff = 0;
10344 PADOFFSET how_many_more = 0;
10346 I32 iterpflags = 0;
10349 PERL_ARGS_ASSERT_NEWFOROP;
10352 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
10353 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
10354 OpTYPE_set(sv, OP_RV2GV);
10356 /* The op_type check is needed to prevent a possible segfault
10357 * if the loop variable is undeclared and 'strict vars' is in
10358 * effect. This is illegal but is nonetheless parsed, so we
10359 * may reach this point with an OP_CONST where we're expecting
10362 if (cUNOPx(sv)->op_first->op_type == OP_GV
10363 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
10364 iterpflags |= OPpITER_DEF;
10366 else if (sv->op_type == OP_PADSV) { /* private variable */
10367 if (sv->op_flags & OPf_PARENS) {
10368 /* handle degenerate 1-var form of "for my ($x, ...)" */
10369 sv->op_private |= OPpLVAL_INTRO;
10372 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
10373 padoff = sv->op_targ;
10377 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
10379 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
10381 else if (sv->op_type == OP_LIST) {
10382 LISTOP *list = (LISTOP *) sv;
10383 OP *pushmark = list->op_first;
10388 iterpflags = OPpLVAL_INTRO; /* for my ($k, $v) () */
10391 if (!pushmark || pushmark->op_type != OP_PUSHMARK) {
10392 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting pushmark",
10393 pushmark ? PL_op_desc[pushmark->op_type] : "NULL");
10395 first_padsv = OpSIBLING(pushmark);
10396 if (!first_padsv || first_padsv->op_type != OP_PADSV) {
10397 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting padsv",
10398 first_padsv ? PL_op_desc[first_padsv->op_type] : "NULL");
10400 padoff = first_padsv->op_targ;
10402 /* There should be at least one more PADSV to find, and the ops
10403 should have consecutive values in targ: */
10404 padsv = (UNOP *) OpSIBLING(first_padsv);
10406 if (!padsv || padsv->op_type != OP_PADSV) {
10407 Perl_croak(aTHX_ "panic: newFORLOOP, found %s at %zd, expecting padsv",
10408 padsv ? PL_op_desc[padsv->op_type] : "NULL",
10412 if (padsv->op_targ != padoff + how_many_more) {
10413 Perl_croak(aTHX_ "panic: newFORLOOP, padsv at %zd targ is %zd, not %zd",
10414 how_many_more, padsv->op_targ, padoff + how_many_more);
10417 padsv = (UNOP *) OpSIBLING(padsv);
10420 /* OK, this optree has the shape that we expected. So now *we*
10421 "claim" the Pad slots: */
10422 first_padsv->op_targ = 0;
10423 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
10427 padsv = (UNOP *) OpSIBLING(first_padsv);
10430 padsv->op_targ = 0;
10431 PAD_COMPNAME_GEN_set(i, PERL_INT_MAX);
10433 padsv = (UNOP *) OpSIBLING(padsv);
10440 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
10442 PADNAME * const pn = PAD_COMPNAME(padoff);
10443 const char * const name = PadnamePV(pn);
10445 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
10446 iterpflags |= OPpITER_DEF;
10450 sv = newGVOP(OP_GV, 0, PL_defgv);
10451 iterpflags |= OPpITER_DEF;
10454 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
10455 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), TRUE), OP_GREPSTART);
10456 iterflags |= OPf_STACKED;
10458 else if (expr->op_type == OP_NULL &&
10459 (expr->op_flags & OPf_KIDS) &&
10460 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
10462 /* Basically turn for($x..$y) into the same as for($x,$y), but we
10463 * set the STACKED flag to indicate that these values are to be
10464 * treated as min/max values by 'pp_enteriter'.
10466 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
10467 LOGOP* const range = (LOGOP*) flip->op_first;
10468 OP* const left = range->op_first;
10469 OP* const right = OpSIBLING(left);
10472 range->op_flags &= ~OPf_KIDS;
10473 /* detach range's children */
10474 op_sibling_splice((OP*)range, NULL, -1, NULL);
10476 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
10477 listop->op_first->op_next = range->op_next;
10478 left->op_next = range->op_other;
10479 right->op_next = (OP*)listop;
10480 listop->op_next = listop->op_first;
10483 expr = (OP*)(listop);
10485 iterflags |= OPf_STACKED;
10488 expr = op_lvalue(force_list(expr, TRUE), OP_GREPSTART);
10491 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
10492 op_append_elem(OP_LIST, list(expr),
10494 assert(!loop->op_next);
10495 /* for my $x () sets OPpLVAL_INTRO;
10496 * for our $x () sets OPpOUR_INTRO */
10497 loop->op_private = (U8)iterpflags;
10499 /* upgrade loop from a LISTOP to a LOOPOP;
10500 * keep it in-place if there's space */
10501 if (loop->op_slabbed
10502 && OpSLOT(loop)->opslot_size
10503 < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
10505 /* no space; allocate new op */
10507 NewOp(1234,tmp,1,LOOP);
10508 Copy(loop,tmp,1,LISTOP);
10509 assert(loop->op_last->op_sibparent == (OP*)loop);
10510 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
10511 S_op_destroy(aTHX_ (OP*)loop);
10514 else if (!loop->op_slabbed)
10516 /* loop was malloc()ed */
10517 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
10518 OpLASTSIB_set(loop->op_last, (OP*)loop);
10520 loop->op_targ = padoff;
10522 /* hint to deparser that this: for my (...) ... */
10523 loop->op_flags |= OPf_PARENS;
10524 iter = newOP(OP_ITER, 0);
10525 iter->op_targ = how_many_more;
10526 return newWHILEOP(flags, 1, loop, iter, block, cont, 0);
10530 =for apidoc newLOOPEX
10532 Constructs, checks, and returns a loop-exiting op (such as C<goto>
10533 or C<last>). C<type> is the opcode. C<label> supplies the parameter
10534 determining the target of the op; it is consumed by this function and
10535 becomes part of the constructed op tree.
10541 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
10545 PERL_ARGS_ASSERT_NEWLOOPEX;
10547 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
10548 || type == OP_CUSTOM);
10550 if (type != OP_GOTO) {
10551 /* "last()" means "last" */
10552 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
10553 o = newOP(type, OPf_SPECIAL);
10557 /* Check whether it's going to be a goto &function */
10558 if (label->op_type == OP_ENTERSUB
10559 && !(label->op_flags & OPf_STACKED))
10560 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
10563 /* Check for a constant argument */
10564 if (label->op_type == OP_CONST) {
10565 SV * const sv = ((SVOP *)label)->op_sv;
10567 const char *s = SvPV_const(sv,l);
10568 if (l == strlen(s)) {
10570 SvUTF8(((SVOP*)label)->op_sv),
10572 SvPV_nolen_const(((SVOP*)label)->op_sv)));
10576 /* If we have already created an op, we do not need the label. */
10579 else o = newUNOP(type, OPf_STACKED, label);
10581 PL_hints |= HINT_BLOCK_SCOPE;
10585 /* if the condition is a literal array or hash
10586 (or @{ ... } etc), make a reference to it.
10589 S_ref_array_or_hash(pTHX_ OP *cond)
10592 && (cond->op_type == OP_RV2AV
10593 || cond->op_type == OP_PADAV
10594 || cond->op_type == OP_RV2HV
10595 || cond->op_type == OP_PADHV))
10597 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
10600 && (cond->op_type == OP_ASLICE
10601 || cond->op_type == OP_KVASLICE
10602 || cond->op_type == OP_HSLICE
10603 || cond->op_type == OP_KVHSLICE)) {
10605 /* anonlist now needs a list from this op, was previously used in
10606 * scalar context */
10607 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
10608 cond->op_flags |= OPf_WANT_LIST;
10610 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
10617 /* These construct the optree fragments representing given()
10620 entergiven and enterwhen are LOGOPs; the op_other pointer
10621 points up to the associated leave op. We need this so we
10622 can put it in the context and make break/continue work.
10623 (Also, of course, pp_enterwhen will jump straight to
10624 op_other if the match fails.)
10628 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
10629 I32 enter_opcode, I32 leave_opcode,
10630 PADOFFSET entertarg)
10635 PERL_ARGS_ASSERT_NEWGIVWHENOP;
10636 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
10638 enterop = alloc_LOGOP(enter_opcode, block, NULL);
10639 enterop->op_targ = 0;
10640 enterop->op_private = 0;
10642 o = newUNOP(leave_opcode, 0, (OP *) enterop);
10645 /* prepend cond if we have one */
10646 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
10648 o->op_next = LINKLIST(cond);
10649 cond->op_next = (OP *) enterop;
10652 /* This is a default {} block */
10653 enterop->op_flags |= OPf_SPECIAL;
10654 o ->op_flags |= OPf_SPECIAL;
10656 o->op_next = (OP *) enterop;
10659 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
10660 entergiven and enterwhen both
10663 enterop->op_next = LINKLIST(block);
10664 block->op_next = enterop->op_other = o;
10670 /* For the purposes of 'when(implied_smartmatch)'
10671 * versus 'when(boolean_expression)',
10672 * does this look like a boolean operation? For these purposes
10673 a boolean operation is:
10674 - a subroutine call [*]
10675 - a logical connective
10676 - a comparison operator
10677 - a filetest operator, with the exception of -s -M -A -C
10678 - defined(), exists() or eof()
10679 - /$re/ or $foo =~ /$re/
10681 [*] possibly surprising
10684 S_looks_like_bool(pTHX_ const OP *o)
10686 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
10688 switch(o->op_type) {
10691 return looks_like_bool(cLOGOPo->op_first);
10695 OP* sibl = OpSIBLING(cLOGOPo->op_first);
10698 looks_like_bool(cLOGOPo->op_first)
10699 && looks_like_bool(sibl));
10705 o->op_flags & OPf_KIDS
10706 && looks_like_bool(cUNOPo->op_first));
10710 case OP_NOT: case OP_XOR:
10712 case OP_EQ: case OP_NE: case OP_LT:
10713 case OP_GT: case OP_LE: case OP_GE:
10715 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
10716 case OP_I_GT: case OP_I_LE: case OP_I_GE:
10718 case OP_SEQ: case OP_SNE: case OP_SLT:
10719 case OP_SGT: case OP_SLE: case OP_SGE:
10721 case OP_SMARTMATCH:
10723 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
10724 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
10725 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
10726 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
10727 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
10728 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
10729 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
10730 case OP_FTTEXT: case OP_FTBINARY:
10732 case OP_DEFINED: case OP_EXISTS:
10733 case OP_MATCH: case OP_EOF:
10741 /* optimised-away (index() != -1) or similar comparison */
10742 if (o->op_private & OPpTRUEBOOL)
10747 /* Detect comparisons that have been optimized away */
10748 if (cSVOPo->op_sv == &PL_sv_yes
10749 || cSVOPo->op_sv == &PL_sv_no)
10762 =for apidoc newGIVENOP
10764 Constructs, checks, and returns an op tree expressing a C<given> block.
10765 C<cond> supplies the expression to whose value C<$_> will be locally
10766 aliased, and C<block> supplies the body of the C<given> construct; they
10767 are consumed by this function and become part of the constructed op tree.
10768 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
10774 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
10776 PERL_ARGS_ASSERT_NEWGIVENOP;
10777 PERL_UNUSED_ARG(defsv_off);
10779 assert(!defsv_off);
10780 return newGIVWHENOP(
10781 ref_array_or_hash(cond),
10783 OP_ENTERGIVEN, OP_LEAVEGIVEN,
10788 =for apidoc newWHENOP
10790 Constructs, checks, and returns an op tree expressing a C<when> block.
10791 C<cond> supplies the test expression, and C<block> supplies the block
10792 that will be executed if the test evaluates to true; they are consumed
10793 by this function and become part of the constructed op tree. C<cond>
10794 will be interpreted DWIMically, often as a comparison against C<$_>,
10795 and may be null to generate a C<default> block.
10801 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
10803 const bool cond_llb = (!cond || looks_like_bool(cond));
10806 PERL_ARGS_ASSERT_NEWWHENOP;
10811 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
10813 scalar(ref_array_or_hash(cond)));
10816 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
10820 =for apidoc newDEFEROP
10822 Constructs and returns a deferred-block statement that implements the
10823 C<defer> semantics. The C<block> optree is consumed by this function and
10824 becomes part of the returned optree.
10826 The C<flags> argument carries additional flags to set on the returned op,
10827 including the C<op_private> field.
10833 Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
10835 OP *o, *start, *blockfirst;
10837 PERL_ARGS_ASSERT_NEWDEFEROP;
10839 start = LINKLIST(block);
10841 /* Hide the block inside an OP_NULL with no exection */
10842 block = newUNOP(OP_NULL, 0, block);
10843 block->op_next = block;
10845 o = (OP *)alloc_LOGOP(OP_PUSHDEFER, block, start);
10846 o->op_flags |= OPf_WANT_VOID | (U8)(flags);
10847 o->op_private = (U8)(flags >> 8);
10849 /* Terminate the block */
10850 blockfirst = cUNOPx(block)->op_first;
10851 assert(blockfirst->op_type == OP_SCOPE || blockfirst->op_type == OP_LEAVE);
10852 blockfirst->op_next = NULL;
10858 =for apidoc op_wrap_finally
10860 Wraps the given C<block> optree fragment in its own scoped block, arranging
10861 for the C<finally> optree fragment to be invoked when leaving that block for
10862 any reason. Both optree fragments are consumed and the combined result is
10869 Perl_op_wrap_finally(pTHX_ OP *block, OP *finally)
10871 PERL_ARGS_ASSERT_OP_WRAP_FINALLY;
10873 /* TODO: If block is already an ENTER/LEAVE-wrapped line sequence we can
10874 * just splice the DEFEROP in at the top, for efficiency.
10877 OP *o = newLISTOP(OP_LINESEQ, 0, newDEFEROP((OPpDEFER_FINALLY << 8), finally), block);
10878 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
10879 OpTYPE_set(o, OP_LEAVE);
10884 /* must not conflict with SVf_UTF8 */
10885 #define CV_CKPROTO_CURSTASH 0x1
10888 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
10889 const STRLEN len, const U32 flags)
10891 SV *name = NULL, *msg;
10892 const char * cvp = SvROK(cv)
10893 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
10894 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
10897 STRLEN clen = CvPROTOLEN(cv), plen = len;
10899 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
10901 if (p == NULL && cvp == NULL)
10904 if (!ckWARN_d(WARN_PROTOTYPE))
10908 p = S_strip_spaces(aTHX_ p, &plen);
10909 cvp = S_strip_spaces(aTHX_ cvp, &clen);
10910 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
10911 if (plen == clen && memEQ(cvp, p, plen))
10914 if (flags & SVf_UTF8) {
10915 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
10919 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
10925 msg = sv_newmortal();
10930 gv_efullname3(name = sv_newmortal(), gv, NULL);
10931 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
10932 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
10933 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
10934 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
10935 sv_catpvs(name, "::");
10937 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
10938 assert (CvNAMED(SvRV_const(gv)));
10939 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
10941 else sv_catsv(name, (SV *)gv);
10943 else name = (SV *)gv;
10945 sv_setpvs(msg, "Prototype mismatch:");
10947 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
10949 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
10950 UTF8fARG(SvUTF8(cv),clen,cvp)
10953 sv_catpvs(msg, ": none");
10954 sv_catpvs(msg, " vs ");
10956 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
10958 sv_catpvs(msg, "none");
10959 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
10962 static void const_sv_xsub(pTHX_ CV* cv);
10963 static void const_av_xsub(pTHX_ CV* cv);
10967 =for apidoc_section $optree_manipulation
10969 =for apidoc cv_const_sv
10971 If C<cv> is a constant sub eligible for inlining, returns the constant
10972 value returned by the sub. Otherwise, returns C<NULL>.
10974 Constant subs can be created with C<newCONSTSUB> or as described in
10975 L<perlsub/"Constant Functions">.
10980 Perl_cv_const_sv(const CV *const cv)
10985 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
10987 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10988 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
10993 Perl_cv_const_sv_or_av(const CV * const cv)
10997 if (SvROK(cv)) return SvRV((SV *)cv);
10998 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
10999 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
11002 /* op_const_sv: examine an optree to determine whether it's in-lineable.
11003 * Can be called in 2 ways:
11006 * look for a single OP_CONST with attached value: return the value
11008 * allow_lex && !CvCONST(cv);
11010 * examine the clone prototype, and if contains only a single
11011 * OP_CONST, return the value; or if it contains a single PADSV ref-
11012 * erencing an outer lexical, turn on CvCONST to indicate the CV is
11013 * a candidate for "constizing" at clone time, and return NULL.
11017 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
11020 bool padsv = FALSE;
11025 for (; o; o = o->op_next) {
11026 const OPCODE type = o->op_type;
11028 if (type == OP_NEXTSTATE || type == OP_LINESEQ
11030 || type == OP_PUSHMARK)
11032 if (type == OP_DBSTATE)
11034 if (type == OP_LEAVESUB)
11038 if (type == OP_CONST && cSVOPo->op_sv)
11039 sv = cSVOPo->op_sv;
11040 else if (type == OP_UNDEF && !o->op_private) {
11041 sv = newSV_type(SVt_NULL);
11044 else if (allow_lex && type == OP_PADSV) {
11045 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
11047 sv = &PL_sv_undef; /* an arbitrary non-null value */
11065 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
11066 PADNAME * const name, SV ** const const_svp)
11069 assert (o || name);
11070 assert (const_svp);
11072 if (CvFLAGS(PL_compcv)) {
11073 /* might have had built-in attrs applied */
11074 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
11075 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
11076 && ckWARN(WARN_MISC))
11078 /* protect against fatal warnings leaking compcv */
11079 SAVEFREESV(PL_compcv);
11080 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
11081 SvREFCNT_inc_simple_void_NN(PL_compcv);
11084 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
11085 & ~(CVf_LVALUE * pureperl));
11090 /* redundant check for speed: */
11091 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11092 const line_t oldline = CopLINE(PL_curcop);
11095 : newSVpvn_flags( PadnamePV(name)+1,PadnameLEN(name)-1,
11096 (PadnameUTF8(name)) ? SVf_UTF8|SVs_TEMP : SVs_TEMP
11098 if (PL_parser && PL_parser->copline != NOLINE)
11099 /* This ensures that warnings are reported at the first
11100 line of a redefinition, not the last. */
11101 CopLINE_set(PL_curcop, PL_parser->copline);
11102 /* protect against fatal warnings leaking compcv */
11103 SAVEFREESV(PL_compcv);
11104 report_redefined_cv(namesv, cv, const_svp);
11105 SvREFCNT_inc_simple_void_NN(PL_compcv);
11106 CopLINE_set(PL_curcop, oldline);
11113 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
11118 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11121 CV *compcv = PL_compcv;
11124 PADOFFSET pax = o->op_targ;
11125 CV *outcv = CvOUTSIDE(PL_compcv);
11128 bool reusable = FALSE;
11130 #ifdef PERL_DEBUG_READONLY_OPS
11131 OPSLAB *slab = NULL;
11134 PERL_ARGS_ASSERT_NEWMYSUB;
11136 PL_hints |= HINT_BLOCK_SCOPE;
11138 /* Find the pad slot for storing the new sub.
11139 We cannot use PL_comppad, as it is the pad owned by the new sub. We
11140 need to look in CvOUTSIDE and find the pad belonging to the enclos-
11141 ing sub. And then we need to dig deeper if this is a lexical from
11143 my sub foo; sub { sub foo { } }
11146 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
11147 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
11148 pax = PARENT_PAD_INDEX(name);
11149 outcv = CvOUTSIDE(outcv);
11154 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
11155 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
11156 spot = (CV **)svspot;
11158 if (!(PL_parser && PL_parser->error_count))
11159 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
11162 assert(proto->op_type == OP_CONST);
11163 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11164 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11174 if (PL_parser && PL_parser->error_count) {
11176 SvREFCNT_dec(PL_compcv);
11181 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
11183 svspot = (SV **)(spot = &clonee);
11185 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
11188 assert (SvTYPE(*spot) == SVt_PVCV);
11189 if (CvNAMED(*spot))
11190 hek = CvNAME_HEK(*spot);
11193 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
11194 CvNAME_HEK_set(*spot, hek =
11197 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
11201 CvLEXICAL_on(*spot);
11203 cv = PadnamePROTOCV(name);
11204 svspot = (SV **)(spot = &PadnamePROTOCV(name));
11208 /* This makes sub {}; work as expected. */
11209 if (block->op_type == OP_STUB) {
11210 const line_t l = PL_parser->copline;
11212 block = newSTATEOP(0, NULL, 0);
11213 PL_parser->copline = l;
11215 block = CvLVALUE(compcv)
11216 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
11217 ? newUNOP(OP_LEAVESUBLV, 0,
11218 op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
11219 : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
11220 start = LINKLIST(block);
11221 block->op_next = 0;
11222 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
11223 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
11231 const bool exists = CvROOT(cv) || CvXSUB(cv);
11233 /* if the subroutine doesn't exist and wasn't pre-declared
11234 * with a prototype, assume it will be AUTOLOADed,
11235 * skipping the prototype check
11237 if (exists || SvPOK(cv))
11238 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
11240 /* already defined? */
11242 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
11248 /* just a "sub foo;" when &foo is already defined */
11249 SAVEFREESV(compcv);
11253 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
11260 SvREFCNT_inc_simple_void_NN(const_sv);
11261 SvFLAGS(const_sv) |= SVs_PADTMP;
11263 assert(!CvROOT(cv) && !CvCONST(cv));
11264 cv_forget_slab(cv);
11267 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11268 CvFILE_set_from_cop(cv, PL_curcop);
11269 CvSTASH_set(cv, PL_curstash);
11272 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
11273 CvXSUBANY(cv).any_ptr = const_sv;
11274 CvXSUB(cv) = const_sv_xsub;
11278 CvFLAGS(cv) |= CvMETHOD(compcv);
11280 SvREFCNT_dec(compcv);
11285 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
11286 determine whether this sub definition is in the same scope as its
11287 declaration. If this sub definition is inside an inner named pack-
11288 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
11289 the package sub. So check PadnameOUTER(name) too.
11291 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
11292 assert(!CvWEAKOUTSIDE(compcv));
11293 SvREFCNT_dec(CvOUTSIDE(compcv));
11294 CvWEAKOUTSIDE_on(compcv);
11296 /* XXX else do we have a circular reference? */
11298 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
11299 /* transfer PL_compcv to cv */
11301 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11302 cv_flags_t preserved_flags =
11303 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
11304 PADLIST *const temp_padl = CvPADLIST(cv);
11305 CV *const temp_cv = CvOUTSIDE(cv);
11306 const cv_flags_t other_flags =
11307 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11308 OP * const cvstart = CvSTART(cv);
11312 CvFLAGS(compcv) | preserved_flags;
11313 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
11314 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
11315 CvPADLIST_set(cv, CvPADLIST(compcv));
11316 CvOUTSIDE(compcv) = temp_cv;
11317 CvPADLIST_set(compcv, temp_padl);
11318 CvSTART(cv) = CvSTART(compcv);
11319 CvSTART(compcv) = cvstart;
11320 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11321 CvFLAGS(compcv) |= other_flags;
11324 Safefree(CvFILE(cv));
11328 /* inner references to compcv must be fixed up ... */
11329 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
11330 if (PERLDB_INTER)/* Advice debugger on the new sub. */
11331 ++PL_sub_generation;
11334 /* Might have had built-in attributes applied -- propagate them. */
11335 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
11337 /* ... before we throw it away */
11338 SvREFCNT_dec(compcv);
11339 PL_compcv = compcv = cv;
11348 if (!CvNAME_HEK(cv)) {
11349 if (hek) (void)share_hek_hek(hek);
11352 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
11353 hek = share_hek(PadnamePV(name)+1,
11354 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
11357 CvNAME_HEK_set(cv, hek);
11363 if (CvFILE(cv) && CvDYNFILE(cv))
11364 Safefree(CvFILE(cv));
11365 CvFILE_set_from_cop(cv, PL_curcop);
11366 CvSTASH_set(cv, PL_curstash);
11369 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11371 SvUTF8_on(MUTABLE_SV(cv));
11375 /* If we assign an optree to a PVCV, then we've defined a
11376 * subroutine that the debugger could be able to set a breakpoint
11377 * in, so signal to pp_entereval that it should not throw away any
11378 * saved lines at scope exit. */
11380 PL_breakable_sub_gen++;
11381 CvROOT(cv) = block;
11382 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11383 itself has a refcount. */
11385 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11386 #ifdef PERL_DEBUG_READONLY_OPS
11387 slab = (OPSLAB *)CvSTART(cv);
11389 S_process_optree(aTHX_ cv, block, start);
11394 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11395 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
11399 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11400 SV * const tmpstr = sv_newmortal();
11401 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11402 GV_ADDMULTI, SVt_PVHV);
11404 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11405 CopFILE(PL_curcop),
11407 (long)CopLINE(PL_curcop));
11408 if (HvNAME_HEK(PL_curstash)) {
11409 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
11410 sv_catpvs(tmpstr, "::");
11413 sv_setpvs(tmpstr, "__ANON__::");
11415 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
11416 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
11417 (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
11418 hv = GvHVn(db_postponed);
11419 if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
11420 CV * const pcv = GvCV(db_postponed);
11426 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11434 assert(CvDEPTH(outcv));
11436 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
11438 cv_clone_into(clonee, *spot);
11439 else *spot = cv_clone(clonee);
11440 SvREFCNT_dec_NN(clonee);
11444 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
11445 PADOFFSET depth = CvDEPTH(outcv);
11448 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
11450 *svspot = SvREFCNT_inc_simple_NN(cv);
11451 SvREFCNT_dec(oldcv);
11457 PL_parser->copline = NOLINE;
11458 LEAVE_SCOPE(floor);
11459 #ifdef PERL_DEBUG_READONLY_OPS
11468 =for apidoc newATTRSUB_x
11470 Construct a Perl subroutine, also performing some surrounding jobs.
11472 This function is expected to be called in a Perl compilation context,
11473 and some aspects of the subroutine are taken from global variables
11474 associated with compilation. In particular, C<PL_compcv> represents
11475 the subroutine that is currently being compiled. It must be non-null
11476 when this function is called, and some aspects of the subroutine being
11477 constructed are taken from it. The constructed subroutine may actually
11478 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
11480 If C<block> is null then the subroutine will have no body, and for the
11481 time being it will be an error to call it. This represents a forward
11482 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
11483 non-null then it provides the Perl code of the subroutine body, which
11484 will be executed when the subroutine is called. This body includes
11485 any argument unwrapping code resulting from a subroutine signature or
11486 similar. The pad use of the code must correspond to the pad attached
11487 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
11488 C<leavesublv> op; this function will add such an op. C<block> is consumed
11489 by this function and will become part of the constructed subroutine.
11491 C<proto> specifies the subroutine's prototype, unless one is supplied
11492 as an attribute (see below). If C<proto> is null, then the subroutine
11493 will not have a prototype. If C<proto> is non-null, it must point to a
11494 C<const> op whose value is a string, and the subroutine will have that
11495 string as its prototype. If a prototype is supplied as an attribute, the
11496 attribute takes precedence over C<proto>, but in that case C<proto> should
11497 preferably be null. In any case, C<proto> is consumed by this function.
11499 C<attrs> supplies attributes to be applied the subroutine. A handful of
11500 attributes take effect by built-in means, being applied to C<PL_compcv>
11501 immediately when seen. Other attributes are collected up and attached
11502 to the subroutine by this route. C<attrs> may be null to supply no
11503 attributes, or point to a C<const> op for a single attribute, or point
11504 to a C<list> op whose children apart from the C<pushmark> are C<const>
11505 ops for one or more attributes. Each C<const> op must be a string,
11506 giving the attribute name optionally followed by parenthesised arguments,
11507 in the manner in which attributes appear in Perl source. The attributes
11508 will be applied to the sub by this function. C<attrs> is consumed by
11511 If C<o_is_gv> is false and C<o> is null, then the subroutine will
11512 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
11513 must point to a C<const> OP, which will be consumed by this function,
11514 and its string value supplies a name for the subroutine. The name may
11515 be qualified or unqualified, and if it is unqualified then a default
11516 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
11517 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
11518 by which the subroutine will be named.
11520 If there is already a subroutine of the specified name, then the new
11521 sub will either replace the existing one in the glob or be merged with
11522 the existing one. A warning may be generated about redefinition.
11524 If the subroutine has one of a few special names, such as C<BEGIN> or
11525 C<END>, then it will be claimed by the appropriate queue for automatic
11526 running of phase-related subroutines. In this case the relevant glob will
11527 be left not containing any subroutine, even if it did contain one before.
11528 In the case of C<BEGIN>, the subroutine will be executed and the reference
11529 to it disposed of before this function returns.
11531 The function returns a pointer to the constructed subroutine. If the sub
11532 is anonymous then ownership of one counted reference to the subroutine
11533 is transferred to the caller. If the sub is named then the caller does
11534 not get ownership of a reference. In most such cases, where the sub
11535 has a non-phase name, the sub will be alive at the point it is returned
11536 by virtue of being contained in the glob that names it. A phase-named
11537 subroutine will usually be alive by virtue of the reference owned by the
11538 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11539 been executed, will quite likely have been destroyed already by the
11540 time this function returns, making it erroneous for the caller to make
11541 any use of the returned pointer. It is the caller's responsibility to
11542 ensure that it knows which of these situations applies.
11544 =for apidoc newATTRSUB
11545 Construct a Perl subroutine, also performing some surrounding jobs.
11547 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter set to
11548 FALSE. This means that if C<o> is null, the new sub will be anonymous; otherwise
11549 the name will be derived from C<o> in the way described (as with all other
11550 details) in L<perlintern/C<newATTRSUB_x>>.
11553 Like C<L</newATTRSUB>>, but without attributes.
11558 /* _x = extended */
11560 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
11561 OP *block, bool o_is_gv)
11565 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11567 CV *cv = NULL; /* the previous CV with this name, if any */
11569 const bool ec = PL_parser && PL_parser->error_count;
11570 /* If the subroutine has no body, no attributes, and no builtin attributes
11571 then it's just a sub declaration, and we may be able to get away with
11572 storing with a placeholder scalar in the symbol table, rather than a
11573 full CV. If anything is present then it will take a full CV to
11575 const I32 gv_fetch_flags
11576 = ec ? GV_NOADD_NOINIT :
11577 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
11578 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
11580 const char * const name =
11581 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
11583 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
11584 bool evanescent = FALSE;
11586 #ifdef PERL_DEBUG_READONLY_OPS
11587 OPSLAB *slab = NULL;
11595 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
11596 hek and CvSTASH pointer together can imply the GV. If the name
11597 contains a package name, then GvSTASH(CvGV(cv)) may differ from
11598 CvSTASH, so forego the optimisation if we find any.
11599 Also, we may be called from load_module at run time, so
11600 PL_curstash (which sets CvSTASH) may not point to the stash the
11601 sub is stored in. */
11602 /* XXX This optimization is currently disabled for packages other
11603 than main, since there was too much CPAN breakage. */
11605 ec ? GV_NOADD_NOINIT
11606 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
11607 || PL_curstash != PL_defstash
11608 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
11610 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
11611 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
11613 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
11614 SV * const sv = sv_newmortal();
11615 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
11616 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11617 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11618 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
11620 } else if (PL_curstash) {
11621 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
11624 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
11630 move_proto_attr(&proto, &attrs, gv, 0);
11633 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
11638 assert(proto->op_type == OP_CONST);
11639 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11640 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11656 SvREFCNT_dec(PL_compcv);
11661 if (name && block) {
11662 const char *s = (char *) my_memrchr(name, ':', namlen);
11663 s = s ? s+1 : name;
11664 if (strEQ(s, "BEGIN")) {
11665 if (PL_in_eval & EVAL_KEEPERR)
11666 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
11668 SV * const errsv = ERRSV;
11669 /* force display of errors found but not reported */
11670 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
11671 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
11678 if (!block && SvTYPE(gv) != SVt_PVGV) {
11679 /* If we are not defining a new sub and the existing one is not a
11681 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
11682 /* We are applying attributes to an existing sub, so we need it
11683 upgraded if it is a constant. */
11684 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
11685 gv_init_pvn(gv, PL_curstash, name, namlen,
11686 SVf_UTF8 * name_is_utf8);
11688 else { /* Maybe prototype now, and had at maximum
11689 a prototype or const/sub ref before. */
11690 if (SvTYPE(gv) > SVt_NULL) {
11691 cv_ckproto_len_flags((const CV *)gv,
11692 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11698 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
11700 SvUTF8_on(MUTABLE_SV(gv));
11703 sv_setiv(MUTABLE_SV(gv), -1);
11706 SvREFCNT_dec(PL_compcv);
11707 cv = PL_compcv = NULL;
11712 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
11716 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
11722 /* This makes sub {}; work as expected. */
11723 if (block->op_type == OP_STUB) {
11724 const line_t l = PL_parser->copline;
11726 block = newSTATEOP(0, NULL, 0);
11727 PL_parser->copline = l;
11729 block = CvLVALUE(PL_compcv)
11730 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
11731 && (!isGV(gv) || !GvASSUMECV(gv)))
11732 ? newUNOP(OP_LEAVESUBLV, 0,
11733 op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
11734 : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
11735 start = LINKLIST(block);
11736 block->op_next = 0;
11737 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
11739 S_op_const_sv(aTHX_ start, PL_compcv,
11740 cBOOL(CvCLONE(PL_compcv)));
11747 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
11748 cv_ckproto_len_flags((const CV *)gv,
11749 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11750 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
11752 /* All the other code for sub redefinition warnings expects the
11753 clobbered sub to be a CV. Instead of making all those code
11754 paths more complex, just inline the RV version here. */
11755 const line_t oldline = CopLINE(PL_curcop);
11756 assert(IN_PERL_COMPILETIME);
11757 if (PL_parser && PL_parser->copline != NOLINE)
11758 /* This ensures that warnings are reported at the first
11759 line of a redefinition, not the last. */
11760 CopLINE_set(PL_curcop, PL_parser->copline);
11761 /* protect against fatal warnings leaking compcv */
11762 SAVEFREESV(PL_compcv);
11764 if (ckWARN(WARN_REDEFINE)
11765 || ( ckWARN_d(WARN_REDEFINE)
11766 && ( !const_sv || SvRV(gv) == const_sv
11767 || sv_cmp(SvRV(gv), const_sv) ))) {
11769 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11770 "Constant subroutine %" SVf " redefined",
11771 SVfARG(cSVOPo->op_sv));
11774 SvREFCNT_inc_simple_void_NN(PL_compcv);
11775 CopLINE_set(PL_curcop, oldline);
11776 SvREFCNT_dec(SvRV(gv));
11781 const bool exists = CvROOT(cv) || CvXSUB(cv);
11783 /* if the subroutine doesn't exist and wasn't pre-declared
11784 * with a prototype, assume it will be AUTOLOADed,
11785 * skipping the prototype check
11787 if (exists || SvPOK(cv))
11788 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
11789 /* already defined (or promised)? */
11790 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
11791 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
11797 /* just a "sub foo;" when &foo is already defined */
11798 SAVEFREESV(PL_compcv);
11805 SvREFCNT_inc_simple_void_NN(const_sv);
11806 SvFLAGS(const_sv) |= SVs_PADTMP;
11808 assert(!CvROOT(cv) && !CvCONST(cv));
11809 cv_forget_slab(cv);
11810 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
11811 CvXSUBANY(cv).any_ptr = const_sv;
11812 CvXSUB(cv) = const_sv_xsub;
11816 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11819 if (isGV(gv) || CvMETHOD(PL_compcv)) {
11820 if (name && isGV(gv))
11821 GvCV_set(gv, NULL);
11822 cv = newCONSTSUB_flags(
11823 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
11827 assert(SvREFCNT((SV*)cv) != 0);
11828 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11832 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11833 prepare_SV_for_RV((SV *)gv);
11834 SvOK_off((SV *)gv);
11837 SvRV_set(gv, const_sv);
11841 SvREFCNT_dec(PL_compcv);
11846 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
11847 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
11850 if (cv) { /* must reuse cv if autoloaded */
11851 /* transfer PL_compcv to cv */
11853 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11854 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
11855 PADLIST *const temp_av = CvPADLIST(cv);
11856 CV *const temp_cv = CvOUTSIDE(cv);
11857 const cv_flags_t other_flags =
11858 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11859 OP * const cvstart = CvSTART(cv);
11863 assert(!CvCVGV_RC(cv));
11864 assert(CvGV(cv) == gv);
11868 PERL_HASH(hash, name, namlen);
11878 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
11880 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
11881 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
11882 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
11883 CvOUTSIDE(PL_compcv) = temp_cv;
11884 CvPADLIST_set(PL_compcv, temp_av);
11885 CvSTART(cv) = CvSTART(PL_compcv);
11886 CvSTART(PL_compcv) = cvstart;
11887 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11888 CvFLAGS(PL_compcv) |= other_flags;
11891 Safefree(CvFILE(cv));
11893 CvFILE_set_from_cop(cv, PL_curcop);
11894 CvSTASH_set(cv, PL_curstash);
11896 /* inner references to PL_compcv must be fixed up ... */
11897 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
11898 if (PERLDB_INTER)/* Advice debugger on the new sub. */
11899 ++PL_sub_generation;
11902 /* Might have had built-in attributes applied -- propagate them. */
11903 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
11905 /* ... before we throw it away */
11906 SvREFCNT_dec(PL_compcv);
11911 if (name && isGV(gv)) {
11914 if (HvENAME_HEK(GvSTASH(gv)))
11915 /* sub Foo::bar { (shift)+1 } */
11916 gv_method_changed(gv);
11920 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11921 prepare_SV_for_RV((SV *)gv);
11922 SvOK_off((SV *)gv);
11925 SvRV_set(gv, (SV *)cv);
11926 if (HvENAME_HEK(PL_curstash))
11927 mro_method_changed_in(PL_curstash);
11931 assert(SvREFCNT((SV*)cv) != 0);
11933 if (!CvHASGV(cv)) {
11938 PERL_HASH(hash, name, namlen);
11939 CvNAME_HEK_set(cv, share_hek(name,
11945 CvFILE_set_from_cop(cv, PL_curcop);
11946 CvSTASH_set(cv, PL_curstash);
11950 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11952 SvUTF8_on(MUTABLE_SV(cv));
11956 /* If we assign an optree to a PVCV, then we've defined a
11957 * subroutine that the debugger could be able to set a breakpoint
11958 * in, so signal to pp_entereval that it should not throw away any
11959 * saved lines at scope exit. */
11961 PL_breakable_sub_gen++;
11962 CvROOT(cv) = block;
11963 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11964 itself has a refcount. */
11966 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11967 #ifdef PERL_DEBUG_READONLY_OPS
11968 slab = (OPSLAB *)CvSTART(cv);
11970 S_process_optree(aTHX_ cv, block, start);
11975 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11976 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
11977 ? GvSTASH(CvGV(cv))
11981 apply_attrs(stash, MUTABLE_SV(cv), attrs);
11983 SvREFCNT_inc_simple_void_NN(cv);
11986 if (block && has_name) {
11987 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11988 SV * const tmpstr = cv_name(cv,NULL,0);
11989 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11990 GV_ADDMULTI, SVt_PVHV);
11992 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11993 CopFILE(PL_curcop),
11995 (long)CopLINE(PL_curcop));
11996 (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
11997 hv = GvHVn(db_postponed);
11998 if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
11999 CV * const pcv = GvCV(db_postponed);
12005 call_sv(MUTABLE_SV(pcv), G_DISCARD);
12011 if (PL_parser && PL_parser->error_count)
12012 clear_special_blocks(name, gv, cv);
12015 process_special_blocks(floor, name, gv, cv);
12021 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
12023 PL_parser->copline = NOLINE;
12024 LEAVE_SCOPE(floor);
12026 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
12028 #ifdef PERL_DEBUG_READONLY_OPS
12032 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
12033 pad_add_weakref(cv);
12039 S_clear_special_blocks(pTHX_ const char *const fullname,
12040 GV *const gv, CV *const cv) {
12044 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
12046 colon = strrchr(fullname,':');
12047 name = colon ? colon + 1 : fullname;
12049 if ((*name == 'B' && strEQ(name, "BEGIN"))
12050 || (*name == 'E' && strEQ(name, "END"))
12051 || (*name == 'U' && strEQ(name, "UNITCHECK"))
12052 || (*name == 'C' && strEQ(name, "CHECK"))
12053 || (*name == 'I' && strEQ(name, "INIT"))) {
12058 GvCV_set(gv, NULL);
12059 SvREFCNT_dec_NN(MUTABLE_SV(cv));
12063 /* Returns true if the sub has been freed. */
12065 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
12069 const char *const colon = strrchr(fullname,':');
12070 const char *const name = colon ? colon + 1 : fullname;
12072 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
12074 if (*name == 'B') {
12075 if (strEQ(name, "BEGIN")) {
12076 const I32 oldscope = PL_scopestack_ix;
12079 if (floor) LEAVE_SCOPE(floor);
12082 SAVEVPTR(PL_curcop);
12083 if (PL_curcop == &PL_compiling) {
12084 /* Avoid pushing the "global" &PL_compiling onto the
12085 * context stack. For example, a stack trace inside
12086 * nested use's would show all calls coming from whoever
12087 * most recently updated PL_compiling.cop_file and
12088 * cop_line. So instead, temporarily set PL_curcop to a
12089 * private copy of &PL_compiling. PL_curcop will soon be
12090 * set to point back to &PL_compiling anyway but only
12091 * after the temp value has been pushed onto the context
12092 * stack as blk_oldcop.
12093 * This is slightly hacky, but necessary. Note also
12094 * that in the brief window before PL_curcop is set back
12095 * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
12096 * will give the wrong answer.
12098 PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL);
12099 CopLINE_set(PL_curcop, CopLINE(&PL_compiling));
12100 SAVEFREEOP(PL_curcop);
12103 PUSHSTACKi(PERLSI_REQUIRE);
12104 SAVECOPFILE(&PL_compiling);
12105 SAVECOPLINE(&PL_compiling);
12107 DEBUG_x( dump_sub(gv) );
12108 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
12109 GvCV_set(gv,0); /* cv has been hijacked */
12110 call_list(oldscope, PL_beginav);
12114 return !PL_savebegin;
12119 if (*name == 'E') {
12120 if (strEQ(name, "END")) {
12121 DEBUG_x( dump_sub(gv) );
12122 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
12125 } else if (*name == 'U') {
12126 if (strEQ(name, "UNITCHECK")) {
12127 /* It's never too late to run a unitcheck block */
12128 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
12132 } else if (*name == 'C') {
12133 if (strEQ(name, "CHECK")) {
12135 /* diag_listed_as: Too late to run %s block */
12136 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
12137 "Too late to run CHECK block");
12138 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
12142 } else if (*name == 'I') {
12143 if (strEQ(name, "INIT")) {
12145 /* diag_listed_as: Too late to run %s block */
12146 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
12147 "Too late to run INIT block");
12148 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
12154 DEBUG_x( dump_sub(gv) );
12156 GvCV_set(gv,0); /* cv has been hijacked */
12162 =for apidoc newCONSTSUB
12164 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
12165 rather than of counted length, and no flags are set. (This means that
12166 C<name> is always interpreted as Latin-1.)
12172 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
12174 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
12178 =for apidoc newCONSTSUB_flags
12180 Construct a constant subroutine, also performing some surrounding
12181 jobs. A scalar constant-valued subroutine is eligible for inlining
12182 at compile-time, and in Perl code can be created by S<C<sub FOO () {
12183 123 }>>. Other kinds of constant subroutine have other treatment.
12185 The subroutine will have an empty prototype and will ignore any arguments
12186 when called. Its constant behaviour is determined by C<sv>. If C<sv>
12187 is null, the subroutine will yield an empty list. If C<sv> points to a
12188 scalar, the subroutine will always yield that scalar. If C<sv> points
12189 to an array, the subroutine will always yield a list of the elements of
12190 that array in list context, or the number of elements in the array in
12191 scalar context. This function takes ownership of one counted reference
12192 to the scalar or array, and will arrange for the object to live as long
12193 as the subroutine does. If C<sv> points to a scalar then the inlining
12194 assumes that the value of the scalar will never change, so the caller
12195 must ensure that the scalar is not subsequently written to. If C<sv>
12196 points to an array then no such assumption is made, so it is ostensibly
12197 safe to mutate the array or its elements, but whether this is really
12198 supported has not been determined.
12200 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
12201 Other aspects of the subroutine will be left in their default state.
12202 The caller is free to mutate the subroutine beyond its initial state
12203 after this function has returned.
12205 If C<name> is null then the subroutine will be anonymous, with its
12206 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
12207 subroutine will be named accordingly, referenced by the appropriate glob.
12208 C<name> is a string of length C<len> bytes giving a sigilless symbol
12209 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
12210 otherwise. The name may be either qualified or unqualified. If the
12211 name is unqualified then it defaults to being in the stash specified by
12212 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
12213 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
12216 C<flags> should not have bits set other than C<SVf_UTF8>.
12218 If there is already a subroutine of the specified name, then the new sub
12219 will replace the existing one in the glob. A warning may be generated
12220 about the redefinition.
12222 If the subroutine has one of a few special names, such as C<BEGIN> or
12223 C<END>, then it will be claimed by the appropriate queue for automatic
12224 running of phase-related subroutines. In this case the relevant glob will
12225 be left not containing any subroutine, even if it did contain one before.
12226 Execution of the subroutine will likely be a no-op, unless C<sv> was
12227 a tied array or the caller modified the subroutine in some interesting
12228 way before it was executed. In the case of C<BEGIN>, the treatment is
12229 buggy: the sub will be executed when only half built, and may be deleted
12230 prematurely, possibly causing a crash.
12232 The function returns a pointer to the constructed subroutine. If the sub
12233 is anonymous then ownership of one counted reference to the subroutine
12234 is transferred to the caller. If the sub is named then the caller does
12235 not get ownership of a reference. In most such cases, where the sub
12236 has a non-phase name, the sub will be alive at the point it is returned
12237 by virtue of being contained in the glob that names it. A phase-named
12238 subroutine will usually be alive by virtue of the reference owned by
12239 the phase's automatic run queue. A C<BEGIN> subroutine may have been
12240 destroyed already by the time this function returns, but currently bugs
12241 occur in that case before the caller gets control. It is the caller's
12242 responsibility to ensure that it knows which of these situations applies.
12248 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
12252 const char *const file = CopFILE(PL_curcop);
12256 if (IN_PERL_RUNTIME) {
12257 /* at runtime, it's not safe to manipulate PL_curcop: it may be
12258 * an op shared between threads. Use a non-shared COP for our
12260 SAVEVPTR(PL_curcop);
12261 SAVECOMPILEWARNINGS();
12262 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
12263 PL_curcop = &PL_compiling;
12265 SAVECOPLINE(PL_curcop);
12266 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
12269 PL_hints &= ~HINT_BLOCK_SCOPE;
12272 SAVEGENERICSV(PL_curstash);
12273 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
12276 /* Protect sv against leakage caused by fatal warnings. */
12277 if (sv) SAVEFREESV(sv);
12279 /* file becomes the CvFILE. For an XS, it's usually static storage,
12280 and so doesn't get free()d. (It's expected to be from the C pre-
12281 processor __FILE__ directive). But we need a dynamically allocated one,
12282 and we need it to get freed. */
12283 cv = newXS_len_flags(name, len,
12284 sv && SvTYPE(sv) == SVt_PVAV
12287 file ? file : "", "",
12288 &sv, XS_DYNAMIC_FILENAME | flags);
12290 assert(SvREFCNT((SV*)cv) != 0);
12291 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
12302 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
12303 static storage, as it is used directly as CvFILE(), without a copy being made.
12309 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
12311 PERL_ARGS_ASSERT_NEWXS;
12312 return newXS_len_flags(
12313 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
12318 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
12319 const char *const filename, const char *const proto,
12322 PERL_ARGS_ASSERT_NEWXS_FLAGS;
12323 return newXS_len_flags(
12324 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
12329 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
12331 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
12332 return newXS_len_flags(
12333 name, strlen(name), subaddr, NULL, NULL, NULL, 0
12338 =for apidoc newXS_len_flags
12340 Construct an XS subroutine, also performing some surrounding jobs.
12342 The subroutine will have the entry point C<subaddr>. It will have
12343 the prototype specified by the nul-terminated string C<proto>, or
12344 no prototype if C<proto> is null. The prototype string is copied;
12345 the caller can mutate the supplied string afterwards. If C<filename>
12346 is non-null, it must be a nul-terminated filename, and the subroutine
12347 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
12348 point directly to the supplied string, which must be static. If C<flags>
12349 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
12352 Other aspects of the subroutine will be left in their default state.
12353 If anything else needs to be done to the subroutine for it to function
12354 correctly, it is the caller's responsibility to do that after this
12355 function has constructed it. However, beware of the subroutine
12356 potentially being destroyed before this function returns, as described
12359 If C<name> is null then the subroutine will be anonymous, with its
12360 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
12361 subroutine will be named accordingly, referenced by the appropriate glob.
12362 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
12363 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
12364 The name may be either qualified or unqualified, with the stash defaulting
12365 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
12366 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
12367 they have there, such as C<GV_ADDWARN>. The symbol is always added to
12368 the stash if necessary, with C<GV_ADDMULTI> semantics.
12370 If there is already a subroutine of the specified name, then the new sub
12371 will replace the existing one in the glob. A warning may be generated
12372 about the redefinition. If the old subroutine was C<CvCONST> then the
12373 decision about whether to warn is influenced by an expectation about
12374 whether the new subroutine will become a constant of similar value.
12375 That expectation is determined by C<const_svp>. (Note that the call to
12376 this function doesn't make the new subroutine C<CvCONST> in any case;
12377 that is left to the caller.) If C<const_svp> is null then it indicates
12378 that the new subroutine will not become a constant. If C<const_svp>
12379 is non-null then it indicates that the new subroutine will become a
12380 constant, and it points to an C<SV*> that provides the constant value
12381 that the subroutine will have.
12383 If the subroutine has one of a few special names, such as C<BEGIN> or
12384 C<END>, then it will be claimed by the appropriate queue for automatic
12385 running of phase-related subroutines. In this case the relevant glob will
12386 be left not containing any subroutine, even if it did contain one before.
12387 In the case of C<BEGIN>, the subroutine will be executed and the reference
12388 to it disposed of before this function returns, and also before its
12389 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
12390 constructed by this function to be ready for execution then the caller
12391 must prevent this happening by giving the subroutine a different name.
12393 The function returns a pointer to the constructed subroutine. If the sub
12394 is anonymous then ownership of one counted reference to the subroutine
12395 is transferred to the caller. If the sub is named then the caller does
12396 not get ownership of a reference. In most such cases, where the sub
12397 has a non-phase name, the sub will be alive at the point it is returned
12398 by virtue of being contained in the glob that names it. A phase-named
12399 subroutine will usually be alive by virtue of the reference owned by the
12400 phase's automatic run queue. But a C<BEGIN> subroutine, having already
12401 been executed, will quite likely have been destroyed already by the
12402 time this function returns, making it erroneous for the caller to make
12403 any use of the returned pointer. It is the caller's responsibility to
12404 ensure that it knows which of these situations applies.
12410 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
12411 XSUBADDR_t subaddr, const char *const filename,
12412 const char *const proto, SV **const_svp,
12416 bool interleave = FALSE;
12417 bool evanescent = FALSE;
12419 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
12422 GV * const gv = gv_fetchpvn(
12423 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
12424 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
12425 sizeof("__ANON__::__ANON__") - 1,
12426 GV_ADDMULTI | flags, SVt_PVCV);
12428 if ((cv = (name ? GvCV(gv) : NULL))) {
12430 /* just a cached method */
12434 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
12435 /* already defined (or promised) */
12436 /* Redundant check that allows us to avoid creating an SV
12437 most of the time: */
12438 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
12439 report_redefined_cv(newSVpvn_flags(
12440 name,len,(flags&SVf_UTF8)|SVs_TEMP
12451 if (cv) /* must reuse cv if autoloaded */
12454 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12458 if (HvENAME_HEK(GvSTASH(gv)))
12459 gv_method_changed(gv); /* newXS */
12463 assert(SvREFCNT((SV*)cv) != 0);
12467 /* XSUBs can't be perl lang/perl5db.pl debugged
12468 if (PERLDB_LINE_OR_SAVESRC)
12469 (void)gv_fetchfile(filename); */
12470 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
12471 if (flags & XS_DYNAMIC_FILENAME) {
12473 CvFILE(cv) = savepv(filename);
12475 /* NOTE: not copied, as it is expected to be an external constant string */
12476 CvFILE(cv) = (char *)filename;
12479 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
12480 CvFILE(cv) = (char*)PL_xsubfilename;
12483 CvXSUB(cv) = subaddr;
12484 #ifndef MULTIPLICITY
12485 CvHSCXT(cv) = &PL_stack_sp;
12491 evanescent = process_special_blocks(0, name, gv, cv);
12494 } /* <- not a conditional branch */
12497 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12499 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
12500 if (interleave) LEAVE;
12501 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12505 /* Add a stub CV to a typeglob.
12506 * This is the implementation of a forward declaration, 'sub foo';'
12510 Perl_newSTUB(pTHX_ GV *gv, bool fake)
12512 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12514 PERL_ARGS_ASSERT_NEWSTUB;
12515 assert(!GvCVu(gv));
12518 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
12519 gv_method_changed(gv);
12521 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
12525 CvGV_set(cv, cvgv);
12526 CvFILE_set_from_cop(cv, PL_curcop);
12527 CvSTASH_set(cv, PL_curstash);
12533 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
12540 if (PL_parser && PL_parser->error_count) {
12546 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
12547 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
12550 if ((cv = GvFORM(gv))) {
12551 if (ckWARN(WARN_REDEFINE)) {
12552 const line_t oldline = CopLINE(PL_curcop);
12553 if (PL_parser && PL_parser->copline != NOLINE)
12554 CopLINE_set(PL_curcop, PL_parser->copline);
12556 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12557 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
12559 /* diag_listed_as: Format %s redefined */
12560 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12561 "Format STDOUT redefined");
12563 CopLINE_set(PL_curcop, oldline);
12568 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
12570 CvFILE_set_from_cop(cv, PL_curcop);
12573 root = newUNOP(OP_LEAVEWRITE, 0, voidnonfinal(block));
12575 start = LINKLIST(root);
12577 S_process_optree(aTHX_ cv, root, start);
12578 cv_forget_slab(cv);
12583 PL_parser->copline = NOLINE;
12584 LEAVE_SCOPE(floor);
12585 PL_compiling.cop_seq = 0;
12589 Perl_newANONLIST(pTHX_ OP *o)
12591 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
12595 Perl_newANONHASH(pTHX_ OP *o)
12597 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
12601 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
12603 return newANONATTRSUB(floor, proto, NULL, block);
12607 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
12609 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
12611 newSVOP(OP_ANONCODE, 0,
12613 if (CvANONCONST(cv))
12614 anoncode = newUNOP(OP_ANONCONST, 0,
12615 op_convert_list(OP_ENTERSUB,
12616 OPf_STACKED|OPf_WANT_SCALAR,
12618 return newUNOP(OP_REFGEN, 0, anoncode);
12622 Perl_oopsAV(pTHX_ OP *o)
12625 PERL_ARGS_ASSERT_OOPSAV;
12627 switch (o->op_type) {
12630 OpTYPE_set(o, OP_PADAV);
12631 return ref(o, OP_RV2AV);
12635 OpTYPE_set(o, OP_RV2AV);
12640 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
12647 Perl_oopsHV(pTHX_ OP *o)
12650 PERL_ARGS_ASSERT_OOPSHV;
12652 switch (o->op_type) {
12655 OpTYPE_set(o, OP_PADHV);
12656 return ref(o, OP_RV2HV);
12660 OpTYPE_set(o, OP_RV2HV);
12661 /* rv2hv steals the bottom bit for its own uses */
12662 o->op_private &= ~OPpARG1_MASK;
12667 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
12674 Perl_newAVREF(pTHX_ OP *o)
12677 PERL_ARGS_ASSERT_NEWAVREF;
12679 if (o->op_type == OP_PADANY) {
12680 OpTYPE_set(o, OP_PADAV);
12683 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
12684 Perl_croak(aTHX_ "Can't use an array as a reference");
12686 return newUNOP(OP_RV2AV, 0, scalar(o));
12690 Perl_newGVREF(pTHX_ I32 type, OP *o)
12692 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
12693 return newUNOP(OP_NULL, 0, o);
12694 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
12698 Perl_newHVREF(pTHX_ OP *o)
12701 PERL_ARGS_ASSERT_NEWHVREF;
12703 if (o->op_type == OP_PADANY) {
12704 OpTYPE_set(o, OP_PADHV);
12707 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12708 Perl_croak(aTHX_ "Can't use a hash as a reference");
12710 return newUNOP(OP_RV2HV, 0, scalar(o));
12714 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12716 if (o->op_type == OP_PADANY) {
12717 OpTYPE_set(o, OP_PADCV);
12719 return newUNOP(OP_RV2CV, flags, scalar(o));
12723 Perl_newSVREF(pTHX_ OP *o)
12726 PERL_ARGS_ASSERT_NEWSVREF;
12728 if (o->op_type == OP_PADANY) {
12729 OpTYPE_set(o, OP_PADSV);
12733 return newUNOP(OP_RV2SV, 0, scalar(o));
12736 /* Check routines. See the comments at the top of this file for details
12737 * on when these are called */
12740 Perl_ck_anoncode(pTHX_ OP *o)
12742 PERL_ARGS_ASSERT_CK_ANONCODE;
12744 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12745 cSVOPo->op_sv = NULL;
12750 S_io_hints(pTHX_ OP *o)
12752 #if O_BINARY != 0 || O_TEXT != 0
12754 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12756 SV **svp = hv_fetchs(table, "open_IN", FALSE);
12759 const char *d = SvPV_const(*svp, len);
12760 const I32 mode = mode_from_discipline(d, len);
12761 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12763 if (mode & O_BINARY)
12764 o->op_private |= OPpOPEN_IN_RAW;
12768 o->op_private |= OPpOPEN_IN_CRLF;
12772 svp = hv_fetchs(table, "open_OUT", FALSE);
12775 const char *d = SvPV_const(*svp, len);
12776 const I32 mode = mode_from_discipline(d, len);
12777 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12779 if (mode & O_BINARY)
12780 o->op_private |= OPpOPEN_OUT_RAW;
12784 o->op_private |= OPpOPEN_OUT_CRLF;
12789 PERL_UNUSED_CONTEXT;
12790 PERL_UNUSED_ARG(o);
12795 Perl_ck_backtick(pTHX_ OP *o)
12800 PERL_ARGS_ASSERT_CK_BACKTICK;
12802 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12803 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12804 && (gv = gv_override("readpipe",8)))
12806 /* detach rest of siblings from o and its first child */
12807 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12808 newop = S_new_entersubop(aTHX_ gv, sibl);
12810 else if (!(o->op_flags & OPf_KIDS))
12811 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12816 S_io_hints(aTHX_ o);
12821 Perl_ck_bitop(pTHX_ OP *o)
12823 PERL_ARGS_ASSERT_CK_BITOP;
12825 /* get rid of arg count and indicate if in the scope of 'use integer' */
12826 o->op_private = (PL_hints & HINT_INTEGER) ? OPpUSEINT : 0;
12828 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12829 && OP_IS_INFIX_BIT(o->op_type))
12831 const OP * const left = cBINOPo->op_first;
12832 const OP * const right = OpSIBLING(left);
12833 if ((OP_IS_NUMCOMPARE(left->op_type) &&
12834 (left->op_flags & OPf_PARENS) == 0) ||
12835 (OP_IS_NUMCOMPARE(right->op_type) &&
12836 (right->op_flags & OPf_PARENS) == 0))
12837 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12838 "Possible precedence problem on bitwise %s operator",
12839 o->op_type == OP_BIT_OR
12840 ||o->op_type == OP_NBIT_OR ? "|"
12841 : o->op_type == OP_BIT_AND
12842 ||o->op_type == OP_NBIT_AND ? "&"
12843 : o->op_type == OP_BIT_XOR
12844 ||o->op_type == OP_NBIT_XOR ? "^"
12845 : o->op_type == OP_SBIT_OR ? "|."
12846 : o->op_type == OP_SBIT_AND ? "&." : "^."
12852 PERL_STATIC_INLINE bool
12853 is_dollar_bracket(pTHX_ const OP * const o)
12856 PERL_UNUSED_CONTEXT;
12857 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12858 && (kid = cUNOPx(o)->op_first)
12859 && kid->op_type == OP_GV
12860 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12863 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12866 Perl_ck_cmp(pTHX_ OP *o)
12872 OP *indexop, *constop, *start;
12876 PERL_ARGS_ASSERT_CK_CMP;
12878 is_eq = ( o->op_type == OP_EQ
12879 || o->op_type == OP_NE
12880 || o->op_type == OP_I_EQ
12881 || o->op_type == OP_I_NE);
12883 if (!is_eq && ckWARN(WARN_SYNTAX)) {
12884 const OP *kid = cUNOPo->op_first;
12887 ( is_dollar_bracket(aTHX_ kid)
12888 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12890 || ( kid->op_type == OP_CONST
12891 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12895 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12896 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12899 /* convert (index(...) == -1) and variations into
12900 * (r)index/BOOL(,NEG)
12905 indexop = cUNOPo->op_first;
12906 constop = OpSIBLING(indexop);
12908 if (indexop->op_type == OP_CONST) {
12910 indexop = OpSIBLING(constop);
12915 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12918 /* ($lex = index(....)) == -1 */
12919 if (indexop->op_private & OPpTARGET_MY)
12922 if (constop->op_type != OP_CONST)
12925 sv = cSVOPx_sv(constop);
12926 if (!(sv && SvIOK_notUV(sv)))
12930 if (iv != -1 && iv != 0)
12934 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12935 if (!(iv0 ^ reverse))
12939 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12944 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12945 if (!(iv0 ^ reverse))
12949 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12954 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12960 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12966 indexop->op_flags &= ~OPf_PARENS;
12967 indexop->op_flags |= (o->op_flags & OPf_PARENS);
12968 indexop->op_private |= OPpTRUEBOOL;
12970 indexop->op_private |= OPpINDEX_BOOLNEG;
12971 /* cut out the index op and free the eq,const ops */
12972 (void)op_sibling_splice(o, start, 1, NULL);
12980 Perl_ck_concat(pTHX_ OP *o)
12982 const OP * const kid = cUNOPo->op_first;
12984 PERL_ARGS_ASSERT_CK_CONCAT;
12985 PERL_UNUSED_CONTEXT;
12987 /* reuse the padtmp returned by the concat child */
12988 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12989 !(kUNOP->op_first->op_flags & OPf_MOD))
12991 o->op_flags |= OPf_STACKED;
12992 o->op_private |= OPpCONCAT_NESTED;
12998 Perl_ck_spair(pTHX_ OP *o)
13001 PERL_ARGS_ASSERT_CK_SPAIR;
13003 if (o->op_flags & OPf_KIDS) {
13007 const OPCODE type = o->op_type;
13008 o = modkids(ck_fun(o), type);
13009 kid = cUNOPo->op_first;
13010 kidkid = kUNOP->op_first;
13011 newop = OpSIBLING(kidkid);
13013 const OPCODE type = newop->op_type;
13014 if (OpHAS_SIBLING(newop))
13016 if (o->op_type == OP_REFGEN
13017 && ( type == OP_RV2CV
13018 || ( !(newop->op_flags & OPf_PARENS)
13019 && ( type == OP_RV2AV || type == OP_PADAV
13020 || type == OP_RV2HV || type == OP_PADHV))))
13021 NOOP; /* OK (allow srefgen for \@a and \%h) */
13022 else if (OP_GIMME(newop,0) != G_SCALAR)
13025 /* excise first sibling */
13026 op_sibling_splice(kid, NULL, 1, NULL);
13029 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
13030 * and OP_CHOMP into OP_SCHOMP */
13031 o->op_ppaddr = PL_ppaddr[++o->op_type];
13036 Perl_ck_delete(pTHX_ OP *o)
13038 PERL_ARGS_ASSERT_CK_DELETE;
13042 if (o->op_flags & OPf_KIDS) {
13043 OP * const kid = cUNOPo->op_first;
13044 switch (kid->op_type) {
13046 o->op_flags |= OPf_SPECIAL;
13049 o->op_private |= OPpSLICE;
13052 o->op_flags |= OPf_SPECIAL;
13057 o->op_flags |= OPf_SPECIAL;
13060 o->op_private |= OPpKVSLICE;
13063 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
13064 "element or slice");
13066 if (kid->op_private & OPpLVAL_INTRO)
13067 o->op_private |= OPpLVAL_INTRO;
13074 Perl_ck_eof(pTHX_ OP *o)
13076 PERL_ARGS_ASSERT_CK_EOF;
13078 if (o->op_flags & OPf_KIDS) {
13080 if (cLISTOPo->op_first->op_type == OP_STUB) {
13082 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
13087 kid = cLISTOPo->op_first;
13088 if (kid->op_type == OP_RV2GV)
13089 kid->op_private |= OPpALLOW_FAKE;
13096 Perl_ck_eval(pTHX_ OP *o)
13099 PERL_ARGS_ASSERT_CK_EVAL;
13101 PL_hints |= HINT_BLOCK_SCOPE;
13102 if (o->op_flags & OPf_KIDS) {
13103 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13106 if (o->op_type == OP_ENTERTRY) {
13109 /* cut whole sibling chain free from o */
13110 op_sibling_splice(o, NULL, -1, NULL);
13113 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
13115 /* establish postfix order */
13116 enter->op_next = (OP*)enter;
13118 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
13119 OpTYPE_set(o, OP_LEAVETRY);
13120 enter->op_other = o;
13125 S_set_haseval(aTHX);
13129 const U8 priv = o->op_private;
13131 /* the newUNOP will recursively call ck_eval(), which will handle
13132 * all the stuff at the end of this function, like adding
13135 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
13137 o->op_targ = (PADOFFSET)PL_hints;
13138 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
13139 if ((PL_hints & HINT_LOCALIZE_HH) != 0
13140 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
13141 /* Store a copy of %^H that pp_entereval can pick up. */
13142 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
13144 STOREFEATUREBITSHH(hh);
13145 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
13146 /* append hhop to only child */
13147 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
13149 o->op_private |= OPpEVAL_HAS_HH;
13151 if (!(o->op_private & OPpEVAL_BYTES)
13152 && FEATURE_UNIEVAL_IS_ENABLED)
13153 o->op_private |= OPpEVAL_UNICODE;
13158 Perl_ck_trycatch(pTHX_ OP *o)
13161 OP *to_free = NULL;
13162 OP *trykid, *catchkid;
13163 OP *catchroot, *catchstart;
13165 PERL_ARGS_ASSERT_CK_TRYCATCH;
13167 trykid = cUNOPo->op_first;
13168 if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) {
13170 trykid = OpSIBLING(trykid);
13172 catchkid = OpSIBLING(trykid);
13174 assert(trykid->op_type == OP_POPTRY);
13175 assert(catchkid->op_type == OP_CATCH);
13177 /* cut whole sibling chain free from o */
13178 op_sibling_splice(o, NULL, -1, NULL);
13183 enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL);
13185 /* establish postfix order */
13186 enter->op_next = (OP*)enter;
13188 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid);
13189 op_append_elem(OP_LINESEQ, (OP*)o, catchkid);
13191 OpTYPE_set(o, OP_LEAVETRYCATCH);
13193 /* The returned optree is actually threaded up slightly nonobviously in
13194 * terms of its ->op_next pointers.
13196 * This way, if the tryblock dies, its retop points at the OP_CATCH, but
13197 * if it does not then its leavetry skips over that and continues
13198 * execution past it.
13201 /* First, link up the actual body of the catch block */
13202 catchroot = OpSIBLING(cUNOPx(catchkid)->op_first);
13203 catchstart = LINKLIST(catchroot);
13204 cLOGOPx(catchkid)->op_other = catchstart;
13206 o->op_next = LINKLIST(o);
13208 /* die within try block should jump to the catch */
13209 enter->op_other = catchkid;
13211 /* after try block that doesn't die, just skip straight to leavetrycatch */
13212 trykid->op_next = o;
13214 /* after catch block, skip back up to the leavetrycatch */
13215 catchroot->op_next = o;
13221 Perl_ck_exec(pTHX_ OP *o)
13223 PERL_ARGS_ASSERT_CK_EXEC;
13225 if (o->op_flags & OPf_STACKED) {
13228 kid = OpSIBLING(cUNOPo->op_first);
13229 if (kid->op_type == OP_RV2GV)
13238 Perl_ck_exists(pTHX_ OP *o)
13240 PERL_ARGS_ASSERT_CK_EXISTS;
13243 if (o->op_flags & OPf_KIDS) {
13244 OP * const kid = cUNOPo->op_first;
13245 if (kid->op_type == OP_ENTERSUB) {
13246 (void) ref(kid, o->op_type);
13247 if (kid->op_type != OP_RV2CV
13248 && !(PL_parser && PL_parser->error_count))
13250 "exists argument is not a subroutine name");
13251 o->op_private |= OPpEXISTS_SUB;
13253 else if (kid->op_type == OP_AELEM)
13254 o->op_flags |= OPf_SPECIAL;
13255 else if (kid->op_type != OP_HELEM)
13256 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
13257 "element or a subroutine");
13264 Perl_ck_rvconst(pTHX_ OP *o)
13266 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13268 PERL_ARGS_ASSERT_CK_RVCONST;
13270 if (o->op_type == OP_RV2HV)
13271 /* rv2hv steals the bottom bit for its own uses */
13272 o->op_private &= ~OPpARG1_MASK;
13274 o->op_private |= (PL_hints & HINT_STRICT_REFS);
13276 if (kid->op_type == OP_CONST) {
13279 SV * const kidsv = kid->op_sv;
13281 /* Is it a constant from cv_const_sv()? */
13282 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
13285 if (SvTYPE(kidsv) == SVt_PVAV) return o;
13286 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
13287 const char *badthing;
13288 switch (o->op_type) {
13290 badthing = "a SCALAR";
13293 badthing = "an ARRAY";
13296 badthing = "a HASH";
13304 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
13305 SVfARG(kidsv), badthing);
13308 * This is a little tricky. We only want to add the symbol if we
13309 * didn't add it in the lexer. Otherwise we get duplicate strict
13310 * warnings. But if we didn't add it in the lexer, we must at
13311 * least pretend like we wanted to add it even if it existed before,
13312 * or we get possible typo warnings. OPpCONST_ENTERED says
13313 * whether the lexer already added THIS instance of this symbol.
13315 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
13316 gv = gv_fetchsv(kidsv,
13317 o->op_type == OP_RV2CV
13318 && o->op_private & OPpMAY_RETURN_CONSTANT
13320 : iscv | !(kid->op_private & OPpCONST_ENTERED),
13323 : o->op_type == OP_RV2SV
13325 : o->op_type == OP_RV2AV
13327 : o->op_type == OP_RV2HV
13334 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
13335 && SvTYPE(SvRV(gv)) != SVt_PVCV)
13336 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
13338 OpTYPE_set(kid, OP_GV);
13339 SvREFCNT_dec(kid->op_sv);
13340 #ifdef USE_ITHREADS
13341 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
13342 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
13343 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
13344 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
13345 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
13347 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
13349 kid->op_private = 0;
13350 /* FAKE globs in the symbol table cause weird bugs (#77810) */
13358 Perl_ck_ftst(pTHX_ OP *o)
13360 const I32 type = o->op_type;
13362 PERL_ARGS_ASSERT_CK_FTST;
13364 if (o->op_flags & OPf_REF) {
13367 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
13368 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13369 const OPCODE kidtype = kid->op_type;
13371 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
13372 && !kid->op_folded) {
13373 OP * const newop = newGVOP(type, OPf_REF,
13374 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
13379 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
13380 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
13382 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
13383 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
13384 array_passed_to_stat, name);
13387 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
13388 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
13391 scalar((OP *) kid);
13392 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
13393 o->op_private |= OPpFT_ACCESS;
13394 if (OP_IS_FILETEST(type)
13395 && OP_IS_FILETEST(kidtype)
13397 o->op_private |= OPpFT_STACKED;
13398 kid->op_private |= OPpFT_STACKING;
13399 if (kidtype == OP_FTTTY && (
13400 !(kid->op_private & OPpFT_STACKED)
13401 || kid->op_private & OPpFT_AFTER_t
13403 o->op_private |= OPpFT_AFTER_t;
13408 if (type == OP_FTTTY)
13409 o = newGVOP(type, OPf_REF, PL_stdingv);
13411 o = newUNOP(type, 0, newDEFSVOP());
13417 Perl_ck_fun(pTHX_ OP *o)
13419 const int type = o->op_type;
13420 I32 oa = PL_opargs[type] >> OASHIFT;
13422 PERL_ARGS_ASSERT_CK_FUN;
13424 if (o->op_flags & OPf_STACKED) {
13425 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
13426 oa &= ~OA_OPTIONAL;
13428 return no_fh_allowed(o);
13431 if (o->op_flags & OPf_KIDS) {
13432 OP *prev_kid = NULL;
13433 OP *kid = cLISTOPo->op_first;
13435 bool seen_optional = FALSE;
13437 if (kid->op_type == OP_PUSHMARK ||
13438 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
13441 kid = OpSIBLING(kid);
13443 if (kid && kid->op_type == OP_COREARGS) {
13444 bool optional = FALSE;
13447 if (oa & OA_OPTIONAL) optional = TRUE;
13450 if (optional) o->op_private |= numargs;
13455 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
13456 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
13457 kid = newDEFSVOP();
13458 /* append kid to chain */
13459 op_sibling_splice(o, prev_kid, 0, kid);
13461 seen_optional = TRUE;
13468 /* list seen where single (scalar) arg expected? */
13469 if (numargs == 1 && !(oa >> 4)
13470 && kid->op_type == OP_LIST && type != OP_SCALAR)
13472 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13474 if (type != OP_DELETE) scalar(kid);
13485 if ((type == OP_PUSH || type == OP_UNSHIFT)
13486 && !OpHAS_SIBLING(kid))
13487 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
13488 "Useless use of %s with no values",
13491 if (kid->op_type == OP_CONST
13492 && ( !SvROK(cSVOPx_sv(kid))
13493 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
13495 bad_type_pv(numargs, "array", o, kid);
13496 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
13497 || kid->op_type == OP_RV2GV) {
13498 bad_type_pv(1, "array", o, kid);
13500 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
13501 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
13502 PL_op_desc[type]), 0);
13505 op_lvalue(kid, type);
13509 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
13510 bad_type_pv(numargs, "hash", o, kid);
13511 op_lvalue(kid, type);
13515 /* replace kid with newop in chain */
13517 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
13518 newop->op_next = newop;
13523 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
13524 if (kid->op_type == OP_CONST &&
13525 (kid->op_private & OPpCONST_BARE))
13527 OP * const newop = newGVOP(OP_GV, 0,
13528 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
13529 /* a first argument is handled by toke.c, ideally we'd
13530 just check here but several ops don't use ck_fun() */
13531 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED && numargs > 1) {
13532 no_bareword_filehandle(SvPVX(cSVOPx_sv((SVOP*)kid)));
13534 /* replace kid with newop in chain */
13535 op_sibling_splice(o, prev_kid, 1, newop);
13539 else if (kid->op_type == OP_READLINE) {
13540 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
13541 bad_type_pv(numargs, "HANDLE", o, kid);
13544 I32 flags = OPf_SPECIAL;
13546 PADOFFSET targ = 0;
13548 /* is this op a FH constructor? */
13549 if (is_handle_constructor(o,numargs)) {
13550 const char *name = NULL;
13553 bool want_dollar = TRUE;
13556 /* Set a flag to tell rv2gv to vivify
13557 * need to "prove" flag does not mean something
13558 * else already - NI-S 1999/05/07
13561 if (kid->op_type == OP_PADSV) {
13563 = PAD_COMPNAME_SV(kid->op_targ);
13564 name = PadnamePV (pn);
13565 len = PadnameLEN(pn);
13566 name_utf8 = PadnameUTF8(pn);
13568 else if (kid->op_type == OP_RV2SV
13569 && kUNOP->op_first->op_type == OP_GV)
13571 GV * const gv = cGVOPx_gv(kUNOP->op_first);
13573 len = GvNAMELEN(gv);
13574 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
13576 else if (kid->op_type == OP_AELEM
13577 || kid->op_type == OP_HELEM)
13580 OP *op = ((BINOP*)kid)->op_first;
13584 const char * const a =
13585 kid->op_type == OP_AELEM ?
13587 if (((op->op_type == OP_RV2AV) ||
13588 (op->op_type == OP_RV2HV)) &&
13589 (firstop = ((UNOP*)op)->op_first) &&
13590 (firstop->op_type == OP_GV)) {
13591 /* packagevar $a[] or $h{} */
13592 GV * const gv = cGVOPx_gv(firstop);
13595 Perl_newSVpvf(aTHX_
13600 else if (op->op_type == OP_PADAV
13601 || op->op_type == OP_PADHV) {
13602 /* lexicalvar $a[] or $h{} */
13603 const char * const padname =
13604 PAD_COMPNAME_PV(op->op_targ);
13607 Perl_newSVpvf(aTHX_
13613 name = SvPV_const(tmpstr, len);
13614 name_utf8 = SvUTF8(tmpstr);
13615 sv_2mortal(tmpstr);
13619 name = "__ANONIO__";
13621 want_dollar = FALSE;
13623 op_lvalue(kid, type);
13627 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
13628 namesv = PAD_SVl(targ);
13629 if (want_dollar && *name != '$')
13630 sv_setpvs(namesv, "$");
13633 sv_catpvn(namesv, name, len);
13634 if ( name_utf8 ) SvUTF8_on(namesv);
13638 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
13640 kid->op_targ = targ;
13641 kid->op_private |= priv;
13647 if ((type == OP_UNDEF || type == OP_POS)
13648 && numargs == 1 && !(oa >> 4)
13649 && kid->op_type == OP_LIST)
13650 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13651 op_lvalue(scalar(kid), type);
13656 kid = OpSIBLING(kid);
13658 /* FIXME - should the numargs or-ing move after the too many
13659 * arguments check? */
13660 o->op_private |= numargs;
13662 return too_many_arguments_pv(o,OP_DESC(o), 0);
13665 else if (PL_opargs[type] & OA_DEFGV) {
13666 /* Ordering of these two is important to keep f_map.t passing. */
13668 return newUNOP(type, 0, newDEFSVOP());
13672 while (oa & OA_OPTIONAL)
13674 if (oa && oa != OA_LIST)
13675 return too_few_arguments_pv(o,OP_DESC(o), 0);
13681 Perl_ck_glob(pTHX_ OP *o)
13685 PERL_ARGS_ASSERT_CK_GLOB;
13688 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13689 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13691 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13695 * \ null - const(wildcard)
13700 * \ mark - glob - rv2cv
13701 * | \ gv(CORE::GLOBAL::glob)
13703 * \ null - const(wildcard)
13705 o->op_flags |= OPf_SPECIAL;
13706 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13707 o = S_new_entersubop(aTHX_ gv, o);
13708 o = newUNOP(OP_NULL, 0, o);
13709 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13712 else o->op_flags &= ~OPf_SPECIAL;
13713 #if !defined(PERL_EXTERNAL_GLOB)
13714 if (!PL_globhook) {
13716 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13717 newSVpvs("File::Glob"), NULL, NULL, NULL);
13720 #endif /* !PERL_EXTERNAL_GLOB */
13721 gv = (GV *)newSV_type(SVt_NULL);
13722 gv_init(gv, 0, "", 0, 0);
13724 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13725 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13731 Perl_ck_grep(pTHX_ OP *o)
13735 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13737 PERL_ARGS_ASSERT_CK_GREP;
13739 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13741 if (o->op_flags & OPf_STACKED) {
13742 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13743 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13744 return no_fh_allowed(o);
13745 o->op_flags &= ~OPf_STACKED;
13747 kid = OpSIBLING(cLISTOPo->op_first);
13748 if (type == OP_MAPWHILE)
13753 if (PL_parser && PL_parser->error_count)
13755 kid = OpSIBLING(cLISTOPo->op_first);
13756 if (kid->op_type != OP_NULL)
13757 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13758 kid = kUNOP->op_first;
13760 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13761 kid->op_next = (OP*)gwop;
13762 o->op_private = gwop->op_private = 0;
13763 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13765 kid = OpSIBLING(cLISTOPo->op_first);
13766 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13767 op_lvalue(kid, OP_GREPSTART);
13773 Perl_ck_index(pTHX_ OP *o)
13775 PERL_ARGS_ASSERT_CK_INDEX;
13777 if (o->op_flags & OPf_KIDS) {
13778 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13780 kid = OpSIBLING(kid); /* get past "big" */
13781 if (kid && kid->op_type == OP_CONST) {
13782 const bool save_taint = TAINT_get;
13783 SV *sv = kSVOP->op_sv;
13784 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13785 && SvOK(sv) && !SvROK(sv))
13787 sv = newSV_type(SVt_NULL);
13788 sv_copypv(sv, kSVOP->op_sv);
13789 SvREFCNT_dec_NN(kSVOP->op_sv);
13792 if (SvOK(sv)) fbm_compile(sv, 0);
13793 TAINT_set(save_taint);
13794 #ifdef NO_TAINT_SUPPORT
13795 PERL_UNUSED_VAR(save_taint);
13803 Perl_ck_lfun(pTHX_ OP *o)
13805 const OPCODE type = o->op_type;
13807 PERL_ARGS_ASSERT_CK_LFUN;
13809 return modkids(ck_fun(o), type);
13813 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
13815 PERL_ARGS_ASSERT_CK_DEFINED;
13817 if ((o->op_flags & OPf_KIDS)) {
13818 switch (cUNOPo->op_first->op_type) {
13821 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13822 " (Maybe you should just omit the defined()?)");
13823 NOT_REACHED; /* NOTREACHED */
13827 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13828 " (Maybe you should just omit the defined()?)");
13829 NOT_REACHED; /* NOTREACHED */
13840 Perl_ck_readline(pTHX_ OP *o)
13842 PERL_ARGS_ASSERT_CK_READLINE;
13844 if (o->op_flags & OPf_KIDS) {
13845 OP *kid = cLISTOPo->op_first;
13846 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13851 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13859 Perl_ck_rfun(pTHX_ OP *o)
13861 const OPCODE type = o->op_type;
13863 PERL_ARGS_ASSERT_CK_RFUN;
13865 return refkids(ck_fun(o), type);
13869 Perl_ck_listiob(pTHX_ OP *o)
13873 PERL_ARGS_ASSERT_CK_LISTIOB;
13875 kid = cLISTOPo->op_first;
13877 o = force_list(o, TRUE);
13878 kid = cLISTOPo->op_first;
13880 if (kid->op_type == OP_PUSHMARK)
13881 kid = OpSIBLING(kid);
13882 if (kid && o->op_flags & OPf_STACKED)
13883 kid = OpSIBLING(kid);
13884 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
13885 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13886 && !kid->op_folded) {
13887 o->op_flags |= OPf_STACKED; /* make it a filehandle */
13889 /* replace old const op with new OP_RV2GV parent */
13890 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13891 OP_RV2GV, OPf_REF);
13892 kid = OpSIBLING(kid);
13897 op_append_elem(o->op_type, o, newDEFSVOP());
13899 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13900 return listkids(o);
13904 Perl_ck_smartmatch(pTHX_ OP *o)
13906 PERL_ARGS_ASSERT_CK_SMARTMATCH;
13907 if (0 == (o->op_flags & OPf_SPECIAL)) {
13908 OP *first = cBINOPo->op_first;
13909 OP *second = OpSIBLING(first);
13911 /* Implicitly take a reference to an array or hash */
13913 /* remove the original two siblings, then add back the
13914 * (possibly different) first and second sibs.
13916 op_sibling_splice(o, NULL, 1, NULL);
13917 op_sibling_splice(o, NULL, 1, NULL);
13918 first = ref_array_or_hash(first);
13919 second = ref_array_or_hash(second);
13920 op_sibling_splice(o, NULL, 0, second);
13921 op_sibling_splice(o, NULL, 0, first);
13923 /* Implicitly take a reference to a regular expression */
13924 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13925 OpTYPE_set(first, OP_QR);
13927 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13928 OpTYPE_set(second, OP_QR);
13937 S_maybe_targlex(pTHX_ OP *o)
13939 OP * const kid = cLISTOPo->op_first;
13940 /* has a disposable target? */
13941 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13942 && !(kid->op_flags & OPf_STACKED)
13943 /* Cannot steal the second time! */
13944 && !(kid->op_private & OPpTARGET_MY)
13947 OP * const kkid = OpSIBLING(kid);
13949 /* Can just relocate the target. */
13950 if (kkid && kkid->op_type == OP_PADSV
13951 && (!(kkid->op_private & OPpLVAL_INTRO)
13952 || kkid->op_private & OPpPAD_STATE))
13954 kid->op_targ = kkid->op_targ;
13956 /* Now we do not need PADSV and SASSIGN.
13957 * Detach kid and free the rest. */
13958 op_sibling_splice(o, NULL, 1, NULL);
13960 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
13968 Perl_ck_sassign(pTHX_ OP *o)
13970 OP * const kid = cBINOPo->op_first;
13972 PERL_ARGS_ASSERT_CK_SASSIGN;
13974 if (OpHAS_SIBLING(kid)) {
13975 OP *kkid = OpSIBLING(kid);
13976 /* For state variable assignment with attributes, kkid is a list op
13977 whose op_last is a padsv. */
13978 if ((kkid->op_type == OP_PADSV ||
13979 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13980 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13983 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13984 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13985 return S_newONCEOP(aTHX_ o, kkid);
13988 return S_maybe_targlex(aTHX_ o);
13993 Perl_ck_match(pTHX_ OP *o)
13995 PERL_UNUSED_CONTEXT;
13996 PERL_ARGS_ASSERT_CK_MATCH;
14002 Perl_ck_method(pTHX_ OP *o)
14004 SV *sv, *methsv, *rclass;
14005 const char* method;
14008 STRLEN len, nsplit = 0, i;
14010 OP * const kid = cUNOPo->op_first;
14012 PERL_ARGS_ASSERT_CK_METHOD;
14013 if (kid->op_type != OP_CONST) return o;
14017 /* replace ' with :: */
14018 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
14019 SvEND(sv) - SvPVX(sv) )))
14022 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
14025 method = SvPVX_const(sv);
14027 utf8 = SvUTF8(sv) ? -1 : 1;
14029 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
14034 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
14036 if (!nsplit) { /* $proto->method() */
14038 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
14041 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
14043 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
14046 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
14047 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
14048 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
14049 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
14051 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
14052 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
14054 #ifdef USE_ITHREADS
14055 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
14057 cMETHOPx(new_op)->op_rclass_sv = rclass;
14064 Perl_ck_null(pTHX_ OP *o)
14066 PERL_ARGS_ASSERT_CK_NULL;
14067 PERL_UNUSED_CONTEXT;
14072 Perl_ck_open(pTHX_ OP *o)
14074 PERL_ARGS_ASSERT_CK_OPEN;
14076 S_io_hints(aTHX_ o);
14078 /* In case of three-arg dup open remove strictness
14079 * from the last arg if it is a bareword. */
14080 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
14081 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
14085 if ((last->op_type == OP_CONST) && /* The bareword. */
14086 (last->op_private & OPpCONST_BARE) &&
14087 (last->op_private & OPpCONST_STRICT) &&
14088 (oa = OpSIBLING(first)) && /* The fh. */
14089 (oa = OpSIBLING(oa)) && /* The mode. */
14090 (oa->op_type == OP_CONST) &&
14091 SvPOK(((SVOP*)oa)->op_sv) &&
14092 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
14093 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
14094 (last == OpSIBLING(oa))) /* The bareword. */
14095 last->op_private &= ~OPpCONST_STRICT;
14101 Perl_ck_prototype(pTHX_ OP *o)
14103 PERL_ARGS_ASSERT_CK_PROTOTYPE;
14104 if (!(o->op_flags & OPf_KIDS)) {
14106 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
14112 Perl_ck_refassign(pTHX_ OP *o)
14114 OP * const right = cLISTOPo->op_first;
14115 OP * const left = OpSIBLING(right);
14116 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
14119 PERL_ARGS_ASSERT_CK_REFASSIGN;
14121 assert (left->op_type == OP_SREFGEN);
14124 /* we use OPpPAD_STATE in refassign to mean either of those things,
14125 * and the code assumes the two flags occupy the same bit position
14126 * in the various ops below */
14127 assert(OPpPAD_STATE == OPpOUR_INTRO);
14129 switch (varop->op_type) {
14131 o->op_private |= OPpLVREF_AV;
14134 o->op_private |= OPpLVREF_HV;
14138 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
14139 o->op_targ = varop->op_targ;
14140 varop->op_targ = 0;
14141 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
14145 o->op_private |= OPpLVREF_AV;
14147 NOT_REACHED; /* NOTREACHED */
14149 o->op_private |= OPpLVREF_HV;
14153 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
14154 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
14156 /* Point varop to its GV kid, detached. */
14157 varop = op_sibling_splice(varop, NULL, -1, NULL);
14161 OP * const kidparent =
14162 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
14163 OP * const kid = cUNOPx(kidparent)->op_first;
14164 o->op_private |= OPpLVREF_CV;
14165 if (kid->op_type == OP_GV) {
14166 SV *sv = (SV*)cGVOPx_gv(kid);
14168 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
14169 /* a CVREF here confuses pp_refassign, so make sure
14171 CV *const cv = (CV*)SvRV(sv);
14172 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
14173 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
14174 assert(SvTYPE(sv) == SVt_PVGV);
14176 goto detach_and_stack;
14178 if (kid->op_type != OP_PADCV) goto bad;
14179 o->op_targ = kid->op_targ;
14185 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
14186 o->op_private |= OPpLVREF_ELEM;
14189 /* Detach varop. */
14190 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
14194 /* diag_listed_as: Can't modify reference to %s in %s assignment */
14195 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
14200 if (!FEATURE_REFALIASING_IS_ENABLED)
14202 "Experimental aliasing via reference not enabled");
14203 Perl_ck_warner_d(aTHX_
14204 packWARN(WARN_EXPERIMENTAL__REFALIASING),
14205 "Aliasing via reference is experimental");
14207 o->op_flags |= OPf_STACKED;
14208 op_sibling_splice(o, right, 1, varop);
14211 o->op_flags &=~ OPf_STACKED;
14212 op_sibling_splice(o, right, 1, NULL);
14219 Perl_ck_repeat(pTHX_ OP *o)
14221 PERL_ARGS_ASSERT_CK_REPEAT;
14223 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
14225 o->op_private |= OPpREPEAT_DOLIST;
14226 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
14227 kids = force_list(kids, TRUE); /* promote it to a list */
14228 op_sibling_splice(o, NULL, 0, kids); /* and add back */
14236 Perl_ck_require(pTHX_ OP *o)
14240 PERL_ARGS_ASSERT_CK_REQUIRE;
14242 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
14243 SVOP * const kid = (SVOP*)cUNOPo->op_first;
14247 if (kid->op_type == OP_CONST) {
14248 SV * const sv = kid->op_sv;
14249 U32 const was_readonly = SvREADONLY(sv);
14250 if (kid->op_private & OPpCONST_BARE) {
14254 if (was_readonly) {
14255 SvREADONLY_off(sv);
14258 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
14263 /* treat ::foo::bar as foo::bar */
14264 if (len >= 2 && s[0] == ':' && s[1] == ':')
14265 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
14267 DIE(aTHX_ "Bareword in require maps to empty filename");
14269 for (; s < end; s++) {
14270 if (*s == ':' && s[1] == ':') {
14272 Move(s+2, s+1, end - s - 1, char);
14276 SvEND_set(sv, end);
14277 sv_catpvs(sv, ".pm");
14278 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
14279 hek = share_hek(SvPVX(sv),
14280 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
14282 sv_sethek(sv, hek);
14284 SvFLAGS(sv) |= was_readonly;
14286 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
14289 if (SvREFCNT(sv) > 1) {
14290 kid->op_sv = newSVpvn_share(
14291 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
14292 SvREFCNT_dec_NN(sv);
14296 if (was_readonly) SvREADONLY_off(sv);
14297 PERL_HASH(hash, s, len);
14299 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
14301 sv_sethek(sv, hek);
14303 SvFLAGS(sv) |= was_readonly;
14309 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
14310 /* handle override, if any */
14311 && (gv = gv_override("require", 7))) {
14313 if (o->op_flags & OPf_KIDS) {
14314 kid = cUNOPo->op_first;
14315 op_sibling_splice(o, NULL, -1, NULL);
14318 kid = newDEFSVOP();
14321 newop = S_new_entersubop(aTHX_ gv, kid);
14329 Perl_ck_return(pTHX_ OP *o)
14333 PERL_ARGS_ASSERT_CK_RETURN;
14335 kid = OpSIBLING(cLISTOPo->op_first);
14336 if (PL_compcv && CvLVALUE(PL_compcv)) {
14337 for (; kid; kid = OpSIBLING(kid))
14338 op_lvalue(kid, OP_LEAVESUBLV);
14345 Perl_ck_select(pTHX_ OP *o)
14349 PERL_ARGS_ASSERT_CK_SELECT;
14351 if (o->op_flags & OPf_KIDS) {
14352 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14353 if (kid && OpHAS_SIBLING(kid)) {
14354 OpTYPE_set(o, OP_SSELECT);
14356 return fold_constants(op_integerize(op_std_init(o)));
14360 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14361 if (kid && kid->op_type == OP_RV2GV)
14362 kid->op_private &= ~HINT_STRICT_REFS;
14367 Perl_ck_shift(pTHX_ OP *o)
14369 const I32 type = o->op_type;
14371 PERL_ARGS_ASSERT_CK_SHIFT;
14373 if (!(o->op_flags & OPf_KIDS)) {
14376 if (!CvUNIQUE(PL_compcv)) {
14377 o->op_flags |= OPf_SPECIAL;
14381 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
14383 return newUNOP(type, 0, scalar(argop));
14385 return scalar(ck_fun(o));
14389 Perl_ck_sort(pTHX_ OP *o)
14395 PERL_ARGS_ASSERT_CK_SORT;
14397 if (o->op_flags & OPf_STACKED)
14399 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14402 return too_few_arguments_pv(o,OP_DESC(o), 0);
14404 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
14405 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
14407 /* if the first arg is a code block, process it and mark sort as
14409 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
14411 if (kid->op_type == OP_LEAVE)
14412 op_null(kid); /* wipe out leave */
14413 /* Prevent execution from escaping out of the sort block. */
14416 /* provide scalar context for comparison function/block */
14417 kid = scalar(firstkid);
14418 kid->op_next = kid;
14419 o->op_flags |= OPf_SPECIAL;
14421 else if (kid->op_type == OP_CONST
14422 && kid->op_private & OPpCONST_BARE) {
14426 const char * const name = SvPV(kSVOP_sv, len);
14428 assert (len < 256);
14429 Copy(name, tmpbuf+1, len, char);
14430 off = pad_findmy_pvn(tmpbuf, len+1, 0);
14431 if (off != NOT_IN_PAD) {
14432 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
14434 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
14435 sv_catpvs(fq, "::");
14436 sv_catsv(fq, kSVOP_sv);
14437 SvREFCNT_dec_NN(kSVOP_sv);
14441 OP * const padop = newOP(OP_PADCV, 0);
14442 padop->op_targ = off;
14443 /* replace the const op with the pad op */
14444 op_sibling_splice(firstkid, NULL, 1, padop);
14450 firstkid = OpSIBLING(firstkid);
14453 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
14454 /* provide list context for arguments */
14457 op_lvalue(kid, OP_GREPSTART);
14463 /* for sort { X } ..., where X is one of
14464 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
14465 * elide the second child of the sort (the one containing X),
14466 * and set these flags as appropriate
14470 * Also, check and warn on lexical $a, $b.
14474 S_simplify_sort(pTHX_ OP *o)
14476 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14480 const char *gvname;
14483 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
14485 kid = kUNOP->op_first; /* get past null */
14486 if (!(have_scopeop = kid->op_type == OP_SCOPE)
14487 && kid->op_type != OP_LEAVE)
14489 kid = kLISTOP->op_last; /* get past scope */
14490 switch(kid->op_type) {
14494 if (!have_scopeop) goto padkids;
14499 k = kid; /* remember this node*/
14500 if (kBINOP->op_first->op_type != OP_RV2SV
14501 || kBINOP->op_last ->op_type != OP_RV2SV)
14504 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
14505 then used in a comparison. This catches most, but not
14506 all cases. For instance, it catches
14507 sort { my($a); $a <=> $b }
14509 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
14510 (although why you'd do that is anyone's guess).
14514 if (!ckWARN(WARN_SYNTAX)) return;
14515 kid = kBINOP->op_first;
14517 if (kid->op_type == OP_PADSV) {
14518 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
14519 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
14520 && ( PadnamePV(name)[1] == 'a'
14521 || PadnamePV(name)[1] == 'b' ))
14522 /* diag_listed_as: "my %s" used in sort comparison */
14523 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14524 "\"%s %s\" used in sort comparison",
14525 PadnameIsSTATE(name)
14530 } while ((kid = OpSIBLING(kid)));
14533 kid = kBINOP->op_first; /* get past cmp */
14534 if (kUNOP->op_first->op_type != OP_GV)
14536 kid = kUNOP->op_first; /* get past rv2sv */
14538 if (GvSTASH(gv) != PL_curstash)
14540 gvname = GvNAME(gv);
14541 if (*gvname == 'a' && gvname[1] == '\0')
14543 else if (*gvname == 'b' && gvname[1] == '\0')
14548 kid = k; /* back to cmp */
14549 /* already checked above that it is rv2sv */
14550 kid = kBINOP->op_last; /* down to 2nd arg */
14551 if (kUNOP->op_first->op_type != OP_GV)
14553 kid = kUNOP->op_first; /* get past rv2sv */
14555 if (GvSTASH(gv) != PL_curstash)
14557 gvname = GvNAME(gv);
14559 ? !(*gvname == 'a' && gvname[1] == '\0')
14560 : !(*gvname == 'b' && gvname[1] == '\0'))
14562 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
14564 o->op_private |= OPpSORT_DESCEND;
14565 if (k->op_type == OP_NCMP)
14566 o->op_private |= OPpSORT_NUMERIC;
14567 if (k->op_type == OP_I_NCMP)
14568 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
14569 kid = OpSIBLING(cLISTOPo->op_first);
14570 /* cut out and delete old block (second sibling) */
14571 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
14576 Perl_ck_split(pTHX_ OP *o)
14581 PERL_ARGS_ASSERT_CK_SPLIT;
14583 assert(o->op_type == OP_LIST);
14585 if (o->op_flags & OPf_STACKED)
14586 return no_fh_allowed(o);
14588 kid = cLISTOPo->op_first;
14589 /* delete leading NULL node, then add a CONST if no other nodes */
14590 assert(kid->op_type == OP_NULL);
14591 op_sibling_splice(o, NULL, 1,
14592 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
14594 kid = cLISTOPo->op_first;
14596 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
14597 /* remove match expression, and replace with new optree with
14598 * a match op at its head */
14599 op_sibling_splice(o, NULL, 1, NULL);
14600 /* pmruntime will handle split " " behavior with flag==2 */
14601 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
14602 op_sibling_splice(o, NULL, 0, kid);
14605 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
14607 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
14608 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
14609 "Use of /g modifier is meaningless in split");
14612 /* eliminate the split op, and move the match op (plus any children)
14613 * into its place, then convert the match op into a split op. i.e.
14615 * SPLIT MATCH SPLIT(ex-MATCH)
14617 * MATCH - A - B - C => R - A - B - C => R - A - B - C
14623 * (R, if it exists, will be a regcomp op)
14626 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14627 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14628 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14629 OpTYPE_set(kid, OP_SPLIT);
14630 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
14631 kid->op_private = o->op_private;
14634 kid = sibs; /* kid is now the string arg of the split */
14637 kid = newDEFSVOP();
14638 op_append_elem(OP_SPLIT, o, kid);
14642 kid = OpSIBLING(kid);
14644 kid = newSVOP(OP_CONST, 0, newSViv(0));
14645 op_append_elem(OP_SPLIT, o, kid);
14646 o->op_private |= OPpSPLIT_IMPLIM;
14650 if (OpHAS_SIBLING(kid))
14651 return too_many_arguments_pv(o,OP_DESC(o), 0);
14657 Perl_ck_stringify(pTHX_ OP *o)
14659 OP * const kid = OpSIBLING(cUNOPo->op_first);
14660 PERL_ARGS_ASSERT_CK_STRINGIFY;
14661 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14662 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
14663 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
14664 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14666 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14674 Perl_ck_join(pTHX_ OP *o)
14676 OP * const kid = OpSIBLING(cLISTOPo->op_first);
14678 PERL_ARGS_ASSERT_CK_JOIN;
14680 if (kid && kid->op_type == OP_MATCH) {
14681 if (ckWARN(WARN_SYNTAX)) {
14682 const REGEXP *re = PM_GETRE(kPMOP);
14684 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14685 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14686 : newSVpvs_flags( "STRING", SVs_TEMP );
14687 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14688 "/%" SVf "/ should probably be written as \"%" SVf "\"",
14689 SVfARG(msg), SVfARG(msg));
14693 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14694 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14695 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14696 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14698 const OP * const bairn = OpSIBLING(kid); /* the list */
14699 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14700 && OP_GIMME(bairn,0) == G_SCALAR)
14702 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14703 op_sibling_splice(o, kid, 1, NULL));
14713 =for apidoc rv2cv_op_cv
14715 Examines an op, which is expected to identify a subroutine at runtime,
14716 and attempts to determine at compile time which subroutine it identifies.
14717 This is normally used during Perl compilation to determine whether
14718 a prototype can be applied to a function call. C<cvop> is the op
14719 being considered, normally an C<rv2cv> op. A pointer to the identified
14720 subroutine is returned, if it could be determined statically, and a null
14721 pointer is returned if it was not possible to determine statically.
14723 Currently, the subroutine can be identified statically if the RV that the
14724 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14725 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
14726 suitable if the constant value must be an RV pointing to a CV. Details of
14727 this process may change in future versions of Perl. If the C<rv2cv> op
14728 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14729 the subroutine statically: this flag is used to suppress compile-time
14730 magic on a subroutine call, forcing it to use default runtime behaviour.
14732 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14733 of a GV reference is modified. If a GV was examined and its CV slot was
14734 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14735 If the op is not optimised away, and the CV slot is later populated with
14736 a subroutine having a prototype, that flag eventually triggers the warning
14737 "called too early to check prototype".
14739 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14740 of returning a pointer to the subroutine it returns a pointer to the
14741 GV giving the most appropriate name for the subroutine in this context.
14742 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14743 (C<CvANON>) subroutine that is referenced through a GV it will be the
14744 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
14745 A null pointer is returned as usual if there is no statically-determinable
14748 =for apidoc Amnh||OPpEARLY_CV
14749 =for apidoc Amnh||OPpENTERSUB_AMPER
14750 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14751 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14756 /* shared by toke.c:yylex */
14758 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14760 PADNAME *name = PAD_COMPNAME(off);
14761 CV *compcv = PL_compcv;
14762 while (PadnameOUTER(name)) {
14763 assert(PARENT_PAD_INDEX(name));
14764 compcv = CvOUTSIDE(compcv);
14765 name = PadlistNAMESARRAY(CvPADLIST(compcv))
14766 [off = PARENT_PAD_INDEX(name)];
14768 assert(!PadnameIsOUR(name));
14769 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14770 return PadnamePROTOCV(name);
14772 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14776 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14781 PERL_ARGS_ASSERT_RV2CV_OP_CV;
14782 if (flags & ~RV2CVOPCV_FLAG_MASK)
14783 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14784 if (cvop->op_type != OP_RV2CV)
14786 if (cvop->op_private & OPpENTERSUB_AMPER)
14788 if (!(cvop->op_flags & OPf_KIDS))
14790 rvop = cUNOPx(cvop)->op_first;
14791 switch (rvop->op_type) {
14793 gv = cGVOPx_gv(rvop);
14795 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14796 cv = MUTABLE_CV(SvRV(gv));
14800 if (flags & RV2CVOPCV_RETURN_STUB)
14806 if (flags & RV2CVOPCV_MARK_EARLY)
14807 rvop->op_private |= OPpEARLY_CV;
14812 SV *rv = cSVOPx_sv(rvop);
14815 cv = (CV*)SvRV(rv);
14819 cv = find_lexical_cv(rvop->op_targ);
14824 } NOT_REACHED; /* NOTREACHED */
14826 if (SvTYPE((SV*)cv) != SVt_PVCV)
14828 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14829 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14833 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14834 if (CvLEXICAL(cv) || CvNAMED(cv))
14836 if (!CvANON(cv) || !gv)
14846 =for apidoc ck_entersub_args_list
14848 Performs the default fixup of the arguments part of an C<entersub>
14849 op tree. This consists of applying list context to each of the
14850 argument ops. This is the standard treatment used on a call marked
14851 with C<&>, or a method call, or a call through a subroutine reference,
14852 or any other call where the callee can't be identified at compile time,
14853 or a call where the callee has no prototype.
14859 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14863 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14865 aop = cUNOPx(entersubop)->op_first;
14866 if (!OpHAS_SIBLING(aop))
14867 aop = cUNOPx(aop)->op_first;
14868 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14869 /* skip the extra attributes->import() call implicitly added in
14870 * something like foo(my $x : bar)
14872 if ( aop->op_type == OP_ENTERSUB
14873 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14877 op_lvalue(aop, OP_ENTERSUB);
14883 =for apidoc ck_entersub_args_proto
14885 Performs the fixup of the arguments part of an C<entersub> op tree
14886 based on a subroutine prototype. This makes various modifications to
14887 the argument ops, from applying context up to inserting C<refgen> ops,
14888 and checking the number and syntactic types of arguments, as directed by
14889 the prototype. This is the standard treatment used on a subroutine call,
14890 not marked with C<&>, where the callee can be identified at compile time
14891 and has a prototype.
14893 C<protosv> supplies the subroutine prototype to be applied to the call.
14894 It may be a normal defined scalar, of which the string value will be used.
14895 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14896 that has been cast to C<SV*>) which has a prototype. The prototype
14897 supplied, in whichever form, does not need to match the actual callee
14898 referenced by the op tree.
14900 If the argument ops disagree with the prototype, for example by having
14901 an unacceptable number of arguments, a valid op tree is returned anyway.
14902 The error is reflected in the parser state, normally resulting in a single
14903 exception at the top level of parsing which covers all the compilation
14904 errors that occurred. In the error message, the callee is referred to
14905 by the name defined by the C<namegv> parameter.
14911 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14914 const char *proto, *proto_end;
14915 OP *aop, *prev, *cvop, *parent;
14918 I32 contextclass = 0;
14919 const char *e = NULL;
14920 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14921 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14922 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14923 "flags=%lx", (unsigned long) SvFLAGS(protosv));
14924 if (SvTYPE(protosv) == SVt_PVCV)
14925 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14926 else proto = SvPV(protosv, proto_len);
14927 proto = S_strip_spaces(aTHX_ proto, &proto_len);
14928 proto_end = proto + proto_len;
14929 parent = entersubop;
14930 aop = cUNOPx(entersubop)->op_first;
14931 if (!OpHAS_SIBLING(aop)) {
14933 aop = cUNOPx(aop)->op_first;
14936 aop = OpSIBLING(aop);
14937 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14938 while (aop != cvop) {
14941 if (proto >= proto_end)
14943 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14944 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14945 SVfARG(namesv)), SvUTF8(namesv));
14955 /* _ must be at the end */
14956 if (proto[1] && !memCHRs(";@%", proto[1]))
14972 if ( o3->op_type != OP_UNDEF
14973 && (o3->op_type != OP_SREFGEN
14974 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14976 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14978 bad_type_gv(arg, namegv, o3,
14979 arg == 1 ? "block or sub {}" : "sub {}");
14982 /* '*' allows any scalar type, including bareword */
14985 if (o3->op_type == OP_RV2GV)
14986 goto wrapref; /* autoconvert GLOB -> GLOBref */
14987 else if (o3->op_type == OP_CONST)
14988 o3->op_private &= ~OPpCONST_STRICT;
14994 if (o3->op_type == OP_RV2AV ||
14995 o3->op_type == OP_PADAV ||
14996 o3->op_type == OP_RV2HV ||
14997 o3->op_type == OP_PADHV
15003 case '[': case ']':
15010 switch (*proto++) {
15012 if (contextclass++ == 0) {
15013 e = (char *) memchr(proto, ']', proto_end - proto);
15014 if (!e || e == proto)
15022 if (contextclass) {
15023 const char *p = proto;
15024 const char *const end = proto;
15026 while (*--p != '[')
15027 /* \[$] accepts any scalar lvalue */
15029 && Perl_op_lvalue_flags(aTHX_
15031 OP_READ, /* not entersub */
15034 bad_type_gv(arg, namegv, o3,
15035 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
15040 if (o3->op_type == OP_RV2GV)
15043 bad_type_gv(arg, namegv, o3, "symbol");
15046 if (o3->op_type == OP_ENTERSUB
15047 && !(o3->op_flags & OPf_STACKED))
15050 bad_type_gv(arg, namegv, o3, "subroutine");
15053 if (o3->op_type == OP_RV2SV ||
15054 o3->op_type == OP_PADSV ||
15055 o3->op_type == OP_HELEM ||
15056 o3->op_type == OP_AELEM)
15058 if (!contextclass) {
15059 /* \$ accepts any scalar lvalue */
15060 if (Perl_op_lvalue_flags(aTHX_
15062 OP_READ, /* not entersub */
15065 bad_type_gv(arg, namegv, o3, "scalar");
15069 if (o3->op_type == OP_RV2AV ||
15070 o3->op_type == OP_PADAV)
15072 o3->op_flags &=~ OPf_PARENS;
15076 bad_type_gv(arg, namegv, o3, "array");
15079 if (o3->op_type == OP_RV2HV ||
15080 o3->op_type == OP_PADHV)
15082 o3->op_flags &=~ OPf_PARENS;
15086 bad_type_gv(arg, namegv, o3, "hash");
15089 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
15091 if (contextclass && e) {
15096 default: goto oops;
15106 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
15107 SVfARG(cv_name((CV *)namegv, NULL, 0)),
15112 op_lvalue(aop, OP_ENTERSUB);
15114 aop = OpSIBLING(aop);
15116 if (aop == cvop && *proto == '_') {
15117 /* generate an access to $_ */
15118 op_sibling_splice(parent, prev, 0, newDEFSVOP());
15120 if (!optional && proto_end > proto &&
15121 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
15123 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
15124 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
15125 SVfARG(namesv)), SvUTF8(namesv));
15131 =for apidoc ck_entersub_args_proto_or_list
15133 Performs the fixup of the arguments part of an C<entersub> op tree either
15134 based on a subroutine prototype or using default list-context processing.
15135 This is the standard treatment used on a subroutine call, not marked
15136 with C<&>, where the callee can be identified at compile time.
15138 C<protosv> supplies the subroutine prototype to be applied to the call,
15139 or indicates that there is no prototype. It may be a normal scalar,
15140 in which case if it is defined then the string value will be used
15141 as a prototype, and if it is undefined then there is no prototype.
15142 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
15143 that has been cast to C<SV*>), of which the prototype will be used if it
15144 has one. The prototype (or lack thereof) supplied, in whichever form,
15145 does not need to match the actual callee referenced by the op tree.
15147 If the argument ops disagree with the prototype, for example by having
15148 an unacceptable number of arguments, a valid op tree is returned anyway.
15149 The error is reflected in the parser state, normally resulting in a single
15150 exception at the top level of parsing which covers all the compilation
15151 errors that occurred. In the error message, the callee is referred to
15152 by the name defined by the C<namegv> parameter.
15158 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
15159 GV *namegv, SV *protosv)
15161 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
15162 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
15163 return ck_entersub_args_proto(entersubop, namegv, protosv);
15165 return ck_entersub_args_list(entersubop);
15169 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
15171 IV cvflags = SvIVX(protosv);
15172 int opnum = cvflags & 0xffff;
15173 OP *aop = cUNOPx(entersubop)->op_first;
15175 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
15179 if (!OpHAS_SIBLING(aop))
15180 aop = cUNOPx(aop)->op_first;
15181 aop = OpSIBLING(aop);
15182 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
15184 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
15185 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
15186 SVfARG(namesv)), SvUTF8(namesv));
15189 op_free(entersubop);
15190 switch(cvflags >> 16) {
15191 case 'F': return newSVOP(OP_CONST, 0,
15192 newSVpv(CopFILE(PL_curcop),0));
15193 case 'L': return newSVOP(
15195 Perl_newSVpvf(aTHX_
15196 "%" IVdf, (IV)CopLINE(PL_curcop)
15199 case 'P': return newSVOP(OP_CONST, 0,
15201 ? newSVhek(HvNAME_HEK(PL_curstash))
15206 NOT_REACHED; /* NOTREACHED */
15209 OP *prev, *cvop, *first, *parent;
15212 parent = entersubop;
15213 if (!OpHAS_SIBLING(aop)) {
15215 aop = cUNOPx(aop)->op_first;
15218 first = prev = aop;
15219 aop = OpSIBLING(aop);
15220 /* find last sibling */
15222 OpHAS_SIBLING(cvop);
15223 prev = cvop, cvop = OpSIBLING(cvop))
15225 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
15226 /* Usually, OPf_SPECIAL on an op with no args means that it had
15227 * parens, but these have their own meaning for that flag: */
15228 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
15229 && opnum != OP_DELETE && opnum != OP_EXISTS)
15230 flags |= OPf_SPECIAL;
15231 /* excise cvop from end of sibling chain */
15232 op_sibling_splice(parent, prev, 1, NULL);
15234 if (aop == cvop) aop = NULL;
15236 /* detach remaining siblings from the first sibling, then
15237 * dispose of original optree */
15240 op_sibling_splice(parent, first, -1, NULL);
15241 op_free(entersubop);
15243 if (cvflags == (OP_ENTEREVAL | (1<<16)))
15244 flags |= OPpEVAL_BYTES <<8;
15246 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
15248 case OA_BASEOP_OR_UNOP:
15249 case OA_FILESTATOP:
15251 return newOP(opnum,flags); /* zero args */
15253 return newUNOP(opnum,flags,aop); /* one arg */
15254 /* too many args */
15261 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
15262 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
15263 SVfARG(namesv)), SvUTF8(namesv));
15265 nextop = OpSIBLING(aop);
15271 return opnum == OP_RUNCV
15272 ? newPVOP(OP_RUNCV,0,NULL)
15275 return op_convert_list(opnum,0,aop);
15278 NOT_REACHED; /* NOTREACHED */
15283 =for apidoc cv_get_call_checker_flags
15285 Retrieves the function that will be used to fix up a call to C<cv>.
15286 Specifically, the function is applied to an C<entersub> op tree for a
15287 subroutine call, not marked with C<&>, where the callee can be identified
15288 at compile time as C<cv>.
15290 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
15291 for it is returned in C<*ckobj_p>, and control flags are returned in
15292 C<*ckflags_p>. The function is intended to be called in this manner:
15294 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
15296 In this call, C<entersubop> is a pointer to the C<entersub> op,
15297 which may be replaced by the check function, and C<namegv> supplies
15298 the name that should be used by the check function to refer
15299 to the callee of the C<entersub> op if it needs to emit any diagnostics.
15300 It is permitted to apply the check function in non-standard situations,
15301 such as to a call to a different subroutine or to a method call.
15303 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
15304 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
15305 instead, anything that can be used as the first argument to L</cv_name>.
15306 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
15307 check function requires C<namegv> to be a genuine GV.
15309 By default, the check function is
15310 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
15311 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
15312 flag is clear. This implements standard prototype processing. It can
15313 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
15315 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
15316 indicates that the caller only knows about the genuine GV version of
15317 C<namegv>, and accordingly the corresponding bit will always be set in
15318 C<*ckflags_p>, regardless of the check function's recorded requirements.
15319 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
15320 indicates the caller knows about the possibility of passing something
15321 other than a GV as C<namegv>, and accordingly the corresponding bit may
15322 be either set or clear in C<*ckflags_p>, indicating the check function's
15323 recorded requirements.
15325 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
15326 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
15327 (for which see above). All other bits should be clear.
15329 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
15331 =for apidoc cv_get_call_checker
15333 The original form of L</cv_get_call_checker_flags>, which does not return
15334 checker flags. When using a checker function returned by this function,
15335 it is only safe to call it with a genuine GV as its C<namegv> argument.
15341 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
15342 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
15345 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
15346 PERL_UNUSED_CONTEXT;
15347 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
15349 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
15350 *ckobj_p = callmg->mg_obj;
15351 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
15353 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
15354 *ckobj_p = (SV*)cv;
15355 *ckflags_p = gflags & MGf_REQUIRE_GV;
15360 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
15363 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
15364 PERL_UNUSED_CONTEXT;
15365 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
15370 =for apidoc cv_set_call_checker_flags
15372 Sets the function that will be used to fix up a call to C<cv>.
15373 Specifically, the function is applied to an C<entersub> op tree for a
15374 subroutine call, not marked with C<&>, where the callee can be identified
15375 at compile time as C<cv>.
15377 The C-level function pointer is supplied in C<ckfun>, an SV argument for
15378 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
15379 The function should be defined like this:
15381 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
15383 It is intended to be called in this manner:
15385 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
15387 In this call, C<entersubop> is a pointer to the C<entersub> op,
15388 which may be replaced by the check function, and C<namegv> supplies
15389 the name that should be used by the check function to refer
15390 to the callee of the C<entersub> op if it needs to emit any diagnostics.
15391 It is permitted to apply the check function in non-standard situations,
15392 such as to a call to a different subroutine or to a method call.
15394 C<namegv> may not actually be a GV. For efficiency, perl may pass a
15395 CV or other SV instead. Whatever is passed can be used as the first
15396 argument to L</cv_name>. You can force perl to pass a GV by including
15397 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
15399 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
15400 bit currently has a defined meaning (for which see above). All other
15401 bits should be clear.
15403 The current setting for a particular CV can be retrieved by
15404 L</cv_get_call_checker_flags>.
15406 =for apidoc cv_set_call_checker
15408 The original form of L</cv_set_call_checker_flags>, which passes it the
15409 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
15410 of that flag setting is that the check function is guaranteed to get a
15411 genuine GV as its C<namegv> argument.
15417 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
15419 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
15420 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
15424 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
15425 SV *ckobj, U32 ckflags)
15427 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
15428 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
15429 if (SvMAGICAL((SV*)cv))
15430 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
15433 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
15434 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
15436 if (callmg->mg_flags & MGf_REFCOUNTED) {
15437 SvREFCNT_dec(callmg->mg_obj);
15438 callmg->mg_flags &= ~MGf_REFCOUNTED;
15440 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
15441 callmg->mg_obj = ckobj;
15442 if (ckobj != (SV*)cv) {
15443 SvREFCNT_inc_simple_void_NN(ckobj);
15444 callmg->mg_flags |= MGf_REFCOUNTED;
15446 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
15447 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
15452 S_entersub_alloc_targ(pTHX_ OP * const o)
15454 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
15455 o->op_private |= OPpENTERSUB_HASTARG;
15459 Perl_ck_subr(pTHX_ OP *o)
15464 SV **const_class = NULL;
15466 PERL_ARGS_ASSERT_CK_SUBR;
15468 aop = cUNOPx(o)->op_first;
15469 if (!OpHAS_SIBLING(aop))
15470 aop = cUNOPx(aop)->op_first;
15471 aop = OpSIBLING(aop);
15472 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
15473 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
15474 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
15476 o->op_private &= ~1;
15477 o->op_private |= (PL_hints & HINT_STRICT_REFS);
15478 if (PERLDB_SUB && PL_curstash != PL_debstash)
15479 o->op_private |= OPpENTERSUB_DB;
15480 switch (cvop->op_type) {
15482 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
15486 case OP_METHOD_NAMED:
15487 case OP_METHOD_SUPER:
15488 case OP_METHOD_REDIR:
15489 case OP_METHOD_REDIR_SUPER:
15490 o->op_flags |= OPf_REF;
15491 if (aop->op_type == OP_CONST) {
15492 aop->op_private &= ~OPpCONST_STRICT;
15493 const_class = &cSVOPx(aop)->op_sv;
15495 else if (aop->op_type == OP_LIST) {
15496 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
15497 if (sib && sib->op_type == OP_CONST) {
15498 sib->op_private &= ~OPpCONST_STRICT;
15499 const_class = &cSVOPx(sib)->op_sv;
15502 /* make class name a shared cow string to speedup method calls */
15503 /* constant string might be replaced with object, f.e. bigint */
15504 if (const_class && SvPOK(*const_class)) {
15506 const char* str = SvPV(*const_class, len);
15508 SV* const shared = newSVpvn_share(
15509 str, SvUTF8(*const_class)
15510 ? -(SSize_t)len : (SSize_t)len,
15513 if (SvREADONLY(*const_class))
15514 SvREADONLY_on(shared);
15515 SvREFCNT_dec(*const_class);
15516 *const_class = shared;
15523 S_entersub_alloc_targ(aTHX_ o);
15524 return ck_entersub_args_list(o);
15526 Perl_call_checker ckfun;
15529 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
15530 if (CvISXSUB(cv) || !CvROOT(cv))
15531 S_entersub_alloc_targ(aTHX_ o);
15533 /* The original call checker API guarantees that a GV will
15534 be provided with the right name. So, if the old API was
15535 used (or the REQUIRE_GV flag was passed), we have to reify
15536 the CV’s GV, unless this is an anonymous sub. This is not
15537 ideal for lexical subs, as its stringification will include
15538 the package. But it is the best we can do. */
15539 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
15540 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
15543 else namegv = MUTABLE_GV(cv);
15544 /* After a syntax error in a lexical sub, the cv that
15545 rv2cv_op_cv returns may be a nameless stub. */
15546 if (!namegv) return ck_entersub_args_list(o);
15549 return ckfun(aTHX_ o, namegv, ckobj);
15554 Perl_ck_svconst(pTHX_ OP *o)
15556 SV * const sv = cSVOPo->op_sv;
15557 PERL_ARGS_ASSERT_CK_SVCONST;
15558 PERL_UNUSED_CONTEXT;
15559 #ifdef PERL_COPY_ON_WRITE
15560 /* Since the read-only flag may be used to protect a string buffer, we
15561 cannot do copy-on-write with existing read-only scalars that are not
15562 already copy-on-write scalars. To allow $_ = "hello" to do COW with
15563 that constant, mark the constant as COWable here, if it is not
15564 already read-only. */
15565 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
15568 # ifdef PERL_DEBUG_READONLY_COW
15578 Perl_ck_trunc(pTHX_ OP *o)
15580 PERL_ARGS_ASSERT_CK_TRUNC;
15582 if (o->op_flags & OPf_KIDS) {
15583 SVOP *kid = (SVOP*)cUNOPo->op_first;
15585 if (kid->op_type == OP_NULL)
15586 kid = (SVOP*)OpSIBLING(kid);
15587 if (kid && kid->op_type == OP_CONST &&
15588 (kid->op_private & OPpCONST_BARE) &&
15591 o->op_flags |= OPf_SPECIAL;
15592 kid->op_private &= ~OPpCONST_STRICT;
15593 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
15594 no_bareword_filehandle(SvPVX(cSVOPx_sv(kid)));
15602 Perl_ck_substr(pTHX_ OP *o)
15604 PERL_ARGS_ASSERT_CK_SUBSTR;
15607 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15608 OP *kid = cLISTOPo->op_first;
15610 if (kid->op_type == OP_NULL)
15611 kid = OpSIBLING(kid);
15613 /* Historically, substr(delete $foo{bar},...) has been allowed
15614 with 4-arg substr. Keep it working by applying entersub
15616 op_lvalue(kid, OP_ENTERSUB);
15623 Perl_ck_tell(pTHX_ OP *o)
15625 PERL_ARGS_ASSERT_CK_TELL;
15627 if (o->op_flags & OPf_KIDS) {
15628 OP *kid = cLISTOPo->op_first;
15629 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15630 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15635 PERL_STATIC_INLINE OP *
15636 S_last_non_null_kid(OP *o) {
15638 if (cUNOPo->op_flags & OPf_KIDS) {
15639 OP *k = cLISTOPo->op_first;
15641 if (k->op_type != OP_NULL) {
15652 Perl_ck_each(pTHX_ OP *o)
15654 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15655 const unsigned orig_type = o->op_type;
15657 PERL_ARGS_ASSERT_CK_EACH;
15660 switch (kid->op_type) {
15665 /* Catch out an anonhash here, since the behaviour might be
15668 * The typical tree is:
15675 * If the contents of the block is more complex you might get:
15683 * Similarly for the anonlist version below.
15685 if (orig_type == OP_EACH &&
15686 ckWARN(WARN_SYNTAX) &&
15687 (cUNOPx(kid)->op_flags & OPf_KIDS) &&
15688 ( cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
15689 cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
15690 (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
15691 /* look for last non-null kid, since we might have:
15692 each %{ some code ; +{ anon hash } }
15694 OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
15695 if (k && k->op_type == OP_ANONHASH) {
15696 /* diag_listed_as: each on anonymous %s will always start from the beginning */
15697 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous hash will always start from the beginning");
15702 if (orig_type == OP_EACH &&
15703 ckWARN(WARN_SYNTAX) &&
15704 (cUNOPx(kid)->op_flags & OPf_KIDS) &&
15705 (cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
15706 cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
15707 (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
15708 OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
15709 if (k && k->op_type == OP_ANONLIST) {
15710 /* diag_listed_as: each on anonymous %s will always start from the beginning */
15711 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous array will always start from the beginning");
15716 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15717 : orig_type == OP_KEYS ? OP_AKEYS
15721 if (kid->op_private == OPpCONST_BARE
15722 || !SvROK(cSVOPx_sv(kid))
15723 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15724 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
15729 qerror(Perl_mess(aTHX_
15730 "Experimental %s on scalar is now forbidden",
15731 PL_op_desc[orig_type]));
15733 bad_type_pv(1, "hash or array", o, kid);
15741 Perl_ck_length(pTHX_ OP *o)
15743 PERL_ARGS_ASSERT_CK_LENGTH;
15747 if (ckWARN(WARN_SYNTAX)) {
15748 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15752 const bool hash = kid->op_type == OP_PADHV
15753 || kid->op_type == OP_RV2HV;
15754 switch (kid->op_type) {
15759 name = S_op_varname(aTHX_ kid);
15765 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15766 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15768 SVfARG(name), hash ? "keys " : "", SVfARG(name)
15771 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15772 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15773 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15775 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15776 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15777 "length() used on @array (did you mean \"scalar(@array)\"?)");
15786 Perl_ck_isa(pTHX_ OP *o)
15788 OP *classop = cBINOPo->op_last;
15790 PERL_ARGS_ASSERT_CK_ISA;
15792 /* Convert barename into PV */
15793 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15794 /* TODO: Optionally convert package to raw HV here */
15795 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15803 ---------------------------------------------------------
15805 Common vars in list assignment
15807 There now follows some enums and static functions for detecting
15808 common variables in list assignments. Here is a little essay I wrote
15809 for myself when trying to get my head around this. DAPM.
15813 First some random observations:
15815 * If a lexical var is an alias of something else, e.g.
15816 for my $x ($lex, $pkg, $a[0]) {...}
15817 then the act of aliasing will increase the reference count of the SV
15819 * If a package var is an alias of something else, it may still have a
15820 reference count of 1, depending on how the alias was created, e.g.
15821 in *a = *b, $a may have a refcount of 1 since the GP is shared
15822 with a single GvSV pointer to the SV. So If it's an alias of another
15823 package var, then RC may be 1; if it's an alias of another scalar, e.g.
15824 a lexical var or an array element, then it will have RC > 1.
15826 * There are many ways to create a package alias; ultimately, XS code
15827 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
15828 run-time tracing mechanisms are unlikely to be able to catch all cases.
15830 * When the LHS is all my declarations, the same vars can't appear directly
15831 on the RHS, but they can indirectly via closures, aliasing and lvalue
15832 subs. But those techniques all involve an increase in the lexical
15833 scalar's ref count.
15835 * When the LHS is all lexical vars (but not necessarily my declarations),
15836 it is possible for the same lexicals to appear directly on the RHS, and
15837 without an increased ref count, since the stack isn't refcounted.
15838 This case can be detected at compile time by scanning for common lex
15839 vars with PL_generation.
15841 * lvalue subs defeat common var detection, but they do at least
15842 return vars with a temporary ref count increment. Also, you can't
15843 tell at compile time whether a sub call is lvalue.
15848 A: There are a few circumstances where there definitely can't be any
15851 LHS empty: () = (...);
15852 RHS empty: (....) = ();
15853 RHS contains only constants or other 'can't possibly be shared'
15854 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
15855 i.e. they only contain ops not marked as dangerous, whose children
15856 are also not dangerous;
15858 LHS contains a single scalar element: e.g. ($x) = (....); because
15859 after $x has been modified, it won't be used again on the RHS;
15860 RHS contains a single element with no aggregate on LHS: e.g.
15861 ($a,$b,$c) = ($x); again, once $a has been modified, its value
15862 won't be used again.
15864 B: If LHS are all 'my' lexical var declarations (or safe ops, which
15867 my ($a, $b, @c) = ...;
15869 Due to closure and goto tricks, these vars may already have content.
15870 For the same reason, an element on the RHS may be a lexical or package
15871 alias of one of the vars on the left, or share common elements, for
15874 my ($x,$y) = f(); # $x and $y on both sides
15875 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
15880 my @a = @$ra; # elements of @a on both sides
15881 sub f { @a = 1..4; \@a }
15884 First, just consider scalar vars on LHS:
15886 RHS is safe only if (A), or in addition,
15887 * contains only lexical *scalar* vars, where neither side's
15888 lexicals have been flagged as aliases
15890 If RHS is not safe, then it's always legal to check LHS vars for
15891 RC==1, since the only RHS aliases will always be associated
15894 Note that in particular, RHS is not safe if:
15896 * it contains package scalar vars; e.g.:
15899 my ($x, $y) = (2, $x_alias);
15900 sub f { $x = 1; *x_alias = \$x; }
15902 * It contains other general elements, such as flattened or
15903 * spliced or single array or hash elements, e.g.
15906 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
15910 use feature 'refaliasing';
15911 \($a[0], $a[1]) = \($y,$x);
15914 It doesn't matter if the array/hash is lexical or package.
15916 * it contains a function call that happens to be an lvalue
15917 sub which returns one or more of the above, e.g.
15928 (so a sub call on the RHS should be treated the same
15929 as having a package var on the RHS).
15931 * any other "dangerous" thing, such an op or built-in that
15932 returns one of the above, e.g. pp_preinc
15935 If RHS is not safe, what we can do however is at compile time flag
15936 that the LHS are all my declarations, and at run time check whether
15937 all the LHS have RC == 1, and if so skip the full scan.
15939 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
15941 Here the issue is whether there can be elements of @a on the RHS
15942 which will get prematurely freed when @a is cleared prior to
15943 assignment. This is only a problem if the aliasing mechanism
15944 is one which doesn't increase the refcount - only if RC == 1
15945 will the RHS element be prematurely freed.
15947 Because the array/hash is being INTROed, it or its elements
15948 can't directly appear on the RHS:
15950 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
15952 but can indirectly, e.g.:
15956 sub f { @a = 1..3; \@a }
15958 So if the RHS isn't safe as defined by (A), we must always
15959 mortalise and bump the ref count of any remaining RHS elements
15960 when assigning to a non-empty LHS aggregate.
15962 Lexical scalars on the RHS aren't safe if they've been involved in
15965 use feature 'refaliasing';
15968 \(my $lex) = \$pkg;
15969 my @a = ($lex,3); # equivalent to ($a[0],3)
15976 Similarly with lexical arrays and hashes on the RHS:
15990 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
15991 my $a; ($a, my $b) = (....);
15993 The difference between (B) and (C) is that it is now physically
15994 possible for the LHS vars to appear on the RHS too, where they
15995 are not reference counted; but in this case, the compile-time
15996 PL_generation sweep will detect such common vars.
15998 So the rules for (C) differ from (B) in that if common vars are
15999 detected, the runtime "test RC==1" optimisation can no longer be used,
16000 and a full mark and sweep is required
16002 D: As (C), but in addition the LHS may contain package vars.
16004 Since package vars can be aliased without a corresponding refcount
16005 increase, all bets are off. It's only safe if (A). E.g.
16007 my ($x, $y) = (1,2);
16009 for $x_alias ($x) {
16010 ($x_alias, $y) = (3, $x); # whoops
16013 Ditto for LHS aggregate package vars.
16015 E: Any other dangerous ops on LHS, e.g.
16016 (f(), $a[0], @$r) = (...);
16018 this is similar to (E) in that all bets are off. In addition, it's
16019 impossible to determine at compile time whether the LHS
16020 contains a scalar or an aggregate, e.g.
16022 sub f : lvalue { @a }
16025 * ---------------------------------------------------------
16029 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
16030 * that at least one of the things flagged was seen.
16034 AAS_MY_SCALAR = 0x001, /* my $scalar */
16035 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
16036 AAS_LEX_SCALAR = 0x004, /* $lexical */
16037 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
16038 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
16039 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
16040 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
16041 AAS_DANGEROUS = 0x080, /* an op (other than the above)
16042 that's flagged OA_DANGEROUS */
16043 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
16044 not in any of the categories above */
16045 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
16050 /* helper function for S_aassign_scan().
16051 * check a PAD-related op for commonality and/or set its generation number.
16052 * Returns a boolean indicating whether its shared */
16055 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
16057 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
16058 /* lexical used in aliasing */
16062 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
16064 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
16071 Helper function for OPpASSIGN_COMMON* detection in rpeep().
16072 It scans the left or right hand subtree of the aassign op, and returns a
16073 set of flags indicating what sorts of things it found there.
16074 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
16075 set PL_generation on lexical vars; if the latter, we see if
16076 PL_generation matches.
16077 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
16078 This fn will increment it by the number seen. It's not intended to
16079 be an accurate count (especially as many ops can push a variable
16080 number of SVs onto the stack); rather it's used as to test whether there
16081 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
16085 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
16088 OP *effective_top_op = o;
16092 bool top = o == effective_top_op;
16094 OP* next_kid = NULL;
16096 /* first, look for a solitary @_ on the RHS */
16099 && (o->op_flags & OPf_KIDS)
16100 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
16102 OP *kid = cUNOPo->op_first;
16103 if ( ( kid->op_type == OP_PUSHMARK
16104 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
16105 && ((kid = OpSIBLING(kid)))
16106 && !OpHAS_SIBLING(kid)
16107 && kid->op_type == OP_RV2AV
16108 && !(kid->op_flags & OPf_REF)
16109 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
16110 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
16111 && ((kid = cUNOPx(kid)->op_first))
16112 && kid->op_type == OP_GV
16113 && cGVOPx_gv(kid) == PL_defgv
16118 switch (o->op_type) {
16121 all_flags |= AAS_PKG_SCALAR;
16127 /* if !top, could be e.g. @a[0,1] */
16128 all_flags |= (top && (o->op_flags & OPf_REF))
16129 ? ((o->op_private & OPpLVAL_INTRO)
16130 ? AAS_MY_AGG : AAS_LEX_AGG)
16136 int comm = S_aassign_padcheck(aTHX_ o, rhs)
16137 ? AAS_LEX_SCALAR_COMM : 0;
16139 all_flags |= (o->op_private & OPpLVAL_INTRO)
16140 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
16148 if (cUNOPx(o)->op_first->op_type != OP_GV)
16149 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
16151 /* if !top, could be e.g. @a[0,1] */
16152 else if (top && (o->op_flags & OPf_REF))
16153 all_flags |= AAS_PKG_AGG;
16155 all_flags |= AAS_DANGEROUS;
16160 if (cUNOPx(o)->op_first->op_type != OP_GV) {
16162 all_flags |= AAS_DANGEROUS; /* ${expr} */
16165 all_flags |= AAS_PKG_SCALAR; /* $pkg */
16169 if (o->op_private & OPpSPLIT_ASSIGN) {
16170 /* the assign in @a = split() has been optimised away
16171 * and the @a attached directly to the split op
16172 * Treat the array as appearing on the RHS, i.e.
16173 * ... = (@a = split)
16178 if (o->op_flags & OPf_STACKED) {
16179 /* @{expr} = split() - the array expression is tacked
16180 * on as an extra child to split - process kid */
16181 next_kid = cLISTOPo->op_last;
16185 /* ... else array is directly attached to split op */
16187 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
16188 ? ((o->op_private & OPpLVAL_INTRO)
16189 ? AAS_MY_AGG : AAS_LEX_AGG)
16194 /* other args of split can't be returned */
16195 all_flags |= AAS_SAFE_SCALAR;
16199 /* undef on LHS following a var is significant, e.g.
16201 * @a = (($x, undef) = (2 => $x));
16202 * # @a shoul be (2,1) not (2,2)
16204 * undef on RHS counts as a scalar:
16205 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
16207 if ((!rhs && *scalars_p) || rhs)
16209 flags = AAS_SAFE_SCALAR;
16214 /* these are all no-ops; they don't push a potentially common SV
16215 * onto the stack, so they are neither AAS_DANGEROUS nor
16216 * AAS_SAFE_SCALAR */
16219 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
16224 /* these do nothing, but may have children */
16228 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
16230 flags = AAS_DANGEROUS;
16234 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
16235 && (o->op_private & OPpTARGET_MY))
16238 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
16239 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
16243 /* if its an unrecognised, non-dangerous op, assume that it
16244 * is the cause of at least one safe scalar */
16246 flags = AAS_SAFE_SCALAR;
16250 all_flags |= flags;
16252 /* by default, process all kids next
16253 * XXX this assumes that all other ops are "transparent" - i.e. that
16254 * they can return some of their children. While this true for e.g.
16255 * sort and grep, it's not true for e.g. map. We really need a
16256 * 'transparent' flag added to regen/opcodes
16258 if (o->op_flags & OPf_KIDS) {
16259 next_kid = cUNOPo->op_first;
16260 /* these ops do nothing but may have children; but their
16261 * children should also be treated as top-level */
16262 if ( o == effective_top_op
16263 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
16265 effective_top_op = next_kid;
16269 /* If next_kid is set, someone in the code above wanted us to process
16270 * that kid and all its remaining siblings. Otherwise, work our way
16271 * back up the tree */
16273 while (!next_kid) {
16275 return all_flags; /* at top; no parents/siblings to try */
16276 if (OpHAS_SIBLING(o)) {
16277 next_kid = o->op_sibparent;
16278 if (o == effective_top_op)
16279 effective_top_op = next_kid;
16281 else if (o == effective_top_op)
16282 effective_top_op = o->op_sibparent;
16283 o = o->op_sibparent; /* try parent's next sibling */
16291 /* Check for in place reverse and sort assignments like "@a = reverse @a"
16292 and modify the optree to make them work inplace */
16295 S_inplace_aassign(pTHX_ OP *o) {
16297 OP *modop, *modop_pushmark;
16299 OP *oleft, *oleft_pushmark;
16301 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
16303 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
16305 assert(cUNOPo->op_first->op_type == OP_NULL);
16306 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
16307 assert(modop_pushmark->op_type == OP_PUSHMARK);
16308 modop = OpSIBLING(modop_pushmark);
16310 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
16313 /* no other operation except sort/reverse */
16314 if (OpHAS_SIBLING(modop))
16317 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
16318 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
16320 if (modop->op_flags & OPf_STACKED) {
16321 /* skip sort subroutine/block */
16322 assert(oright->op_type == OP_NULL);
16323 oright = OpSIBLING(oright);
16326 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
16327 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
16328 assert(oleft_pushmark->op_type == OP_PUSHMARK);
16329 oleft = OpSIBLING(oleft_pushmark);
16331 /* Check the lhs is an array */
16333 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
16334 || OpHAS_SIBLING(oleft)
16335 || (oleft->op_private & OPpLVAL_INTRO)
16339 /* Only one thing on the rhs */
16340 if (OpHAS_SIBLING(oright))
16343 /* check the array is the same on both sides */
16344 if (oleft->op_type == OP_RV2AV) {
16345 if (oright->op_type != OP_RV2AV
16346 || !cUNOPx(oright)->op_first
16347 || cUNOPx(oright)->op_first->op_type != OP_GV
16348 || cUNOPx(oleft )->op_first->op_type != OP_GV
16349 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
16350 cGVOPx_gv(cUNOPx(oright)->op_first)
16354 else if (oright->op_type != OP_PADAV
16355 || oright->op_targ != oleft->op_targ
16359 /* This actually is an inplace assignment */
16361 modop->op_private |= OPpSORT_INPLACE;
16363 /* transfer MODishness etc from LHS arg to RHS arg */
16364 oright->op_flags = oleft->op_flags;
16366 /* remove the aassign op and the lhs */
16368 op_null(oleft_pushmark);
16369 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
16370 op_null(cUNOPx(oleft)->op_first);
16376 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
16377 * that potentially represent a series of one or more aggregate derefs
16378 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
16379 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
16380 * additional ops left in too).
16382 * The caller will have already verified that the first few ops in the
16383 * chain following 'start' indicate a multideref candidate, and will have
16384 * set 'orig_o' to the point further on in the chain where the first index
16385 * expression (if any) begins. 'orig_action' specifies what type of
16386 * beginning has already been determined by the ops between start..orig_o
16387 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
16389 * 'hints' contains any hints flags that need adding (currently just
16390 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
16394 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
16397 UNOP_AUX_item *arg_buf = NULL;
16398 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
16399 int index_skip = -1; /* don't output index arg on this action */
16401 /* similar to regex compiling, do two passes; the first pass
16402 * determines whether the op chain is convertible and calculates the
16403 * buffer size; the second pass populates the buffer and makes any
16404 * changes necessary to ops (such as moving consts to the pad on
16405 * threaded builds).
16407 * NB: for things like Coverity, note that both passes take the same
16408 * path through the logic tree (except for 'if (pass)' bits), since
16409 * both passes are following the same op_next chain; and in
16410 * particular, if it would return early on the second pass, it would
16411 * already have returned early on the first pass.
16413 for (pass = 0; pass < 2; pass++) {
16415 UV action = orig_action;
16416 OP *first_elem_op = NULL; /* first seen aelem/helem */
16417 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
16418 int action_count = 0; /* number of actions seen so far */
16419 int action_ix = 0; /* action_count % (actions per IV) */
16420 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
16421 bool is_last = FALSE; /* no more derefs to follow */
16422 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
16423 UV action_word = 0; /* all actions so far */
16424 UNOP_AUX_item *arg = arg_buf;
16425 UNOP_AUX_item *action_ptr = arg_buf;
16427 arg++; /* reserve slot for first action word */
16430 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
16431 case MDEREF_HV_gvhv_helem:
16432 next_is_hash = TRUE;
16434 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
16435 case MDEREF_AV_gvav_aelem:
16437 #ifdef USE_ITHREADS
16438 arg->pad_offset = cPADOPx(start)->op_padix;
16439 /* stop it being swiped when nulled */
16440 cPADOPx(start)->op_padix = 0;
16442 arg->sv = cSVOPx(start)->op_sv;
16443 cSVOPx(start)->op_sv = NULL;
16449 case MDEREF_HV_padhv_helem:
16450 case MDEREF_HV_padsv_vivify_rv2hv_helem:
16451 next_is_hash = TRUE;
16453 case MDEREF_AV_padav_aelem:
16454 case MDEREF_AV_padsv_vivify_rv2av_aelem:
16456 arg->pad_offset = start->op_targ;
16457 /* we skip setting op_targ = 0 for now, since the intact
16458 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
16459 reset_start_targ = TRUE;
16464 case MDEREF_HV_pop_rv2hv_helem:
16465 next_is_hash = TRUE;
16467 case MDEREF_AV_pop_rv2av_aelem:
16471 NOT_REACHED; /* NOTREACHED */
16476 /* look for another (rv2av/hv; get index;
16477 * aelem/helem/exists/delele) sequence */
16482 UV index_type = MDEREF_INDEX_none;
16484 if (action_count) {
16485 /* if this is not the first lookup, consume the rv2av/hv */
16487 /* for N levels of aggregate lookup, we normally expect
16488 * that the first N-1 [ah]elem ops will be flagged as
16489 * /DEREF (so they autovivifiy if necessary), and the last
16490 * lookup op not to be.
16491 * For other things (like @{$h{k1}{k2}}) extra scope or
16492 * leave ops can appear, so abandon the effort in that
16494 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
16497 /* rv2av or rv2hv sKR/1 */
16499 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16500 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16501 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16504 /* at this point, we wouldn't expect any of these
16505 * possible private flags:
16506 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
16507 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
16509 ASSUME(!(o->op_private &
16510 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
16512 hints = (o->op_private & OPpHINT_STRICT_REFS);
16514 /* make sure the type of the previous /DEREF matches the
16515 * type of the next lookup */
16516 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
16519 action = next_is_hash
16520 ? MDEREF_HV_vivify_rv2hv_helem
16521 : MDEREF_AV_vivify_rv2av_aelem;
16525 /* if this is the second pass, and we're at the depth where
16526 * previously we encountered a non-simple index expression,
16527 * stop processing the index at this point */
16528 if (action_count != index_skip) {
16530 /* look for one or more simple ops that return an array
16531 * index or hash key */
16533 switch (o->op_type) {
16535 /* it may be a lexical var index */
16536 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
16537 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16538 ASSUME(!(o->op_private &
16539 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16541 if ( OP_GIMME(o,0) == G_SCALAR
16542 && !(o->op_flags & (OPf_REF|OPf_MOD))
16543 && o->op_private == 0)
16546 arg->pad_offset = o->op_targ;
16548 index_type = MDEREF_INDEX_padsv;
16554 if (next_is_hash) {
16555 /* it's a constant hash index */
16556 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
16557 /* "use constant foo => FOO; $h{+foo}" for
16558 * some weird FOO, can leave you with constants
16559 * that aren't simple strings. It's not worth
16560 * the extra hassle for those edge cases */
16565 OP * helem_op = o->op_next;
16567 ASSUME( helem_op->op_type == OP_HELEM
16568 || helem_op->op_type == OP_NULL
16570 if (helem_op->op_type == OP_HELEM) {
16571 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
16572 if ( helem_op->op_private & OPpLVAL_INTRO
16573 || rop->op_type != OP_RV2HV
16577 /* on first pass just check; on second pass
16579 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
16584 #ifdef USE_ITHREADS
16585 /* Relocate sv to the pad for thread safety */
16586 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
16587 arg->pad_offset = o->op_targ;
16590 arg->sv = cSVOPx_sv(o);
16595 /* it's a constant array index */
16597 SV *ix_sv = cSVOPo->op_sv;
16602 if ( action_count == 0
16605 && ( action == MDEREF_AV_padav_aelem
16606 || action == MDEREF_AV_gvav_aelem)
16608 maybe_aelemfast = TRUE;
16612 SvREFCNT_dec_NN(cSVOPo->op_sv);
16616 /* we've taken ownership of the SV */
16617 cSVOPo->op_sv = NULL;
16619 index_type = MDEREF_INDEX_const;
16624 /* it may be a package var index */
16626 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
16627 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
16628 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
16629 || o->op_private != 0
16634 if (kid->op_type != OP_RV2SV)
16637 ASSUME(!(kid->op_flags &
16638 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
16639 |OPf_SPECIAL|OPf_PARENS)));
16640 ASSUME(!(kid->op_private &
16642 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
16643 |OPpDEREF|OPpLVAL_INTRO)));
16644 if( (kid->op_flags &~ OPf_PARENS)
16645 != (OPf_WANT_SCALAR|OPf_KIDS)
16646 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
16651 #ifdef USE_ITHREADS
16652 arg->pad_offset = cPADOPx(o)->op_padix;
16653 /* stop it being swiped when nulled */
16654 cPADOPx(o)->op_padix = 0;
16656 arg->sv = cSVOPx(o)->op_sv;
16657 cSVOPo->op_sv = NULL;
16661 index_type = MDEREF_INDEX_gvsv;
16666 } /* action_count != index_skip */
16668 action |= index_type;
16671 /* at this point we have either:
16672 * * detected what looks like a simple index expression,
16673 * and expect the next op to be an [ah]elem, or
16674 * an nulled [ah]elem followed by a delete or exists;
16675 * * found a more complex expression, so something other
16676 * than the above follows.
16679 /* possibly an optimised away [ah]elem (where op_next is
16680 * exists or delete) */
16681 if (o->op_type == OP_NULL)
16684 /* at this point we're looking for an OP_AELEM, OP_HELEM,
16685 * OP_EXISTS or OP_DELETE */
16687 /* if a custom array/hash access checker is in scope,
16688 * abandon optimisation attempt */
16689 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16690 && PL_check[o->op_type] != Perl_ck_null)
16692 /* similarly for customised exists and delete */
16693 if ( (o->op_type == OP_EXISTS)
16694 && PL_check[o->op_type] != Perl_ck_exists)
16696 if ( (o->op_type == OP_DELETE)
16697 && PL_check[o->op_type] != Perl_ck_delete)
16700 if ( o->op_type != OP_AELEM
16701 || (o->op_private &
16702 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
16704 maybe_aelemfast = FALSE;
16706 /* look for aelem/helem/exists/delete. If it's not the last elem
16707 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
16708 * flags; if it's the last, then it mustn't have
16709 * OPpDEREF_AV/HV, but may have lots of other flags, like
16710 * OPpLVAL_INTRO etc
16713 if ( index_type == MDEREF_INDEX_none
16714 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
16715 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
16719 /* we have aelem/helem/exists/delete with valid simple index */
16721 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16722 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
16723 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
16725 /* This doesn't make much sense but is legal:
16726 * @{ local $x[0][0] } = 1
16727 * Since scope exit will undo the autovivification,
16728 * don't bother in the first place. The OP_LEAVE
16729 * assertion is in case there are other cases of both
16730 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
16731 * exit that would undo the local - in which case this
16732 * block of code would need rethinking.
16734 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
16736 OP *n = o->op_next;
16737 while (n && ( n->op_type == OP_NULL
16738 || n->op_type == OP_LIST
16739 || n->op_type == OP_SCALAR))
16741 assert(n && n->op_type == OP_LEAVE);
16743 o->op_private &= ~OPpDEREF;
16748 ASSUME(!(o->op_flags &
16749 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
16750 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
16752 ok = (o->op_flags &~ OPf_PARENS)
16753 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
16754 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
16756 else if (o->op_type == OP_EXISTS) {
16757 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16758 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16759 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
16760 ok = !(o->op_private & ~OPpARG1_MASK);
16762 else if (o->op_type == OP_DELETE) {
16763 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16764 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16765 ASSUME(!(o->op_private &
16766 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
16767 /* don't handle slices or 'local delete'; the latter
16768 * is fairly rare, and has a complex runtime */
16769 ok = !(o->op_private & ~OPpARG1_MASK);
16770 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
16771 /* skip handling run-tome error */
16772 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
16775 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
16776 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
16777 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
16778 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
16779 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
16780 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
16785 if (!first_elem_op)
16789 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
16794 action |= MDEREF_FLAG_last;
16798 /* at this point we have something that started
16799 * promisingly enough (with rv2av or whatever), but failed
16800 * to find a simple index followed by an
16801 * aelem/helem/exists/delete. If this is the first action,
16802 * give up; but if we've already seen at least one
16803 * aelem/helem, then keep them and add a new action with
16804 * MDEREF_INDEX_none, which causes it to do the vivify
16805 * from the end of the previous lookup, and do the deref,
16806 * but stop at that point. So $a[0][expr] will do one
16807 * av_fetch, vivify and deref, then continue executing at
16812 index_skip = action_count;
16813 action |= MDEREF_FLAG_last;
16814 if (index_type != MDEREF_INDEX_none)
16818 action_word |= (action << (action_ix * MDEREF_SHIFT));
16821 /* if there's no space for the next action, reserve a new slot
16822 * for it *before* we start adding args for that action */
16823 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
16825 action_ptr->uv = action_word;
16831 } /* while !is_last */
16836 /* slot reserved for next action word not now needed */
16839 action_ptr->uv = action_word;
16845 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
16846 if (index_skip == -1) {
16847 mderef->op_flags = o->op_flags
16848 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
16849 if (o->op_type == OP_EXISTS)
16850 mderef->op_private = OPpMULTIDEREF_EXISTS;
16851 else if (o->op_type == OP_DELETE)
16852 mderef->op_private = OPpMULTIDEREF_DELETE;
16854 mderef->op_private = o->op_private
16855 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
16857 /* accumulate strictness from every level (although I don't think
16858 * they can actually vary) */
16859 mderef->op_private |= hints;
16861 /* integrate the new multideref op into the optree and the
16864 * In general an op like aelem or helem has two child
16865 * sub-trees: the aggregate expression (a_expr) and the
16866 * index expression (i_expr):
16872 * The a_expr returns an AV or HV, while the i-expr returns an
16873 * index. In general a multideref replaces most or all of a
16874 * multi-level tree, e.g.
16890 * With multideref, all the i_exprs will be simple vars or
16891 * constants, except that i_expr1 may be arbitrary in the case
16892 * of MDEREF_INDEX_none.
16894 * The bottom-most a_expr will be either:
16895 * 1) a simple var (so padXv or gv+rv2Xv);
16896 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
16897 * so a simple var with an extra rv2Xv;
16898 * 3) or an arbitrary expression.
16900 * 'start', the first op in the execution chain, will point to
16901 * 1),2): the padXv or gv op;
16902 * 3): the rv2Xv which forms the last op in the a_expr
16903 * execution chain, and the top-most op in the a_expr
16906 * For all cases, the 'start' node is no longer required,
16907 * but we can't free it since one or more external nodes
16908 * may point to it. E.g. consider
16909 * $h{foo} = $a ? $b : $c
16910 * Here, both the op_next and op_other branches of the
16911 * cond_expr point to the gv[*h] of the hash expression, so
16912 * we can't free the 'start' op.
16914 * For expr->[...], we need to save the subtree containing the
16915 * expression; for the other cases, we just need to save the
16917 * So in all cases, we null the start op and keep it around by
16918 * making it the child of the multideref op; for the expr->
16919 * case, the expr will be a subtree of the start node.
16921 * So in the simple 1,2 case the optree above changes to
16927 * ex-gv (or ex-padxv)
16929 * with the op_next chain being
16931 * -> ex-gv -> multideref -> op-following-ex-exists ->
16933 * In the 3 case, we have
16946 * -> rest-of-a_expr subtree ->
16947 * ex-rv2xv -> multideref -> op-following-ex-exists ->
16950 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
16951 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
16952 * multideref attached as the child, e.g.
16958 * ex-rv2av - i_expr1
16966 /* if we free this op, don't free the pad entry */
16967 if (reset_start_targ)
16968 start->op_targ = 0;
16971 /* Cut the bit we need to save out of the tree and attach to
16972 * the multideref op, then free the rest of the tree */
16974 /* find parent of node to be detached (for use by splice) */
16976 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
16977 || orig_action == MDEREF_HV_pop_rv2hv_helem)
16979 /* there is an arbitrary expression preceding us, e.g.
16980 * expr->[..]? so we need to save the 'expr' subtree */
16981 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
16982 p = cUNOPx(p)->op_first;
16983 ASSUME( start->op_type == OP_RV2AV
16984 || start->op_type == OP_RV2HV);
16987 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
16988 * above for exists/delete. */
16989 while ( (p->op_flags & OPf_KIDS)
16990 && cUNOPx(p)->op_first != start
16992 p = cUNOPx(p)->op_first;
16994 ASSUME(cUNOPx(p)->op_first == start);
16996 /* detach from main tree, and re-attach under the multideref */
16997 op_sibling_splice(mderef, NULL, 0,
16998 op_sibling_splice(p, NULL, 1, NULL));
17001 start->op_next = mderef;
17003 mderef->op_next = index_skip == -1 ? o->op_next : o;
17005 /* excise and free the original tree, and replace with
17006 * the multideref op */
17007 p = op_sibling_splice(top_op, NULL, -1, mderef);
17016 Size_t size = arg - arg_buf;
17018 if (maybe_aelemfast && action_count == 1)
17021 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
17022 sizeof(UNOP_AUX_item) * (size + 1));
17023 /* for dumping etc: store the length in a hidden first slot;
17024 * we set the op_aux pointer to the second slot */
17025 arg_buf->uv = size;
17028 } /* for (pass = ...) */
17031 /* See if the ops following o are such that o will always be executed in
17032 * boolean context: that is, the SV which o pushes onto the stack will
17033 * only ever be consumed by later ops via SvTRUE(sv) or similar.
17034 * If so, set a suitable private flag on o. Normally this will be
17035 * bool_flag; but see below why maybe_flag is needed too.
17037 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
17038 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
17039 * already be taken, so you'll have to give that op two different flags.
17041 * More explanation of 'maybe_flag' and 'safe_and' parameters.
17042 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
17043 * those underlying ops) short-circuit, which means that rather than
17044 * necessarily returning a truth value, they may return the LH argument,
17045 * which may not be boolean. For example in $x = (keys %h || -1), keys
17046 * should return a key count rather than a boolean, even though its
17047 * sort-of being used in boolean context.
17049 * So we only consider such logical ops to provide boolean context to
17050 * their LH argument if they themselves are in void or boolean context.
17051 * However, sometimes the context isn't known until run-time. In this
17052 * case the op is marked with the maybe_flag flag it.
17054 * Consider the following.
17056 * sub f { ....; if (%h) { .... } }
17058 * This is actually compiled as
17060 * sub f { ....; %h && do { .... } }
17062 * Here we won't know until runtime whether the final statement (and hence
17063 * the &&) is in void context and so is safe to return a boolean value.
17064 * So mark o with maybe_flag rather than the bool_flag.
17065 * Note that there is cost associated with determining context at runtime
17066 * (e.g. a call to block_gimme()), so it may not be worth setting (at
17067 * compile time) and testing (at runtime) maybe_flag if the scalar verses
17068 * boolean costs savings are marginal.
17070 * However, we can do slightly better with && (compared to || and //):
17071 * this op only returns its LH argument when that argument is false. In
17072 * this case, as long as the op promises to return a false value which is
17073 * valid in both boolean and scalar contexts, we can mark an op consumed
17074 * by && with bool_flag rather than maybe_flag.
17075 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
17076 * than &PL_sv_no for a false result in boolean context, then it's safe. An
17077 * op which promises to handle this case is indicated by setting safe_and
17082 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
17087 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
17089 /* OPpTARGET_MY and boolean context probably don't mix well.
17090 * If someone finds a valid use case, maybe add an extra flag to this
17091 * function which indicates its safe to do so for this op? */
17092 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
17093 && (o->op_private & OPpTARGET_MY)));
17098 switch (lop->op_type) {
17103 /* these two consume the stack argument in the scalar case,
17104 * and treat it as a boolean in the non linenumber case */
17107 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
17108 || (lop->op_private & OPpFLIP_LINENUM))
17114 /* these never leave the original value on the stack */
17123 /* OR DOR and AND evaluate their arg as a boolean, but then may
17124 * leave the original scalar value on the stack when following the
17125 * op_next route. If not in void context, we need to ensure
17126 * that whatever follows consumes the arg only in boolean context
17138 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
17142 else if (!(lop->op_flags & OPf_WANT)) {
17143 /* unknown context - decide at runtime */
17155 lop = lop->op_next;
17158 o->op_private |= flag;
17163 /* mechanism for deferring recursion in rpeep() */
17165 #define MAX_DEFERRED 4
17169 if (defer_ix == (MAX_DEFERRED-1)) { \
17170 OP **defer = defer_queue[defer_base]; \
17171 CALL_RPEEP(*defer); \
17172 S_prune_chain_head(defer); \
17173 defer_base = (defer_base + 1) % MAX_DEFERRED; \
17176 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
17179 #define IS_AND_OP(o) (o->op_type == OP_AND)
17180 #define IS_OR_OP(o) (o->op_type == OP_OR)
17183 /* A peephole optimizer. We visit the ops in the order they're to execute.
17184 * See the comments at the top of this file for more details about when
17185 * peep() is called */
17188 Perl_rpeep(pTHX_ OP *o)
17191 OP* oldoldop = NULL;
17192 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
17193 int defer_base = 0;
17196 if (!o || o->op_opt)
17199 assert(o->op_type != OP_FREED);
17203 SAVEVPTR(PL_curcop);
17204 for (;; o = o->op_next) {
17205 if (o && o->op_opt)
17208 while (defer_ix >= 0) {
17210 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
17211 CALL_RPEEP(*defer);
17212 S_prune_chain_head(defer);
17219 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
17220 assert(!oldoldop || oldoldop->op_next == oldop);
17221 assert(!oldop || oldop->op_next == o);
17223 /* By default, this op has now been optimised. A couple of cases below
17224 clear this again. */
17228 /* look for a series of 1 or more aggregate derefs, e.g.
17229 * $a[1]{foo}[$i]{$k}
17230 * and replace with a single OP_MULTIDEREF op.
17231 * Each index must be either a const, or a simple variable,
17233 * First, look for likely combinations of starting ops,
17234 * corresponding to (global and lexical variants of)
17236 * $r->[...] $r->{...}
17237 * (preceding expression)->[...]
17238 * (preceding expression)->{...}
17239 * and if so, call maybe_multideref() to do a full inspection
17240 * of the op chain and if appropriate, replace with an
17248 switch (o2->op_type) {
17250 /* $pkg[..] : gv[*pkg]
17251 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
17253 /* Fail if there are new op flag combinations that we're
17254 * not aware of, rather than:
17255 * * silently failing to optimise, or
17256 * * silently optimising the flag away.
17257 * If this ASSUME starts failing, examine what new flag
17258 * has been added to the op, and decide whether the
17259 * optimisation should still occur with that flag, then
17260 * update the code accordingly. This applies to all the
17261 * other ASSUMEs in the block of code too.
17263 ASSUME(!(o2->op_flags &
17264 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
17265 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
17269 if (o2->op_type == OP_RV2AV) {
17270 action = MDEREF_AV_gvav_aelem;
17274 if (o2->op_type == OP_RV2HV) {
17275 action = MDEREF_HV_gvhv_helem;
17279 if (o2->op_type != OP_RV2SV)
17282 /* at this point we've seen gv,rv2sv, so the only valid
17283 * construct left is $pkg->[] or $pkg->{} */
17285 ASSUME(!(o2->op_flags & OPf_STACKED));
17286 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
17287 != (OPf_WANT_SCALAR|OPf_MOD))
17290 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
17291 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
17292 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
17294 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
17295 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
17299 if (o2->op_type == OP_RV2AV) {
17300 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
17303 if (o2->op_type == OP_RV2HV) {
17304 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
17310 /* $lex->[...]: padsv[$lex] sM/DREFAV */
17312 ASSUME(!(o2->op_flags &
17313 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
17314 if ((o2->op_flags &
17315 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
17316 != (OPf_WANT_SCALAR|OPf_MOD))
17319 ASSUME(!(o2->op_private &
17320 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
17321 /* skip if state or intro, or not a deref */
17322 if ( o2->op_private != OPpDEREF_AV
17323 && o2->op_private != OPpDEREF_HV)
17327 if (o2->op_type == OP_RV2AV) {
17328 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
17331 if (o2->op_type == OP_RV2HV) {
17332 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
17339 /* $lex[..]: padav[@lex:1,2] sR *
17340 * or $lex{..}: padhv[%lex:1,2] sR */
17341 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
17342 OPf_REF|OPf_SPECIAL)));
17343 if ((o2->op_flags &
17344 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
17345 != (OPf_WANT_SCALAR|OPf_REF))
17347 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
17349 /* OPf_PARENS isn't currently used in this case;
17350 * if that changes, let us know! */
17351 ASSUME(!(o2->op_flags & OPf_PARENS));
17353 /* at this point, we wouldn't expect any of the remaining
17354 * possible private flags:
17355 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
17356 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
17358 * OPpSLICEWARNING shouldn't affect runtime
17360 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
17362 action = o2->op_type == OP_PADAV
17363 ? MDEREF_AV_padav_aelem
17364 : MDEREF_HV_padhv_helem;
17366 S_maybe_multideref(aTHX_ o, o2, action, 0);
17372 action = o2->op_type == OP_RV2AV
17373 ? MDEREF_AV_pop_rv2av_aelem
17374 : MDEREF_HV_pop_rv2hv_helem;
17377 /* (expr)->[...]: rv2av sKR/1;
17378 * (expr)->{...}: rv2hv sKR/1; */
17380 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
17382 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
17383 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
17384 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
17387 /* at this point, we wouldn't expect any of these
17388 * possible private flags:
17389 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
17390 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
17392 ASSUME(!(o2->op_private &
17393 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
17395 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
17399 S_maybe_multideref(aTHX_ o, o2, action, hints);
17408 switch (o->op_type) {
17410 PL_curcop = ((COP*)o); /* for warnings */
17413 PL_curcop = ((COP*)o); /* for warnings */
17415 /* Optimise a "return ..." at the end of a sub to just be "...".
17416 * This saves 2 ops. Before:
17417 * 1 <;> nextstate(main 1 -e:1) v ->2
17418 * 4 <@> return K ->5
17419 * 2 <0> pushmark s ->3
17420 * - <1> ex-rv2sv sK/1 ->4
17421 * 3 <#> gvsv[*cat] s ->4
17424 * - <@> return K ->-
17425 * - <0> pushmark s ->2
17426 * - <1> ex-rv2sv sK/1 ->-
17427 * 2 <$> gvsv(*cat) s ->3
17430 OP *next = o->op_next;
17431 OP *sibling = OpSIBLING(o);
17432 if ( OP_TYPE_IS(next, OP_PUSHMARK)
17433 && OP_TYPE_IS(sibling, OP_RETURN)
17434 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
17435 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
17436 ||OP_TYPE_IS(sibling->op_next->op_next,
17438 && cUNOPx(sibling)->op_first == next
17439 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
17442 /* Look through the PUSHMARK's siblings for one that
17443 * points to the RETURN */
17444 OP *top = OpSIBLING(next);
17445 while (top && top->op_next) {
17446 if (top->op_next == sibling) {
17447 top->op_next = sibling->op_next;
17448 o->op_next = next->op_next;
17451 top = OpSIBLING(top);
17456 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
17458 * This latter form is then suitable for conversion into padrange
17459 * later on. Convert:
17461 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
17465 * nextstate1 -> listop -> nextstate3
17467 * pushmark -> padop1 -> padop2
17469 if (o->op_next && (
17470 o->op_next->op_type == OP_PADSV
17471 || o->op_next->op_type == OP_PADAV
17472 || o->op_next->op_type == OP_PADHV
17474 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
17475 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
17476 && o->op_next->op_next->op_next && (
17477 o->op_next->op_next->op_next->op_type == OP_PADSV
17478 || o->op_next->op_next->op_next->op_type == OP_PADAV
17479 || o->op_next->op_next->op_next->op_type == OP_PADHV
17481 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
17482 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
17483 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
17484 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
17486 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
17489 ns2 = pad1->op_next;
17490 pad2 = ns2->op_next;
17491 ns3 = pad2->op_next;
17493 /* we assume here that the op_next chain is the same as
17494 * the op_sibling chain */
17495 assert(OpSIBLING(o) == pad1);
17496 assert(OpSIBLING(pad1) == ns2);
17497 assert(OpSIBLING(ns2) == pad2);
17498 assert(OpSIBLING(pad2) == ns3);
17500 /* excise and delete ns2 */
17501 op_sibling_splice(NULL, pad1, 1, NULL);
17504 /* excise pad1 and pad2 */
17505 op_sibling_splice(NULL, o, 2, NULL);
17507 /* create new listop, with children consisting of:
17508 * a new pushmark, pad1, pad2. */
17509 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
17510 newop->op_flags |= OPf_PARENS;
17511 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17513 /* insert newop between o and ns3 */
17514 op_sibling_splice(NULL, o, 0, newop);
17516 /*fixup op_next chain */
17517 newpm = cUNOPx(newop)->op_first; /* pushmark */
17518 o ->op_next = newpm;
17519 newpm->op_next = pad1;
17520 pad1 ->op_next = pad2;
17521 pad2 ->op_next = newop; /* listop */
17522 newop->op_next = ns3;
17524 /* Ensure pushmark has this flag if padops do */
17525 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
17526 newpm->op_flags |= OPf_MOD;
17532 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
17533 to carry two labels. For now, take the easier option, and skip
17534 this optimisation if the first NEXTSTATE has a label. */
17535 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
17536 OP *nextop = o->op_next;
17538 switch (nextop->op_type) {
17543 nextop = nextop->op_next;
17549 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
17552 oldop->op_next = nextop;
17554 /* Skip (old)oldop assignment since the current oldop's
17555 op_next already points to the next op. */
17562 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
17563 if (o->op_next->op_private & OPpTARGET_MY) {
17564 if (o->op_flags & OPf_STACKED) /* chained concats */
17565 break; /* ignore_optimization */
17567 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
17568 o->op_targ = o->op_next->op_targ;
17569 o->op_next->op_targ = 0;
17570 o->op_private |= OPpTARGET_MY;
17573 op_null(o->op_next);
17577 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
17578 break; /* Scalar stub must produce undef. List stub is noop */
17582 if (o->op_targ == OP_NEXTSTATE
17583 || o->op_targ == OP_DBSTATE)
17585 PL_curcop = ((COP*)o);
17587 /* XXX: We avoid setting op_seq here to prevent later calls
17588 to rpeep() from mistakenly concluding that optimisation
17589 has already occurred. This doesn't fix the real problem,
17590 though (See 20010220.007 (#5874)). AMS 20010719 */
17591 /* op_seq functionality is now replaced by op_opt */
17599 oldop->op_next = o->op_next;
17613 convert repeat into a stub with no kids.
17615 if (o->op_next->op_type == OP_CONST
17616 || ( o->op_next->op_type == OP_PADSV
17617 && !(o->op_next->op_private & OPpLVAL_INTRO))
17618 || ( o->op_next->op_type == OP_GV
17619 && o->op_next->op_next->op_type == OP_RV2SV
17620 && !(o->op_next->op_next->op_private
17621 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
17623 const OP *kid = o->op_next->op_next;
17624 if (o->op_next->op_type == OP_GV)
17625 kid = kid->op_next;
17626 /* kid is now the ex-list. */
17627 if (kid->op_type == OP_NULL
17628 && (kid = kid->op_next)->op_type == OP_CONST
17629 /* kid is now the repeat count. */
17630 && kid->op_next->op_type == OP_REPEAT
17631 && kid->op_next->op_private & OPpREPEAT_DOLIST
17632 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
17633 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
17636 o = kid->op_next; /* repeat */
17637 oldop->op_next = o;
17638 op_free(cBINOPo->op_first);
17639 op_free(cBINOPo->op_last );
17640 o->op_flags &=~ OPf_KIDS;
17641 /* stub is a baseop; repeat is a binop */
17642 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
17643 OpTYPE_set(o, OP_STUB);
17649 /* Convert a series of PAD ops for my vars plus support into a
17650 * single padrange op. Basically
17652 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
17654 * becomes, depending on circumstances, one of
17656 * padrange ----------------------------------> (list) -> rest
17657 * padrange --------------------------------------------> rest
17659 * where all the pad indexes are sequential and of the same type
17661 * We convert the pushmark into a padrange op, then skip
17662 * any other pad ops, and possibly some trailing ops.
17663 * Note that we don't null() the skipped ops, to make it
17664 * easier for Deparse to undo this optimisation (and none of
17665 * the skipped ops are holding any resourses). It also makes
17666 * it easier for find_uninit_var(), as it can just ignore
17667 * padrange, and examine the original pad ops.
17671 OP *followop = NULL; /* the op that will follow the padrange op */
17674 PADOFFSET base = 0; /* init only to stop compiler whining */
17675 bool gvoid = 0; /* init only to stop compiler whining */
17676 bool defav = 0; /* seen (...) = @_ */
17677 bool reuse = 0; /* reuse an existing padrange op */
17679 /* look for a pushmark -> gv[_] -> rv2av */
17684 if ( p->op_type == OP_GV
17685 && cGVOPx_gv(p) == PL_defgv
17686 && (rv2av = p->op_next)
17687 && rv2av->op_type == OP_RV2AV
17688 && !(rv2av->op_flags & OPf_REF)
17689 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
17690 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
17692 q = rv2av->op_next;
17693 if (q->op_type == OP_NULL)
17695 if (q->op_type == OP_PUSHMARK) {
17705 /* scan for PAD ops */
17707 for (p = p->op_next; p; p = p->op_next) {
17708 if (p->op_type == OP_NULL)
17711 if (( p->op_type != OP_PADSV
17712 && p->op_type != OP_PADAV
17713 && p->op_type != OP_PADHV
17715 /* any private flag other than INTRO? e.g. STATE */
17716 || (p->op_private & ~OPpLVAL_INTRO)
17720 /* let $a[N] potentially be optimised into AELEMFAST_LEX
17722 if ( p->op_type == OP_PADAV
17724 && p->op_next->op_type == OP_CONST
17725 && p->op_next->op_next
17726 && p->op_next->op_next->op_type == OP_AELEM
17730 /* for 1st padop, note what type it is and the range
17731 * start; for the others, check that it's the same type
17732 * and that the targs are contiguous */
17734 intro = (p->op_private & OPpLVAL_INTRO);
17736 gvoid = OP_GIMME(p,0) == G_VOID;
17739 if ((p->op_private & OPpLVAL_INTRO) != intro)
17741 /* Note that you'd normally expect targs to be
17742 * contiguous in my($a,$b,$c), but that's not the case
17743 * when external modules start doing things, e.g.
17744 * Function::Parameters */
17745 if (p->op_targ != base + count)
17747 assert(p->op_targ == base + count);
17748 /* Either all the padops or none of the padops should
17749 be in void context. Since we only do the optimisa-
17750 tion for av/hv when the aggregate itself is pushed
17751 on to the stack (one item), there is no need to dis-
17752 tinguish list from scalar context. */
17753 if (gvoid != (OP_GIMME(p,0) == G_VOID))
17757 /* for AV, HV, only when we're not flattening */
17758 if ( p->op_type != OP_PADSV
17760 && !(p->op_flags & OPf_REF)
17764 if (count >= OPpPADRANGE_COUNTMASK)
17767 /* there's a biggest base we can fit into a
17768 * SAVEt_CLEARPADRANGE in pp_padrange.
17769 * (The sizeof() stuff will be constant-folded, and is
17770 * intended to avoid getting "comparison is always false"
17771 * compiler warnings. See the comments above
17772 * MEM_WRAP_CHECK for more explanation on why we do this
17773 * in a weird way to avoid compiler warnings.)
17776 && (8*sizeof(base) >
17777 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
17779 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17781 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17785 /* Success! We've got another valid pad op to optimise away */
17787 followop = p->op_next;
17790 if (count < 1 || (count == 1 && !defav))
17793 /* pp_padrange in specifically compile-time void context
17794 * skips pushing a mark and lexicals; in all other contexts
17795 * (including unknown till runtime) it pushes a mark and the
17796 * lexicals. We must be very careful then, that the ops we
17797 * optimise away would have exactly the same effect as the
17799 * In particular in void context, we can only optimise to
17800 * a padrange if we see the complete sequence
17801 * pushmark, pad*v, ...., list
17802 * which has the net effect of leaving the markstack as it
17803 * was. Not pushing onto the stack (whereas padsv does touch
17804 * the stack) makes no difference in void context.
17808 if (followop->op_type == OP_LIST
17809 && OP_GIMME(followop,0) == G_VOID
17812 followop = followop->op_next; /* skip OP_LIST */
17814 /* consolidate two successive my(...);'s */
17817 && oldoldop->op_type == OP_PADRANGE
17818 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
17819 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
17820 && !(oldoldop->op_flags & OPf_SPECIAL)
17823 assert(oldoldop->op_next == oldop);
17824 assert( oldop->op_type == OP_NEXTSTATE
17825 || oldop->op_type == OP_DBSTATE);
17826 assert(oldop->op_next == o);
17829 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
17831 /* Do not assume pad offsets for $c and $d are con-
17836 if ( oldoldop->op_targ + old_count == base
17837 && old_count < OPpPADRANGE_COUNTMASK - count) {
17838 base = oldoldop->op_targ;
17839 count += old_count;
17844 /* if there's any immediately following singleton
17845 * my var's; then swallow them and the associated
17847 * my ($a,$b); my $c; my $d;
17849 * my ($a,$b,$c,$d);
17852 while ( ((p = followop->op_next))
17853 && ( p->op_type == OP_PADSV
17854 || p->op_type == OP_PADAV
17855 || p->op_type == OP_PADHV)
17856 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
17857 && (p->op_private & OPpLVAL_INTRO) == intro
17858 && !(p->op_private & ~OPpLVAL_INTRO)
17860 && ( p->op_next->op_type == OP_NEXTSTATE
17861 || p->op_next->op_type == OP_DBSTATE)
17862 && count < OPpPADRANGE_COUNTMASK
17863 && base + count == p->op_targ
17866 followop = p->op_next;
17874 assert(oldoldop->op_type == OP_PADRANGE);
17875 oldoldop->op_next = followop;
17876 oldoldop->op_private = (intro | count);
17882 /* Convert the pushmark into a padrange.
17883 * To make Deparse easier, we guarantee that a padrange was
17884 * *always* formerly a pushmark */
17885 assert(o->op_type == OP_PUSHMARK);
17886 o->op_next = followop;
17887 OpTYPE_set(o, OP_PADRANGE);
17889 /* bit 7: INTRO; bit 6..0: count */
17890 o->op_private = (intro | count);
17891 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
17892 | gvoid * OPf_WANT_VOID
17893 | (defav ? OPf_SPECIAL : 0));
17899 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17900 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17905 /*'keys %h' in void or scalar context: skip the OP_KEYS
17906 * and perform the functionality directly in the RV2HV/PADHV
17909 if (o->op_flags & OPf_REF) {
17910 OP *k = o->op_next;
17911 U8 want = (k->op_flags & OPf_WANT);
17913 && k->op_type == OP_KEYS
17914 && ( want == OPf_WANT_VOID
17915 || want == OPf_WANT_SCALAR)
17916 && !(k->op_private & OPpMAYBE_LVSUB)
17917 && !(k->op_flags & OPf_MOD)
17919 o->op_next = k->op_next;
17920 o->op_flags &= ~(OPf_REF|OPf_WANT);
17921 o->op_flags |= want;
17922 o->op_private |= (o->op_type == OP_PADHV ?
17923 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
17924 /* for keys(%lex), hold onto the OP_KEYS's targ
17925 * since padhv doesn't have its own targ to return
17927 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
17932 /* see if %h is used in boolean context */
17933 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17934 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17937 if (o->op_type != OP_PADHV)
17941 if ( o->op_type == OP_PADAV
17942 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17944 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17947 /* Skip over state($x) in void context. */
17948 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
17949 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
17951 oldop->op_next = o->op_next;
17952 goto redo_nextstate;
17954 if (o->op_type != OP_PADAV)
17958 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
17959 OP* const pop = (o->op_type == OP_PADAV) ?
17960 o->op_next : o->op_next->op_next;
17962 if (pop && pop->op_type == OP_CONST &&
17963 ((PL_op = pop->op_next)) &&
17964 pop->op_next->op_type == OP_AELEM &&
17965 !(pop->op_next->op_private &
17966 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
17967 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
17970 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
17971 no_bareword_allowed(pop);
17972 if (o->op_type == OP_GV)
17973 op_null(o->op_next);
17974 op_null(pop->op_next);
17976 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
17977 o->op_next = pop->op_next->op_next;
17978 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
17979 o->op_private = (U8)i;
17980 if (o->op_type == OP_GV) {
17983 o->op_type = OP_AELEMFAST;
17986 o->op_type = OP_AELEMFAST_LEX;
17988 if (o->op_type != OP_GV)
17992 /* Remove $foo from the op_next chain in void context. */
17994 && ( o->op_next->op_type == OP_RV2SV
17995 || o->op_next->op_type == OP_RV2AV
17996 || o->op_next->op_type == OP_RV2HV )
17997 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17998 && !(o->op_next->op_private & OPpLVAL_INTRO))
18000 oldop->op_next = o->op_next->op_next;
18001 /* Reprocess the previous op if it is a nextstate, to
18002 allow double-nextstate optimisation. */
18004 if (oldop->op_type == OP_NEXTSTATE) {
18011 o = oldop->op_next;
18014 else if (o->op_next->op_type == OP_RV2SV) {
18015 if (!(o->op_next->op_private & OPpDEREF)) {
18016 op_null(o->op_next);
18017 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
18019 o->op_next = o->op_next->op_next;
18020 OpTYPE_set(o, OP_GVSV);
18023 else if (o->op_next->op_type == OP_READLINE
18024 && o->op_next->op_next->op_type == OP_CONCAT
18025 && (o->op_next->op_next->op_flags & OPf_STACKED))
18027 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
18028 OpTYPE_set(o, OP_RCATLINE);
18029 o->op_flags |= OPf_STACKED;
18030 op_null(o->op_next->op_next);
18031 op_null(o->op_next);
18042 case OP_CMPCHAIN_AND:
18044 while (cLOGOP->op_other->op_type == OP_NULL)
18045 cLOGOP->op_other = cLOGOP->op_other->op_next;
18046 while (o->op_next && ( o->op_type == o->op_next->op_type
18047 || o->op_next->op_type == OP_NULL))
18048 o->op_next = o->op_next->op_next;
18050 /* If we're an OR and our next is an AND in void context, we'll
18051 follow its op_other on short circuit, same for reverse.
18052 We can't do this with OP_DOR since if it's true, its return
18053 value is the underlying value which must be evaluated
18057 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
18058 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
18060 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
18062 o->op_next = ((LOGOP*)o->op_next)->op_other;
18064 DEFER(cLOGOP->op_other);
18069 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
18070 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
18079 case OP_ARGDEFELEM:
18080 while (cLOGOP->op_other->op_type == OP_NULL)
18081 cLOGOP->op_other = cLOGOP->op_other->op_next;
18082 DEFER(cLOGOP->op_other);
18087 while (cLOOP->op_redoop->op_type == OP_NULL)
18088 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
18089 while (cLOOP->op_nextop->op_type == OP_NULL)
18090 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
18091 while (cLOOP->op_lastop->op_type == OP_NULL)
18092 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
18093 /* a while(1) loop doesn't have an op_next that escapes the
18094 * loop, so we have to explicitly follow the op_lastop to
18095 * process the rest of the code */
18096 DEFER(cLOOP->op_lastop);
18100 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
18101 DEFER(cLOGOPo->op_other);
18104 case OP_ENTERTRYCATCH:
18105 assert(cLOGOPo->op_other->op_type == OP_CATCH);
18106 /* catch body is the ->op_other of the OP_CATCH */
18107 DEFER(cLOGOPx(cLOGOPo->op_other)->op_other);
18111 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
18112 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
18113 assert(!(cPMOP->op_pmflags & PMf_ONCE));
18114 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
18115 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
18116 cPMOP->op_pmstashstartu.op_pmreplstart
18117 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
18118 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
18124 if (o->op_flags & OPf_SPECIAL) {
18125 /* first arg is a code block */
18126 OP * const nullop = OpSIBLING(cLISTOP->op_first);
18127 OP * kid = cUNOPx(nullop)->op_first;
18129 assert(nullop->op_type == OP_NULL);
18130 assert(kid->op_type == OP_SCOPE
18131 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
18132 /* since OP_SORT doesn't have a handy op_other-style
18133 * field that can point directly to the start of the code
18134 * block, store it in the otherwise-unused op_next field
18135 * of the top-level OP_NULL. This will be quicker at
18136 * run-time, and it will also allow us to remove leading
18137 * OP_NULLs by just messing with op_nexts without
18138 * altering the basic op_first/op_sibling layout. */
18139 kid = kLISTOP->op_first;
18141 (kid->op_type == OP_NULL
18142 && ( kid->op_targ == OP_NEXTSTATE
18143 || kid->op_targ == OP_DBSTATE ))
18144 || kid->op_type == OP_STUB
18145 || kid->op_type == OP_ENTER
18146 || (PL_parser && PL_parser->error_count));
18147 nullop->op_next = kid->op_next;
18148 DEFER(nullop->op_next);
18151 /* check that RHS of sort is a single plain array */
18152 oright = cUNOPo->op_first;
18153 if (!oright || oright->op_type != OP_PUSHMARK)
18156 if (o->op_private & OPpSORT_INPLACE)
18159 /* reverse sort ... can be optimised. */
18160 if (!OpHAS_SIBLING(cUNOPo)) {
18161 /* Nothing follows us on the list. */
18162 OP * const reverse = o->op_next;
18164 if (reverse->op_type == OP_REVERSE &&
18165 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
18166 OP * const pushmark = cUNOPx(reverse)->op_first;
18167 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
18168 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
18169 /* reverse -> pushmark -> sort */
18170 o->op_private |= OPpSORT_REVERSE;
18172 pushmark->op_next = oright->op_next;
18182 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
18184 LISTOP *enter, *exlist;
18186 if (o->op_private & OPpSORT_INPLACE)
18189 enter = (LISTOP *) o->op_next;
18192 if (enter->op_type == OP_NULL) {
18193 enter = (LISTOP *) enter->op_next;
18197 /* for $a (...) will have OP_GV then OP_RV2GV here.
18198 for (...) just has an OP_GV. */
18199 if (enter->op_type == OP_GV) {
18200 gvop = (OP *) enter;
18201 enter = (LISTOP *) enter->op_next;
18204 if (enter->op_type == OP_RV2GV) {
18205 enter = (LISTOP *) enter->op_next;
18211 if (enter->op_type != OP_ENTERITER)
18214 iter = enter->op_next;
18215 if (!iter || iter->op_type != OP_ITER)
18218 expushmark = enter->op_first;
18219 if (!expushmark || expushmark->op_type != OP_NULL
18220 || expushmark->op_targ != OP_PUSHMARK)
18223 exlist = (LISTOP *) OpSIBLING(expushmark);
18224 if (!exlist || exlist->op_type != OP_NULL
18225 || exlist->op_targ != OP_LIST)
18228 if (exlist->op_last != o) {
18229 /* Mmm. Was expecting to point back to this op. */
18232 theirmark = exlist->op_first;
18233 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
18236 if (OpSIBLING(theirmark) != o) {
18237 /* There's something between the mark and the reverse, eg
18238 for (1, reverse (...))
18243 ourmark = ((LISTOP *)o)->op_first;
18244 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
18247 ourlast = ((LISTOP *)o)->op_last;
18248 if (!ourlast || ourlast->op_next != o)
18251 rv2av = OpSIBLING(ourmark);
18252 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
18253 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
18254 /* We're just reversing a single array. */
18255 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
18256 enter->op_flags |= OPf_STACKED;
18259 /* We don't have control over who points to theirmark, so sacrifice
18261 theirmark->op_next = ourmark->op_next;
18262 theirmark->op_flags = ourmark->op_flags;
18263 ourlast->op_next = gvop ? gvop : (OP *) enter;
18266 enter->op_private |= OPpITER_REVERSED;
18267 iter->op_private |= OPpITER_REVERSED;
18271 o = oldop->op_next;
18273 NOT_REACHED; /* NOTREACHED */
18279 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
18280 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
18285 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
18286 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
18289 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
18291 sv = newRV((SV *)PL_compcv);
18295 OpTYPE_set(o, OP_CONST);
18296 o->op_flags |= OPf_SPECIAL;
18297 cSVOPo->op_sv = sv;
18302 if (OP_GIMME(o,0) == G_VOID
18303 || ( o->op_next->op_type == OP_LINESEQ
18304 && ( o->op_next->op_next->op_type == OP_LEAVESUB
18305 || ( o->op_next->op_next->op_type == OP_RETURN
18306 && !CvLVALUE(PL_compcv)))))
18308 OP *right = cBINOP->op_first;
18327 OP *left = OpSIBLING(right);
18328 if (left->op_type == OP_SUBSTR
18329 && (left->op_private & 7) < 4) {
18331 /* cut out right */
18332 op_sibling_splice(o, NULL, 1, NULL);
18333 /* and insert it as second child of OP_SUBSTR */
18334 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
18336 left->op_private |= OPpSUBSTR_REPL_FIRST;
18338 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
18345 int l, r, lr, lscalars, rscalars;
18347 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
18348 Note that we do this now rather than in newASSIGNOP(),
18349 since only by now are aliased lexicals flagged as such
18351 See the essay "Common vars in list assignment" above for
18352 the full details of the rationale behind all the conditions
18355 PL_generation sorcery:
18356 To detect whether there are common vars, the global var
18357 PL_generation is incremented for each assign op we scan.
18358 Then we run through all the lexical variables on the LHS,
18359 of the assignment, setting a spare slot in each of them to
18360 PL_generation. Then we scan the RHS, and if any lexicals
18361 already have that value, we know we've got commonality.
18362 Also, if the generation number is already set to
18363 PERL_INT_MAX, then the variable is involved in aliasing, so
18364 we also have potential commonality in that case.
18370 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
18373 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
18377 /* After looking for things which are *always* safe, this main
18378 * if/else chain selects primarily based on the type of the
18379 * LHS, gradually working its way down from the more dangerous
18380 * to the more restrictive and thus safer cases */
18382 if ( !l /* () = ....; */
18383 || !r /* .... = (); */
18384 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
18385 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
18386 || (lscalars < 2) /* (undef, $x) = ... */
18388 NOOP; /* always safe */
18390 else if (l & AAS_DANGEROUS) {
18391 /* always dangerous */
18392 o->op_private |= OPpASSIGN_COMMON_SCALAR;
18393 o->op_private |= OPpASSIGN_COMMON_AGG;
18395 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
18396 /* package vars are always dangerous - too many
18397 * aliasing possibilities */
18398 if (l & AAS_PKG_SCALAR)
18399 o->op_private |= OPpASSIGN_COMMON_SCALAR;
18400 if (l & AAS_PKG_AGG)
18401 o->op_private |= OPpASSIGN_COMMON_AGG;
18403 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
18404 |AAS_LEX_SCALAR|AAS_LEX_AGG))
18406 /* LHS contains only lexicals and safe ops */
18408 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
18409 o->op_private |= OPpASSIGN_COMMON_AGG;
18411 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
18412 if (lr & AAS_LEX_SCALAR_COMM)
18413 o->op_private |= OPpASSIGN_COMMON_SCALAR;
18414 else if ( !(l & AAS_LEX_SCALAR)
18415 && (r & AAS_DEFAV))
18419 * as scalar-safe for performance reasons.
18420 * (it will still have been marked _AGG if necessary */
18423 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
18424 /* if there are only lexicals on the LHS and no
18425 * common ones on the RHS, then we assume that the
18426 * only way those lexicals could also get
18427 * on the RHS is via some sort of dereffing or
18430 * ($lex, $x) = (1, $$r)
18431 * and in this case we assume the var must have
18432 * a bumped ref count. So if its ref count is 1,
18433 * it must only be on the LHS.
18435 o->op_private |= OPpASSIGN_COMMON_RC1;
18440 * may have to handle aggregate on LHS, but we can't
18441 * have common scalars. */
18444 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
18446 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
18447 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
18453 /* if the op is used in boolean context, set the TRUEBOOL flag
18454 * which enables an optimisation at runtime which avoids creating
18455 * a stack temporary for known-true package names */
18456 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
18457 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
18461 /* see if the op is used in known boolean context,
18462 * but not if OA_TARGLEX optimisation is enabled */
18463 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
18464 && !(o->op_private & OPpTARGET_MY)
18466 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
18470 /* see if the op is used in known boolean context */
18471 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
18472 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
18476 Perl_cpeep_t cpeep =
18477 XopENTRYCUSTOM(o, xop_peep);
18479 cpeep(aTHX_ o, oldop);
18484 /* did we just null the current op? If so, re-process it to handle
18485 * eliding "empty" ops from the chain */
18486 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
18499 Perl_peep(pTHX_ OP *o)
18505 =for apidoc_section $custom
18507 =for apidoc Perl_custom_op_xop
18508 Return the XOP structure for a given custom op. This macro should be
18509 considered internal to C<OP_NAME> and the other access macros: use them instead.
18510 This macro does call a function. Prior
18511 to 5.19.6, this was implemented as a
18518 /* use PERL_MAGIC_ext to call a function to free the xop structure when
18519 * freeing PL_custom_ops */
18522 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
18526 PERL_UNUSED_ARG(mg);
18527 xop = INT2PTR(XOP *, SvIV(sv));
18528 Safefree(xop->xop_name);
18529 Safefree(xop->xop_desc);
18535 static const MGVTBL custom_op_register_vtbl = {
18540 custom_op_register_free, /* free */
18550 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
18556 static const XOP xop_null = { 0, 0, 0, 0, 0 };
18558 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
18559 assert(o->op_type == OP_CUSTOM);
18561 /* This is wrong. It assumes a function pointer can be cast to IV,
18562 * which isn't guaranteed, but this is what the old custom OP code
18563 * did. In principle it should be safer to Copy the bytes of the
18564 * pointer into a PV: since the new interface is hidden behind
18565 * functions, this can be changed later if necessary. */
18566 /* Change custom_op_xop if this ever happens */
18567 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
18570 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18572 /* See if the op isn't registered, but its name *is* registered.
18573 * That implies someone is using the pre-5.14 API,where only name and
18574 * description could be registered. If so, fake up a real
18576 * We only check for an existing name, and assume no one will have
18577 * just registered a desc */
18578 if (!he && PL_custom_op_names &&
18579 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
18584 /* XXX does all this need to be shared mem? */
18585 Newxz(xop, 1, XOP);
18586 pv = SvPV(HeVAL(he), l);
18587 XopENTRY_set(xop, xop_name, savepvn(pv, l));
18588 if (PL_custom_op_descs &&
18589 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
18591 pv = SvPV(HeVAL(he), l);
18592 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
18594 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
18595 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18596 /* add magic to the SV so that the xop struct (pointed to by
18597 * SvIV(sv)) is freed. Normally a static xop is registered, but
18598 * for this backcompat hack, we've alloced one */
18599 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
18600 &custom_op_register_vtbl, NULL, 0);
18605 xop = (XOP *)&xop_null;
18607 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
18612 if(field == XOPe_xop_ptr) {
18615 const U32 flags = XopFLAGS(xop);
18616 if(flags & field) {
18618 case XOPe_xop_name:
18619 any.xop_name = xop->xop_name;
18621 case XOPe_xop_desc:
18622 any.xop_desc = xop->xop_desc;
18624 case XOPe_xop_class:
18625 any.xop_class = xop->xop_class;
18627 case XOPe_xop_peep:
18628 any.xop_peep = xop->xop_peep;
18633 "panic: custom_op_get_field(): invalid field %d\n",
18639 case XOPe_xop_name:
18640 any.xop_name = XOPd_xop_name;
18642 case XOPe_xop_desc:
18643 any.xop_desc = XOPd_xop_desc;
18645 case XOPe_xop_class:
18646 any.xop_class = XOPd_xop_class;
18648 case XOPe_xop_peep:
18649 any.xop_peep = XOPd_xop_peep;
18662 =for apidoc custom_op_register
18663 Register a custom op. See L<perlguts/"Custom Operators">.
18669 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
18673 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
18675 /* see the comment in custom_op_xop */
18676 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
18678 if (!PL_custom_ops)
18679 PL_custom_ops = newHV();
18681 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
18682 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
18687 =for apidoc core_prototype
18689 This function assigns the prototype of the named core function to C<sv>, or
18690 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
18691 C<NULL> if the core function has no prototype. C<code> is a code as returned
18692 by C<keyword()>. It must not be equal to 0.
18698 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
18701 int i = 0, n = 0, seen_question = 0, defgv = 0;
18703 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
18704 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
18705 bool nullret = FALSE;
18707 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
18711 if (!sv) sv = sv_newmortal();
18713 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
18715 switch (code < 0 ? -code : code) {
18716 case KEY_and : case KEY_chop: case KEY_chomp:
18717 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
18718 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
18719 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
18720 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
18721 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
18722 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
18723 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
18724 case KEY_x : case KEY_xor :
18725 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
18726 case KEY_glob: retsetpvs("_;", OP_GLOB);
18727 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
18728 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
18729 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
18730 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
18731 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
18733 case KEY_evalbytes:
18734 name = "entereval"; break;
18742 while (i < MAXO) { /* The slow way. */
18743 if (strEQ(name, PL_op_name[i])
18744 || strEQ(name, PL_op_desc[i]))
18746 if (nullret) { assert(opnum); *opnum = i; return NULL; }
18753 defgv = PL_opargs[i] & OA_DEFGV;
18754 oa = PL_opargs[i] >> OASHIFT;
18756 if (oa & OA_OPTIONAL && !seen_question && (
18757 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
18762 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
18763 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
18764 /* But globs are already references (kinda) */
18765 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
18769 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
18770 && !scalar_mod_type(NULL, i)) {
18775 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
18779 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
18780 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
18781 str[n-1] = '_'; defgv = 0;
18785 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
18787 sv_setpvn(sv, str, n - 1);
18788 if (opnum) *opnum = i;
18793 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
18796 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
18797 newSVOP(OP_COREARGS,0,coreargssv);
18800 PERL_ARGS_ASSERT_CORESUB_OP;
18804 return op_append_elem(OP_LINESEQ,
18807 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
18814 o = newUNOP(OP_AVHVSWITCH,0,argop);
18815 o->op_private = opnum-OP_EACH;
18817 case OP_SELECT: /* which represents OP_SSELECT as well */
18822 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
18823 newSVOP(OP_CONST, 0, newSVuv(1))
18825 coresub_op(newSVuv((UV)OP_SSELECT), 0,
18827 coresub_op(coreargssv, 0, OP_SELECT)
18831 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
18833 return op_append_elem(
18836 opnum == OP_WANTARRAY || opnum == OP_RUNCV
18837 ? OPpOFFBYONE << 8 : 0)
18839 case OA_BASEOP_OR_UNOP:
18840 if (opnum == OP_ENTEREVAL) {
18841 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
18842 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
18844 else o = newUNOP(opnum,0,argop);
18845 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
18848 if (is_handle_constructor(o, 1))
18849 argop->op_private |= OPpCOREARGS_DEREF1;
18850 if (scalar_mod_type(NULL, opnum))
18851 argop->op_private |= OPpCOREARGS_SCALARMOD;
18855 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
18856 if (is_handle_constructor(o, 2))
18857 argop->op_private |= OPpCOREARGS_DEREF2;
18858 if (opnum == OP_SUBSTR) {
18859 o->op_private |= OPpMAYBE_LVSUB;
18868 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
18869 SV * const *new_const_svp)
18871 const char *hvname;
18872 bool is_const = !!CvCONST(old_cv);
18873 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
18875 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
18877 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
18879 /* They are 2 constant subroutines generated from
18880 the same constant. This probably means that
18881 they are really the "same" proxy subroutine
18882 instantiated in 2 places. Most likely this is
18883 when a constant is exported twice. Don't warn.
18886 (ckWARN(WARN_REDEFINE)
18888 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
18889 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
18890 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
18891 strEQ(hvname, "autouse"))
18895 && ckWARN_d(WARN_REDEFINE)
18896 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
18899 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
18901 ? "Constant subroutine %" SVf " redefined"
18902 : "Subroutine %" SVf " redefined",
18907 =for apidoc_section $hook
18909 These functions provide convenient and thread-safe means of manipulating
18916 =for apidoc wrap_op_checker
18918 Puts a C function into the chain of check functions for a specified op
18919 type. This is the preferred way to manipulate the L</PL_check> array.
18920 C<opcode> specifies which type of op is to be affected. C<new_checker>
18921 is a pointer to the C function that is to be added to that opcode's
18922 check chain, and C<old_checker_p> points to the storage location where a
18923 pointer to the next function in the chain will be stored. The value of
18924 C<new_checker> is written into the L</PL_check> array, while the value
18925 previously stored there is written to C<*old_checker_p>.
18927 L</PL_check> is global to an entire process, and a module wishing to
18928 hook op checking may find itself invoked more than once per process,
18929 typically in different threads. To handle that situation, this function
18930 is idempotent. The location C<*old_checker_p> must initially (once
18931 per process) contain a null pointer. A C variable of static duration
18932 (declared at file scope, typically also marked C<static> to give
18933 it internal linkage) will be implicitly initialised appropriately,
18934 if it does not have an explicit initialiser. This function will only
18935 actually modify the check chain if it finds C<*old_checker_p> to be null.
18936 This function is also thread safe on the small scale. It uses appropriate
18937 locking to avoid race conditions in accessing L</PL_check>.
18939 When this function is called, the function referenced by C<new_checker>
18940 must be ready to be called, except for C<*old_checker_p> being unfilled.
18941 In a threading situation, C<new_checker> may be called immediately,
18942 even before this function has returned. C<*old_checker_p> will always
18943 be appropriately set before C<new_checker> is called. If C<new_checker>
18944 decides not to do anything special with an op that it is given (which
18945 is the usual case for most uses of op check hooking), it must chain the
18946 check function referenced by C<*old_checker_p>.
18948 Taken all together, XS code to hook an op checker should typically look
18949 something like this:
18951 static Perl_check_t nxck_frob;
18952 static OP *myck_frob(pTHX_ OP *op) {
18954 op = nxck_frob(aTHX_ op);
18959 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
18961 If you want to influence compilation of calls to a specific subroutine,
18962 then use L</cv_set_call_checker_flags> rather than hooking checking of
18963 all C<entersub> ops.
18969 Perl_wrap_op_checker(pTHX_ Optype opcode,
18970 Perl_check_t new_checker, Perl_check_t *old_checker_p)
18973 PERL_UNUSED_CONTEXT;
18974 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
18975 if (*old_checker_p) return;
18976 OP_CHECK_MUTEX_LOCK;
18977 if (!*old_checker_p) {
18978 *old_checker_p = PL_check[opcode];
18979 PL_check[opcode] = new_checker;
18981 OP_CHECK_MUTEX_UNLOCK;
18986 /* Efficient sub that returns a constant scalar value. */
18988 const_sv_xsub(pTHX_ CV* cv)
18991 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
18992 PERL_UNUSED_ARG(items);
19002 const_av_xsub(pTHX_ CV* cv)
19005 AV * const av = MUTABLE_AV(XSANY.any_ptr);
19013 if (SvRMAGICAL(av))
19014 Perl_croak(aTHX_ "Magical list constants are not supported");
19015 if (GIMME_V != G_LIST) {
19017 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
19020 EXTEND(SP, AvFILLp(av)+1);
19021 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
19022 XSRETURN(AvFILLp(av)+1);
19025 /* Copy an existing cop->cop_warnings field.
19026 * If it's one of the standard addresses, just re-use the address.
19027 * This is the e implementation for the DUP_WARNINGS() macro
19031 Perl_dup_warnings(pTHX_ STRLEN* warnings)
19034 STRLEN *new_warnings;
19036 if (warnings == NULL || specialWARN(warnings))
19039 size = sizeof(*warnings) + *warnings;
19041 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
19042 Copy(warnings, new_warnings, size, char);
19043 return new_warnings;
19047 * ex: set ts=8 sts=4 sw=4 et: