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 Perl_op_refcnt_lock(pTHX)
1439 PERL_TSA_ACQUIRE(PL_op_mutex)
1441 PERL_UNUSED_CONTEXT;
1446 Perl_op_refcnt_unlock(pTHX)
1447 PERL_TSA_RELEASE(PL_op_mutex)
1449 PERL_UNUSED_CONTEXT;
1455 =for apidoc op_sibling_splice
1457 A general function for editing the structure of an existing chain of
1458 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1459 you to delete zero or more sequential nodes, replacing them with zero or
1460 more different nodes. Performs the necessary op_first/op_last
1461 housekeeping on the parent node and op_sibling manipulation on the
1462 children. The last deleted node will be marked as the last node by
1463 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1465 Note that op_next is not manipulated, and nodes are not freed; that is the
1466 responsibility of the caller. It also won't create a new list op for an
1467 empty list etc; use higher-level functions like op_append_elem() for that.
1469 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1470 the splicing doesn't affect the first or last op in the chain.
1472 C<start> is the node preceding the first node to be spliced. Node(s)
1473 following it will be deleted, and ops will be inserted after it. If it is
1474 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1477 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1478 If -1 or greater than or equal to the number of remaining kids, all
1479 remaining kids are deleted.
1481 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1482 If C<NULL>, no nodes are inserted.
1484 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1489 action before after returns
1490 ------ ----- ----- -------
1493 splice(P, A, 2, X-Y-Z) | | B-C
1497 splice(P, NULL, 1, X-Y) | | A
1501 splice(P, NULL, 3, NULL) | | A-B-C
1505 splice(P, B, 0, X-Y) | | NULL
1509 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1510 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1516 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1520 OP *last_del = NULL;
1521 OP *last_ins = NULL;
1524 first = OpSIBLING(start);
1528 first = cLISTOPx(parent)->op_first;
1530 assert(del_count >= -1);
1532 if (del_count && first) {
1534 while (--del_count && OpHAS_SIBLING(last_del))
1535 last_del = OpSIBLING(last_del);
1536 rest = OpSIBLING(last_del);
1537 OpLASTSIB_set(last_del, NULL);
1544 while (OpHAS_SIBLING(last_ins))
1545 last_ins = OpSIBLING(last_ins);
1546 OpMAYBESIB_set(last_ins, rest, NULL);
1552 OpMAYBESIB_set(start, insert, NULL);
1556 cLISTOPx(parent)->op_first = insert;
1558 parent->op_flags |= OPf_KIDS;
1560 parent->op_flags &= ~OPf_KIDS;
1564 /* update op_last etc */
1571 /* ought to use OP_CLASS(parent) here, but that can't handle
1572 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1574 type = parent->op_type;
1575 if (type == OP_CUSTOM) {
1577 type = XopENTRYCUSTOM(parent, xop_class);
1580 if (type == OP_NULL)
1581 type = parent->op_targ;
1582 type = PL_opargs[type] & OA_CLASS_MASK;
1585 lastop = last_ins ? last_ins : start ? start : NULL;
1586 if ( type == OA_BINOP
1587 || type == OA_LISTOP
1591 cLISTOPx(parent)->op_last = lastop;
1594 OpLASTSIB_set(lastop, parent);
1596 return last_del ? first : NULL;
1599 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1603 =for apidoc op_parent
1605 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1611 Perl_op_parent(OP *o)
1613 PERL_ARGS_ASSERT_OP_PARENT;
1614 while (OpHAS_SIBLING(o))
1616 return o->op_sibparent;
1619 /* replace the sibling following start with a new UNOP, which becomes
1620 * the parent of the original sibling; e.g.
1622 * op_sibling_newUNOP(P, A, unop-args...)
1630 * where U is the new UNOP.
1632 * parent and start args are the same as for op_sibling_splice();
1633 * type and flags args are as newUNOP().
1635 * Returns the new UNOP.
1639 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1643 kid = op_sibling_splice(parent, start, 1, NULL);
1644 newop = newUNOP(type, flags, kid);
1645 op_sibling_splice(parent, start, 0, newop);
1650 /* lowest-level newLOGOP-style function - just allocates and populates
1651 * the struct. Higher-level stuff should be done by S_new_logop() /
1652 * newLOGOP(). This function exists mainly to avoid op_first assignment
1653 * being spread throughout this file.
1657 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1661 NewOp(1101, logop, 1, LOGOP);
1662 OpTYPE_set(logop, type);
1663 logop->op_first = first;
1664 logop->op_other = other;
1666 logop->op_flags = OPf_KIDS;
1667 while (kid && OpHAS_SIBLING(kid))
1668 kid = OpSIBLING(kid);
1670 OpLASTSIB_set(kid, (OP*)logop);
1675 /* Contextualizers */
1678 =for apidoc op_contextualize
1680 Applies a syntactic context to an op tree representing an expression.
1681 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_LIST>,
1682 or C<G_VOID> to specify the context to apply. The modified op tree
1689 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1691 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1693 case G_SCALAR: return scalar(o);
1694 case G_LIST: return list(o);
1695 case G_VOID: return scalarvoid(o);
1697 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1704 =for apidoc op_linklist
1705 This function is the implementation of the L</LINKLIST> macro. It should
1706 not be called directly.
1713 Perl_op_linklist(pTHX_ OP *o)
1720 PERL_ARGS_ASSERT_OP_LINKLIST;
1723 /* Descend down the tree looking for any unprocessed subtrees to
1726 if (o->op_flags & OPf_KIDS) {
1727 o = cUNOPo->op_first;
1730 o->op_next = o; /* leaf node; link to self initially */
1733 /* if we're at the top level, there either weren't any children
1734 * to process, or we've worked our way back to the top. */
1738 /* o is now processed. Next, process any sibling subtrees */
1740 if (OpHAS_SIBLING(o)) {
1745 /* Done all the subtrees at this level. Go back up a level and
1746 * link the parent in with all its (processed) children.
1749 o = o->op_sibparent;
1750 assert(!o->op_next);
1751 prevp = &(o->op_next);
1752 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1754 *prevp = kid->op_next;
1755 prevp = &(kid->op_next);
1756 kid = OpSIBLING(kid);
1764 S_scalarkids(pTHX_ OP *o)
1766 if (o && o->op_flags & OPf_KIDS) {
1768 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1775 S_scalarboolean(pTHX_ OP *o)
1777 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1779 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1780 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1781 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1782 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1783 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1784 if (ckWARN(WARN_SYNTAX)) {
1785 const line_t oldline = CopLINE(PL_curcop);
1787 if (PL_parser && PL_parser->copline != NOLINE) {
1788 /* This ensures that warnings are reported at the first line
1789 of the conditional, not the last. */
1790 CopLINE_set(PL_curcop, PL_parser->copline);
1792 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1793 CopLINE_set(PL_curcop, oldline);
1800 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1803 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1804 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1806 const char funny = o->op_type == OP_PADAV
1807 || o->op_type == OP_RV2AV ? '@' : '%';
1808 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1810 if (cUNOPo->op_first->op_type != OP_GV
1811 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1813 return varname(gv, funny, 0, NULL, 0, subscript_type);
1816 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1821 S_op_varname(pTHX_ const OP *o)
1823 return S_op_varname_subscript(aTHX_ o, 1);
1827 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1828 { /* or not so pretty :-) */
1829 if (o->op_type == OP_CONST) {
1831 if (SvPOK(*retsv)) {
1833 *retsv = sv_newmortal();
1834 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1835 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1837 else if (!SvOK(*retsv))
1840 else *retpv = "...";
1844 S_scalar_slice_warning(pTHX_ const OP *o)
1847 const bool h = o->op_type == OP_HSLICE
1848 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1854 SV *keysv = NULL; /* just to silence compiler warnings */
1855 const char *key = NULL;
1857 if (!(o->op_private & OPpSLICEWARNING))
1859 if (PL_parser && PL_parser->error_count)
1860 /* This warning can be nonsensical when there is a syntax error. */
1863 kid = cLISTOPo->op_first;
1864 kid = OpSIBLING(kid); /* get past pushmark */
1865 /* weed out false positives: any ops that can return lists */
1866 switch (kid->op_type) {
1892 /* Don't warn if we have a nulled list either. */
1893 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1896 assert(OpSIBLING(kid));
1897 name = S_op_varname(aTHX_ OpSIBLING(kid));
1898 if (!name) /* XS module fiddling with the op tree */
1900 S_op_pretty(aTHX_ kid, &keysv, &key);
1901 assert(SvPOK(name));
1902 sv_chop(name,SvPVX(name)+1);
1904 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1905 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1906 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1908 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1909 lbrack, key, rbrack);
1911 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1912 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1913 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1915 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1916 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1921 /* apply scalar context to the o subtree */
1924 Perl_scalar(pTHX_ OP *o)
1929 OP *next_kid = NULL; /* what op (if any) to process next */
1932 /* assumes no premature commitment */
1933 if (!o || (PL_parser && PL_parser->error_count)
1934 || (o->op_flags & OPf_WANT)
1935 || o->op_type == OP_RETURN)
1940 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1942 switch (o->op_type) {
1944 scalar(cBINOPo->op_first);
1945 /* convert what initially looked like a list repeat into a
1946 * scalar repeat, e.g. $s = (1) x $n
1948 if (o->op_private & OPpREPEAT_DOLIST) {
1949 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1950 assert(kid->op_type == OP_PUSHMARK);
1951 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1952 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1953 o->op_private &=~ OPpREPEAT_DOLIST;
1961 /* impose scalar context on everything except the condition */
1962 next_kid = OpSIBLING(cUNOPo->op_first);
1966 if (o->op_flags & OPf_KIDS)
1967 next_kid = cUNOPo->op_first; /* do all kids */
1970 /* the children of these ops are usually a list of statements,
1971 * except the leaves, whose first child is a corresponding enter
1976 kid = cLISTOPo->op_first;
1980 kid = cLISTOPo->op_first;
1982 kid = OpSIBLING(kid);
1985 OP *sib = OpSIBLING(kid);
1986 /* Apply void context to all kids except the last, which
1987 * is scalar (ignoring a trailing ex-nextstate in determining
1988 * if it's the last kid). E.g.
1989 * $scalar = do { void; void; scalar }
1990 * Except that 'when's are always scalar, e.g.
1991 * $scalar = do { given(..) {
1992 * when (..) { scalar }
1993 * when (..) { scalar }
1998 || ( !OpHAS_SIBLING(sib)
1999 && sib->op_type == OP_NULL
2000 && ( sib->op_targ == OP_NEXTSTATE
2001 || sib->op_targ == OP_DBSTATE )
2005 /* tail call optimise calling scalar() on the last kid */
2009 else if (kid->op_type == OP_LEAVEWHEN)
2015 NOT_REACHED; /* NOTREACHED */
2019 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
2025 /* Warn about scalar context */
2026 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
2027 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
2030 const char *key = NULL;
2032 /* This warning can be nonsensical when there is a syntax error. */
2033 if (PL_parser && PL_parser->error_count)
2036 if (!ckWARN(WARN_SYNTAX)) break;
2038 kid = cLISTOPo->op_first;
2039 kid = OpSIBLING(kid); /* get past pushmark */
2040 assert(OpSIBLING(kid));
2041 name = S_op_varname(aTHX_ OpSIBLING(kid));
2042 if (!name) /* XS module fiddling with the op tree */
2044 S_op_pretty(aTHX_ kid, &keysv, &key);
2045 assert(SvPOK(name));
2046 sv_chop(name,SvPVX(name)+1);
2048 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2049 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2050 "%%%" SVf "%c%s%c in scalar context better written "
2051 "as $%" SVf "%c%s%c",
2052 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
2053 lbrack, key, rbrack);
2055 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2056 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2057 "%%%" SVf "%c%" SVf "%c in scalar context better "
2058 "written as $%" SVf "%c%" SVf "%c",
2059 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
2060 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2064 /* If next_kid is set, someone in the code above wanted us to process
2065 * that kid and all its remaining siblings. Otherwise, work our way
2066 * back up the tree */
2070 return top_op; /* at top; no parents/siblings to try */
2071 if (OpHAS_SIBLING(o))
2072 next_kid = o->op_sibparent;
2074 o = o->op_sibparent; /*try parent's next sibling */
2075 switch (o->op_type) {
2081 /* should really restore PL_curcop to its old value, but
2082 * setting it to PL_compiling is better than do nothing */
2083 PL_curcop = &PL_compiling;
2092 /* apply void context to the optree arg */
2095 Perl_scalarvoid(pTHX_ OP *arg)
2101 PERL_ARGS_ASSERT_SCALARVOID;
2105 SV *useless_sv = NULL;
2106 const char* useless = NULL;
2107 OP * next_kid = NULL;
2109 if (o->op_type == OP_NEXTSTATE
2110 || o->op_type == OP_DBSTATE
2111 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2112 || o->op_targ == OP_DBSTATE)))
2113 PL_curcop = (COP*)o; /* for warning below */
2115 /* assumes no premature commitment */
2116 want = o->op_flags & OPf_WANT;
2117 if ((want && want != OPf_WANT_SCALAR)
2118 || (PL_parser && PL_parser->error_count)
2119 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2124 if ((o->op_private & OPpTARGET_MY)
2125 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2127 /* newASSIGNOP has already applied scalar context, which we
2128 leave, as if this op is inside SASSIGN. */
2132 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2134 switch (o->op_type) {
2136 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2140 if (o->op_flags & OPf_STACKED)
2142 if (o->op_type == OP_REPEAT)
2143 scalar(cBINOPo->op_first);
2146 if ((o->op_flags & OPf_STACKED) &&
2147 !(o->op_private & OPpCONCAT_NESTED))
2151 if (o->op_private == 4)
2186 case OP_GETSOCKNAME:
2187 case OP_GETPEERNAME:
2192 case OP_GETPRIORITY:
2217 useless = OP_DESC(o);
2227 case OP_AELEMFAST_LEX:
2231 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2232 /* Otherwise it's "Useless use of grep iterator" */
2233 useless = OP_DESC(o);
2237 if (!(o->op_private & OPpSPLIT_ASSIGN))
2238 useless = OP_DESC(o);
2242 kid = cUNOPo->op_first;
2243 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2244 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2247 useless = "negative pattern binding (!~)";
2251 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2252 useless = "non-destructive substitution (s///r)";
2256 useless = "non-destructive transliteration (tr///r)";
2263 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2264 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2265 useless = "a variable";
2270 if (cSVOPo->op_private & OPpCONST_STRICT)
2271 no_bareword_allowed(o);
2273 if (ckWARN(WARN_VOID)) {
2275 /* don't warn on optimised away booleans, eg
2276 * use constant Foo, 5; Foo || print; */
2277 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2279 /* the constants 0 and 1 are permitted as they are
2280 conventionally used as dummies in constructs like
2281 1 while some_condition_with_side_effects; */
2282 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2284 else if (SvPOK(sv)) {
2285 SV * const dsv = newSVpvs("");
2287 = Perl_newSVpvf(aTHX_
2289 pv_pretty(dsv, SvPVX_const(sv),
2290 SvCUR(sv), 32, NULL, NULL,
2292 | PERL_PV_ESCAPE_NOCLEAR
2293 | PERL_PV_ESCAPE_UNI_DETECT));
2294 SvREFCNT_dec_NN(dsv);
2296 else if (SvOK(sv)) {
2297 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2300 useless = "a constant (undef)";
2303 op_null(o); /* don't execute or even remember it */
2307 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2311 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2315 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2319 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2324 UNOP *refgen, *rv2cv;
2327 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2330 rv2gv = ((BINOP *)o)->op_last;
2331 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2334 refgen = (UNOP *)((BINOP *)o)->op_first;
2336 if (!refgen || (refgen->op_type != OP_REFGEN
2337 && refgen->op_type != OP_SREFGEN))
2340 exlist = (LISTOP *)refgen->op_first;
2341 if (!exlist || exlist->op_type != OP_NULL
2342 || exlist->op_targ != OP_LIST)
2345 if (exlist->op_first->op_type != OP_PUSHMARK
2346 && exlist->op_first != exlist->op_last)
2349 rv2cv = (UNOP*)exlist->op_last;
2351 if (rv2cv->op_type != OP_RV2CV)
2354 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2355 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2356 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2358 o->op_private |= OPpASSIGN_CV_TO_GV;
2359 rv2gv->op_private |= OPpDONT_INIT_GV;
2360 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2372 kid = cLOGOPo->op_first;
2373 if (kid->op_type == OP_NOT
2374 && (kid->op_flags & OPf_KIDS)) {
2375 if (o->op_type == OP_AND) {
2376 OpTYPE_set(o, OP_OR);
2378 OpTYPE_set(o, OP_AND);
2388 next_kid = OpSIBLING(cUNOPo->op_first);
2392 if (o->op_flags & OPf_STACKED)
2399 if (!(o->op_flags & OPf_KIDS))
2410 next_kid = cLISTOPo->op_first;
2413 /* If the first kid after pushmark is something that the padrange
2414 optimisation would reject, then null the list and the pushmark.
2416 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2417 && ( !(kid = OpSIBLING(kid))
2418 || ( kid->op_type != OP_PADSV
2419 && kid->op_type != OP_PADAV
2420 && kid->op_type != OP_PADHV)
2421 || kid->op_private & ~OPpLVAL_INTRO
2422 || !(kid = OpSIBLING(kid))
2423 || ( kid->op_type != OP_PADSV
2424 && kid->op_type != OP_PADAV
2425 && kid->op_type != OP_PADHV)
2426 || kid->op_private & ~OPpLVAL_INTRO)
2428 op_null(cUNOPo->op_first); /* NULL the pushmark */
2429 op_null(o); /* NULL the list */
2441 /* mortalise it, in case warnings are fatal. */
2442 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2443 "Useless use of %" SVf " in void context",
2444 SVfARG(sv_2mortal(useless_sv)));
2447 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2448 "Useless use of %s in void context",
2453 /* if a kid hasn't been nominated to process, continue with the
2454 * next sibling, or if no siblings left, go back to the parent's
2455 * siblings and so on
2459 return arg; /* at top; no parents/siblings to try */
2460 if (OpHAS_SIBLING(o))
2461 next_kid = o->op_sibparent;
2463 o = o->op_sibparent; /*try parent's next sibling */
2473 S_listkids(pTHX_ OP *o)
2475 if (o && o->op_flags & OPf_KIDS) {
2477 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2484 /* apply list context to the o subtree */
2487 Perl_list(pTHX_ OP *o)
2492 OP *next_kid = NULL; /* what op (if any) to process next */
2496 /* assumes no premature commitment */
2497 if (!o || (o->op_flags & OPf_WANT)
2498 || (PL_parser && PL_parser->error_count)
2499 || o->op_type == OP_RETURN)
2504 if ((o->op_private & OPpTARGET_MY)
2505 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2507 goto do_next; /* As if inside SASSIGN */
2510 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2512 switch (o->op_type) {
2514 if (o->op_private & OPpREPEAT_DOLIST
2515 && !(o->op_flags & OPf_STACKED))
2517 list(cBINOPo->op_first);
2518 kid = cBINOPo->op_last;
2519 /* optimise away (.....) x 1 */
2520 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2521 && SvIVX(kSVOP_sv) == 1)
2523 op_null(o); /* repeat */
2524 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2526 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2534 /* impose list context on everything except the condition */
2535 next_kid = OpSIBLING(cUNOPo->op_first);
2539 if (!(o->op_flags & OPf_KIDS))
2541 /* possibly flatten 1..10 into a constant array */
2542 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2543 list(cBINOPo->op_first);
2544 gen_constant_list(o);
2547 next_kid = cUNOPo->op_first; /* do all kids */
2551 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2552 op_null(cUNOPo->op_first); /* NULL the pushmark */
2553 op_null(o); /* NULL the list */
2555 if (o->op_flags & OPf_KIDS)
2556 next_kid = cUNOPo->op_first; /* do all kids */
2559 /* the children of these ops are usually a list of statements,
2560 * except the leaves, whose first child is a corresponding enter
2564 kid = cLISTOPo->op_first;
2568 kid = cLISTOPo->op_first;
2570 kid = OpSIBLING(kid);
2573 OP *sib = OpSIBLING(kid);
2574 /* Apply void context to all kids except the last, which
2576 * @a = do { void; void; list }
2577 * Except that 'when's are always list context, e.g.
2578 * @a = do { given(..) {
2579 * when (..) { list }
2580 * when (..) { list }
2585 /* tail call optimise calling list() on the last kid */
2589 else if (kid->op_type == OP_LEAVEWHEN)
2595 NOT_REACHED; /* NOTREACHED */
2600 /* If next_kid is set, someone in the code above wanted us to process
2601 * that kid and all its remaining siblings. Otherwise, work our way
2602 * back up the tree */
2606 return top_op; /* at top; no parents/siblings to try */
2607 if (OpHAS_SIBLING(o))
2608 next_kid = o->op_sibparent;
2610 o = o->op_sibparent; /*try parent's next sibling */
2611 switch (o->op_type) {
2617 /* should really restore PL_curcop to its old value, but
2618 * setting it to PL_compiling is better than do nothing */
2619 PL_curcop = &PL_compiling;
2629 /* apply void context to non-final ops of a sequence */
2632 S_voidnonfinal(pTHX_ OP *o)
2635 const OPCODE type = o->op_type;
2637 if (type == OP_LINESEQ || type == OP_SCOPE ||
2638 type == OP_LEAVE || type == OP_LEAVETRY)
2640 OP *kid = cLISTOPo->op_first, *sib;
2641 if(type == OP_LEAVE) {
2642 /* Don't put the OP_ENTER in void context */
2643 assert(kid->op_type == OP_ENTER);
2644 kid = OpSIBLING(kid);
2646 for (; kid; kid = sib) {
2647 if ((sib = OpSIBLING(kid))
2648 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2649 || ( sib->op_targ != OP_NEXTSTATE
2650 && sib->op_targ != OP_DBSTATE )))
2655 PL_curcop = &PL_compiling;
2657 o->op_flags &= ~OPf_PARENS;
2658 if (PL_hints & HINT_BLOCK_SCOPE)
2659 o->op_flags |= OPf_PARENS;
2662 o = newOP(OP_STUB, 0);
2667 S_modkids(pTHX_ OP *o, I32 type)
2669 if (o && o->op_flags & OPf_KIDS) {
2671 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2672 op_lvalue(kid, type);
2678 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2679 * const fields. Also, convert CONST keys to HEK-in-SVs.
2680 * rop is the op that retrieves the hash;
2681 * key_op is the first key
2682 * real if false, only check (and possibly croak); don't update op
2686 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2692 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2694 if (rop->op_first->op_type == OP_PADSV)
2695 /* @$hash{qw(keys here)} */
2696 rop = (UNOP*)rop->op_first;
2698 /* @{$hash}{qw(keys here)} */
2699 if (rop->op_first->op_type == OP_SCOPE
2700 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2702 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2709 lexname = NULL; /* just to silence compiler warnings */
2710 fields = NULL; /* just to silence compiler warnings */
2714 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2715 SvPAD_TYPED(lexname))
2716 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2717 && isGV(*fields) && GvHV(*fields);
2719 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2721 if (key_op->op_type != OP_CONST)
2723 svp = cSVOPx_svp(key_op);
2725 /* make sure it's not a bareword under strict subs */
2726 if (key_op->op_private & OPpCONST_BARE &&
2727 key_op->op_private & OPpCONST_STRICT)
2729 no_bareword_allowed((OP*)key_op);
2732 /* Make the CONST have a shared SV */
2733 if ( !SvIsCOW_shared_hash(sv = *svp)
2734 && SvTYPE(sv) < SVt_PVMG
2740 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2741 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2742 SvREFCNT_dec_NN(sv);
2747 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2749 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2750 "in variable %" PNf " of type %" HEKf,
2751 SVfARG(*svp), PNfARG(lexname),
2752 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2757 /* info returned by S_sprintf_is_multiconcatable() */
2759 struct sprintf_ismc_info {
2760 SSize_t nargs; /* num of args to sprintf (not including the format) */
2761 char *start; /* start of raw format string */
2762 char *end; /* bytes after end of raw format string */
2763 STRLEN total_len; /* total length (in bytes) of format string, not
2764 including '%s' and half of '%%' */
2765 STRLEN variant; /* number of bytes by which total_len_p would grow
2766 if upgraded to utf8 */
2767 bool utf8; /* whether the format is utf8 */
2771 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2772 * i.e. its format argument is a const string with only '%s' and '%%'
2773 * formats, and the number of args is known, e.g.
2774 * sprintf "a=%s f=%s", $a[0], scalar(f());
2776 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2778 * If successful, the sprintf_ismc_info struct pointed to by info will be
2783 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2785 OP *pm, *constop, *kid;
2788 SSize_t nargs, nformats;
2789 STRLEN cur, total_len, variant;
2792 /* if sprintf's behaviour changes, die here so that someone
2793 * can decide whether to enhance this function or skip optimising
2794 * under those new circumstances */
2795 assert(!(o->op_flags & OPf_STACKED));
2796 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2797 assert(!(o->op_private & ~OPpARG4_MASK));
2799 pm = cUNOPo->op_first;
2800 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2802 constop = OpSIBLING(pm);
2803 if (!constop || constop->op_type != OP_CONST)
2805 sv = cSVOPx_sv(constop);
2806 if (SvMAGICAL(sv) || !SvPOK(sv))
2812 /* Scan format for %% and %s and work out how many %s there are.
2813 * Abandon if other format types are found.
2820 for (p = s; p < e; p++) {
2823 if (!UTF8_IS_INVARIANT(*p))
2829 return FALSE; /* lone % at end gives "Invalid conversion" */
2838 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2841 utf8 = cBOOL(SvUTF8(sv));
2845 /* scan args; they must all be in scalar cxt */
2848 kid = OpSIBLING(constop);
2851 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2854 kid = OpSIBLING(kid);
2857 if (nargs != nformats)
2858 return FALSE; /* e.g. sprintf("%s%s", $a); */
2861 info->nargs = nargs;
2864 info->total_len = total_len;
2865 info->variant = variant;
2873 /* S_maybe_multiconcat():
2875 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2876 * convert it (and its children) into an OP_MULTICONCAT. See the code
2877 * comments just before pp_multiconcat() for the full details of what
2878 * OP_MULTICONCAT supports.
2880 * Basically we're looking for an optree with a chain of OP_CONCATS down
2881 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2882 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2890 * STRINGIFY -- PADSV[$x]
2893 * ex-PUSHMARK -- CONCAT/S
2895 * CONCAT/S -- PADSV[$d]
2897 * CONCAT -- CONST["-"]
2899 * PADSV[$a] -- PADSV[$b]
2901 * Note that at this stage the OP_SASSIGN may have already been optimised
2902 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2906 S_maybe_multiconcat(pTHX_ OP *o)
2908 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2909 OP *topop; /* the top-most op in the concat tree (often equals o,
2910 unless there are assign/stringify ops above it */
2911 OP *parentop; /* the parent op of topop (or itself if no parent) */
2912 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2913 OP *targetop; /* the op corresponding to target=... or target.=... */
2914 OP *stringop; /* the OP_STRINGIFY op, if any */
2915 OP *nextop; /* used for recreating the op_next chain without consts */
2916 OP *kid; /* general-purpose op pointer */
2918 UNOP_AUX_item *lenp;
2919 char *const_str, *p;
2920 struct sprintf_ismc_info sprintf_info;
2922 /* store info about each arg in args[];
2923 * toparg is the highest used slot; argp is a general
2924 * pointer to args[] slots */
2926 void *p; /* initially points to const sv (or null for op);
2927 later, set to SvPV(constsv), with ... */
2928 STRLEN len; /* ... len set to SvPV(..., len) */
2929 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2933 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2936 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2937 the last-processed arg will the LHS of one,
2938 as args are processed in reverse order */
2939 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2940 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2941 U8 flags = 0; /* what will become the op_flags and ... */
2942 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2943 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2944 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2945 bool prev_was_const = FALSE; /* previous arg was a const */
2947 /* -----------------------------------------------------------------
2950 * Examine the optree non-destructively to determine whether it's
2951 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2952 * information about the optree in args[].
2962 assert( o->op_type == OP_SASSIGN
2963 || o->op_type == OP_CONCAT
2964 || o->op_type == OP_SPRINTF
2965 || o->op_type == OP_STRINGIFY);
2967 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2969 /* first see if, at the top of the tree, there is an assign,
2970 * append and/or stringify */
2972 if (topop->op_type == OP_SASSIGN) {
2974 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2976 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2978 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2981 topop = cBINOPo->op_first;
2982 targetop = OpSIBLING(topop);
2983 if (!targetop) /* probably some sort of syntax error */
2986 /* don't optimise away assign in 'local $foo = ....' */
2987 if ( (targetop->op_private & OPpLVAL_INTRO)
2988 /* these are the common ops which do 'local', but
2990 && ( targetop->op_type == OP_GVSV
2991 || targetop->op_type == OP_RV2SV
2992 || targetop->op_type == OP_AELEM
2993 || targetop->op_type == OP_HELEM
2998 else if ( topop->op_type == OP_CONCAT
2999 && (topop->op_flags & OPf_STACKED)
3000 && (!(topop->op_private & OPpCONCAT_NESTED))
3005 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
3006 * decide what to do about it */
3007 assert(!(o->op_private & OPpTARGET_MY));
3009 /* barf on unknown flags */
3010 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
3011 private_flags |= OPpMULTICONCAT_APPEND;
3012 targetop = cBINOPo->op_first;
3014 topop = OpSIBLING(targetop);
3016 /* $x .= <FOO> gets optimised to rcatline instead */
3017 if (topop->op_type == OP_READLINE)
3022 /* Can targetop (the LHS) if it's a padsv, be optimised
3023 * away and use OPpTARGET_MY instead?
3025 if ( (targetop->op_type == OP_PADSV)
3026 && !(targetop->op_private & OPpDEREF)
3027 && !(targetop->op_private & OPpPAD_STATE)
3028 /* we don't support 'my $x .= ...' */
3029 && ( o->op_type == OP_SASSIGN
3030 || !(targetop->op_private & OPpLVAL_INTRO))
3035 if (topop->op_type == OP_STRINGIFY) {
3036 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
3040 /* barf on unknown flags */
3041 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
3043 if ((topop->op_private & OPpTARGET_MY)) {
3044 if (o->op_type == OP_SASSIGN)
3045 return; /* can't have two assigns */
3049 private_flags |= OPpMULTICONCAT_STRINGIFY;
3051 topop = cBINOPx(topop)->op_first;
3052 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
3053 topop = OpSIBLING(topop);
3056 if (topop->op_type == OP_SPRINTF) {
3057 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
3059 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
3060 nargs = sprintf_info.nargs;
3061 total_len = sprintf_info.total_len;
3062 variant = sprintf_info.variant;
3063 utf8 = sprintf_info.utf8;
3065 private_flags |= OPpMULTICONCAT_FAKE;
3067 /* we have an sprintf op rather than a concat optree.
3068 * Skip most of the code below which is associated with
3069 * processing that optree. We also skip phase 2, determining
3070 * whether its cost effective to optimise, since for sprintf,
3071 * multiconcat is *always* faster */
3074 /* note that even if the sprintf itself isn't multiconcatable,
3075 * the expression as a whole may be, e.g. in
3076 * $x .= sprintf("%d",...)
3077 * the sprintf op will be left as-is, but the concat/S op may
3078 * be upgraded to multiconcat
3081 else if (topop->op_type == OP_CONCAT) {
3082 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
3085 if ((topop->op_private & OPpTARGET_MY)) {
3086 if (o->op_type == OP_SASSIGN || targmyop)
3087 return; /* can't have two assigns */
3092 /* Is it safe to convert a sassign/stringify/concat op into
3094 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
3095 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
3096 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3097 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
3098 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
3099 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3100 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
3101 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3103 /* Now scan the down the tree looking for a series of
3104 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3105 * stacked). For example this tree:
3110 * CONCAT/STACKED -- EXPR5
3112 * CONCAT/STACKED -- EXPR4
3118 * corresponds to an expression like
3120 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3122 * Record info about each EXPR in args[]: in particular, whether it is
3123 * a stringifiable OP_CONST and if so what the const sv is.
3125 * The reason why the last concat can't be STACKED is the difference
3128 * ((($a .= $a) .= $a) .= $a) .= $a
3131 * $a . $a . $a . $a . $a
3133 * The main difference between the optrees for those two constructs
3134 * is the presence of the last STACKED. As well as modifying $a,
3135 * the former sees the changed $a between each concat, so if $s is
3136 * initially 'a', the first returns 'a' x 16, while the latter returns
3137 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3147 if ( kid->op_type == OP_CONCAT
3151 k1 = cUNOPx(kid)->op_first;
3153 /* shouldn't happen except maybe after compile err? */
3157 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3158 if (kid->op_private & OPpTARGET_MY)
3161 stacked_last = (kid->op_flags & OPf_STACKED);
3173 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3174 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3176 /* At least two spare slots are needed to decompose both
3177 * concat args. If there are no slots left, continue to
3178 * examine the rest of the optree, but don't push new values
3179 * on args[]. If the optree as a whole is legal for conversion
3180 * (in particular that the last concat isn't STACKED), then
3181 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3182 * can be converted into an OP_MULTICONCAT now, with the first
3183 * child of that op being the remainder of the optree -
3184 * which may itself later be converted to a multiconcat op
3188 /* the last arg is the rest of the optree */
3193 else if ( argop->op_type == OP_CONST
3194 && ((sv = cSVOPx_sv(argop)))
3195 /* defer stringification until runtime of 'constant'
3196 * things that might stringify variantly, e.g. the radix
3197 * point of NVs, or overloaded RVs */
3198 && (SvPOK(sv) || SvIOK(sv))
3199 && (!SvGMAGICAL(sv))
3201 if (argop->op_private & OPpCONST_STRICT)
3202 no_bareword_allowed(argop);
3204 utf8 |= cBOOL(SvUTF8(sv));
3207 /* this const may be demoted back to a plain arg later;
3208 * make sure we have enough arg slots left */
3210 prev_was_const = !prev_was_const;
3215 prev_was_const = FALSE;
3225 return; /* we don't support ((A.=B).=C)...) */
3227 /* look for two adjacent consts and don't fold them together:
3230 * $o->concat("a")->concat("b")
3233 * (but $o .= "a" . "b" should still fold)
3236 bool seen_nonconst = FALSE;
3237 for (argp = toparg; argp >= args; argp--) {
3238 if (argp->p == NULL) {
3239 seen_nonconst = TRUE;
3245 /* both previous and current arg were constants;
3246 * leave the current OP_CONST as-is */
3254 /* -----------------------------------------------------------------
3257 * At this point we have determined that the optree *can* be converted
3258 * into a multiconcat. Having gathered all the evidence, we now decide
3259 * whether it *should*.
3263 /* we need at least one concat action, e.g.:
3269 * otherwise we could be doing something like $x = "foo", which
3270 * if treated as a concat, would fail to COW.
3272 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3275 /* Benchmarking seems to indicate that we gain if:
3276 * * we optimise at least two actions into a single multiconcat
3277 * (e.g concat+concat, sassign+concat);
3278 * * or if we can eliminate at least 1 OP_CONST;
3279 * * or if we can eliminate a padsv via OPpTARGET_MY
3283 /* eliminated at least one OP_CONST */
3285 /* eliminated an OP_SASSIGN */
3286 || o->op_type == OP_SASSIGN
3287 /* eliminated an OP_PADSV */
3288 || (!targmyop && is_targable)
3290 /* definitely a net gain to optimise */
3293 /* ... if not, what else? */
3295 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3296 * multiconcat is faster (due to not creating a temporary copy of
3297 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3303 && topop->op_type == OP_CONCAT
3305 PADOFFSET t = targmyop->op_targ;
3306 OP *k1 = cBINOPx(topop)->op_first;
3307 OP *k2 = cBINOPx(topop)->op_last;
3308 if ( k2->op_type == OP_PADSV
3310 && ( k1->op_type != OP_PADSV
3311 || k1->op_targ != t)
3316 /* need at least two concats */
3317 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3322 /* -----------------------------------------------------------------
3325 * At this point the optree has been verified as ok to be optimised
3326 * into an OP_MULTICONCAT. Now start changing things.
3331 /* stringify all const args and determine utf8ness */
3334 for (argp = args; argp <= toparg; argp++) {
3335 SV *sv = (SV*)argp->p;
3337 continue; /* not a const op */
3338 if (utf8 && !SvUTF8(sv))
3339 sv_utf8_upgrade_nomg(sv);
3340 argp->p = SvPV_nomg(sv, argp->len);
3341 total_len += argp->len;
3343 /* see if any strings would grow if converted to utf8 */
3345 variant += variant_under_utf8_count((U8 *) argp->p,
3346 (U8 *) argp->p + argp->len);
3350 /* create and populate aux struct */
3354 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3355 sizeof(UNOP_AUX_item)
3357 PERL_MULTICONCAT_HEADER_SIZE
3358 + ((nargs + 1) * (variant ? 2 : 1))
3361 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3363 /* Extract all the non-const expressions from the concat tree then
3364 * dispose of the old tree, e.g. convert the tree from this:
3368 * STRINGIFY -- TARGET
3370 * ex-PUSHMARK -- CONCAT
3385 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3387 * except that if EXPRi is an OP_CONST, it's discarded.
3389 * During the conversion process, EXPR ops are stripped from the tree
3390 * and unshifted onto o. Finally, any of o's remaining original
3391 * childen are discarded and o is converted into an OP_MULTICONCAT.
3393 * In this middle of this, o may contain both: unshifted args on the
3394 * left, and some remaining original args on the right. lastkidop
3395 * is set to point to the right-most unshifted arg to delineate
3396 * between the two sets.
3401 /* create a copy of the format with the %'s removed, and record
3402 * the sizes of the const string segments in the aux struct */
3404 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3406 p = sprintf_info.start;
3409 for (; p < sprintf_info.end; p++) {
3413 (lenp++)->ssize = q - oldq;
3420 lenp->ssize = q - oldq;
3421 assert((STRLEN)(q - const_str) == total_len);
3423 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3424 * may or may not be topop) The pushmark and const ops need to be
3425 * kept in case they're an op_next entry point.
3427 lastkidop = cLISTOPx(topop)->op_last;
3428 kid = cUNOPx(topop)->op_first; /* pushmark */
3430 op_null(OpSIBLING(kid)); /* const */
3432 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3433 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3434 lastkidop->op_next = o;
3439 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3443 /* Concatenate all const strings into const_str.
3444 * Note that args[] contains the RHS args in reverse order, so
3445 * we scan args[] from top to bottom to get constant strings
3448 for (argp = toparg; argp >= args; argp--) {
3450 /* not a const op */
3451 (++lenp)->ssize = -1;
3453 STRLEN l = argp->len;
3454 Copy(argp->p, p, l, char);
3456 if (lenp->ssize == -1)
3467 for (argp = args; argp <= toparg; argp++) {
3468 /* only keep non-const args, except keep the first-in-next-chain
3469 * arg no matter what it is (but nulled if OP_CONST), because it
3470 * may be the entry point to this subtree from the previous
3473 bool last = (argp == toparg);
3476 /* set prev to the sibling *before* the arg to be cut out,
3477 * e.g. when cutting EXPR:
3482 * prev= CONCAT -- EXPR
3485 if (argp == args && kid->op_type != OP_CONCAT) {
3486 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3487 * so the expression to be cut isn't kid->op_last but
3490 /* find the op before kid */
3492 o2 = cUNOPx(parentop)->op_first;
3493 while (o2 && o2 != kid) {
3501 else if (kid == o && lastkidop)
3502 prev = last ? lastkidop : OpSIBLING(lastkidop);
3504 prev = last ? NULL : cUNOPx(kid)->op_first;
3506 if (!argp->p || last) {
3508 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3509 /* and unshift to front of o */
3510 op_sibling_splice(o, NULL, 0, aop);
3511 /* record the right-most op added to o: later we will
3512 * free anything to the right of it */
3515 aop->op_next = nextop;
3518 /* null the const at start of op_next chain */
3522 nextop = prev->op_next;
3525 /* the last two arguments are both attached to the same concat op */
3526 if (argp < toparg - 1)
3531 /* Populate the aux struct */
3533 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3534 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3535 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3536 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3537 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3539 /* if variant > 0, calculate a variant const string and lengths where
3540 * the utf8 version of the string will take 'variant' more bytes than
3544 char *p = const_str;
3545 STRLEN ulen = total_len + variant;
3546 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3547 UNOP_AUX_item *ulens = lens + (nargs + 1);
3548 char *up = (char*)PerlMemShared_malloc(ulen);
3551 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3552 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3554 for (n = 0; n < (nargs + 1); n++) {
3556 char * orig_up = up;
3557 for (i = (lens++)->ssize; i > 0; i--) {
3559 append_utf8_from_native_byte(c, (U8**)&up);
3561 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3566 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3567 * that op's first child - an ex-PUSHMARK - because the op_next of
3568 * the previous op may point to it (i.e. it's the entry point for
3573 ? op_sibling_splice(o, lastkidop, 1, NULL)
3574 : op_sibling_splice(stringop, NULL, 1, NULL);
3575 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3576 op_sibling_splice(o, NULL, 0, pmop);
3583 * target .= A.B.C...
3589 if (o->op_type == OP_SASSIGN) {
3590 /* Move the target subtree from being the last of o's children
3591 * to being the last of o's preserved children.
3592 * Note the difference between 'target = ...' and 'target .= ...':
3593 * for the former, target is executed last; for the latter,
3596 kid = OpSIBLING(lastkidop);
3597 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3598 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3599 lastkidop->op_next = kid->op_next;
3600 lastkidop = targetop;
3603 /* Move the target subtree from being the first of o's
3604 * original children to being the first of *all* o's children.
3607 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3608 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3611 /* if the RHS of .= doesn't contain a concat (e.g.
3612 * $x .= "foo"), it gets missed by the "strip ops from the
3613 * tree and add to o" loop earlier */
3614 assert(topop->op_type != OP_CONCAT);
3616 /* in e.g. $x .= "$y", move the $y expression
3617 * from being a child of OP_STRINGIFY to being the
3618 * second child of the OP_CONCAT
3620 assert(cUNOPx(stringop)->op_first == topop);
3621 op_sibling_splice(stringop, NULL, 1, NULL);
3622 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3624 assert(topop == OpSIBLING(cBINOPo->op_first));
3633 * my $lex = A.B.C...
3636 * The original padsv op is kept but nulled in case it's the
3637 * entry point for the optree (which it will be for
3640 private_flags |= OPpTARGET_MY;
3641 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3642 o->op_targ = targetop->op_targ;
3643 targetop->op_targ = 0;
3647 flags |= OPf_STACKED;
3649 else if (targmyop) {
3650 private_flags |= OPpTARGET_MY;
3651 if (o != targmyop) {
3652 o->op_targ = targmyop->op_targ;
3653 targmyop->op_targ = 0;
3657 /* detach the emaciated husk of the sprintf/concat optree and free it */
3659 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3665 /* and convert o into a multiconcat */
3667 o->op_flags = (flags|OPf_KIDS|stacked_last
3668 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3669 o->op_private = private_flags;
3670 o->op_type = OP_MULTICONCAT;
3671 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3672 cUNOP_AUXo->op_aux = aux;
3676 /* do all the final processing on an optree (e.g. running the peephole
3677 * optimiser on it), then attach it to cv (if cv is non-null)
3681 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3685 /* XXX for some reason, evals, require and main optrees are
3686 * never attached to their CV; instead they just hang off
3687 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3688 * and get manually freed when appropriate */
3690 startp = &CvSTART(cv);
3692 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3695 optree->op_private |= OPpREFCOUNTED;
3696 OpREFCNT_set(optree, 1);
3697 optimize_optree(optree);
3699 finalize_optree(optree);
3700 S_prune_chain_head(startp);
3703 /* now that optimizer has done its work, adjust pad values */
3704 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3705 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3711 =for apidoc optimize_optree
3713 This function applies some optimisations to the optree in top-down order.
3714 It is called before the peephole optimizer, which processes ops in
3715 execution order. Note that finalize_optree() also does a top-down scan,
3716 but is called *after* the peephole optimizer.
3722 Perl_optimize_optree(pTHX_ OP* o)
3724 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3727 SAVEVPTR(PL_curcop);
3735 #define warn_implicit_snail_cvsig(o) S_warn_implicit_snail_cvsig(aTHX_ o)
3737 S_warn_implicit_snail_cvsig(pTHX_ OP *o)
3740 while(cv && CvEVAL(cv))
3743 if(cv && CvSIGNATURE(cv))
3744 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__ARGS_ARRAY_WITH_SIGNATURES),
3745 "Implicit use of @_ in %s with signatured subroutine is experimental", OP_DESC(o));
3748 #define OP_ZOOM(o) (OP_TYPE_IS(o, OP_NULL) ? cUNOPx(o)->op_first : (o))
3750 /* helper for optimize_optree() which optimises one op then recurses
3751 * to optimise any children.
3755 S_optimize_op(pTHX_ OP* o)
3759 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3762 OP * next_kid = NULL;
3764 assert(o->op_type != OP_FREED);
3766 switch (o->op_type) {
3769 PL_curcop = ((COP*)o); /* for warnings */
3777 S_maybe_multiconcat(aTHX_ o);
3781 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3782 /* we can't assume that op_pmreplroot->op_sibparent == o
3783 * and that it is thus possible to walk back up the tree
3784 * past op_pmreplroot. So, although we try to avoid
3785 * recursing through op trees, do it here. After all,
3786 * there are unlikely to be many nested s///e's within
3787 * the replacement part of a s///e.
3789 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3795 OP *first = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
3797 while(cv && CvEVAL(cv))
3800 if(cv && CvSIGNATURE(cv) &&
3801 OP_TYPE_IS(first, OP_GV) && cGVOPx_gv(first) == PL_defgv) {
3802 OP *parent = op_parent(o);
3803 while(OP_TYPE_IS(parent, OP_NULL))
3804 parent = op_parent(parent);
3806 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__ARGS_ARRAY_WITH_SIGNATURES),
3807 "Use of @_ in %s with signatured subroutine is experimental", OP_DESC(parent));
3814 if(!CvUNIQUE(PL_compcv) && !(o->op_flags & OPf_KIDS))
3815 warn_implicit_snail_cvsig(o);
3819 if(!(o->op_flags & OPf_STACKED))
3820 warn_implicit_snail_cvsig(o);
3825 OP *first = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
3827 if(OP_TYPE_IS(first, OP_SREFGEN) &&
3828 (ffirst = OP_ZOOM(cUNOPx(first)->op_first)) &&
3829 OP_TYPE_IS(ffirst, OP_RV2CV))
3830 warn_implicit_snail_cvsig(o);
3838 if (o->op_flags & OPf_KIDS)
3839 next_kid = cUNOPo->op_first;
3841 /* if a kid hasn't been nominated to process, continue with the
3842 * next sibling, or if no siblings left, go back to the parent's
3843 * siblings and so on
3847 return; /* at top; no parents/siblings to try */
3848 if (OpHAS_SIBLING(o))
3849 next_kid = o->op_sibparent;
3851 o = o->op_sibparent; /*try parent's next sibling */
3854 /* this label not yet used. Goto here if any code above sets
3864 =for apidoc finalize_optree
3866 This function finalizes the optree. Should be called directly after
3867 the complete optree is built. It does some additional
3868 checking which can't be done in the normal C<ck_>xxx functions and makes
3869 the tree thread-safe.
3874 Perl_finalize_optree(pTHX_ OP* o)
3876 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3879 SAVEVPTR(PL_curcop);
3887 /* Relocate sv to the pad for thread safety.
3888 * Despite being a "constant", the SV is written to,
3889 * for reference counts, sv_upgrade() etc. */
3890 PERL_STATIC_INLINE void
3891 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3894 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3896 ix = pad_alloc(OP_CONST, SVf_READONLY);
3897 SvREFCNT_dec(PAD_SVl(ix));
3898 PAD_SETSV(ix, *svp);
3899 /* XXX I don't know how this isn't readonly already. */
3900 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3907 =for apidoc traverse_op_tree
3909 Return the next op in a depth-first traversal of the op tree,
3910 returning NULL when the traversal is complete.
3912 The initial call must supply the root of the tree as both top and o.
3914 For now it's static, but it may be exposed to the API in the future.
3920 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3923 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3925 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3926 return cUNOPo->op_first;
3928 else if ((sib = OpSIBLING(o))) {
3932 OP *parent = o->op_sibparent;
3933 assert(!(o->op_moresib));
3934 while (parent && parent != top) {
3935 OP *sib = OpSIBLING(parent);
3938 parent = parent->op_sibparent;
3946 S_finalize_op(pTHX_ OP* o)
3949 PERL_ARGS_ASSERT_FINALIZE_OP;
3952 assert(o->op_type != OP_FREED);
3954 switch (o->op_type) {
3957 PL_curcop = ((COP*)o); /* for warnings */
3960 if (OpHAS_SIBLING(o)) {
3961 OP *sib = OpSIBLING(o);
3962 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3963 && ckWARN(WARN_EXEC)
3964 && OpHAS_SIBLING(sib))
3966 const OPCODE type = OpSIBLING(sib)->op_type;
3967 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3968 const line_t oldline = CopLINE(PL_curcop);
3969 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3970 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3971 "Statement unlikely to be reached");
3972 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3973 "\t(Maybe you meant system() when you said exec()?)\n");
3974 CopLINE_set(PL_curcop, oldline);
3981 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3982 GV * const gv = cGVOPo_gv;
3983 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3984 /* XXX could check prototype here instead of just carping */
3985 SV * const sv = sv_newmortal();
3986 gv_efullname3(sv, gv, NULL);
3987 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3988 "%" SVf "() called too early to check prototype",
3995 if (cSVOPo->op_private & OPpCONST_STRICT)
3996 no_bareword_allowed(o);
4000 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
4005 /* Relocate all the METHOP's SVs to the pad for thread safety. */
4006 case OP_METHOD_NAMED:
4007 case OP_METHOD_SUPER:
4008 case OP_METHOD_REDIR:
4009 case OP_METHOD_REDIR_SUPER:
4010 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
4019 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
4022 rop = (UNOP*)((BINOP*)o)->op_first;
4027 S_scalar_slice_warning(aTHX_ o);
4031 kid = OpSIBLING(cLISTOPo->op_first);
4032 if (/* I bet there's always a pushmark... */
4033 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
4034 && OP_TYPE_ISNT_NN(kid, OP_CONST))
4039 key_op = (SVOP*)(kid->op_type == OP_CONST
4041 : OpSIBLING(kLISTOP->op_first));
4043 rop = (UNOP*)((LISTOP*)o)->op_last;
4046 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
4048 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
4052 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
4056 S_scalar_slice_warning(aTHX_ o);
4060 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
4061 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
4069 if (o->op_flags & OPf_KIDS) {
4072 /* check that op_last points to the last sibling, and that
4073 * the last op_sibling/op_sibparent field points back to the
4074 * parent, and that the only ops with KIDS are those which are
4075 * entitled to them */
4076 U32 type = o->op_type;
4080 if (type == OP_NULL) {
4082 /* ck_glob creates a null UNOP with ex-type GLOB
4083 * (which is a list op. So pretend it wasn't a listop */
4084 if (type == OP_GLOB)
4087 family = PL_opargs[type] & OA_CLASS_MASK;
4089 has_last = ( family == OA_BINOP
4090 || family == OA_LISTOP
4091 || family == OA_PMOP
4092 || family == OA_LOOP
4094 assert( has_last /* has op_first and op_last, or ...
4095 ... has (or may have) op_first: */
4096 || family == OA_UNOP
4097 || family == OA_UNOP_AUX
4098 || family == OA_LOGOP
4099 || family == OA_BASEOP_OR_UNOP
4100 || family == OA_FILESTATOP
4101 || family == OA_LOOPEXOP
4102 || family == OA_METHOP
4103 || type == OP_CUSTOM
4104 || type == OP_NULL /* new_logop does this */
4107 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
4108 if (!OpHAS_SIBLING(kid)) {
4110 assert(kid == cLISTOPo->op_last);
4111 assert(kid->op_sibparent == o);
4116 } while (( o = traverse_op_tree(top, o)) != NULL);
4120 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
4123 PadnameLVALUE_on(pn);
4124 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
4126 /* RT #127786: cv can be NULL due to an eval within the DB package
4127 * called from an anon sub - anon subs don't have CvOUTSIDE() set
4128 * unless they contain an eval, but calling eval within DB
4129 * pretends the eval was done in the caller's scope.
4133 assert(CvPADLIST(cv));
4135 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
4136 assert(PadnameLEN(pn));
4137 PadnameLVALUE_on(pn);
4142 S_vivifies(const OPCODE type)
4145 case OP_RV2AV: case OP_ASLICE:
4146 case OP_RV2HV: case OP_KVASLICE:
4147 case OP_RV2SV: case OP_HSLICE:
4148 case OP_AELEMFAST: case OP_KVHSLICE:
4157 /* apply lvalue reference (aliasing) context to the optree o.
4160 * o would be the list ($x,$y) and type would be OP_AASSIGN.
4161 * It may descend and apply this to children too, for example in
4162 * \( $cond ? $x, $y) = (...)
4166 S_lvref(pTHX_ OP *o, I32 type)
4172 switch (o->op_type) {
4174 o = OpSIBLING(cUNOPo->op_first);
4181 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4182 o->op_flags |= OPf_STACKED;
4183 if (o->op_flags & OPf_PARENS) {
4184 if (o->op_private & OPpLVAL_INTRO) {
4185 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4186 "localized parenthesized array in list assignment"));
4190 OpTYPE_set(o, OP_LVAVREF);
4191 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4192 o->op_flags |= OPf_MOD|OPf_REF;
4195 o->op_private |= OPpLVREF_AV;
4199 kid = cUNOPo->op_first;
4200 if (kid->op_type == OP_NULL)
4201 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4203 o->op_private = OPpLVREF_CV;
4204 if (kid->op_type == OP_GV)
4205 o->op_flags |= OPf_STACKED;
4206 else if (kid->op_type == OP_PADCV) {
4207 o->op_targ = kid->op_targ;
4209 op_free(cUNOPo->op_first);
4210 cUNOPo->op_first = NULL;
4211 o->op_flags &=~ OPf_KIDS;
4217 if (o->op_flags & OPf_PARENS) {
4219 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4220 "parenthesized hash in list assignment"));
4223 o->op_private |= OPpLVREF_HV;
4227 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4228 o->op_flags |= OPf_STACKED;
4232 if (o->op_flags & OPf_PARENS) goto parenhash;
4233 o->op_private |= OPpLVREF_HV;
4236 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4240 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4241 if (o->op_flags & OPf_PARENS) goto slurpy;
4242 o->op_private |= OPpLVREF_AV;
4247 o->op_private |= OPpLVREF_ELEM;
4248 o->op_flags |= OPf_STACKED;
4253 OpTYPE_set(o, OP_LVREFSLICE);
4254 o->op_private &= OPpLVAL_INTRO;
4258 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4260 else if (!(o->op_flags & OPf_KIDS))
4263 /* the code formerly only recursed into the first child of
4264 * a non ex-list OP_NULL. if we ever encounter such a null op with
4265 * more than one child, need to decide whether its ok to process
4266 * *all* its kids or not */
4267 assert(o->op_targ == OP_LIST
4268 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4271 o = cLISTOPo->op_first;
4275 if (o->op_flags & OPf_PARENS)
4280 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4281 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4282 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4289 OpTYPE_set(o, OP_LVREF);
4291 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4292 if (type == OP_ENTERLOOP)
4293 o->op_private |= OPpLVREF_ITER;
4298 return; /* at top; no parents/siblings to try */
4299 if (OpHAS_SIBLING(o)) {
4300 o = o->op_sibparent;
4303 o = o->op_sibparent; /*try parent's next sibling */
4309 PERL_STATIC_INLINE bool
4310 S_potential_mod_type(I32 type)
4312 /* Types that only potentially result in modification. */
4313 return type == OP_GREPSTART || type == OP_ENTERSUB
4314 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4319 =for apidoc op_lvalue
4321 Propagate lvalue ("modifiable") context to an op and its children.
4322 C<type> represents the context type, roughly based on the type of op that
4323 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4324 because it has no op type of its own (it is signalled by a flag on
4327 This function detects things that can't be modified, such as C<$x+1>, and
4328 generates errors for them. For example, C<$x+1 = 2> would cause it to be
4329 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4331 It also flags things that need to behave specially in an lvalue context,
4332 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4336 Perl_op_lvalue_flags() is a non-API lower-level interface to
4337 op_lvalue(). The flags param has these bits:
4338 OP_LVALUE_NO_CROAK: return rather than croaking on error
4343 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4347 if (!o || (PL_parser && PL_parser->error_count))
4352 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4354 OP *next_kid = NULL;
4356 if ((o->op_private & OPpTARGET_MY)
4357 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4362 /* elements of a list might be in void context because the list is
4363 in scalar context or because they are attribute sub calls */
4364 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4367 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4369 switch (o->op_type) {
4371 if (type == OP_SASSIGN)
4377 if ((o->op_flags & OPf_PARENS))
4382 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4383 !(o->op_flags & OPf_STACKED)) {
4384 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4385 assert(cUNOPo->op_first->op_type == OP_NULL);
4386 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4389 else { /* lvalue subroutine call */
4390 o->op_private |= OPpLVAL_INTRO;
4391 PL_modcount = RETURN_UNLIMITED_NUMBER;
4392 if (S_potential_mod_type(type)) {
4393 o->op_private |= OPpENTERSUB_INARGS;
4396 else { /* Compile-time error message: */
4397 OP *kid = cUNOPo->op_first;
4402 if (kid->op_type != OP_PUSHMARK) {
4403 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4405 "panic: unexpected lvalue entersub "
4406 "args: type/targ %ld:%" UVuf,
4407 (long)kid->op_type, (UV)kid->op_targ);
4408 kid = kLISTOP->op_first;
4410 while (OpHAS_SIBLING(kid))
4411 kid = OpSIBLING(kid);
4412 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4413 break; /* Postpone until runtime */
4416 kid = kUNOP->op_first;
4417 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4418 kid = kUNOP->op_first;
4419 if (kid->op_type == OP_NULL)
4421 "panic: unexpected constant lvalue entersub "
4422 "entry via type/targ %ld:%" UVuf,
4423 (long)kid->op_type, (UV)kid->op_targ);
4424 if (kid->op_type != OP_GV) {
4431 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4432 ? MUTABLE_CV(SvRV(gv))
4438 if (flags & OP_LVALUE_NO_CROAK)
4441 namesv = cv_name(cv, NULL, 0);
4442 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4443 "subroutine call of &%" SVf " in %s",
4444 SVfARG(namesv), PL_op_desc[type]),
4452 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4453 /* grep, foreach, subcalls, refgen */
4454 if (S_potential_mod_type(type))
4456 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4457 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4460 type ? PL_op_desc[type] : "local"));
4473 case OP_RIGHT_SHIFT:
4482 if (!(o->op_flags & OPf_STACKED))
4488 if (o->op_flags & OPf_STACKED) {
4492 if (!(o->op_private & OPpREPEAT_DOLIST))
4495 const I32 mods = PL_modcount;
4496 /* we recurse rather than iterate here because we need to
4497 * calculate and use the delta applied to PL_modcount by the
4498 * first child. So in something like
4499 * ($x, ($y) x 3) = split;
4500 * split knows that 4 elements are wanted
4502 modkids(cBINOPo->op_first, type);
4503 if (type != OP_AASSIGN)
4505 kid = cBINOPo->op_last;
4506 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4507 const IV iv = SvIV(kSVOP_sv);
4508 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4510 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4513 PL_modcount = RETURN_UNLIMITED_NUMBER;
4519 next_kid = OpSIBLING(cUNOPo->op_first);
4524 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4525 PL_modcount = RETURN_UNLIMITED_NUMBER;
4526 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4527 fiable since some contexts need to know. */
4528 o->op_flags |= OPf_MOD;
4533 if (scalar_mod_type(o, type))
4535 ref(cUNOPo->op_first, o->op_type);
4542 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4543 if (type == OP_LEAVESUBLV && (
4544 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4545 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4547 o->op_private |= OPpMAYBE_LVSUB;
4551 PL_modcount = RETURN_UNLIMITED_NUMBER;
4557 if (type == OP_LEAVESUBLV)
4558 o->op_private |= OPpMAYBE_LVSUB;
4562 if (type == OP_LEAVESUBLV
4563 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4564 o->op_private |= OPpMAYBE_LVSUB;
4568 PL_hints |= HINT_BLOCK_SCOPE;
4569 if (type == OP_LEAVESUBLV)
4570 o->op_private |= OPpMAYBE_LVSUB;
4575 ref(cUNOPo->op_first, o->op_type);
4579 PL_hints |= HINT_BLOCK_SCOPE;
4589 case OP_AELEMFAST_LEX:
4596 PL_modcount = RETURN_UNLIMITED_NUMBER;
4597 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4599 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4600 fiable since some contexts need to know. */
4601 o->op_flags |= OPf_MOD;
4604 if (scalar_mod_type(o, type))
4606 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4607 && type == OP_LEAVESUBLV)
4608 o->op_private |= OPpMAYBE_LVSUB;
4612 if (!type) /* local() */
4613 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4614 PNfARG(PAD_COMPNAME(o->op_targ)));
4615 if (!(o->op_private & OPpLVAL_INTRO)
4616 || ( type != OP_SASSIGN && type != OP_AASSIGN
4617 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4618 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4626 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4630 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4636 if (type == OP_LEAVESUBLV)
4637 o->op_private |= OPpMAYBE_LVSUB;
4638 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4639 /* we recurse rather than iterate here because the child
4640 * needs to be processed with a different 'type' parameter */
4642 /* substr and vec */
4643 /* If this op is in merely potential (non-fatal) modifiable
4644 context, then apply OP_ENTERSUB context to
4645 the kid op (to avoid croaking). Other-
4646 wise pass this op’s own type so the correct op is mentioned
4647 in error messages. */
4648 op_lvalue(OpSIBLING(cBINOPo->op_first),
4649 S_potential_mod_type(type)
4657 ref(cBINOPo->op_first, o->op_type);
4658 if (type == OP_ENTERSUB &&
4659 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4660 o->op_private |= OPpLVAL_DEFER;
4661 if (type == OP_LEAVESUBLV)
4662 o->op_private |= OPpMAYBE_LVSUB;
4669 o->op_private |= OPpLVALUE;
4675 if (o->op_flags & OPf_KIDS)
4676 next_kid = cLISTOPo->op_last;
4681 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4683 else if (!(o->op_flags & OPf_KIDS))
4686 if (o->op_targ != OP_LIST) {
4687 OP *sib = OpSIBLING(cLISTOPo->op_first);
4688 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4695 * compared with things like OP_MATCH which have the argument
4701 * so handle specially to correctly get "Can't modify" croaks etc
4704 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4706 /* this should trigger a "Can't modify transliteration" err */
4707 op_lvalue(sib, type);
4709 next_kid = cBINOPo->op_first;
4710 /* we assume OP_NULLs which aren't ex-list have no more than 2
4711 * children. If this assumption is wrong, increase the scan
4713 assert( !OpHAS_SIBLING(next_kid)
4714 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4720 next_kid = cLISTOPo->op_first;
4728 if (type == OP_LEAVESUBLV
4729 || !S_vivifies(cLOGOPo->op_first->op_type))
4730 next_kid = cLOGOPo->op_first;
4731 else if (type == OP_LEAVESUBLV
4732 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4733 next_kid = OpSIBLING(cLOGOPo->op_first);
4737 if (type == OP_NULL) { /* local */
4739 if (!FEATURE_MYREF_IS_ENABLED)
4740 Perl_croak(aTHX_ "The experimental declared_refs "
4741 "feature is not enabled");
4742 Perl_ck_warner_d(aTHX_
4743 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4744 "Declaring references is experimental");
4745 next_kid = cUNOPo->op_first;
4748 if (type != OP_AASSIGN && type != OP_SASSIGN
4749 && type != OP_ENTERLOOP)
4751 /* Don’t bother applying lvalue context to the ex-list. */
4752 kid = cUNOPx(cUNOPo->op_first)->op_first;
4753 assert (!OpHAS_SIBLING(kid));
4756 if (type == OP_NULL) /* local */
4758 if (type != OP_AASSIGN) goto nomod;
4759 kid = cUNOPo->op_first;
4762 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4763 S_lvref(aTHX_ kid, type);
4764 if (!PL_parser || PL_parser->error_count == ec) {
4765 if (!FEATURE_REFALIASING_IS_ENABLED)
4767 "Experimental aliasing via reference not enabled");
4768 Perl_ck_warner_d(aTHX_
4769 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4770 "Aliasing via reference is experimental");
4773 if (o->op_type == OP_REFGEN)
4774 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4779 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4780 /* This is actually @array = split. */
4781 PL_modcount = RETURN_UNLIMITED_NUMBER;
4787 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4791 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4792 their argument is a filehandle; thus \stat(".") should not set
4794 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4797 if (type != OP_LEAVESUBLV)
4798 o->op_flags |= OPf_MOD;
4800 if (type == OP_AASSIGN || type == OP_SASSIGN)
4801 o->op_flags |= OPf_SPECIAL
4802 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4803 else if (!type) { /* local() */
4806 o->op_private |= OPpLVAL_INTRO;
4807 o->op_flags &= ~OPf_SPECIAL;
4808 PL_hints |= HINT_BLOCK_SCOPE;
4813 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4814 "Useless localization of %s", OP_DESC(o));
4817 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4818 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4819 o->op_flags |= OPf_REF;
4824 return top_op; /* at top; no parents/siblings to try */
4825 if (OpHAS_SIBLING(o)) {
4826 next_kid = o->op_sibparent;
4827 if (!OpHAS_SIBLING(next_kid)) {
4828 /* a few node types don't recurse into their second child */
4829 OP *parent = next_kid->op_sibparent;
4830 I32 ptype = parent->op_type;
4831 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
4832 || ( (ptype == OP_AND || ptype == OP_OR)
4833 && (type != OP_LEAVESUBLV
4834 && S_vivifies(next_kid->op_type))
4837 /*try parent's next sibling */
4844 o = o->op_sibparent; /*try parent's next sibling */
4855 S_scalar_mod_type(const OP *o, I32 type)
4860 if (o && o->op_type == OP_RV2GV)
4884 case OP_RIGHT_SHIFT:
4913 S_is_handle_constructor(const OP *o, I32 numargs)
4915 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4917 switch (o->op_type) {
4925 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4938 S_refkids(pTHX_ OP *o, I32 type)
4940 if (o && o->op_flags & OPf_KIDS) {
4942 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4949 /* Apply reference (autovivification) context to the subtree at o.
4951 * push @{expression}, ....;
4952 * o will be the head of 'expression' and type will be OP_RV2AV.
4953 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4955 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4956 * set_op_ref is true.
4958 * Also calls scalar(o).
4962 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4966 PERL_ARGS_ASSERT_DOREF;
4968 if (PL_parser && PL_parser->error_count)
4972 switch (o->op_type) {
4974 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4975 !(o->op_flags & OPf_STACKED)) {
4976 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4977 assert(cUNOPo->op_first->op_type == OP_NULL);
4978 /* disable pushmark */
4979 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4980 o->op_flags |= OPf_SPECIAL;
4982 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4983 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4984 : type == OP_RV2HV ? OPpDEREF_HV
4986 o->op_flags |= OPf_MOD;
4992 o = OpSIBLING(cUNOPo->op_first);
4996 if (type == OP_DEFINED)
4997 o->op_flags |= OPf_SPECIAL; /* don't create GV */
5000 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5001 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
5002 : type == OP_RV2HV ? OPpDEREF_HV
5004 o->op_flags |= OPf_MOD;
5006 if (o->op_flags & OPf_KIDS) {
5008 o = cUNOPo->op_first;
5016 o->op_flags |= OPf_REF;
5019 if (type == OP_DEFINED)
5020 o->op_flags |= OPf_SPECIAL; /* don't create GV */
5022 o = cUNOPo->op_first;
5028 o->op_flags |= OPf_REF;
5033 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
5035 o = cBINOPo->op_first;
5040 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5041 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
5042 : type == OP_RV2HV ? OPpDEREF_HV
5044 o->op_flags |= OPf_MOD;
5047 o = cBINOPo->op_first;
5056 if (!(o->op_flags & OPf_KIDS))
5058 o = cLISTOPo->op_last;
5067 return scalar(top_op); /* at top; no parents/siblings to try */
5068 if (OpHAS_SIBLING(o)) {
5069 o = o->op_sibparent;
5070 /* Normally skip all siblings and go straight to the parent;
5071 * the only op that requires two children to be processed
5072 * is OP_COND_EXPR */
5073 if (!OpHAS_SIBLING(o)
5074 && o->op_sibparent->op_type == OP_COND_EXPR)
5078 o = o->op_sibparent; /*try parent's next sibling */
5085 S_dup_attrlist(pTHX_ OP *o)
5089 PERL_ARGS_ASSERT_DUP_ATTRLIST;
5091 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
5092 * where the first kid is OP_PUSHMARK and the remaining ones
5093 * are OP_CONST. We need to push the OP_CONST values.
5095 if (o->op_type == OP_CONST)
5096 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
5098 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5100 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
5101 if (o->op_type == OP_CONST)
5102 rop = op_append_elem(OP_LIST, rop,
5103 newSVOP(OP_CONST, o->op_flags,
5104 SvREFCNT_inc_NN(cSVOPo->op_sv)));
5111 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
5113 PERL_ARGS_ASSERT_APPLY_ATTRS;
5115 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
5117 /* fake up C<use attributes $pkg,$rv,@attrs> */
5119 #define ATTRSMODULE "attributes"
5120 #define ATTRSMODULE_PM "attributes.pm"
5123 aTHX_ PERL_LOADMOD_IMPORT_OPS,
5124 newSVpvs(ATTRSMODULE),
5126 op_prepend_elem(OP_LIST,
5127 newSVOP(OP_CONST, 0, stashsv),
5128 op_prepend_elem(OP_LIST,
5129 newSVOP(OP_CONST, 0,
5131 dup_attrlist(attrs))));
5136 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
5138 OP *pack, *imop, *arg;
5139 SV *meth, *stashsv, **svp;
5141 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
5146 assert(target->op_type == OP_PADSV ||
5147 target->op_type == OP_PADHV ||
5148 target->op_type == OP_PADAV);
5150 /* Ensure that attributes.pm is loaded. */
5151 /* Don't force the C<use> if we don't need it. */
5152 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
5153 if (svp && *svp != &PL_sv_undef)
5154 NOOP; /* already in %INC */
5156 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5157 newSVpvs(ATTRSMODULE), NULL);
5159 /* Need package name for method call. */
5160 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
5162 /* Build up the real arg-list. */
5163 stashsv = newSVhek(HvNAME_HEK(stash));
5165 arg = newOP(OP_PADSV, 0);
5166 arg->op_targ = target->op_targ;
5167 arg = op_prepend_elem(OP_LIST,
5168 newSVOP(OP_CONST, 0, stashsv),
5169 op_prepend_elem(OP_LIST,
5170 newUNOP(OP_REFGEN, 0,
5172 dup_attrlist(attrs)));
5174 /* Fake up a method call to import */
5175 meth = newSVpvs_share("import");
5176 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
5177 op_append_elem(OP_LIST,
5178 op_prepend_elem(OP_LIST, pack, arg),
5179 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5181 /* Combine the ops. */
5182 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
5186 =notfor apidoc apply_attrs_string
5188 Attempts to apply a list of attributes specified by the C<attrstr> and
5189 C<len> arguments to the subroutine identified by the C<cv> argument which
5190 is expected to be associated with the package identified by the C<stashpv>
5191 argument (see L<attributes>). It gets this wrong, though, in that it
5192 does not correctly identify the boundaries of the individual attribute
5193 specifications within C<attrstr>. This is not really intended for the
5194 public API, but has to be listed here for systems such as AIX which
5195 need an explicit export list for symbols. (It's called from XS code
5196 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
5197 to respect attribute syntax properly would be welcome.
5203 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
5204 const char *attrstr, STRLEN len)
5208 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
5211 len = strlen(attrstr);
5215 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
5217 const char * const sstr = attrstr;
5218 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
5219 attrs = op_append_elem(OP_LIST, attrs,
5220 newSVOP(OP_CONST, 0,
5221 newSVpvn(sstr, attrstr-sstr)));
5225 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5226 newSVpvs(ATTRSMODULE),
5227 NULL, op_prepend_elem(OP_LIST,
5228 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5229 op_prepend_elem(OP_LIST,
5230 newSVOP(OP_CONST, 0,
5231 newRV(MUTABLE_SV(cv))),
5236 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5239 OP *new_proto = NULL;
5244 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5250 if (o->op_type == OP_CONST) {
5251 pv = SvPV(cSVOPo_sv, pvlen);
5252 if (memBEGINs(pv, pvlen, "prototype(")) {
5253 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5254 SV ** const tmpo = cSVOPx_svp(o);
5255 SvREFCNT_dec(cSVOPo_sv);
5260 } else if (o->op_type == OP_LIST) {
5262 assert(o->op_flags & OPf_KIDS);
5263 lasto = cLISTOPo->op_first;
5264 assert(lasto->op_type == OP_PUSHMARK);
5265 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
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);
5273 if (new_proto && ckWARN(WARN_MISC)) {
5275 const char * newp = SvPV(cSVOPo_sv, new_len);
5276 Perl_warner(aTHX_ packWARN(WARN_MISC),
5277 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5278 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5284 /* excise new_proto from the list */
5285 op_sibling_splice(*attrs, lasto, 1, NULL);
5292 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5293 would get pulled in with no real need */
5294 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5303 svname = sv_newmortal();
5304 gv_efullname3(svname, name, NULL);
5306 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5307 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5309 svname = (SV *)name;
5310 if (ckWARN(WARN_ILLEGALPROTO))
5311 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5313 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5314 STRLEN old_len, new_len;
5315 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5316 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5318 if (curstash && svname == (SV *)name
5319 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5320 svname = sv_2mortal(newSVsv(PL_curstname));
5321 sv_catpvs(svname, "::");
5322 sv_catsv(svname, (SV *)name);
5325 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5326 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5328 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5329 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5339 S_cant_declare(pTHX_ OP *o)
5341 if (o->op_type == OP_NULL
5342 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5343 o = cUNOPo->op_first;
5344 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5345 o->op_type == OP_NULL
5346 && o->op_flags & OPf_SPECIAL
5349 PL_parser->in_my == KEY_our ? "our" :
5350 PL_parser->in_my == KEY_state ? "state" :
5355 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5358 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5360 PERL_ARGS_ASSERT_MY_KID;
5362 if (!o || (PL_parser && PL_parser->error_count))
5367 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5369 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5370 my_kid(kid, attrs, imopsp);
5372 } else if (type == OP_UNDEF || type == OP_STUB) {
5374 } else if (type == OP_RV2SV || /* "our" declaration */
5377 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5378 S_cant_declare(aTHX_ o);
5380 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5382 PL_parser->in_my = FALSE;
5383 PL_parser->in_my_stash = NULL;
5384 apply_attrs(GvSTASH(gv),
5385 (type == OP_RV2SV ? GvSVn(gv) :
5386 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5387 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5390 o->op_private |= OPpOUR_INTRO;
5393 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5394 if (!FEATURE_MYREF_IS_ENABLED)
5395 Perl_croak(aTHX_ "The experimental declared_refs "
5396 "feature is not enabled");
5397 Perl_ck_warner_d(aTHX_
5398 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5399 "Declaring references is experimental");
5400 /* Kid is a nulled OP_LIST, handled above. */
5401 my_kid(cUNOPo->op_first, attrs, imopsp);
5404 else if (type != OP_PADSV &&
5407 type != OP_PUSHMARK)
5409 S_cant_declare(aTHX_ o);
5412 else if (attrs && type != OP_PUSHMARK) {
5416 PL_parser->in_my = FALSE;
5417 PL_parser->in_my_stash = NULL;
5419 /* check for C<my Dog $spot> when deciding package */
5420 stash = PAD_COMPNAME_TYPE(o->op_targ);
5422 stash = PL_curstash;
5423 apply_attrs_my(stash, o, attrs, imopsp);
5425 o->op_flags |= OPf_MOD;
5426 o->op_private |= OPpLVAL_INTRO;
5428 o->op_private |= OPpPAD_STATE;
5433 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5436 int maybe_scalar = 0;
5438 PERL_ARGS_ASSERT_MY_ATTRS;
5440 /* [perl #17376]: this appears to be premature, and results in code such as
5441 C< our(%x); > executing in list mode rather than void mode */
5443 if (o->op_flags & OPf_PARENS)
5453 o = my_kid(o, attrs, &rops);
5455 if (maybe_scalar && o->op_type == OP_PADSV) {
5456 o = scalar(op_append_list(OP_LIST, rops, o));
5457 o->op_private |= OPpLVAL_INTRO;
5460 /* The listop in rops might have a pushmark at the beginning,
5461 which will mess up list assignment. */
5462 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5463 if (rops->op_type == OP_LIST &&
5464 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5466 OP * const pushmark = lrops->op_first;
5467 /* excise pushmark */
5468 op_sibling_splice(rops, NULL, 1, NULL);
5471 o = op_append_list(OP_LIST, o, rops);
5474 PL_parser->in_my = FALSE;
5475 PL_parser->in_my_stash = NULL;
5480 Perl_sawparens(pTHX_ OP *o)
5482 PERL_UNUSED_CONTEXT;
5484 o->op_flags |= OPf_PARENS;
5489 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5493 const OPCODE ltype = left->op_type;
5494 const OPCODE rtype = right->op_type;
5496 PERL_ARGS_ASSERT_BIND_MATCH;
5498 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5499 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5501 const char * const desc
5503 rtype == OP_SUBST || rtype == OP_TRANS
5504 || rtype == OP_TRANSR
5506 ? (int)rtype : OP_MATCH];
5507 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5509 S_op_varname(aTHX_ left);
5511 Perl_warner(aTHX_ packWARN(WARN_MISC),
5512 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5513 desc, SVfARG(name), SVfARG(name));
5515 const char * const sample = (isary
5516 ? "@array" : "%hash");
5517 Perl_warner(aTHX_ packWARN(WARN_MISC),
5518 "Applying %s to %s will act on scalar(%s)",
5519 desc, sample, sample);
5523 if (rtype == OP_CONST &&
5524 cSVOPx(right)->op_private & OPpCONST_BARE &&
5525 cSVOPx(right)->op_private & OPpCONST_STRICT)
5527 no_bareword_allowed(right);
5530 /* !~ doesn't make sense with /r, so error on it for now */
5531 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5533 /* diag_listed_as: Using !~ with %s doesn't make sense */
5534 yyerror("Using !~ with s///r doesn't make sense");
5535 if (rtype == OP_TRANSR && type == OP_NOT)
5536 /* diag_listed_as: Using !~ with %s doesn't make sense */
5537 yyerror("Using !~ with tr///r doesn't make sense");
5539 ismatchop = (rtype == OP_MATCH ||
5540 rtype == OP_SUBST ||
5541 rtype == OP_TRANS || rtype == OP_TRANSR)
5542 && !(right->op_flags & OPf_SPECIAL);
5543 if (ismatchop && right->op_private & OPpTARGET_MY) {
5545 right->op_private &= ~OPpTARGET_MY;
5547 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5548 if (left->op_type == OP_PADSV
5549 && !(left->op_private & OPpLVAL_INTRO))
5551 right->op_targ = left->op_targ;
5556 right->op_flags |= OPf_STACKED;
5557 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5558 ! (rtype == OP_TRANS &&
5559 right->op_private & OPpTRANS_IDENTICAL) &&
5560 ! (rtype == OP_SUBST &&
5561 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5562 left = op_lvalue(left, rtype);
5563 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5564 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5566 o = op_prepend_elem(rtype, scalar(left), right);
5569 return newUNOP(OP_NOT, 0, scalar(o));
5573 return bind_match(type, left,
5574 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5578 Perl_invert(pTHX_ OP *o)
5582 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5586 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
5592 left = newOP(OP_NULL, 0);
5594 right = newOP(OP_NULL, 0);
5597 NewOp(0, bop, 1, BINOP);
5599 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5600 OpTYPE_set(op, type);
5601 cBINOPx(op)->op_flags = OPf_KIDS;
5602 cBINOPx(op)->op_private = 2;
5603 cBINOPx(op)->op_first = left;
5604 cBINOPx(op)->op_last = right;
5605 OpMORESIB_set(left, right);
5606 OpLASTSIB_set(right, op);
5611 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
5616 PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
5618 right = newOP(OP_NULL, 0);
5620 NewOp(0, bop, 1, BINOP);
5622 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5623 OpTYPE_set(op, type);
5624 if (ch->op_type != OP_NULL) {
5626 OP *nch, *cleft, *cright;
5627 NewOp(0, lch, 1, UNOP);
5629 OpTYPE_set(nch, OP_NULL);
5630 nch->op_flags = OPf_KIDS;
5631 cleft = cBINOPx(ch)->op_first;
5632 cright = cBINOPx(ch)->op_last;
5633 cBINOPx(ch)->op_first = NULL;
5634 cBINOPx(ch)->op_last = NULL;
5635 cBINOPx(ch)->op_private = 0;
5636 cBINOPx(ch)->op_flags = 0;
5637 cUNOPx(nch)->op_first = cright;
5638 OpMORESIB_set(cright, ch);
5639 OpMORESIB_set(ch, cleft);
5640 OpLASTSIB_set(cleft, nch);
5643 OpMORESIB_set(right, op);
5644 OpMORESIB_set(op, cUNOPx(ch)->op_first);
5645 cUNOPx(ch)->op_first = right;
5650 Perl_cmpchain_finish(pTHX_ OP *ch)
5653 PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
5654 if (ch->op_type != OP_NULL) {
5655 OPCODE cmpoptype = ch->op_type;
5656 ch = CHECKOP(cmpoptype, ch);
5657 if(!ch->op_next && ch->op_type == cmpoptype)
5658 ch = fold_constants(op_integerize(op_std_init(ch)));
5662 OP *rightarg = cUNOPx(ch)->op_first;
5663 cUNOPx(ch)->op_first = OpSIBLING(rightarg);
5664 OpLASTSIB_set(rightarg, NULL);
5666 OP *cmpop = cUNOPx(ch)->op_first;
5667 OP *leftarg = OpSIBLING(cmpop);
5668 OPCODE cmpoptype = cmpop->op_type;
5671 is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
5672 OpLASTSIB_set(cmpop, NULL);
5673 OpLASTSIB_set(leftarg, NULL);
5677 nextrightarg = NULL;
5679 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
5680 leftarg = newOP(OP_NULL, 0);
5682 cBINOPx(cmpop)->op_first = leftarg;
5683 cBINOPx(cmpop)->op_last = rightarg;
5684 OpMORESIB_set(leftarg, rightarg);
5685 OpLASTSIB_set(rightarg, cmpop);
5686 cmpop->op_flags = OPf_KIDS;
5687 cmpop->op_private = 2;
5688 cmpop = CHECKOP(cmpoptype, cmpop);
5689 if(!cmpop->op_next && cmpop->op_type == cmpoptype)
5690 cmpop = op_integerize(op_std_init(cmpop));
5691 condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
5695 rightarg = nextrightarg;
5701 =for apidoc op_scope
5703 Wraps up an op tree with some additional ops so that at runtime a dynamic
5704 scope will be created. The original ops run in the new dynamic scope,
5705 and then, provided that they exit normally, the scope will be unwound.
5706 The additional ops used to create and unwind the dynamic scope will
5707 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5708 instead if the ops are simple enough to not need the full dynamic scope
5715 Perl_op_scope(pTHX_ OP *o)
5718 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5719 o = op_prepend_elem(OP_LINESEQ,
5720 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
5721 OpTYPE_set(o, OP_LEAVE);
5723 else if (o->op_type == OP_LINESEQ) {
5725 OpTYPE_set(o, OP_SCOPE);
5726 kid = ((LISTOP*)o)->op_first;
5727 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5730 /* The following deals with things like 'do {1 for 1}' */
5731 kid = OpSIBLING(kid);
5733 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5738 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5744 Perl_op_unscope(pTHX_ OP *o)
5746 if (o && o->op_type == OP_LINESEQ) {
5747 OP *kid = cLISTOPo->op_first;
5748 for(; kid; kid = OpSIBLING(kid))
5749 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5756 =for apidoc block_start
5758 Handles compile-time scope entry.
5759 Arranges for hints to be restored on block
5760 exit and also handles pad sequence numbers to make lexical variables scope
5761 right. Returns a savestack index for use with C<block_end>.
5767 Perl_block_start(pTHX_ int full)
5769 const int retval = PL_savestack_ix;
5771 PL_compiling.cop_seq = PL_cop_seqmax;
5773 pad_block_start(full);
5775 PL_hints &= ~HINT_BLOCK_SCOPE;
5776 SAVECOMPILEWARNINGS();
5777 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5778 SAVEI32(PL_compiling.cop_seq);
5779 PL_compiling.cop_seq = 0;
5781 CALL_BLOCK_HOOKS(bhk_start, full);
5787 =for apidoc block_end
5789 Handles compile-time scope exit. C<floor>
5790 is the savestack index returned by
5791 C<block_start>, and C<seq> is the body of the block. Returns the block,
5798 Perl_block_end(pTHX_ I32 floor, OP *seq)
5800 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5801 OP* retval = voidnonfinal(seq);
5804 /* XXX Is the null PL_parser check necessary here? */
5805 assert(PL_parser); /* Let’s find out under debugging builds. */
5806 if (PL_parser && PL_parser->parsed_sub) {
5807 o = newSTATEOP(0, NULL, NULL);
5809 retval = op_append_elem(OP_LINESEQ, retval, o);
5812 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5816 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5820 /* pad_leavemy has created a sequence of introcv ops for all my
5821 subs declared in the block. We have to replicate that list with
5822 clonecv ops, to deal with this situation:
5827 sub s1 { state sub foo { \&s2 } }
5830 Originally, I was going to have introcv clone the CV and turn
5831 off the stale flag. Since &s1 is declared before &s2, the
5832 introcv op for &s1 is executed (on sub entry) before the one for
5833 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5834 cloned, since it is a state sub) closes over &s2 and expects
5835 to see it in its outer CV’s pad. If the introcv op clones &s1,
5836 then &s2 is still marked stale. Since &s1 is not active, and
5837 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5838 ble will not stay shared’ warning. Because it is the same stub
5839 that will be used when the introcv op for &s2 is executed, clos-
5840 ing over it is safe. Hence, we have to turn off the stale flag
5841 on all lexical subs in the block before we clone any of them.
5842 Hence, having introcv clone the sub cannot work. So we create a
5843 list of ops like this:
5867 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5868 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5869 for (;; kid = OpSIBLING(kid)) {
5870 OP *newkid = newOP(OP_CLONECV, 0);
5871 newkid->op_targ = kid->op_targ;
5872 o = op_append_elem(OP_LINESEQ, o, newkid);
5873 if (kid == last) break;
5875 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5878 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5884 =for apidoc_section $scope
5886 =for apidoc blockhook_register
5888 Register a set of hooks to be called when the Perl lexical scope changes
5889 at compile time. See L<perlguts/"Compile-time scope hooks">.
5895 Perl_blockhook_register(pTHX_ BHK *hk)
5897 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5899 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5903 Perl_newPROG(pTHX_ OP *o)
5907 PERL_ARGS_ASSERT_NEWPROG;
5914 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5915 ((PL_in_eval & EVAL_KEEPERR)
5916 ? OPf_SPECIAL : 0), o);
5919 assert(CxTYPE(cx) == CXt_EVAL);
5921 if ((cx->blk_gimme & G_WANT) == G_VOID)
5922 scalarvoid(PL_eval_root);
5923 else if ((cx->blk_gimme & G_WANT) == G_LIST)
5926 scalar(PL_eval_root);
5928 start = op_linklist(PL_eval_root);
5929 PL_eval_root->op_next = 0;
5930 i = PL_savestack_ix;
5933 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5935 PL_savestack_ix = i;
5938 if (o->op_type == OP_STUB) {
5939 /* This block is entered if nothing is compiled for the main
5940 program. This will be the case for an genuinely empty main
5941 program, or one which only has BEGIN blocks etc, so already
5944 Historically (5.000) the guard above was !o. However, commit
5945 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5946 c71fccf11fde0068, changed perly.y so that newPROG() is now
5947 called with the output of block_end(), which returns a new
5948 OP_STUB for the case of an empty optree. ByteLoader (and
5949 maybe other things) also take this path, because they set up
5950 PL_main_start and PL_main_root directly, without generating an
5953 If the parsing the main program aborts (due to parse errors,
5954 or due to BEGIN or similar calling exit), then newPROG()
5955 isn't even called, and hence this code path and its cleanups
5956 are skipped. This shouldn't make a make a difference:
5957 * a non-zero return from perl_parse is a failure, and
5958 perl_destruct() should be called immediately.
5959 * however, if exit(0) is called during the parse, then
5960 perl_parse() returns 0, and perl_run() is called. As
5961 PL_main_start will be NULL, perl_run() will return
5962 promptly, and the exit code will remain 0.
5965 PL_comppad_name = 0;
5967 S_op_destroy(aTHX_ o);
5970 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5971 PL_curcop = &PL_compiling;
5972 start = LINKLIST(PL_main_root);
5973 PL_main_root->op_next = 0;
5974 S_process_optree(aTHX_ NULL, PL_main_root, start);
5975 if (!PL_parser->error_count)
5976 /* on error, leave CV slabbed so that ops left lying around
5977 * will eb cleaned up. Else unslab */
5978 cv_forget_slab(PL_compcv);
5981 /* Register with debugger */
5983 CV * const cv = get_cvs("DB::postponed", 0);
5987 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5989 call_sv(MUTABLE_SV(cv), G_DISCARD);
5996 Perl_localize(pTHX_ OP *o, I32 lex)
5998 PERL_ARGS_ASSERT_LOCALIZE;
6000 if (o->op_flags & OPf_PARENS)
6001 /* [perl #17376]: this appears to be premature, and results in code such as
6002 C< our(%x); > executing in list mode rather than void mode */
6009 if ( PL_parser->bufptr > PL_parser->oldbufptr
6010 && PL_parser->bufptr[-1] == ','
6011 && ckWARN(WARN_PARENTHESIS))
6013 char *s = PL_parser->bufptr;
6016 /* some heuristics to detect a potential error */
6017 while (*s && (memCHRs(", \t\n", *s)))
6021 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
6023 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
6026 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
6028 while (*s && (memCHRs(", \t\n", *s)))
6034 if (sigil && (*s == ';' || *s == '=')) {
6035 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
6036 "Parentheses missing around \"%s\" list",
6038 ? (PL_parser->in_my == KEY_our
6040 : PL_parser->in_my == KEY_state
6050 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
6051 PL_parser->in_my = FALSE;
6052 PL_parser->in_my_stash = NULL;
6057 Perl_jmaybe(pTHX_ OP *o)
6059 PERL_ARGS_ASSERT_JMAYBE;
6061 if (o->op_type == OP_LIST) {
6062 if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
6064 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
6065 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
6068 /* If the user disables this, then a warning might not be enough to alert
6069 them to a possible change of behaviour here, so throw an exception.
6071 yyerror("Multidimensional hash lookup is disabled");
6077 PERL_STATIC_INLINE OP *
6078 S_op_std_init(pTHX_ OP *o)
6080 I32 type = o->op_type;
6082 PERL_ARGS_ASSERT_OP_STD_INIT;
6084 if (PL_opargs[type] & OA_RETSCALAR)
6086 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
6087 o->op_targ = pad_alloc(type, SVs_PADTMP);
6092 PERL_STATIC_INLINE OP *
6093 S_op_integerize(pTHX_ OP *o)
6095 I32 type = o->op_type;
6097 PERL_ARGS_ASSERT_OP_INTEGERIZE;
6099 /* integerize op. */
6100 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
6102 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
6105 if (type == OP_NEGATE)
6106 /* XXX might want a ck_negate() for this */
6107 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
6112 /* This function exists solely to provide a scope to limit
6113 setjmp/longjmp() messing with auto variables. It cannot be inlined because
6117 S_fold_constants_eval(pTHX) {
6133 S_fold_constants(pTHX_ OP *const o)
6137 I32 type = o->op_type;
6142 SV * const oldwarnhook = PL_warnhook;
6143 SV * const olddiehook = PL_diehook;
6145 U8 oldwarn = PL_dowarn;
6148 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
6150 if (!(PL_opargs[type] & OA_FOLDCONST))
6159 #ifdef USE_LOCALE_CTYPE
6160 if (IN_LC_COMPILETIME(LC_CTYPE))
6169 #ifdef USE_LOCALE_COLLATE
6170 if (IN_LC_COMPILETIME(LC_COLLATE))
6175 /* XXX what about the numeric ops? */
6176 #ifdef USE_LOCALE_NUMERIC
6177 if (IN_LC_COMPILETIME(LC_NUMERIC))
6182 if (!OpHAS_SIBLING(cLISTOPo->op_first)
6183 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
6186 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
6187 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
6189 const char *s = SvPVX_const(sv);
6190 while (s < SvEND(sv)) {
6191 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
6198 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
6201 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
6202 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
6206 if (PL_parser && PL_parser->error_count)
6207 goto nope; /* Don't try to run w/ errors */
6209 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
6210 switch (curop->op_type) {
6212 if ( (curop->op_private & OPpCONST_BARE)
6213 && (curop->op_private & OPpCONST_STRICT)) {
6214 no_bareword_allowed(curop);
6222 /* Foldable; move to next op in list */
6226 /* No other op types are considered foldable */
6231 curop = LINKLIST(o);
6232 old_next = o->op_next;
6236 old_cxix = cxstack_ix;
6237 create_eval_scope(NULL, G_FAKINGEVAL);
6239 /* Verify that we don't need to save it: */
6240 assert(PL_curcop == &PL_compiling);
6241 StructCopy(&PL_compiling, ¬_compiling, COP);
6242 PL_curcop = ¬_compiling;
6243 /* The above ensures that we run with all the correct hints of the
6244 currently compiling COP, but that IN_PERL_RUNTIME is true. */
6245 assert(IN_PERL_RUNTIME);
6246 PL_warnhook = PERL_WARNHOOK_FATAL;
6249 /* Effective $^W=1. */
6250 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6251 PL_dowarn |= G_WARN_ON;
6253 ret = S_fold_constants_eval(aTHX);
6257 sv = *(PL_stack_sp--);
6258 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
6259 pad_swipe(o->op_targ, FALSE);
6261 else if (SvTEMP(sv)) { /* grab mortal temp? */
6262 SvREFCNT_inc_simple_void(sv);
6265 else { assert(SvIMMORTAL(sv)); }
6268 /* Something tried to die. Abandon constant folding. */
6269 /* Pretend the error never happened. */
6271 o->op_next = old_next;
6274 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
6275 PL_warnhook = oldwarnhook;
6276 PL_diehook = olddiehook;
6277 /* XXX note that this croak may fail as we've already blown away
6278 * the stack - eg any nested evals */
6279 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6281 PL_dowarn = oldwarn;
6282 PL_warnhook = oldwarnhook;
6283 PL_diehook = olddiehook;
6284 PL_curcop = &PL_compiling;
6286 /* if we croaked, depending on how we croaked the eval scope
6287 * may or may not have already been popped */
6288 if (cxstack_ix > old_cxix) {
6289 assert(cxstack_ix == old_cxix + 1);
6290 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6291 delete_eval_scope();
6296 /* OP_STRINGIFY and constant folding are used to implement qq.
6297 Here the constant folding is an implementation detail that we
6298 want to hide. If the stringify op is itself already marked
6299 folded, however, then it is actually a folded join. */
6300 is_stringify = type == OP_STRINGIFY && !o->op_folded;
6305 else if (!SvIMMORTAL(sv)) {
6309 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6310 if (!is_stringify) newop->op_folded = 1;
6317 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6318 * the constant value being an AV holding the flattened range.
6322 S_gen_constant_list(pTHX_ OP *o)
6324 OP *curop, *old_next;
6325 SV * const oldwarnhook = PL_warnhook;
6326 SV * const olddiehook = PL_diehook;
6328 U8 oldwarn = PL_dowarn;
6338 if (PL_parser && PL_parser->error_count)
6339 return; /* Don't attempt to run with errors */
6341 curop = LINKLIST(o);
6342 old_next = o->op_next;
6344 op_was_null = o->op_type == OP_NULL;
6345 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6346 o->op_type = OP_CUSTOM;
6349 o->op_type = OP_NULL;
6350 S_prune_chain_head(&curop);
6353 old_cxix = cxstack_ix;
6354 create_eval_scope(NULL, G_FAKINGEVAL);
6356 old_curcop = PL_curcop;
6357 StructCopy(old_curcop, ¬_compiling, COP);
6358 PL_curcop = ¬_compiling;
6359 /* The above ensures that we run with all the correct hints of the
6360 current COP, but that IN_PERL_RUNTIME is true. */
6361 assert(IN_PERL_RUNTIME);
6362 PL_warnhook = PERL_WARNHOOK_FATAL;
6366 /* Effective $^W=1. */
6367 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6368 PL_dowarn |= G_WARN_ON;
6372 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6373 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6375 Perl_pp_pushmark(aTHX);
6378 assert (!(curop->op_flags & OPf_SPECIAL));
6379 assert(curop->op_type == OP_RANGE);
6380 Perl_pp_anonlist(aTHX);
6384 o->op_next = old_next;
6388 PL_warnhook = oldwarnhook;
6389 PL_diehook = olddiehook;
6390 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6395 PL_dowarn = oldwarn;
6396 PL_warnhook = oldwarnhook;
6397 PL_diehook = olddiehook;
6398 PL_curcop = old_curcop;
6400 if (cxstack_ix > old_cxix) {
6401 assert(cxstack_ix == old_cxix + 1);
6402 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6403 delete_eval_scope();
6408 OpTYPE_set(o, OP_RV2AV);
6409 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6410 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6411 o->op_opt = 0; /* needs to be revisited in rpeep() */
6412 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6414 /* replace subtree with an OP_CONST */
6415 curop = ((UNOP*)o)->op_first;
6416 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6419 if (AvFILLp(av) != -1)
6420 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6423 SvREADONLY_on(*svp);
6431 =for apidoc_section $optree_manipulation
6434 /* List constructors */
6437 =for apidoc op_append_elem
6439 Append an item to the list of ops contained directly within a list-type
6440 op, returning the lengthened list. C<first> is the list-type op,
6441 and C<last> is the op to append to the list. C<optype> specifies the
6442 intended opcode for the list. If C<first> is not already a list of the
6443 right type, it will be upgraded into one. If either C<first> or C<last>
6444 is null, the other is returned unchanged.
6450 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6458 if (first->op_type != (unsigned)type
6459 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6461 return newLISTOP(type, 0, first, last);
6464 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6465 first->op_flags |= OPf_KIDS;
6470 =for apidoc op_append_list
6472 Concatenate the lists of ops contained directly within two list-type ops,
6473 returning the combined list. C<first> and C<last> are the list-type ops
6474 to concatenate. C<optype> specifies the intended opcode for the list.
6475 If either C<first> or C<last> is not already a list of the right type,
6476 it will be upgraded into one. If either C<first> or C<last> is null,
6477 the other is returned unchanged.
6483 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6491 if (first->op_type != (unsigned)type)
6492 return op_prepend_elem(type, first, last);
6494 if (last->op_type != (unsigned)type)
6495 return op_append_elem(type, first, last);
6497 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6498 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6499 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6500 first->op_flags |= (last->op_flags & OPf_KIDS);
6502 S_op_destroy(aTHX_ last);
6508 =for apidoc op_prepend_elem
6510 Prepend an item to the list of ops contained directly within a list-type
6511 op, returning the lengthened list. C<first> is the op to prepend to the
6512 list, and C<last> is the list-type op. C<optype> specifies the intended
6513 opcode for the list. If C<last> is not already a list of the right type,
6514 it will be upgraded into one. If either C<first> or C<last> is null,
6515 the other is returned unchanged.
6521 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6529 if (last->op_type == (unsigned)type) {
6530 if (type == OP_LIST) { /* already a PUSHMARK there */
6531 /* insert 'first' after pushmark */
6532 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6533 if (!(first->op_flags & OPf_PARENS))
6534 last->op_flags &= ~OPf_PARENS;
6537 op_sibling_splice(last, NULL, 0, first);
6538 last->op_flags |= OPf_KIDS;
6542 return newLISTOP(type, 0, first, last);
6546 =for apidoc op_convert_list
6548 Converts C<o> into a list op if it is not one already, and then converts it
6549 into the specified C<type>, calling its check function, allocating a target if
6550 it needs one, and folding constants.
6552 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6553 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6554 C<op_convert_list> to make it the right type.
6560 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6562 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6563 if (!o || o->op_type != OP_LIST)
6564 o = force_list(o, FALSE);
6567 o->op_flags &= ~OPf_WANT;
6568 o->op_private &= ~OPpLVAL_INTRO;
6571 if (!(PL_opargs[type] & OA_MARK))
6572 op_null(cLISTOPo->op_first);
6574 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6575 if (kid2 && kid2->op_type == OP_COREARGS) {
6576 op_null(cLISTOPo->op_first);
6577 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6581 if (type != OP_SPLIT)
6582 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6583 * ck_split() create a real PMOP and leave the op's type as listop
6584 * for now. Otherwise op_free() etc will crash.
6586 OpTYPE_set(o, type);
6588 o->op_flags |= flags;
6589 if (flags & OPf_FOLDED)
6592 o = CHECKOP(type, o);
6593 if (o->op_type != (unsigned)type)
6596 return fold_constants(op_integerize(op_std_init(o)));
6603 =for apidoc_section $optree_construction
6605 =for apidoc newNULLLIST
6607 Constructs, checks, and returns a new C<stub> op, which represents an
6608 empty list expression.
6614 Perl_newNULLLIST(pTHX)
6616 return newOP(OP_STUB, 0);
6619 /* promote o and any siblings to be a list if its not already; i.e.
6627 * pushmark - o - A - B
6629 * If nullit it true, the list op is nulled.
6633 S_force_list(pTHX_ OP *o, bool nullit)
6635 if (!o || o->op_type != OP_LIST) {
6638 /* manually detach any siblings then add them back later */
6639 rest = OpSIBLING(o);
6640 OpLASTSIB_set(o, NULL);
6642 o = newLISTOP(OP_LIST, 0, o, NULL);
6644 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6652 =for apidoc newLISTOP
6654 Constructs, checks, and returns an op of any list type. C<type> is
6655 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6656 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6657 supply up to two ops to be direct children of the list op; they are
6658 consumed by this function and become part of the constructed op tree.
6660 For most list operators, the check function expects all the kid ops to be
6661 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6662 appropriate. What you want to do in that case is create an op of type
6663 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6664 See L</op_convert_list> for more information.
6671 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6674 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6675 * pushmark is banned. So do it now while existing ops are in a
6676 * consistent state, in case they suddenly get freed */
6677 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6679 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6680 || type == OP_CUSTOM);
6682 NewOp(1101, listop, 1, LISTOP);
6683 OpTYPE_set(listop, type);
6686 listop->op_flags = (U8)flags;
6690 else if (!first && last)
6693 OpMORESIB_set(first, last);
6694 listop->op_first = first;
6695 listop->op_last = last;
6698 OpMORESIB_set(pushop, first);
6699 listop->op_first = pushop;
6700 listop->op_flags |= OPf_KIDS;
6702 listop->op_last = pushop;
6704 if (listop->op_last)
6705 OpLASTSIB_set(listop->op_last, (OP*)listop);
6707 return CHECKOP(type, listop);
6713 Constructs, checks, and returns an op of any base type (any type that
6714 has no extra fields). C<type> is the opcode. C<flags> gives the
6715 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6722 Perl_newOP(pTHX_ I32 type, I32 flags)
6726 if (type == -OP_ENTEREVAL) {
6727 type = OP_ENTEREVAL;
6728 flags |= OPpEVAL_BYTES<<8;
6731 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6732 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6733 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6734 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6736 NewOp(1101, o, 1, OP);
6737 OpTYPE_set(o, type);
6738 o->op_flags = (U8)flags;
6741 o->op_private = (U8)(0 | (flags >> 8));
6742 if (PL_opargs[type] & OA_RETSCALAR)
6744 if (PL_opargs[type] & OA_TARGET)
6745 o->op_targ = pad_alloc(type, SVs_PADTMP);
6746 return CHECKOP(type, o);
6752 Constructs, checks, and returns an op of any unary type. C<type> is
6753 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6754 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6755 bits, the eight bits of C<op_private>, except that the bit with value 1
6756 is automatically set. C<first> supplies an optional op to be the direct
6757 child of the unary op; it is consumed by this function and become part
6758 of the constructed op tree.
6760 =for apidoc Amnh||OPf_KIDS
6766 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6770 if (type == -OP_ENTEREVAL) {
6771 type = OP_ENTEREVAL;
6772 flags |= OPpEVAL_BYTES<<8;
6775 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6776 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6777 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6778 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6779 || type == OP_SASSIGN
6780 || type == OP_ENTERTRY
6781 || type == OP_ENTERTRYCATCH
6782 || type == OP_CUSTOM
6783 || type == OP_NULL );
6786 first = newOP(OP_STUB, 0);
6787 if (PL_opargs[type] & OA_MARK)
6788 first = force_list(first, TRUE);
6790 NewOp(1101, unop, 1, UNOP);
6791 OpTYPE_set(unop, type);
6792 unop->op_first = first;
6793 unop->op_flags = (U8)(flags | OPf_KIDS);
6794 unop->op_private = (U8)(1 | (flags >> 8));
6796 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6797 OpLASTSIB_set(first, (OP*)unop);
6799 unop = (UNOP*) CHECKOP(type, unop);
6803 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6807 =for apidoc newUNOP_AUX
6809 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6810 initialised to C<aux>
6816 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6820 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6821 || type == OP_CUSTOM);
6823 NewOp(1101, unop, 1, UNOP_AUX);
6824 unop->op_type = (OPCODE)type;
6825 unop->op_ppaddr = PL_ppaddr[type];
6826 unop->op_first = first;
6827 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6828 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6831 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6832 OpLASTSIB_set(first, (OP*)unop);
6834 unop = (UNOP_AUX*) CHECKOP(type, unop);
6836 return op_std_init((OP *) unop);
6840 =for apidoc newMETHOP
6842 Constructs, checks, and returns an op of method type with a method name
6843 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6844 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6845 and, shifted up eight bits, the eight bits of C<op_private>, except that
6846 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6847 op which evaluates method name; it is consumed by this function and
6848 become part of the constructed op tree.
6849 Supported optypes: C<OP_METHOD>.
6855 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6858 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6859 || type == OP_CUSTOM);
6861 NewOp(1101, methop, 1, METHOP);
6863 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, TRUE);
6864 methop->op_flags = (U8)(flags | OPf_KIDS);
6865 methop->op_u.op_first = dynamic_meth;
6866 methop->op_private = (U8)(1 | (flags >> 8));
6868 if (!OpHAS_SIBLING(dynamic_meth))
6869 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6873 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6874 methop->op_u.op_meth_sv = const_meth;
6875 methop->op_private = (U8)(0 | (flags >> 8));
6876 methop->op_next = (OP*)methop;
6880 methop->op_rclass_targ = 0;
6882 methop->op_rclass_sv = NULL;
6885 OpTYPE_set(methop, type);
6886 return CHECKOP(type, methop);
6890 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6891 PERL_ARGS_ASSERT_NEWMETHOP;
6892 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6896 =for apidoc newMETHOP_named
6898 Constructs, checks, and returns an op of method type with a constant
6899 method name. C<type> is the opcode. C<flags> gives the eight bits of
6900 C<op_flags>, and, shifted up eight bits, the eight bits of
6901 C<op_private>. C<const_meth> supplies a constant method name;
6902 it must be a shared COW string.
6903 Supported optypes: C<OP_METHOD_NAMED>.
6909 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6910 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6911 return newMETHOP_internal(type, flags, NULL, const_meth);
6915 =for apidoc newBINOP
6917 Constructs, checks, and returns an op of any binary type. C<type>
6918 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6919 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6920 the eight bits of C<op_private>, except that the bit with value 1 or
6921 2 is automatically set as required. C<first> and C<last> supply up to
6922 two ops to be the direct children of the binary op; they are consumed
6923 by this function and become part of the constructed op tree.
6929 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6933 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6934 || type == OP_NULL || type == OP_CUSTOM);
6936 NewOp(1101, binop, 1, BINOP);
6939 first = newOP(OP_NULL, 0);
6941 OpTYPE_set(binop, type);
6942 binop->op_first = first;
6943 binop->op_flags = (U8)(flags | OPf_KIDS);
6946 binop->op_private = (U8)(1 | (flags >> 8));
6949 binop->op_private = (U8)(2 | (flags >> 8));
6950 OpMORESIB_set(first, last);
6953 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6954 OpLASTSIB_set(last, (OP*)binop);
6956 binop->op_last = OpSIBLING(binop->op_first);
6958 OpLASTSIB_set(binop->op_last, (OP*)binop);
6960 binop = (BINOP*)CHECKOP(type, binop);
6961 if (binop->op_next || binop->op_type != (OPCODE)type)
6964 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6968 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
6970 const char indent[] = " ";
6972 UV len = _invlist_len(invlist);
6973 UV * array = invlist_array(invlist);
6976 PERL_ARGS_ASSERT_INVMAP_DUMP;
6978 for (i = 0; i < len; i++) {
6979 UV start = array[i];
6980 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
6982 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
6983 if (end == IV_MAX) {
6984 PerlIO_printf(Perl_debug_log, " .. INFTY");
6986 else if (end != start) {
6987 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
6990 PerlIO_printf(Perl_debug_log, " ");
6993 PerlIO_printf(Perl_debug_log, "\t");
6995 if (map[i] == TR_UNLISTED) {
6996 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
6998 else if (map[i] == TR_SPECIAL_HANDLING) {
6999 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
7002 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
7007 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
7008 * containing the search and replacement strings, assemble into
7009 * a translation table attached as o->op_pv.
7010 * Free expr and repl.
7011 * It expects the toker to have already set the
7012 * OPpTRANS_COMPLEMENT
7015 * flags as appropriate; this function may add
7017 * OPpTRANS_CAN_FORCE_UTF8
7018 * OPpTRANS_IDENTICAL
7024 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
7026 /* This function compiles a tr///, from data gathered from toke.c, into a
7027 * form suitable for use by do_trans() in doop.c at runtime.
7029 * It first normalizes the data, while discarding extraneous inputs; then
7030 * writes out the compiled data. The normalization allows for complete
7031 * analysis, and avoids some false negatives and positives earlier versions
7034 * The normalization form is an inversion map (described below in detail).
7035 * This is essentially the compiled form for tr///'s that require UTF-8,
7036 * and its easy to use it to write the 257-byte table for tr///'s that
7037 * don't need UTF-8. That table is identical to what's been in use for
7038 * many perl versions, except that it doesn't handle some edge cases that
7039 * it used to, involving code points above 255. The UTF-8 form now handles
7040 * these. (This could be changed with extra coding should it shown to be
7043 * If the complement (/c) option is specified, the lhs string (tstr) is
7044 * parsed into an inversion list. Complementing these is trivial. Then a
7045 * complemented tstr is built from that, and used thenceforth. This hides
7046 * the fact that it was complemented from almost all successive code.
7048 * One of the important characteristics to know about the input is whether
7049 * the transliteration may be done in place, or does a temporary need to be
7050 * allocated, then copied. If the replacement for every character in every
7051 * possible string takes up no more bytes than the character it
7052 * replaces, then it can be edited in place. Otherwise the replacement
7053 * could overwrite a byte we are about to read, depending on the strings
7054 * being processed. The comments and variable names here refer to this as
7055 * "growing". Some inputs won't grow, and might even shrink under /d, but
7056 * some inputs could grow, so we have to assume any given one might grow.
7057 * On very long inputs, the temporary could eat up a lot of memory, so we
7058 * want to avoid it if possible. For non-UTF-8 inputs, everything is
7059 * single-byte, so can be edited in place, unless there is something in the
7060 * pattern that could force it into UTF-8. The inversion map makes it
7061 * feasible to determine this. Previous versions of this code pretty much
7062 * punted on determining if UTF-8 could be edited in place. Now, this code
7063 * is rigorous in making that determination.
7065 * Another characteristic we need to know is whether the lhs and rhs are
7066 * identical. If so, and no other flags are present, the only effect of
7067 * the tr/// is to count the characters present in the input that are
7068 * mentioned in the lhs string. The implementation of that is easier and
7069 * runs faster than the more general case. Normalizing here allows for
7070 * accurate determination of this. Previously there were false negatives
7073 * Instead of 'transliterated', the comments here use 'unmapped' for the
7074 * characters that are left unchanged by the operation; otherwise they are
7077 * The lhs of the tr/// is here referred to as the t side.
7078 * The rhs of the tr/// is here referred to as the r side.
7081 SV * const tstr = ((SVOP*)expr)->op_sv;
7082 SV * const rstr = ((SVOP*)repl)->op_sv;
7085 const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
7086 const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
7089 UV t_count = 0, r_count = 0; /* Number of characters in search and
7090 replacement lists */
7092 /* khw thinks some of the private flags for this op are quaintly named.
7093 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
7094 * character when represented in UTF-8 is longer than the original
7095 * character's UTF-8 representation */
7096 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
7097 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
7098 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
7100 /* Set to true if there is some character < 256 in the lhs that maps to
7101 * above 255. If so, a non-UTF-8 match string can be forced into being in
7102 * UTF-8 by a tr/// operation. */
7103 bool can_force_utf8 = FALSE;
7105 /* What is the maximum expansion factor in UTF-8 transliterations. If a
7106 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
7107 * expansion factor is 1.5. This number is used at runtime to calculate
7108 * how much space to allocate for non-inplace transliterations. Without
7109 * this number, the worst case is 14, which is extremely unlikely to happen
7110 * in real life, and could require significant memory overhead. */
7111 NV max_expansion = 1.;
7113 UV t_range_count, r_range_count, min_range_count;
7117 UV r_cp = 0, t_cp = 0;
7118 UV t_cp_end = (UV) -1;
7122 UV final_map = TR_UNLISTED; /* The final character in the replacement
7123 list, updated as we go along. Initialize
7124 to something illegal */
7126 bool rstr_utf8 = cBOOL(SvUTF8(rstr));
7127 bool tstr_utf8 = cBOOL(SvUTF8(tstr));
7129 const U8* tend = t + tlen;
7130 const U8* rend = r + rlen;
7132 SV * inverted_tstr = NULL;
7137 /* This routine implements detection of a transliteration having a longer
7138 * UTF-8 representation than its source, by partitioning all the possible
7139 * code points of the platform into equivalence classes of the same UTF-8
7140 * byte length in the first pass. As it constructs the mappings, it carves
7141 * these up into smaller chunks, but doesn't merge any together. This
7142 * makes it easy to find the instances it's looking for. A second pass is
7143 * done after this has been determined which merges things together to
7144 * shrink the table for runtime. The table below is used for both ASCII
7145 * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically
7146 * increasing for code points below 256. To correct for that, the macro
7147 * CP_ADJUST defined below converts those code points to ASCII in the first
7148 * pass, and we use the ASCII partition values. That works because the
7149 * growth factor will be unaffected, which is all that is calculated during
7150 * the first pass. */
7151 UV PL_partition_by_byte_length[] = {
7153 0x80, /* Below this is 1 byte representations */
7154 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */
7155 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */
7156 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */
7157 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */
7158 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */
7162 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */
7167 PERL_ARGS_ASSERT_PMTRANS;
7169 PL_hints |= HINT_BLOCK_SCOPE;
7171 /* If /c, the search list is sorted and complemented. This is now done by
7172 * creating an inversion list from it, and then trivially inverting that.
7173 * The previous implementation used qsort, but creating the list
7174 * automatically keeps it sorted as we go along */
7177 SV * inverted_tlist = _new_invlist(tlen);
7180 DEBUG_y(PerlIO_printf(Perl_debug_log,
7181 "%s: %d: tstr before inversion=\n%s\n",
7182 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7186 /* Non-utf8 strings don't have ranges, so each character is listed
7189 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
7192 else { /* But UTF-8 strings have been parsed in toke.c to have
7193 * ranges if appropriate. */
7197 /* Get the first character */
7198 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7201 /* If the next byte indicates that this wasn't the first
7202 * element of a range, the range is just this one */
7203 if (t >= tend || *t != RANGE_INDICATOR) {
7204 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
7206 else { /* Otherwise, ignore the indicator byte, and get the
7207 final element, and add the whole range */
7209 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
7212 inverted_tlist = _add_range_to_invlist(inverted_tlist,
7216 } /* End of parse through tstr */
7218 /* The inversion list is done; now invert it */
7219 _invlist_invert(inverted_tlist);
7221 /* Now go through the inverted list and create a new tstr for the rest
7222 * of the routine to use. Since the UTF-8 version can have ranges, and
7223 * can be much more compact than the non-UTF-8 version, we create the
7224 * string in UTF-8 even if not necessary. (This is just an intermediate
7225 * value that gets thrown away anyway.) */
7226 invlist_iterinit(inverted_tlist);
7227 inverted_tstr = newSVpvs("");
7228 while (invlist_iternext(inverted_tlist, &start, &end)) {
7229 U8 temp[UTF8_MAXBYTES];
7232 /* IV_MAX keeps things from going out of bounds */
7233 start = MIN(IV_MAX, start);
7234 end = MIN(IV_MAX, end);
7236 temp_end_pos = uvchr_to_utf8(temp, start);
7237 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7240 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
7241 temp_end_pos = uvchr_to_utf8(temp, end);
7242 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7246 /* Set up so the remainder of the routine uses this complement, instead
7247 * of the actual input */
7248 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
7249 tend = t0 + temp_len;
7252 SvREFCNT_dec_NN(inverted_tlist);
7255 /* For non-/d, an empty rhs means to use the lhs */
7256 if (rlen == 0 && ! del) {
7259 rstr_utf8 = tstr_utf8;
7262 t_invlist = _new_invlist(1);
7264 /* Initialize to a single range */
7265 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7267 /* For the first pass, the lhs is partitioned such that the
7268 * number of UTF-8 bytes required to represent a code point in each
7269 * partition is the same as the number for any other code point in
7270 * that partion. We copy the pre-compiled partion. */
7271 len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
7272 invlist_extend(t_invlist, len);
7273 t_array = invlist_array(t_invlist);
7274 Copy(PL_partition_by_byte_length, t_array, len, UV);
7275 invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
7276 Newx(r_map, len + 1, UV);
7278 /* Parse the (potentially adjusted) input, creating the inversion map.
7279 * This is done in two passes. The first pass is to determine if the
7280 * transliteration can be done in place. The inversion map it creates
7281 * could be used, but generally would be larger and slower to run than the
7282 * output of the second pass, which starts with a more compact table and
7283 * allows more ranges to be merged */
7284 for (pass2 = 0; pass2 < 2; pass2++) {
7286 /* Initialize to a single range */
7287 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7289 /* In the second pass, we just have the single range */
7291 t_array = invlist_array(t_invlist);
7294 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
7295 * so as to get the well-behaved length 1 vs length 2 boundary. Only code
7296 * points below 256 differ between the two character sets in this regard. For
7297 * these, we also can't have any ranges, as they have to be individually
7300 # define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x))
7301 # define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256))
7302 # define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
7304 # define CP_ADJUST(x) (x)
7305 # define FORCE_RANGE_LEN_1(x) 0
7306 # define CP_SKIP(x) UVCHR_SKIP(x)
7309 /* And the mapping of each of the ranges is initialized. Initially,
7310 * everything is TR_UNLISTED. */
7311 for (i = 0; i < len; i++) {
7312 r_map[i] = TR_UNLISTED;
7319 t_range_count = r_range_count = 0;
7321 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
7322 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7323 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
7324 _byte_dump_string(r, rend - r, 0)));
7325 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
7326 complement, squash, del));
7327 DEBUG_y(invmap_dump(t_invlist, r_map));
7329 /* Now go through the search list constructing an inversion map. The
7330 * input is not necessarily in any particular order. Making it an
7331 * inversion map orders it, potentially simplifying, and makes it easy
7332 * to deal with at run time. This is the only place in core that
7333 * generates an inversion map; if others were introduced, it might be
7334 * better to create general purpose routines to handle them.
7335 * (Inversion maps are created in perl in other places.)
7337 * An inversion map consists of two parallel arrays. One is
7338 * essentially an inversion list: an ordered list of code points such
7339 * that each element gives the first code point of a range of
7340 * consecutive code points that map to the element in the other array
7341 * that has the same index as this one (in other words, the
7342 * corresponding element). Thus the range extends up to (but not
7343 * including) the code point given by the next higher element. In a
7344 * true inversion map, the corresponding element in the other array
7345 * gives the mapping of the first code point in the range, with the
7346 * understanding that the next higher code point in the inversion
7347 * list's range will map to the next higher code point in the map.
7349 * So if at element [i], let's say we have:
7354 * This means that A => a, B => b, C => c.... Let's say that the
7355 * situation is such that:
7359 * This means the sequence that started at [i] stops at K => k. This
7360 * illustrates that you need to look at the next element to find where
7361 * a sequence stops. Except, the highest element in the inversion list
7362 * begins a range that is understood to extend to the platform's
7365 * This routine modifies traditional inversion maps to reserve two
7368 * TR_UNLISTED (or -1) indicates that no code point in the range
7369 * is listed in the tr/// searchlist. At runtime, these are
7370 * always passed through unchanged. In the inversion map, all
7371 * points in the range are mapped to -1, instead of increasing,
7372 * like the 'L' in the example above.
7374 * We start the parse with every code point mapped to this, and as
7375 * we parse and find ones that are listed in the search list, we
7376 * carve out ranges as we go along that override that.
7378 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
7379 * range needs special handling. Again, all code points in the
7380 * range are mapped to -2, instead of increasing.
7382 * Under /d this value means the code point should be deleted from
7383 * the transliteration when encountered.
7385 * Otherwise, it marks that every code point in the range is to
7386 * map to the final character in the replacement list. This
7387 * happens only when the replacement list is shorter than the
7388 * search one, so there are things in the search list that have no
7389 * correspondence in the replacement list. For example, in
7390 * tr/a-z/A/, 'A' is the final value, and the inversion map
7391 * generated for this would be like this:
7396 * 'A' appears once, then the remainder of the range maps to -2.
7397 * The use of -2 isn't strictly necessary, as an inversion map is
7398 * capable of representing this situation, but not nearly so
7399 * compactly, and this is actually quite commonly encountered.
7400 * Indeed, the original design of this code used a full inversion
7401 * map for this. But things like
7403 * generated huge data structures, slowly, and the execution was
7404 * also slow. So the current scheme was implemented.
7406 * So, if the next element in our example is:
7410 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next
7414 * [i+4] S TR_UNLISTED
7416 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is
7417 * the final element in the arrays, every code point from S to infinity
7418 * maps to TR_UNLISTED.
7421 /* Finish up range started in what otherwise would
7422 * have been the final iteration */
7423 while (t < tend || t_range_count > 0) {
7424 bool adjacent_to_range_above = FALSE;
7425 bool adjacent_to_range_below = FALSE;
7427 bool merge_with_range_above = FALSE;
7428 bool merge_with_range_below = FALSE;
7430 UV span, invmap_range_length_remaining;
7434 /* If we are in the middle of processing a range in the 'target'
7435 * side, the previous iteration has set us up. Otherwise, look at
7436 * the next character in the search list */
7437 if (t_range_count <= 0) {
7440 /* Here, not in the middle of a range, and not UTF-8. The
7441 * next code point is the single byte where we're at */
7442 t_cp = CP_ADJUST(*t);
7449 /* Here, not in the middle of a range, and is UTF-8. The
7450 * next code point is the next UTF-8 char in the input. We
7451 * know the input is valid, because the toker constructed
7453 t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
7456 /* UTF-8 strings (only) have been parsed in toke.c to have
7457 * ranges. See if the next byte indicates that this was
7458 * the first element of a range. If so, get the final
7459 * element and calculate the range size. If not, the range
7461 if ( t < tend && *t == RANGE_INDICATOR
7462 && ! FORCE_RANGE_LEN_1(t_cp))
7465 t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
7474 /* Count the total number of listed code points * */
7475 t_count += t_range_count;
7478 /* Similarly, get the next character in the replacement list */
7479 if (r_range_count <= 0) {
7482 /* But if we've exhausted the rhs, there is nothing to map
7483 * to, except the special handling one, and we make the
7484 * range the same size as the lhs one. */
7485 r_cp = TR_SPECIAL_HANDLING;
7486 r_range_count = t_range_count;
7489 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7490 "final_map =%" UVXf "\n", final_map));
7495 r_cp = CP_ADJUST(*r);
7502 r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
7504 if ( r < rend && *r == RANGE_INDICATOR
7505 && ! FORCE_RANGE_LEN_1(r_cp))
7508 r_range_count = valid_utf8_to_uvchr(r,
7509 &r_char_len) - r_cp + 1;
7517 if (r_cp == TR_SPECIAL_HANDLING) {
7518 r_range_count = t_range_count;
7521 /* This is the final character so far */
7522 final_map = r_cp + r_range_count - 1;
7524 r_count += r_range_count;
7528 /* Here, we have the next things ready in both sides. They are
7529 * potentially ranges. We try to process as big a chunk as
7530 * possible at once, but the lhs and rhs must be synchronized, so
7531 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
7533 min_range_count = MIN(t_range_count, r_range_count);
7535 /* Search the inversion list for the entry that contains the input
7536 * code point <cp>. The inversion map was initialized to cover the
7537 * entire range of possible inputs, so this should not fail. So
7538 * the return value is the index into the list's array of the range
7539 * that contains <cp>, that is, 'i' such that array[i] <= cp <
7541 j = _invlist_search(t_invlist, t_cp);
7545 /* Here, the data structure might look like:
7548 * [i-1] J j # J-L => j-l
7549 * [i] M -1 # M => default; as do N, O, P, Q
7550 * [i+1] R x # R => x, S => x+1, T => x+2
7551 * [i+2] U y # U => y, V => y+1, ...
7553 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7555 * where 'x' and 'y' above are not to be taken literally.
7557 * The maximum chunk we can handle in this loop iteration, is the
7558 * smallest of the three components: the lhs 't_', the rhs 'r_',
7559 * and the remainder of the range in element [i]. (In pass 1, that
7560 * range will have everything in it be of the same class; we can't
7561 * cross into another class.) 'min_range_count' already contains
7562 * the smallest of the first two values. The final one is
7563 * irrelevant if the map is to the special indicator */
7565 invmap_range_length_remaining = (i + 1 < len)
7566 ? t_array[i+1] - t_cp
7568 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
7570 /* The end point of this chunk is where we are, plus the span, but
7571 * never larger than the platform's infinity */
7572 t_cp_end = MIN(IV_MAX, t_cp + span - 1);
7574 if (r_cp == TR_SPECIAL_HANDLING) {
7576 /* If unmatched lhs code points map to the final map, use that
7577 * value. This being set to TR_SPECIAL_HANDLING indicates that
7578 * we don't have a final map: unmatched lhs code points are
7580 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
7583 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
7585 /* If something on the lhs is below 256, and something on the
7586 * rhs is above, there is a potential mapping here across that
7587 * boundary. Indeed the only way there isn't is if both sides
7588 * start at the same point. That means they both cross at the
7589 * same time. But otherwise one crosses before the other */
7590 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
7591 can_force_utf8 = TRUE;
7595 /* If a character appears in the search list more than once, the
7596 * 2nd and succeeding occurrences are ignored, so only do this
7597 * range if haven't already processed this character. (The range
7598 * has been set up so that all members in it will be of the same
7600 if (r_map[i] == TR_UNLISTED) {
7601 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7602 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
7603 t_cp, t_cp_end, r_cp, r_cp_end));
7605 /* This is the first definition for this chunk, hence is valid
7606 * and needs to be processed. Here and in the comments below,
7607 * we use the above sample data. The t_cp chunk must be any
7608 * contiguous subset of M, N, O, P, and/or Q.
7610 * In the first pass, calculate if there is any possible input
7611 * string that has a character whose transliteration will be
7612 * longer than it. If none, the transliteration may be done
7613 * in-place, as it can't write over a so-far unread byte.
7614 * Otherwise, a copy must first be made. This could be
7615 * expensive for long inputs.
7617 * In the first pass, the t_invlist has been partitioned so
7618 * that all elements in any single range have the same number
7619 * of bytes in their UTF-8 representations. And the r space is
7620 * either a single byte, or a range of strictly monotonically
7621 * increasing code points. So the final element in the range
7622 * will be represented by no fewer bytes than the initial one.
7623 * That means that if the final code point in the t range has
7624 * at least as many bytes as the final code point in the r,
7625 * then all code points in the t range have at least as many
7626 * bytes as their corresponding r range element. But if that's
7627 * not true, the transliteration of at least the final code
7628 * point grows in length. As an example, suppose we had
7629 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
7630 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
7631 * platforms. We have deliberately set up the data structure
7632 * so that any range in the lhs gets split into chunks for
7633 * processing, such that every code point in a chunk has the
7634 * same number of UTF-8 bytes. We only have to check the final
7635 * code point in the rhs against any code point in the lhs. */
7637 && r_cp_end != TR_SPECIAL_HANDLING
7638 && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
7640 /* Here, we will need to make a copy of the input string
7641 * before doing the transliteration. The worst possible
7642 * case is an expansion ratio of 14:1. This is rare, and
7643 * we'd rather allocate only the necessary amount of extra
7644 * memory for that copy. We can calculate the worst case
7645 * for this particular transliteration is by keeping track
7646 * of the expansion factor for each range.
7648 * Consider tr/\xCB/\X{E000}/. The maximum expansion
7649 * factor is 1 byte going to 3 if the target string is not
7650 * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We
7651 * could pass two different values so doop could choose
7652 * based on the UTF-8ness of the target. But khw thinks
7653 * (perhaps wrongly) that is overkill. It is used only to
7654 * make sure we malloc enough space.
7656 * If no target string can force the result to be UTF-8,
7657 * then we don't have to worry about the case of the target
7658 * string not being UTF-8 */
7659 NV t_size = (can_force_utf8 && t_cp < 256)
7661 : CP_SKIP(t_cp_end);
7662 NV ratio = CP_SKIP(r_cp_end) / t_size;
7664 o->op_private |= OPpTRANS_GROWS;
7666 /* Now that we know it grows, we can keep track of the
7668 if (ratio > max_expansion) {
7669 max_expansion = ratio;
7670 DEBUG_y(PerlIO_printf(Perl_debug_log,
7671 "New expansion factor: %" NVgf "\n",
7676 /* The very first range is marked as adjacent to the
7677 * non-existent range below it, as it causes things to "just
7680 * If the lowest code point in this chunk is M, it adjoins the
7682 if (t_cp == t_array[i]) {
7683 adjacent_to_range_below = TRUE;
7685 /* And if the map has the same offset from the beginning of
7686 * the range as does this new code point (or both are for
7687 * TR_SPECIAL_HANDLING), this chunk can be completely
7688 * merged with the range below. EXCEPT, in the first pass,
7689 * we don't merge ranges whose UTF-8 byte representations
7690 * have different lengths, so that we can more easily
7691 * detect if a replacement is longer than the source, that
7692 * is if it 'grows'. But in the 2nd pass, there's no
7693 * reason to not merge */
7694 if ( (i > 0 && ( pass2
7695 || CP_SKIP(t_array[i-1])
7697 && ( ( r_cp == TR_SPECIAL_HANDLING
7698 && r_map[i-1] == TR_SPECIAL_HANDLING)
7699 || ( r_cp != TR_SPECIAL_HANDLING
7700 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
7702 merge_with_range_below = TRUE;
7706 /* Similarly, if the highest code point in this chunk is 'Q',
7707 * it adjoins the range above, and if the map is suitable, can
7708 * be merged with it */
7709 if ( t_cp_end >= IV_MAX - 1
7711 && t_cp_end + 1 == t_array[i+1]))
7713 adjacent_to_range_above = TRUE;
7716 || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
7717 && ( ( r_cp == TR_SPECIAL_HANDLING
7718 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
7719 || ( r_cp != TR_SPECIAL_HANDLING
7720 && r_cp_end == r_map[i+1] - 1)))
7722 merge_with_range_above = TRUE;
7726 if (merge_with_range_below && merge_with_range_above) {
7728 /* Here the new chunk looks like M => m, ... Q => q; and
7729 * the range above is like R => r, .... Thus, the [i-1]
7730 * and [i+1] ranges should be seamlessly melded so the
7733 * [i-1] J j # J-T => j-t
7734 * [i] U y # U => y, V => y+1, ...
7736 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7738 Move(t_array + i + 2, t_array + i, len - i - 2, UV);
7739 Move(r_map + i + 2, r_map + i, len - i - 2, UV);
7741 invlist_set_len(t_invlist,
7743 *(get_invlist_offset_addr(t_invlist)));
7745 else if (merge_with_range_below) {
7747 /* Here the new chunk looks like M => m, .... But either
7748 * (or both) it doesn't extend all the way up through Q; or
7749 * the range above doesn't start with R => r. */
7750 if (! adjacent_to_range_above) {
7752 /* In the first case, let's say the new chunk extends
7753 * through O. We then want:
7755 * [i-1] J j # J-O => j-o
7756 * [i] P -1 # P => -1, Q => -1
7757 * [i+1] R x # R => x, S => x+1, T => x+2
7758 * [i+2] U y # U => y, V => y+1, ...
7760 * [-1] Z -1 # Z => default; as do Z+1, ...
7763 t_array[i] = t_cp_end + 1;
7764 r_map[i] = TR_UNLISTED;
7766 else { /* Adjoins the range above, but can't merge with it
7767 (because 'x' is not the next map after q) */
7769 * [i-1] J j # J-Q => j-q
7770 * [i] R x # R => x, S => x+1, T => x+2
7771 * [i+1] U y # U => y, V => y+1, ...
7773 * [-1] Z -1 # Z => default; as do Z+1, ...
7777 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7778 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7780 invlist_set_len(t_invlist, len,
7781 *(get_invlist_offset_addr(t_invlist)));
7784 else if (merge_with_range_above) {
7786 /* Here the new chunk ends with Q => q, and the range above
7787 * must start with R => r, so the two can be merged. But
7788 * either (or both) the new chunk doesn't extend all the
7789 * way down to M; or the mapping of the final code point
7790 * range below isn't m */
7791 if (! adjacent_to_range_below) {
7793 /* In the first case, let's assume the new chunk starts
7794 * with P => p. Then, because it's merge-able with the
7795 * range above, that range must be R => r. We want:
7797 * [i-1] J j # J-L => j-l
7798 * [i] M -1 # M => -1, N => -1
7799 * [i+1] P p # P-T => p-t
7800 * [i+2] U y # U => y, V => y+1, ...
7802 * [-1] Z -1 # Z => default; as do Z+1, ...
7805 t_array[i+1] = t_cp;
7808 else { /* Adjoins the range below, but can't merge with it
7811 * [i-1] J j # J-L => j-l
7812 * [i] M x # M-T => x-5 .. x+2
7813 * [i+1] U y # U => y, V => y+1, ...
7815 * [-1] Z -1 # Z => default; as do Z+1, ...
7818 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7819 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7823 invlist_set_len(t_invlist, len,
7824 *(get_invlist_offset_addr(t_invlist)));
7827 else if (adjacent_to_range_below && adjacent_to_range_above) {
7828 /* The new chunk completely fills the gap between the
7829 * ranges on either side, but can't merge with either of
7832 * [i-1] J j # J-L => j-l
7833 * [i] M z # M => z, N => z+1 ... Q => z+4
7834 * [i+1] R x # R => x, S => x+1, T => x+2
7835 * [i+2] U y # U => y, V => y+1, ...
7837 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7841 else if (adjacent_to_range_below) {
7842 /* The new chunk adjoins the range below, but not the range
7843 * above, and can't merge. Let's assume the chunk ends at
7846 * [i-1] J j # J-L => j-l
7847 * [i] M z # M => z, N => z+1, O => z+2
7848 * [i+1] P -1 # P => -1, Q => -1
7849 * [i+2] R x # R => x, S => x+1, T => x+2
7850 * [i+3] U y # U => y, V => y+1, ...
7852 * [-w] Z -1 # Z => default; as do Z+1, ... infinity
7854 invlist_extend(t_invlist, len + 1);
7855 t_array = invlist_array(t_invlist);
7856 Renew(r_map, len + 1, UV);
7858 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7859 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7861 t_array[i+1] = t_cp_end + 1;
7862 r_map[i+1] = TR_UNLISTED;
7864 invlist_set_len(t_invlist, len,
7865 *(get_invlist_offset_addr(t_invlist)));
7867 else if (adjacent_to_range_above) {
7868 /* The new chunk adjoins the range above, but not the range
7869 * below, and can't merge. Let's assume the new chunk
7872 * [i-1] J j # J-L => j-l
7873 * [i] M -1 # M => default, N => default
7874 * [i+1] O z # O => z, P => z+1, Q => z+2
7875 * [i+2] R x # R => x, S => x+1, T => x+2
7876 * [i+3] U y # U => y, V => y+1, ...
7878 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7880 invlist_extend(t_invlist, len + 1);
7881 t_array = invlist_array(t_invlist);
7882 Renew(r_map, len + 1, UV);
7884 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7885 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7886 t_array[i+1] = t_cp;
7889 invlist_set_len(t_invlist, len,
7890 *(get_invlist_offset_addr(t_invlist)));
7893 /* The new chunk adjoins neither the range above, nor the
7894 * range below. Lets assume it is N..P => n..p
7896 * [i-1] J j # J-L => j-l
7897 * [i] M -1 # M => default
7898 * [i+1] N n # N..P => n..p
7899 * [i+2] Q -1 # Q => default
7900 * [i+3] R x # R => x, S => x+1, T => x+2
7901 * [i+4] U y # U => y, V => y+1, ...
7903 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7906 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7907 "Before fixing up: len=%d, i=%d\n",
7908 (int) len, (int) i));
7909 DEBUG_yv(invmap_dump(t_invlist, r_map));
7911 invlist_extend(t_invlist, len + 2);
7912 t_array = invlist_array(t_invlist);
7913 Renew(r_map, len + 2, UV);
7915 Move(t_array + i + 1,
7916 t_array + i + 2 + 1, len - i - (2 - 1), UV);
7918 r_map + i + 2 + 1, len - i - (2 - 1), UV);
7921 invlist_set_len(t_invlist, len,
7922 *(get_invlist_offset_addr(t_invlist)));
7924 t_array[i+1] = t_cp;
7927 t_array[i+2] = t_cp_end + 1;
7928 r_map[i+2] = TR_UNLISTED;
7930 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7931 "After iteration: span=%" UVuf ", t_range_count=%"
7932 UVuf " r_range_count=%" UVuf "\n",
7933 span, t_range_count, r_range_count));
7934 DEBUG_yv(invmap_dump(t_invlist, r_map));
7935 } /* End of this chunk needs to be processed */
7937 /* Done with this chunk. */
7939 if (t_cp >= IV_MAX) {
7942 t_range_count -= span;
7943 if (r_cp != TR_SPECIAL_HANDLING) {
7945 r_range_count -= span;
7951 } /* End of loop through the search list */
7953 /* We don't need an exact count, but we do need to know if there is
7954 * anything left over in the replacement list. So, just assume it's
7955 * one byte per character */
7959 } /* End of passes */
7961 SvREFCNT_dec(inverted_tstr);
7963 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
7964 DEBUG_y(invmap_dump(t_invlist, r_map));
7966 /* We now have normalized the input into an inversion map.
7968 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op
7969 * except for the count, and streamlined runtime code can be used */
7970 if (!del && !squash) {
7972 /* They are identical if they point to same address, or if everything
7973 * maps to UNLISTED or to itself. This catches things that not looking
7974 * at the normalized inversion map doesn't catch, like tr/aa/ab/ or
7975 * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */
7977 for (i = 0; i < len; i++) {
7978 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
7979 goto done_identical_check;
7984 /* Here have gone through entire list, and didn't find any
7985 * non-identical mappings */
7986 o->op_private |= OPpTRANS_IDENTICAL;
7988 done_identical_check: ;
7991 t_array = invlist_array(t_invlist);
7993 /* If has components above 255, we generally need to use the inversion map
7997 && t_array[len-1] > 255
7998 /* If the final range is 0x100-INFINITY and is a special
7999 * mapping, the table implementation can handle it */
8000 && ! ( t_array[len-1] == 256
8001 && ( r_map[len-1] == TR_UNLISTED
8002 || r_map[len-1] == TR_SPECIAL_HANDLING))))
8006 /* A UTF-8 op is generated, indicated by this flag. This op is an
8008 o->op_private |= OPpTRANS_USE_SVOP;
8010 if (can_force_utf8) {
8011 o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
8014 /* The inversion map is pushed; first the list. */
8015 invmap = MUTABLE_AV(newAV());
8016 av_push(invmap, t_invlist);
8018 /* 2nd is the mapping */
8019 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
8020 av_push(invmap, r_map_sv);
8022 /* 3rd is the max possible expansion factor */
8023 av_push(invmap, newSVnv(max_expansion));
8025 /* Characters that are in the search list, but not in the replacement
8026 * list are mapped to the final character in the replacement list */
8027 if (! del && r_count < t_count) {
8028 av_push(invmap, newSVuv(final_map));
8032 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
8033 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
8034 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
8035 SvPADTMP_on(invmap);
8036 SvREADONLY_on(invmap);
8038 cSVOPo->op_sv = (SV *) invmap;
8046 /* The OPtrans_map struct already contains one slot; hence the -1. */
8047 SSize_t struct_size = sizeof(OPtrans_map)
8048 + (256 - 1 + 1)*sizeof(short);
8050 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
8051 * table. Entries with the value TR_UNMAPPED indicate chars not to be
8052 * translated, while TR_DELETE indicates a search char without a
8053 * corresponding replacement char under /d.
8055 * In addition, an extra slot at the end is used to store the final
8056 * repeating char, or TR_R_EMPTY under an empty replacement list, or
8057 * TR_DELETE under /d; which makes the runtime code easier.
8060 /* Indicate this is an op_pv */
8061 o->op_private &= ~OPpTRANS_USE_SVOP;
8063 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
8065 cPVOPo->op_pv = (char*)tbl;
8067 for (i = 0; i < len; i++) {
8068 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
8069 short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
8070 short to = (short) r_map[i];
8072 bool do_increment = TRUE;
8074 /* Any code points above our limit should be irrelevant */
8075 if (t_array[i] >= tbl->size) break;
8077 /* Set up the map */
8078 if (to == (short) TR_SPECIAL_HANDLING && ! del) {
8079 to = (short) final_map;
8080 do_increment = FALSE;
8083 do_increment = FALSE;
8086 /* Create a map for everything in this range. The value increases
8087 * except for the special cases */
8088 for (j = (short) t_array[i]; j < upper; j++) {
8090 if (do_increment) to++;
8094 tbl->map[tbl->size] = del
8098 : (short) TR_R_EMPTY;
8099 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
8100 for (i = 0; i < tbl->size; i++) {
8101 if (tbl->map[i] < 0) {
8102 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
8103 (unsigned) i, tbl->map[i]));
8106 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
8107 (unsigned) i, tbl->map[i]));
8109 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
8110 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
8113 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
8114 (unsigned) tbl->size, tbl->map[tbl->size]));
8116 SvREFCNT_dec(t_invlist);
8118 #if 0 /* code that added excess above-255 chars at the end of the table, in
8119 case we ever want to not use the inversion map implementation for
8126 /* More replacement chars than search chars:
8127 * store excess replacement chars at end of main table.
8130 struct_size += excess;
8131 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
8132 struct_size + excess * sizeof(short));
8133 tbl->size += excess;
8134 cPVOPo->op_pv = (char*)tbl;
8136 for (i = 0; i < excess; i++)
8137 tbl->map[i + 256] = r[j+i];
8140 /* no more replacement chars than search chars */
8146 DEBUG_y(PerlIO_printf(Perl_debug_log,
8147 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
8148 " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
8149 del, squash, complement,
8150 cBOOL(o->op_private & OPpTRANS_IDENTICAL),
8151 cBOOL(o->op_private & OPpTRANS_USE_SVOP),
8152 cBOOL(o->op_private & OPpTRANS_GROWS),
8153 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
8158 if(del && rlen != 0 && r_count == t_count) {
8159 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
8160 } else if(r_count > t_count) {
8161 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
8174 Constructs, checks, and returns an op of any pattern matching type.
8175 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
8176 and, shifted up eight bits, the eight bits of C<op_private>.
8182 Perl_newPMOP(pTHX_ I32 type, I32 flags)
8186 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
8187 || type == OP_CUSTOM);
8189 NewOp(1101, pmop, 1, PMOP);
8190 OpTYPE_set(pmop, type);
8191 pmop->op_flags = (U8)flags;
8192 pmop->op_private = (U8)(0 | (flags >> 8));
8193 if (PL_opargs[type] & OA_RETSCALAR)
8196 if (PL_hints & HINT_RE_TAINT)
8197 pmop->op_pmflags |= PMf_RETAINT;
8198 #ifdef USE_LOCALE_CTYPE
8199 if (IN_LC_COMPILETIME(LC_CTYPE)) {
8200 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
8205 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
8207 if (PL_hints & HINT_RE_FLAGS) {
8208 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8209 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
8211 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
8212 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8213 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
8215 if (reflags && SvOK(reflags)) {
8216 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
8222 assert(SvPOK(PL_regex_pad[0]));
8223 if (SvCUR(PL_regex_pad[0])) {
8224 /* Pop off the "packed" IV from the end. */
8225 SV *const repointer_list = PL_regex_pad[0];
8226 const char *p = SvEND(repointer_list) - sizeof(IV);
8227 const IV offset = *((IV*)p);
8229 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
8231 SvEND_set(repointer_list, p);
8233 pmop->op_pmoffset = offset;
8234 /* This slot should be free, so assert this: */
8235 assert(PL_regex_pad[offset] == &PL_sv_undef);
8237 SV * const repointer = &PL_sv_undef;
8238 av_push(PL_regex_padav, repointer);
8239 pmop->op_pmoffset = av_top_index(PL_regex_padav);
8240 PL_regex_pad = AvARRAY(PL_regex_padav);
8244 return CHECKOP(type, pmop);
8252 /* Any pad names in scope are potentially lvalues. */
8253 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
8254 PADNAME *pn = PAD_COMPNAME_SV(i);
8255 if (!pn || !PadnameLEN(pn))
8257 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
8258 S_mark_padname_lvalue(aTHX_ pn);
8262 /* Given some sort of match op o, and an expression expr containing a
8263 * pattern, either compile expr into a regex and attach it to o (if it's
8264 * constant), or convert expr into a runtime regcomp op sequence (if it's
8267 * Flags currently has 2 bits of meaning:
8268 * 1: isreg indicates that the pattern is part of a regex construct, eg
8269 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
8270 * split "pattern", which aren't. In the former case, expr will be a list
8271 * if the pattern contains more than one term (eg /a$b/).
8272 * 2: The pattern is for a split.
8274 * When the pattern has been compiled within a new anon CV (for
8275 * qr/(?{...})/ ), then floor indicates the savestack level just before
8276 * the new sub was created
8278 * tr/// is also handled.
8282 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
8286 I32 repl_has_vars = 0;
8287 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
8288 bool is_compiletime;
8290 bool isreg = cBOOL(flags & 1);
8291 bool is_split = cBOOL(flags & 2);
8293 PERL_ARGS_ASSERT_PMRUNTIME;
8296 return pmtrans(o, expr, repl);
8299 /* find whether we have any runtime or code elements;
8300 * at the same time, temporarily set the op_next of each DO block;
8301 * then when we LINKLIST, this will cause the DO blocks to be excluded
8302 * from the op_next chain (and from having LINKLIST recursively
8303 * applied to them). We fix up the DOs specially later */
8307 if (expr->op_type == OP_LIST) {
8309 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8310 if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
8312 assert(!child->op_next);
8313 if (UNLIKELY(!OpHAS_SIBLING(child))) {
8314 assert(PL_parser && PL_parser->error_count);
8315 /* This can happen with qr/ (?{(^{})/. Just fake up
8316 the op we were expecting to see, to avoid crashing
8318 op_sibling_splice(expr, child, 0,
8319 newSVOP(OP_CONST, 0, &PL_sv_no));
8321 child->op_next = OpSIBLING(child);
8323 else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
8327 else if (expr->op_type != OP_CONST)
8332 /* fix up DO blocks; treat each one as a separate little sub;
8333 * also, mark any arrays as LIST/REF */
8335 if (expr->op_type == OP_LIST) {
8337 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8339 if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
8340 assert( !(child->op_flags & OPf_WANT));
8341 /* push the array rather than its contents. The regex
8342 * engine will retrieve and join the elements later */
8343 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
8347 if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
8349 child->op_next = NULL; /* undo temporary hack from above */
8352 if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
8353 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
8355 assert(leaveop->op_first->op_type == OP_ENTER);
8356 assert(OpHAS_SIBLING(leaveop->op_first));
8357 child->op_next = OpSIBLING(leaveop->op_first);
8359 assert(leaveop->op_flags & OPf_KIDS);
8360 assert(leaveop->op_last->op_next == (OP*)leaveop);
8361 leaveop->op_next = NULL; /* stop on last op */
8362 op_null((OP*)leaveop);
8366 OP *scope = cLISTOPx(child)->op_first;
8367 assert(scope->op_type == OP_SCOPE);
8368 assert(scope->op_flags & OPf_KIDS);
8369 scope->op_next = NULL; /* stop on last op */
8373 /* XXX optimize_optree() must be called on o before
8374 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
8375 * currently cope with a peephole-optimised optree.
8376 * Calling optimize_optree() here ensures that condition
8377 * is met, but may mean optimize_optree() is applied
8378 * to the same optree later (where hopefully it won't do any
8379 * harm as it can't convert an op to multiconcat if it's
8380 * already been converted */
8381 optimize_optree(child);
8383 /* have to peep the DOs individually as we've removed it from
8384 * the op_next chain */
8386 S_prune_chain_head(&(child->op_next));
8388 /* runtime finalizes as part of finalizing whole tree */
8389 finalize_optree(child);
8392 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
8393 assert( !(expr->op_flags & OPf_WANT));
8394 /* push the array rather than its contents. The regex
8395 * engine will retrieve and join the elements later */
8396 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
8399 PL_hints |= HINT_BLOCK_SCOPE;
8401 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
8403 if (is_compiletime) {
8404 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
8405 regexp_engine const *eng = current_re_engine();
8408 /* make engine handle split ' ' specially */
8409 pm->op_pmflags |= PMf_SPLIT;
8410 rx_flags |= RXf_SPLIT;
8413 if (!has_code || !eng->op_comp) {
8414 /* compile-time simple constant pattern */
8416 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
8417 /* whoops! we guessed that a qr// had a code block, but we
8418 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
8419 * that isn't required now. Note that we have to be pretty
8420 * confident that nothing used that CV's pad while the
8421 * regex was parsed, except maybe op targets for \Q etc.
8422 * If there were any op targets, though, they should have
8423 * been stolen by constant folding.
8427 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
8428 while (++i <= AvFILLp(PL_comppad)) {
8429 # ifdef USE_PAD_RESET
8430 /* under USE_PAD_RESET, pad swipe replaces a swiped
8431 * folded constant with a fresh padtmp */
8432 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
8434 assert(!PL_curpad[i]);
8438 /* This LEAVE_SCOPE will restore PL_compcv to point to the
8439 * outer CV (the one whose slab holds the pm op). The
8440 * inner CV (which holds expr) will be freed later, once
8441 * all the entries on the parse stack have been popped on
8442 * return from this function. Which is why its safe to
8443 * call op_free(expr) below.
8446 pm->op_pmflags &= ~PMf_HAS_CV;
8449 /* Skip compiling if parser found an error for this pattern */
8450 if (pm->op_pmflags & PMf_HAS_ERROR) {
8456 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8457 rx_flags, pm->op_pmflags)
8458 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8459 rx_flags, pm->op_pmflags)
8464 /* compile-time pattern that includes literal code blocks */
8468 /* Skip compiling if parser found an error for this pattern */
8469 if (pm->op_pmflags & PMf_HAS_ERROR) {
8473 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8476 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
8479 if (pm->op_pmflags & PMf_HAS_CV) {
8481 /* this QR op (and the anon sub we embed it in) is never
8482 * actually executed. It's just a placeholder where we can
8483 * squirrel away expr in op_code_list without the peephole
8484 * optimiser etc processing it for a second time */
8485 OP *qr = newPMOP(OP_QR, 0);
8486 ((PMOP*)qr)->op_code_list = expr;
8488 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
8489 SvREFCNT_inc_simple_void(PL_compcv);
8490 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8491 ReANY(re)->qr_anoncv = cv;
8493 /* attach the anon CV to the pad so that
8494 * pad_fixup_inner_anons() can find it */
8495 (void)pad_add_anon(cv, o->op_type);
8496 SvREFCNT_inc_simple_void(cv);
8499 pm->op_code_list = expr;
8504 /* runtime pattern: build chain of regcomp etc ops */
8506 PADOFFSET cv_targ = 0;
8508 reglist = isreg && expr->op_type == OP_LIST;
8513 pm->op_code_list = expr;
8514 /* don't free op_code_list; its ops are embedded elsewhere too */
8515 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
8519 /* make engine handle split ' ' specially */
8520 pm->op_pmflags |= PMf_SPLIT;
8522 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
8523 * to allow its op_next to be pointed past the regcomp and
8524 * preceding stacking ops;
8525 * OP_REGCRESET is there to reset taint before executing the
8527 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
8528 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
8530 if (pm->op_pmflags & PMf_HAS_CV) {
8531 /* we have a runtime qr with literal code. This means
8532 * that the qr// has been wrapped in a new CV, which
8533 * means that runtime consts, vars etc will have been compiled
8534 * against a new pad. So... we need to execute those ops
8535 * within the environment of the new CV. So wrap them in a call
8536 * to a new anon sub. i.e. for
8540 * we build an anon sub that looks like
8542 * sub { "a", $b, '(?{...})' }
8544 * and call it, passing the returned list to regcomp.
8545 * Or to put it another way, the list of ops that get executed
8549 * ------ -------------------
8550 * pushmark (for regcomp)
8551 * pushmark (for entersub)
8555 * regcreset regcreset
8557 * const("a") const("a")
8559 * const("(?{...})") const("(?{...})")
8564 SvREFCNT_inc_simple_void(PL_compcv);
8565 CvLVALUE_on(PL_compcv);
8566 /* these lines are just an unrolled newANONATTRSUB */
8567 expr = newSVOP(OP_ANONCODE, 0,
8568 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
8569 cv_targ = expr->op_targ;
8570 expr = newUNOP(OP_REFGEN, 0, expr);
8572 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), TRUE));
8575 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
8576 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
8577 | (reglist ? OPf_STACKED : 0);
8578 rcop->op_targ = cv_targ;
8580 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
8581 if (PL_hints & HINT_RE_EVAL)
8582 S_set_haseval(aTHX);
8584 /* establish postfix order */
8585 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
8587 rcop->op_next = expr;
8588 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
8591 rcop->op_next = LINKLIST(expr);
8592 expr->op_next = (OP*)rcop;
8595 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
8601 /* If we are looking at s//.../e with a single statement, get past
8602 the implicit do{}. */
8603 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
8604 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
8605 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
8608 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
8609 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
8610 && !OpHAS_SIBLING(sib))
8613 if (curop->op_type == OP_CONST)
8615 else if (( (curop->op_type == OP_RV2SV ||
8616 curop->op_type == OP_RV2AV ||
8617 curop->op_type == OP_RV2HV ||
8618 curop->op_type == OP_RV2GV)
8619 && cUNOPx(curop)->op_first
8620 && cUNOPx(curop)->op_first->op_type == OP_GV )
8621 || curop->op_type == OP_PADSV
8622 || curop->op_type == OP_PADAV
8623 || curop->op_type == OP_PADHV
8624 || curop->op_type == OP_PADANY) {
8632 || !RX_PRELEN(PM_GETRE(pm))
8633 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
8635 pm->op_pmflags |= PMf_CONST; /* const for long enough */
8636 op_prepend_elem(o->op_type, scalar(repl), o);
8639 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
8640 rcop->op_private = 1;
8642 /* establish postfix order */
8643 rcop->op_next = LINKLIST(repl);
8644 repl->op_next = (OP*)rcop;
8646 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
8647 assert(!(pm->op_pmflags & PMf_ONCE));
8648 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
8659 Constructs, checks, and returns an op of any type that involves an
8660 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
8661 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
8662 takes ownership of one reference to it.
8668 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
8672 PERL_ARGS_ASSERT_NEWSVOP;
8674 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8675 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8676 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8677 || type == OP_CUSTOM);
8679 NewOp(1101, svop, 1, SVOP);
8680 OpTYPE_set(svop, type);
8682 svop->op_next = (OP*)svop;
8683 svop->op_flags = (U8)flags;
8684 svop->op_private = (U8)(0 | (flags >> 8));
8685 if (PL_opargs[type] & OA_RETSCALAR)
8687 if (PL_opargs[type] & OA_TARGET)
8688 svop->op_targ = pad_alloc(type, SVs_PADTMP);
8689 return CHECKOP(type, svop);
8693 =for apidoc newDEFSVOP
8695 Constructs and returns an op to access C<$_>.
8701 Perl_newDEFSVOP(pTHX)
8703 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
8709 =for apidoc newPADOP
8711 Constructs, checks, and returns an op of any type that involves a
8712 reference to a pad element. C<type> is the opcode. C<flags> gives the
8713 eight bits of C<op_flags>. A pad slot is automatically allocated, and
8714 is populated with C<sv>; this function takes ownership of one reference
8717 This function only exists if Perl has been compiled to use ithreads.
8723 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
8727 PERL_ARGS_ASSERT_NEWPADOP;
8729 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8730 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8731 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8732 || type == OP_CUSTOM);
8734 NewOp(1101, padop, 1, PADOP);
8735 OpTYPE_set(padop, type);
8737 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
8738 SvREFCNT_dec(PAD_SVl(padop->op_padix));
8739 PAD_SETSV(padop->op_padix, sv);
8741 padop->op_next = (OP*)padop;
8742 padop->op_flags = (U8)flags;
8743 if (PL_opargs[type] & OA_RETSCALAR)
8745 if (PL_opargs[type] & OA_TARGET)
8746 padop->op_targ = pad_alloc(type, SVs_PADTMP);
8747 return CHECKOP(type, padop);
8750 #endif /* USE_ITHREADS */
8755 Constructs, checks, and returns an op of any type that involves an
8756 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
8757 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
8758 reference; calling this function does not transfer ownership of any
8765 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
8767 PERL_ARGS_ASSERT_NEWGVOP;
8770 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8772 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8779 Constructs, checks, and returns an op of any type that involves an
8780 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
8781 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
8782 Depending on the op type, the memory referenced by C<pv> may be freed
8783 when the op is destroyed. If the op is of a freeing type, C<pv> must
8784 have been allocated using C<PerlMemShared_malloc>.
8790 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
8792 const bool utf8 = cBOOL(flags & SVf_UTF8);
8797 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8798 || type == OP_RUNCV || type == OP_CUSTOM
8799 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
8801 NewOp(1101, pvop, 1, PVOP);
8802 OpTYPE_set(pvop, type);
8804 pvop->op_next = (OP*)pvop;
8805 pvop->op_flags = (U8)flags;
8806 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
8807 if (PL_opargs[type] & OA_RETSCALAR)
8809 if (PL_opargs[type] & OA_TARGET)
8810 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
8811 return CHECKOP(type, pvop);
8815 Perl_package(pTHX_ OP *o)
8817 SV *const sv = cSVOPo->op_sv;
8819 PERL_ARGS_ASSERT_PACKAGE;
8821 SAVEGENERICSV(PL_curstash);
8822 save_item(PL_curstname);
8824 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
8826 sv_setsv(PL_curstname, sv);
8828 PL_hints |= HINT_BLOCK_SCOPE;
8829 PL_parser->copline = NOLINE;
8835 Perl_package_version( pTHX_ OP *v )
8837 U32 savehints = PL_hints;
8838 PERL_ARGS_ASSERT_PACKAGE_VERSION;
8839 PL_hints &= ~HINT_STRICT_VARS;
8840 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
8841 PL_hints = savehints;
8845 /* Extract the first two components of a "version" object as two 8bit integers
8846 * and return them packed into a single U16 in the format of PL_prevailing_version.
8847 * This function only ever has to cope with version objects already known
8848 * bounded by the current perl version, so we know its components will fit
8849 * (Up until we reach perl version 5.256 anyway) */
8850 static U16 S_extract_shortver(pTHX_ SV *sv)
8853 if(!SvRV(sv) || !SvOBJECT(rv = SvRV(sv)) || !sv_derived_from(sv, "version"))
8856 AV *av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rv), "version", 0)));
8860 IV major = av_count(av) > 0 ? SvIV(*av_fetch(av, 0, false)) : 0;
8862 shortver |= 255 << 8;
8864 shortver |= major << 8;
8866 IV minor = av_count(av) > 1 ? SvIV(*av_fetch(av, 1, false)) : 0;
8874 #define SHORTVER(maj,min) ((maj << 8) | min)
8877 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
8882 SV *use_version = NULL;
8884 PERL_ARGS_ASSERT_UTILIZE;
8886 if (idop->op_type != OP_CONST)
8887 Perl_croak(aTHX_ "Module name must be constant");
8892 SV * const vesv = ((SVOP*)version)->op_sv;
8894 if (!arg && !SvNIOKp(vesv)) {
8901 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
8902 Perl_croak(aTHX_ "Version number must be a constant number");
8904 /* Make copy of idop so we don't free it twice */
8905 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8907 /* Fake up a method call to VERSION */
8908 meth = newSVpvs_share("VERSION");
8909 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8910 op_append_elem(OP_LIST,
8911 op_prepend_elem(OP_LIST, pack, version),
8912 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
8916 /* Fake up an import/unimport */
8917 if (arg && arg->op_type == OP_STUB) {
8918 imop = arg; /* no import on explicit () */
8920 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
8921 imop = NULL; /* use 5.0; */
8923 use_version = ((SVOP*)idop)->op_sv;
8925 idop->op_private |= OPpCONST_NOVER;
8930 /* Make copy of idop so we don't free it twice */
8931 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8933 /* Fake up a method call to import/unimport */
8935 ? newSVpvs_share("import") : newSVpvs_share("unimport");
8936 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8937 op_append_elem(OP_LIST,
8938 op_prepend_elem(OP_LIST, pack, arg),
8939 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
8943 /* Fake up the BEGIN {}, which does its thing immediately. */
8945 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
8948 op_append_elem(OP_LINESEQ,
8949 op_append_elem(OP_LINESEQ,
8950 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
8951 newSTATEOP(0, NULL, veop)),
8952 newSTATEOP(0, NULL, imop) ));
8956 * feature bundle that corresponds to the required version. */
8957 use_version = sv_2mortal(new_version(use_version));
8958 S_enable_feature_bundle(aTHX_ use_version);
8960 U16 shortver = S_extract_shortver(aTHX_ use_version);
8962 /* If a version >= 5.11.0 is requested, strictures are on by default! */
8963 if (shortver >= SHORTVER(5, 11)) {
8964 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8965 PL_hints |= HINT_STRICT_REFS;
8966 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8967 PL_hints |= HINT_STRICT_SUBS;
8968 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8969 PL_hints |= HINT_STRICT_VARS;
8971 if (shortver >= SHORTVER(5, 35))
8972 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
8974 /* otherwise they are off */
8976 if(PL_prevailing_version >= SHORTVER(5, 11))
8977 deprecate_fatal_in("5.40",
8978 "Downgrading a use VERSION declaration to below v5.11");
8980 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8981 PL_hints &= ~HINT_STRICT_REFS;
8982 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8983 PL_hints &= ~HINT_STRICT_SUBS;
8984 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8985 PL_hints &= ~HINT_STRICT_VARS;
8988 PL_prevailing_version = shortver;
8991 /* The "did you use incorrect case?" warning used to be here.
8992 * The problem is that on case-insensitive filesystems one
8993 * might get false positives for "use" (and "require"):
8994 * "use Strict" or "require CARP" will work. This causes
8995 * portability problems for the script: in case-strict
8996 * filesystems the script will stop working.
8998 * The "incorrect case" warning checked whether "use Foo"
8999 * imported "Foo" to your namespace, but that is wrong, too:
9000 * there is no requirement nor promise in the language that
9001 * a Foo.pm should or would contain anything in package "Foo".
9003 * There is very little Configure-wise that can be done, either:
9004 * the case-sensitivity of the build filesystem of Perl does not
9005 * help in guessing the case-sensitivity of the runtime environment.
9008 PL_hints |= HINT_BLOCK_SCOPE;
9009 PL_parser->copline = NOLINE;
9010 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
9014 =for apidoc_section $embedding
9016 =for apidoc load_module
9018 Loads the module whose name is pointed to by the string part of C<name>.
9019 Note that the actual module name, not its filename, should be given.
9020 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
9021 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
9022 trailing arguments can be used to specify arguments to the module's C<import()>
9023 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
9024 on the flags. The flags argument is a bitwise-ORed collection of any of
9025 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
9026 (or 0 for no flags).
9028 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
9029 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
9030 the trailing optional arguments may be omitted entirely. Otherwise, if
9031 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
9032 exactly one C<OP*>, containing the op tree that produces the relevant import
9033 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
9034 will be used as import arguments; and the list must be terminated with C<(SV*)
9035 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
9036 set, the trailing C<NULL> pointer is needed even if no import arguments are
9037 desired. The reference count for each specified C<SV*> argument is
9038 decremented. In addition, the C<name> argument is modified.
9040 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
9043 =for apidoc Amnh||PERL_LOADMOD_DENY
9044 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
9045 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
9047 =for apidoc vload_module
9048 Like C<L</load_module>> but the arguments are an encapsulated argument list.
9050 =for apidoc load_module_nocontext
9051 Like C<L</load_module>> but does not take a thread context (C<aTHX>) parameter,
9052 so is used in situations where the caller doesn't already have the thread
9058 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
9062 PERL_ARGS_ASSERT_LOAD_MODULE;
9064 va_start(args, ver);
9065 vload_module(flags, name, ver, &args);
9071 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
9075 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
9076 va_start(args, ver);
9077 vload_module(flags, name, ver, &args);
9083 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
9089 PERL_ARGS_ASSERT_VLOAD_MODULE;
9091 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
9092 * that it has a PL_parser to play with while doing that, and also
9093 * that it doesn't mess with any existing parser, by creating a tmp
9094 * new parser with lex_start(). This won't actually be used for much,
9095 * since pp_require() will create another parser for the real work.
9096 * The ENTER/LEAVE pair protect callers from any side effects of use.
9098 * start_subparse() creates a new PL_compcv. This means that any ops
9099 * allocated below will be allocated from that CV's op slab, and so
9100 * will be automatically freed if the utilise() fails
9104 SAVEVPTR(PL_curcop);
9105 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
9106 floor = start_subparse(FALSE, 0);
9108 modname = newSVOP(OP_CONST, 0, name);
9109 modname->op_private |= OPpCONST_BARE;
9111 veop = newSVOP(OP_CONST, 0, ver);
9115 if (flags & PERL_LOADMOD_NOIMPORT) {
9116 imop = sawparens(newNULLLIST());
9118 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
9119 imop = va_arg(*args, OP*);
9124 sv = va_arg(*args, SV*);
9126 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
9127 sv = va_arg(*args, SV*);
9131 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
9135 PERL_STATIC_INLINE OP *
9136 S_new_entersubop(pTHX_ GV *gv, OP *arg)
9138 return newUNOP(OP_ENTERSUB, OPf_STACKED,
9139 newLISTOP(OP_LIST, 0, arg,
9140 newUNOP(OP_RV2CV, 0,
9141 newGVOP(OP_GV, 0, gv))));
9145 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
9150 PERL_ARGS_ASSERT_DOFILE;
9152 if (!force_builtin && (gv = gv_override("do", 2))) {
9153 doop = S_new_entersubop(aTHX_ gv, term);
9156 doop = newUNOP(OP_DOFILE, 0, scalar(term));
9162 =for apidoc_section $optree_construction
9164 =for apidoc newSLICEOP
9166 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
9167 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
9168 be set automatically, and, shifted up eight bits, the eight bits of
9169 C<op_private>, except that the bit with value 1 or 2 is automatically
9170 set as required. C<listval> and C<subscript> supply the parameters of
9171 the slice; they are consumed by this function and become part of the
9172 constructed op tree.
9178 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
9180 return newBINOP(OP_LSLICE, flags,
9181 list(force_list(subscript, TRUE)),
9182 list(force_list(listval, TRUE)));
9185 #define ASSIGN_SCALAR 0
9186 #define ASSIGN_LIST 1
9187 #define ASSIGN_REF 2
9189 /* given the optree o on the LHS of an assignment, determine whether its:
9190 * ASSIGN_SCALAR $x = ...
9191 * ASSIGN_LIST ($x) = ...
9192 * ASSIGN_REF \$x = ...
9196 S_assignment_type(pTHX_ const OP *o)
9205 if (o->op_type == OP_SREFGEN)
9207 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
9208 type = kid->op_type;
9209 flags = o->op_flags | kid->op_flags;
9210 if (!(flags & OPf_PARENS)
9211 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
9212 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
9216 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
9217 o = cUNOPo->op_first;
9218 flags = o->op_flags;
9220 ret = ASSIGN_SCALAR;
9223 if (type == OP_COND_EXPR) {
9224 OP * const sib = OpSIBLING(cLOGOPo->op_first);
9225 const I32 t = assignment_type(sib);
9226 const I32 f = assignment_type(OpSIBLING(sib));
9228 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
9230 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
9231 yyerror("Assignment to both a list and a scalar");
9232 return ASSIGN_SCALAR;
9235 if (type == OP_LIST &&
9236 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
9237 o->op_private & OPpLVAL_INTRO)
9240 if (type == OP_LIST || flags & OPf_PARENS ||
9241 type == OP_RV2AV || type == OP_RV2HV ||
9242 type == OP_ASLICE || type == OP_HSLICE ||
9243 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
9246 if (type == OP_PADAV || type == OP_PADHV)
9249 if (type == OP_RV2SV)
9256 S_newONCEOP(pTHX_ OP *initop, OP *padop)
9258 const PADOFFSET target = padop->op_targ;
9259 OP *const other = newOP(OP_PADSV,
9261 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
9262 OP *const first = newOP(OP_NULL, 0);
9263 OP *const nullop = newCONDOP(0, first, initop, other);
9264 /* XXX targlex disabled for now; see ticket #124160
9265 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
9267 OP *const condop = first->op_next;
9269 OpTYPE_set(condop, OP_ONCE);
9270 other->op_targ = target;
9271 nullop->op_flags |= OPf_WANT_SCALAR;
9273 /* Store the initializedness of state vars in a separate
9276 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
9277 /* hijacking PADSTALE for uninitialized state variables */
9278 SvPADSTALE_on(PAD_SVl(condop->op_targ));
9284 =for apidoc newASSIGNOP
9286 Constructs, checks, and returns an assignment op. C<left> and C<right>
9287 supply the parameters of the assignment; they are consumed by this
9288 function and become part of the constructed op tree.
9290 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
9291 a suitable conditional optree is constructed. If C<optype> is the opcode
9292 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
9293 performs the binary operation and assigns the result to the left argument.
9294 Either way, if C<optype> is non-zero then C<flags> has no effect.
9296 If C<optype> is zero, then a plain scalar or list assignment is
9297 constructed. Which type of assignment it is is automatically determined.
9298 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9299 will be set automatically, and, shifted up eight bits, the eight bits
9300 of C<op_private>, except that the bit with value 1 or 2 is automatically
9307 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
9317 right = scalar(right);
9318 return newLOGOP(optype, 0,
9319 op_lvalue(scalar(left), optype),
9320 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
9322 return newBINOP(optype, OPf_STACKED,
9323 op_lvalue(scalar(left), optype), scalar(right));
9326 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
9327 OP *state_var_op = NULL;
9328 static const char no_list_state[] = "Initialization of state variables"
9329 " in list currently forbidden";
9332 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
9333 left->op_private &= ~ OPpSLICEWARNING;
9336 left = op_lvalue(left, OP_AASSIGN);
9337 curop = list(force_list(left, TRUE));
9338 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, TRUE)), curop);
9339 o->op_private = (U8)(0 | (flags >> 8));
9341 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
9343 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
9344 if (!(left->op_flags & OPf_PARENS) &&
9345 lop->op_type == OP_PUSHMARK &&
9346 (vop = OpSIBLING(lop)) &&
9347 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
9348 !(vop->op_flags & OPf_PARENS) &&
9349 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
9350 (OPpLVAL_INTRO|OPpPAD_STATE) &&
9351 (eop = OpSIBLING(vop)) &&
9352 eop->op_type == OP_ENTERSUB &&
9353 !OpHAS_SIBLING(eop)) {
9357 if ((lop->op_type == OP_PADSV ||
9358 lop->op_type == OP_PADAV ||
9359 lop->op_type == OP_PADHV ||
9360 lop->op_type == OP_PADANY)
9361 && (lop->op_private & OPpPAD_STATE)
9363 yyerror(no_list_state);
9364 lop = OpSIBLING(lop);
9368 else if ( (left->op_private & OPpLVAL_INTRO)
9369 && (left->op_private & OPpPAD_STATE)
9370 && ( left->op_type == OP_PADSV
9371 || left->op_type == OP_PADAV
9372 || left->op_type == OP_PADHV
9373 || left->op_type == OP_PADANY)
9375 /* All single variable list context state assignments, hence
9385 if (left->op_flags & OPf_PARENS)
9386 yyerror(no_list_state);
9388 state_var_op = left;
9391 /* optimise @a = split(...) into:
9392 * @{expr}: split(..., @{expr}) (where @a is not flattened)
9393 * @a, my @a, local @a: split(...) (where @a is attached to
9394 * the split op itself)
9398 && right->op_type == OP_SPLIT
9399 /* don't do twice, e.g. @b = (@a = split) */
9400 && !(right->op_private & OPpSPLIT_ASSIGN))
9404 if ( ( left->op_type == OP_RV2AV
9405 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
9406 || left->op_type == OP_PADAV)
9408 /* @pkg or @lex or local @pkg' or 'my @lex' */
9412 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
9413 = cPADOPx(gvop)->op_padix;
9414 cPADOPx(gvop)->op_padix = 0; /* steal it */
9416 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
9417 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
9418 cSVOPx(gvop)->op_sv = NULL; /* steal it */
9420 right->op_private |=
9421 left->op_private & OPpOUR_INTRO;
9424 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
9425 left->op_targ = 0; /* steal it */
9426 right->op_private |= OPpSPLIT_LEX;
9428 right->op_private |= left->op_private & OPpLVAL_INTRO;
9431 tmpop = cUNOPo->op_first; /* to list (nulled) */
9432 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
9433 assert(OpSIBLING(tmpop) == right);
9434 assert(!OpHAS_SIBLING(right));
9435 /* detach the split subtreee from the o tree,
9436 * then free the residual o tree */
9437 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
9438 op_free(o); /* blow off assign */
9439 right->op_private |= OPpSPLIT_ASSIGN;
9440 right->op_flags &= ~OPf_WANT;
9441 /* "I don't know and I don't care." */
9444 else if (left->op_type == OP_RV2AV) {
9447 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
9448 assert(OpSIBLING(pushop) == left);
9449 /* Detach the array ... */
9450 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
9451 /* ... and attach it to the split. */
9452 op_sibling_splice(right, cLISTOPx(right)->op_last,
9454 right->op_flags |= OPf_STACKED;
9455 /* Detach split and expunge aassign as above. */
9458 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
9459 ((LISTOP*)right)->op_last->op_type == OP_CONST)
9461 /* convert split(...,0) to split(..., PL_modcount+1) */
9463 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
9464 SV * const sv = *svp;
9465 if (SvIOK(sv) && SvIVX(sv) == 0)
9467 if (right->op_private & OPpSPLIT_IMPLIM) {
9468 /* our own SV, created in ck_split */
9470 sv_setiv(sv, PL_modcount+1);
9473 /* SV may belong to someone else */
9475 *svp = newSViv(PL_modcount+1);
9482 o = S_newONCEOP(aTHX_ o, state_var_op);
9485 if (assign_type == ASSIGN_REF)
9486 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
9488 right = newOP(OP_UNDEF, 0);
9489 if (right->op_type == OP_READLINE) {
9490 right->op_flags |= OPf_STACKED;
9491 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
9495 o = newBINOP(OP_SASSIGN, flags,
9496 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
9502 =for apidoc newSTATEOP
9504 Constructs a state op (COP). The state op is normally a C<nextstate> op,
9505 but will be a C<dbstate> op if debugging is enabled for currently-compiled
9506 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
9507 If C<label> is non-null, it supplies the name of a label to attach to
9508 the state op; this function takes ownership of the memory pointed at by
9509 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
9512 If C<o> is null, the state op is returned. Otherwise the state op is
9513 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
9514 is consumed by this function and becomes part of the returned op tree.
9520 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
9522 const U32 seq = intro_my();
9523 const U32 utf8 = flags & SVf_UTF8;
9526 PL_parser->parsed_sub = 0;
9530 NewOp(1101, cop, 1, COP);
9531 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
9532 OpTYPE_set(cop, OP_DBSTATE);
9535 OpTYPE_set(cop, OP_NEXTSTATE);
9537 cop->op_flags = (U8)flags;
9538 CopHINTS_set(cop, PL_hints);
9540 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
9542 cop->op_next = (OP*)cop;
9545 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9546 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
9548 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
9550 PL_hints |= HINT_BLOCK_SCOPE;
9551 /* It seems that we need to defer freeing this pointer, as other parts
9552 of the grammar end up wanting to copy it after this op has been
9557 if (PL_parser->preambling != NOLINE) {
9558 CopLINE_set(cop, PL_parser->preambling);
9559 PL_parser->copline = NOLINE;
9561 else if (PL_parser->copline == NOLINE)
9562 CopLINE_set(cop, CopLINE(PL_curcop));
9564 CopLINE_set(cop, PL_parser->copline);
9565 PL_parser->copline = NOLINE;
9568 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
9570 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
9572 CopSTASH_set(cop, PL_curstash);
9574 if (cop->op_type == OP_DBSTATE) {
9575 /* this line can have a breakpoint - store the cop in IV */
9576 AV *av = CopFILEAVx(PL_curcop);
9578 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
9579 if (svp && *svp != &PL_sv_undef ) {
9580 (void)SvIOK_on(*svp);
9581 SvIV_set(*svp, PTR2IV(cop));
9586 if (flags & OPf_SPECIAL)
9588 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
9592 =for apidoc newLOGOP
9594 Constructs, checks, and returns a logical (flow control) op. C<type>
9595 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
9596 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
9597 the eight bits of C<op_private>, except that the bit with value 1 is
9598 automatically set. C<first> supplies the expression controlling the
9599 flow, and C<other> supplies the side (alternate) chain of ops; they are
9600 consumed by this function and become part of the constructed op tree.
9606 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
9608 PERL_ARGS_ASSERT_NEWLOGOP;
9610 return new_logop(type, flags, &first, &other);
9614 /* See if the optree o contains a single OP_CONST (plus possibly
9615 * surrounding enter/nextstate/null etc). If so, return it, else return
9620 S_search_const(pTHX_ OP *o)
9622 PERL_ARGS_ASSERT_SEARCH_CONST;
9625 switch (o->op_type) {
9629 if (o->op_flags & OPf_KIDS) {
9630 o = cUNOPo->op_first;
9639 if (!(o->op_flags & OPf_KIDS))
9641 kid = cLISTOPo->op_first;
9644 switch (kid->op_type) {
9648 kid = OpSIBLING(kid);
9651 if (kid != cLISTOPo->op_last)
9658 kid = cLISTOPo->op_last;
9670 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
9677 int prepend_not = 0;
9679 PERL_ARGS_ASSERT_NEW_LOGOP;
9684 /* [perl #59802]: Warn about things like "return $a or $b", which
9685 is parsed as "(return $a) or $b" rather than "return ($a or
9686 $b)". NB: This also applies to xor, which is why we do it
9689 switch (first->op_type) {
9693 /* XXX: Perhaps we should emit a stronger warning for these.
9694 Even with the high-precedence operator they don't seem to do
9697 But until we do, fall through here.
9703 /* XXX: Currently we allow people to "shoot themselves in the
9704 foot" by explicitly writing "(return $a) or $b".
9706 Warn unless we are looking at the result from folding or if
9707 the programmer explicitly grouped the operators like this.
9708 The former can occur with e.g.
9710 use constant FEATURE => ( $] >= ... );
9711 sub { not FEATURE and return or do_stuff(); }
9713 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
9714 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9715 "Possible precedence issue with control flow operator");
9716 /* XXX: Should we optimze this to "return $a;" (i.e. remove
9722 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
9723 return newBINOP(type, flags, scalar(first), scalar(other));
9725 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
9726 || type == OP_CUSTOM);
9728 scalarboolean(first);
9730 /* search for a constant op that could let us fold the test */
9731 if ((cstop = search_const(first))) {
9732 if (cstop->op_private & OPpCONST_STRICT)
9733 no_bareword_allowed(cstop);
9734 else if ((cstop->op_private & OPpCONST_BARE))
9735 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
9736 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
9737 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
9738 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
9739 /* Elide the (constant) lhs, since it can't affect the outcome */
9741 if (other->op_type == OP_CONST)
9742 other->op_private |= OPpCONST_SHORTCIRCUIT;
9744 if (other->op_type == OP_LEAVE)
9745 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
9746 else if (other->op_type == OP_MATCH
9747 || other->op_type == OP_SUBST
9748 || other->op_type == OP_TRANSR
9749 || other->op_type == OP_TRANS)
9750 /* Mark the op as being unbindable with =~ */
9751 other->op_flags |= OPf_SPECIAL;
9753 other->op_folded = 1;
9757 /* Elide the rhs, since the outcome is entirely determined by
9758 * the (constant) lhs */
9760 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
9761 const OP *o2 = other;
9762 if ( ! (o2->op_type == OP_LIST
9763 && (( o2 = cUNOPx(o2)->op_first))
9764 && o2->op_type == OP_PUSHMARK
9765 && (( o2 = OpSIBLING(o2))) )
9768 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
9769 || o2->op_type == OP_PADHV)
9770 && o2->op_private & OPpLVAL_INTRO
9771 && !(o2->op_private & OPpPAD_STATE))
9773 Perl_croak(aTHX_ "This use of my() in false conditional is "
9774 "no longer allowed");
9778 if (cstop->op_type == OP_CONST)
9779 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
9784 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
9785 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
9787 const OP * const k1 = ((UNOP*)first)->op_first;
9788 const OP * const k2 = OpSIBLING(k1);
9790 switch (first->op_type)
9793 if (k2 && k2->op_type == OP_READLINE
9794 && (k2->op_flags & OPf_STACKED)
9795 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9797 warnop = k2->op_type;
9802 if (k1->op_type == OP_READDIR
9803 || k1->op_type == OP_GLOB
9804 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9805 || k1->op_type == OP_EACH
9806 || k1->op_type == OP_AEACH)
9808 warnop = ((k1->op_type == OP_NULL)
9809 ? (OPCODE)k1->op_targ : k1->op_type);
9814 const line_t oldline = CopLINE(PL_curcop);
9815 /* This ensures that warnings are reported at the first line
9816 of the construction, not the last. */
9817 CopLINE_set(PL_curcop, PL_parser->copline);
9818 Perl_warner(aTHX_ packWARN(WARN_MISC),
9819 "Value of %s%s can be \"0\"; test with defined()",
9821 ((warnop == OP_READLINE || warnop == OP_GLOB)
9822 ? " construct" : "() operator"));
9823 CopLINE_set(PL_curcop, oldline);
9827 /* optimize AND and OR ops that have NOTs as children */
9828 if (first->op_type == OP_NOT
9829 && (first->op_flags & OPf_KIDS)
9830 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
9831 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
9833 if (type == OP_AND || type == OP_OR) {
9839 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
9841 prepend_not = 1; /* prepend a NOT op later */
9846 logop = alloc_LOGOP(type, first, LINKLIST(other));
9847 logop->op_flags |= (U8)flags;
9848 logop->op_private = (U8)(1 | (flags >> 8));
9850 /* establish postfix order */
9851 logop->op_next = LINKLIST(first);
9852 first->op_next = (OP*)logop;
9853 assert(!OpHAS_SIBLING(first));
9854 op_sibling_splice((OP*)logop, first, 0, other);
9856 CHECKOP(type,logop);
9858 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
9859 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
9867 =for apidoc newCONDOP
9869 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
9870 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9871 will be set automatically, and, shifted up eight bits, the eight bits of
9872 C<op_private>, except that the bit with value 1 is automatically set.
9873 C<first> supplies the expression selecting between the two branches,
9874 and C<trueop> and C<falseop> supply the branches; they are consumed by
9875 this function and become part of the constructed op tree.
9881 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
9888 PERL_ARGS_ASSERT_NEWCONDOP;
9891 return newLOGOP(OP_AND, 0, first, trueop);
9893 return newLOGOP(OP_OR, 0, first, falseop);
9895 scalarboolean(first);
9896 if ((cstop = search_const(first))) {
9897 /* Left or right arm of the conditional? */
9898 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
9899 OP *live = left ? trueop : falseop;
9900 OP *const dead = left ? falseop : trueop;
9901 if (cstop->op_private & OPpCONST_BARE &&
9902 cstop->op_private & OPpCONST_STRICT) {
9903 no_bareword_allowed(cstop);
9907 if (live->op_type == OP_LEAVE)
9908 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
9909 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
9910 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
9911 /* Mark the op as being unbindable with =~ */
9912 live->op_flags |= OPf_SPECIAL;
9913 live->op_folded = 1;
9916 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
9917 logop->op_flags |= (U8)flags;
9918 logop->op_private = (U8)(1 | (flags >> 8));
9919 logop->op_next = LINKLIST(falseop);
9921 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
9924 /* establish postfix order */
9925 start = LINKLIST(first);
9926 first->op_next = (OP*)logop;
9928 /* make first, trueop, falseop siblings */
9929 op_sibling_splice((OP*)logop, first, 0, trueop);
9930 op_sibling_splice((OP*)logop, trueop, 0, falseop);
9932 o = newUNOP(OP_NULL, 0, (OP*)logop);
9934 trueop->op_next = falseop->op_next = o;
9941 =for apidoc newTRYCATCHOP
9943 Constructs and returns a conditional execution statement that implements
9944 the C<try>/C<catch> semantics. First the op tree in C<tryblock> is executed,
9945 inside a context that traps exceptions. If an exception occurs then the
9946 optree in C<catchblock> is executed, with the trapped exception set into the
9947 lexical variable given by C<catchvar> (which must be an op of type
9948 C<OP_PADSV>). All the optrees are consumed by this function and become part
9949 of the returned op tree.
9951 The C<flags> argument is currently ignored.
9957 Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock)
9961 PERL_ARGS_ASSERT_NEWTRYCATCHOP;
9962 assert(catchvar->op_type == OP_PADSV);
9964 PERL_UNUSED_ARG(flags);
9966 /* The returned optree is shaped as:
9967 * LISTOP leavetrycatch
9968 * LOGOP entertrycatch
9975 if(tryblock->op_type != OP_LINESEQ)
9976 tryblock = op_convert_list(OP_LINESEQ, 0, tryblock);
9977 OpTYPE_set(tryblock, OP_POPTRY);
9979 /* Manually construct a naked LOGOP.
9980 * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL)
9981 * containing the LOGOP we wanted as its op_first */
9982 catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock);
9983 OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock);
9984 OpLASTSIB_set(catchblock, catchop);
9986 /* Inject the catchvar's pad offset into the OP_CATCH targ */
9987 cLOGOPx(catchop)->op_targ = catchvar->op_targ;
9990 /* Build the optree structure */
9991 o = newLISTOP(OP_LIST, 0, tryblock, catchop);
9992 o = op_convert_list(OP_ENTERTRYCATCH, 0, o);
9998 =for apidoc newRANGE
10000 Constructs and returns a C<range> op, with subordinate C<flip> and
10001 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
10002 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
10003 for both the C<flip> and C<range> ops, except that the bit with value
10004 1 is automatically set. C<left> and C<right> supply the expressions
10005 controlling the endpoints of the range; they are consumed by this function
10006 and become part of the constructed op tree.
10012 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
10020 PERL_ARGS_ASSERT_NEWRANGE;
10022 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
10023 range->op_flags = OPf_KIDS;
10024 leftstart = LINKLIST(left);
10025 range->op_private = (U8)(1 | (flags >> 8));
10027 /* make left and right siblings */
10028 op_sibling_splice((OP*)range, left, 0, right);
10030 range->op_next = (OP*)range;
10031 flip = newUNOP(OP_FLIP, flags, (OP*)range);
10032 flop = newUNOP(OP_FLOP, 0, flip);
10033 o = newUNOP(OP_NULL, 0, flop);
10035 range->op_next = leftstart;
10037 left->op_next = flip;
10038 right->op_next = flop;
10041 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
10042 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
10044 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
10045 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
10046 SvPADTMP_on(PAD_SV(flip->op_targ));
10048 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
10049 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
10051 /* check barewords before they might be optimized aways */
10052 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
10053 no_bareword_allowed(left);
10054 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
10055 no_bareword_allowed(right);
10058 if (!flip->op_private || !flop->op_private)
10059 LINKLIST(o); /* blow off optimizer unless constant */
10065 =for apidoc newLOOPOP
10067 Constructs, checks, and returns an op tree expressing a loop. This is
10068 only a loop in the control flow through the op tree; it does not have
10069 the heavyweight loop structure that allows exiting the loop by C<last>
10070 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
10071 top-level op, except that some bits will be set automatically as required.
10072 C<expr> supplies the expression controlling loop iteration, and C<block>
10073 supplies the body of the loop; they are consumed by this function and
10074 become part of the constructed op tree. C<debuggable> is currently
10075 unused and should always be 1.
10081 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
10085 const bool once = block && block->op_flags & OPf_SPECIAL &&
10086 block->op_type == OP_NULL;
10088 PERL_UNUSED_ARG(debuggable);
10092 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
10093 || ( expr->op_type == OP_NOT
10094 && cUNOPx(expr)->op_first->op_type == OP_CONST
10095 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
10098 /* Return the block now, so that S_new_logop does not try to
10102 return block; /* do {} while 0 does once */
10105 if (expr->op_type == OP_READLINE
10106 || expr->op_type == OP_READDIR
10107 || expr->op_type == OP_GLOB
10108 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
10109 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
10110 expr = newUNOP(OP_DEFINED, 0,
10111 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
10112 } else if (expr->op_flags & OPf_KIDS) {
10113 const OP * const k1 = ((UNOP*)expr)->op_first;
10114 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
10115 switch (expr->op_type) {
10117 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
10118 && (k2->op_flags & OPf_STACKED)
10119 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
10120 expr = newUNOP(OP_DEFINED, 0, expr);
10124 if (k1 && (k1->op_type == OP_READDIR
10125 || k1->op_type == OP_GLOB
10126 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
10127 || k1->op_type == OP_EACH
10128 || k1->op_type == OP_AEACH))
10129 expr = newUNOP(OP_DEFINED, 0, expr);
10135 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
10136 * op, in listop. This is wrong. [perl #27024] */
10138 block = newOP(OP_NULL, 0);
10139 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
10140 o = new_logop(OP_AND, 0, &expr, &listop);
10147 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
10149 if (once && o != listop)
10151 assert(cUNOPo->op_first->op_type == OP_AND
10152 || cUNOPo->op_first->op_type == OP_OR);
10153 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
10157 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
10159 o->op_flags |= flags;
10161 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
10166 =for apidoc newWHILEOP
10168 Constructs, checks, and returns an op tree expressing a C<while> loop.
10169 This is a heavyweight loop, with structure that allows exiting the loop
10170 by C<last> and suchlike.
10172 C<loop> is an optional preconstructed C<enterloop> op to use in the
10173 loop; if it is null then a suitable op will be constructed automatically.
10174 C<expr> supplies the loop's controlling expression. C<block> supplies the
10175 main body of the loop, and C<cont> optionally supplies a C<continue> block
10176 that operates as a second half of the body. All of these optree inputs
10177 are consumed by this function and become part of the constructed op tree.
10179 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10180 op and, shifted up eight bits, the eight bits of C<op_private> for
10181 the C<leaveloop> op, except that (in both cases) some bits will be set
10182 automatically. C<debuggable> is currently unused and should always be 1.
10183 C<has_my> can be supplied as true to force the
10184 loop body to be enclosed in its own scope.
10190 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
10191 OP *expr, OP *block, OP *cont, I32 has_my)
10199 PERL_UNUSED_ARG(debuggable);
10202 if (expr->op_type == OP_READLINE
10203 || expr->op_type == OP_READDIR
10204 || expr->op_type == OP_GLOB
10205 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
10206 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
10207 expr = newUNOP(OP_DEFINED, 0,
10208 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
10209 } else if (expr->op_flags & OPf_KIDS) {
10210 const OP * const k1 = ((UNOP*)expr)->op_first;
10211 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
10212 switch (expr->op_type) {
10214 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
10215 && (k2->op_flags & OPf_STACKED)
10216 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
10217 expr = newUNOP(OP_DEFINED, 0, expr);
10221 if (k1 && (k1->op_type == OP_READDIR
10222 || k1->op_type == OP_GLOB
10223 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
10224 || k1->op_type == OP_EACH
10225 || k1->op_type == OP_AEACH))
10226 expr = newUNOP(OP_DEFINED, 0, expr);
10233 block = newOP(OP_NULL, 0);
10234 else if (cont || has_my) {
10235 block = op_scope(block);
10239 next = LINKLIST(cont);
10242 OP * const unstack = newOP(OP_UNSTACK, 0);
10245 cont = op_append_elem(OP_LINESEQ, cont, unstack);
10249 listop = op_append_list(OP_LINESEQ, block, cont);
10251 redo = LINKLIST(listop);
10255 o = new_logop(OP_AND, 0, &expr, &listop);
10256 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
10257 op_free((OP*)loop);
10258 return expr; /* listop already freed by new_logop */
10261 ((LISTOP*)listop)->op_last->op_next =
10262 (o == listop ? redo : LINKLIST(o));
10268 NewOp(1101,loop,1,LOOP);
10269 OpTYPE_set(loop, OP_ENTERLOOP);
10270 loop->op_private = 0;
10271 loop->op_next = (OP*)loop;
10274 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
10276 loop->op_redoop = redo;
10277 loop->op_lastop = o;
10278 o->op_private |= loopflags;
10281 loop->op_nextop = next;
10283 loop->op_nextop = o;
10285 o->op_flags |= flags;
10286 o->op_private |= (flags >> 8);
10291 =for apidoc newFOROP
10293 Constructs, checks, and returns an op tree expressing a C<foreach>
10294 loop (iteration through a list of values). This is a heavyweight loop,
10295 with structure that allows exiting the loop by C<last> and suchlike.
10297 C<sv> optionally supplies the variable(s) that will be aliased to each
10298 item in turn; if null, it defaults to C<$_>.
10299 C<expr> supplies the list of values to iterate over. C<block> supplies
10300 the main body of the loop, and C<cont> optionally supplies a C<continue>
10301 block that operates as a second half of the body. All of these optree
10302 inputs are consumed by this function and become part of the constructed
10305 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10306 op and, shifted up eight bits, the eight bits of C<op_private> for
10307 the C<leaveloop> op, except that (in both cases) some bits will be set
10314 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
10318 PADOFFSET padoff = 0;
10319 PADOFFSET how_many_more = 0;
10321 I32 iterpflags = 0;
10323 PERL_ARGS_ASSERT_NEWFOROP;
10326 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
10327 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
10328 OpTYPE_set(sv, OP_RV2GV);
10330 /* The op_type check is needed to prevent a possible segfault
10331 * if the loop variable is undeclared and 'strict vars' is in
10332 * effect. This is illegal but is nonetheless parsed, so we
10333 * may reach this point with an OP_CONST where we're expecting
10336 if (cUNOPx(sv)->op_first->op_type == OP_GV
10337 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
10338 iterpflags |= OPpITER_DEF;
10340 else if (sv->op_type == OP_PADSV) { /* private variable */
10341 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
10342 padoff = sv->op_targ;
10346 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
10348 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
10350 else if (sv->op_type == OP_LIST) {
10351 LISTOP *list = (LISTOP *) sv;
10352 OP *pushmark = list->op_first;
10357 iterpflags = OPpLVAL_INTRO; /* for my ($k, $v) () */
10359 if (!pushmark || pushmark->op_type != OP_PUSHMARK) {
10360 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting pushmark",
10361 pushmark ? PL_op_desc[pushmark->op_type] : "NULL");
10363 first_padsv = OpSIBLING(pushmark);
10364 if (!first_padsv || first_padsv->op_type != OP_PADSV) {
10365 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting padsv",
10366 first_padsv ? PL_op_desc[first_padsv->op_type] : "NULL");
10368 padoff = first_padsv->op_targ;
10370 /* There should be at least one more PADSV to find, and the ops
10371 should have consecutive values in targ: */
10372 padsv = (UNOP *) OpSIBLING(first_padsv);
10374 if (!padsv || padsv->op_type != OP_PADSV) {
10375 Perl_croak(aTHX_ "panic: newFORLOOP, found %s at %zd, expecting padsv",
10376 padsv ? PL_op_desc[padsv->op_type] : "NULL",
10380 if (padsv->op_targ != padoff + how_many_more) {
10381 Perl_croak(aTHX_ "panic: newFORLOOP, padsv at %zd targ is %zd, not %zd",
10382 how_many_more, padsv->op_targ, padoff + how_many_more);
10385 padsv = (UNOP *) OpSIBLING(padsv);
10388 /* OK, this optree has the shape that we expected. So now *we*
10389 "claim" the Pad slots: */
10390 first_padsv->op_targ = 0;
10391 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
10395 padsv = (UNOP *) OpSIBLING(first_padsv);
10398 padsv->op_targ = 0;
10399 PAD_COMPNAME_GEN_set(i, PERL_INT_MAX);
10401 padsv = (UNOP *) OpSIBLING(padsv);
10408 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
10410 PADNAME * const pn = PAD_COMPNAME(padoff);
10411 const char * const name = PadnamePV(pn);
10413 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
10414 iterpflags |= OPpITER_DEF;
10418 sv = newGVOP(OP_GV, 0, PL_defgv);
10419 iterpflags |= OPpITER_DEF;
10422 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
10423 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), TRUE), OP_GREPSTART);
10424 iterflags |= OPf_STACKED;
10426 else if (expr->op_type == OP_NULL &&
10427 (expr->op_flags & OPf_KIDS) &&
10428 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
10430 /* Basically turn for($x..$y) into the same as for($x,$y), but we
10431 * set the STACKED flag to indicate that these values are to be
10432 * treated as min/max values by 'pp_enteriter'.
10434 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
10435 LOGOP* const range = (LOGOP*) flip->op_first;
10436 OP* const left = range->op_first;
10437 OP* const right = OpSIBLING(left);
10440 range->op_flags &= ~OPf_KIDS;
10441 /* detach range's children */
10442 op_sibling_splice((OP*)range, NULL, -1, NULL);
10444 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
10445 listop->op_first->op_next = range->op_next;
10446 left->op_next = range->op_other;
10447 right->op_next = (OP*)listop;
10448 listop->op_next = listop->op_first;
10451 expr = (OP*)(listop);
10453 iterflags |= OPf_STACKED;
10456 expr = op_lvalue(force_list(expr, TRUE), OP_GREPSTART);
10459 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
10460 op_append_elem(OP_LIST, list(expr),
10462 assert(!loop->op_next);
10463 /* for my $x () sets OPpLVAL_INTRO;
10464 * for our $x () sets OPpOUR_INTRO */
10465 loop->op_private = (U8)iterpflags;
10467 /* upgrade loop from a LISTOP to a LOOPOP;
10468 * keep it in-place if there's space */
10469 if (loop->op_slabbed
10470 && OpSLOT(loop)->opslot_size
10471 < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
10473 /* no space; allocate new op */
10475 NewOp(1234,tmp,1,LOOP);
10476 Copy(loop,tmp,1,LISTOP);
10477 assert(loop->op_last->op_sibparent == (OP*)loop);
10478 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
10479 S_op_destroy(aTHX_ (OP*)loop);
10482 else if (!loop->op_slabbed)
10484 /* loop was malloc()ed */
10485 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
10486 OpLASTSIB_set(loop->op_last, (OP*)loop);
10488 loop->op_targ = padoff;
10489 iter = newOP(OP_ITER, 0);
10490 iter->op_targ = how_many_more;
10491 return newWHILEOP(flags, 1, loop, iter, block, cont, 0);
10495 =for apidoc newLOOPEX
10497 Constructs, checks, and returns a loop-exiting op (such as C<goto>
10498 or C<last>). C<type> is the opcode. C<label> supplies the parameter
10499 determining the target of the op; it is consumed by this function and
10500 becomes part of the constructed op tree.
10506 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
10510 PERL_ARGS_ASSERT_NEWLOOPEX;
10512 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
10513 || type == OP_CUSTOM);
10515 if (type != OP_GOTO) {
10516 /* "last()" means "last" */
10517 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
10518 o = newOP(type, OPf_SPECIAL);
10522 /* Check whether it's going to be a goto &function */
10523 if (label->op_type == OP_ENTERSUB
10524 && !(label->op_flags & OPf_STACKED))
10525 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
10528 /* Check for a constant argument */
10529 if (label->op_type == OP_CONST) {
10530 SV * const sv = ((SVOP *)label)->op_sv;
10532 const char *s = SvPV_const(sv,l);
10533 if (l == strlen(s)) {
10535 SvUTF8(((SVOP*)label)->op_sv),
10537 SvPV_nolen_const(((SVOP*)label)->op_sv)));
10541 /* If we have already created an op, we do not need the label. */
10544 else o = newUNOP(type, OPf_STACKED, label);
10546 PL_hints |= HINT_BLOCK_SCOPE;
10550 /* if the condition is a literal array or hash
10551 (or @{ ... } etc), make a reference to it.
10554 S_ref_array_or_hash(pTHX_ OP *cond)
10557 && (cond->op_type == OP_RV2AV
10558 || cond->op_type == OP_PADAV
10559 || cond->op_type == OP_RV2HV
10560 || cond->op_type == OP_PADHV))
10562 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
10565 && (cond->op_type == OP_ASLICE
10566 || cond->op_type == OP_KVASLICE
10567 || cond->op_type == OP_HSLICE
10568 || cond->op_type == OP_KVHSLICE)) {
10570 /* anonlist now needs a list from this op, was previously used in
10571 * scalar context */
10572 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
10573 cond->op_flags |= OPf_WANT_LIST;
10575 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
10582 /* These construct the optree fragments representing given()
10585 entergiven and enterwhen are LOGOPs; the op_other pointer
10586 points up to the associated leave op. We need this so we
10587 can put it in the context and make break/continue work.
10588 (Also, of course, pp_enterwhen will jump straight to
10589 op_other if the match fails.)
10593 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
10594 I32 enter_opcode, I32 leave_opcode,
10595 PADOFFSET entertarg)
10600 PERL_ARGS_ASSERT_NEWGIVWHENOP;
10601 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
10603 enterop = alloc_LOGOP(enter_opcode, block, NULL);
10604 enterop->op_targ = 0;
10605 enterop->op_private = 0;
10607 o = newUNOP(leave_opcode, 0, (OP *) enterop);
10610 /* prepend cond if we have one */
10611 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
10613 o->op_next = LINKLIST(cond);
10614 cond->op_next = (OP *) enterop;
10617 /* This is a default {} block */
10618 enterop->op_flags |= OPf_SPECIAL;
10619 o ->op_flags |= OPf_SPECIAL;
10621 o->op_next = (OP *) enterop;
10624 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
10625 entergiven and enterwhen both
10628 enterop->op_next = LINKLIST(block);
10629 block->op_next = enterop->op_other = o;
10635 /* For the purposes of 'when(implied_smartmatch)'
10636 * versus 'when(boolean_expression)',
10637 * does this look like a boolean operation? For these purposes
10638 a boolean operation is:
10639 - a subroutine call [*]
10640 - a logical connective
10641 - a comparison operator
10642 - a filetest operator, with the exception of -s -M -A -C
10643 - defined(), exists() or eof()
10644 - /$re/ or $foo =~ /$re/
10646 [*] possibly surprising
10649 S_looks_like_bool(pTHX_ const OP *o)
10651 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
10653 switch(o->op_type) {
10656 return looks_like_bool(cLOGOPo->op_first);
10660 OP* sibl = OpSIBLING(cLOGOPo->op_first);
10663 looks_like_bool(cLOGOPo->op_first)
10664 && looks_like_bool(sibl));
10670 o->op_flags & OPf_KIDS
10671 && looks_like_bool(cUNOPo->op_first));
10675 case OP_NOT: case OP_XOR:
10677 case OP_EQ: case OP_NE: case OP_LT:
10678 case OP_GT: case OP_LE: case OP_GE:
10680 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
10681 case OP_I_GT: case OP_I_LE: case OP_I_GE:
10683 case OP_SEQ: case OP_SNE: case OP_SLT:
10684 case OP_SGT: case OP_SLE: case OP_SGE:
10686 case OP_SMARTMATCH:
10688 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
10689 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
10690 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
10691 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
10692 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
10693 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
10694 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
10695 case OP_FTTEXT: case OP_FTBINARY:
10697 case OP_DEFINED: case OP_EXISTS:
10698 case OP_MATCH: case OP_EOF:
10706 /* optimised-away (index() != -1) or similar comparison */
10707 if (o->op_private & OPpTRUEBOOL)
10712 /* Detect comparisons that have been optimized away */
10713 if (cSVOPo->op_sv == &PL_sv_yes
10714 || cSVOPo->op_sv == &PL_sv_no)
10727 =for apidoc newGIVENOP
10729 Constructs, checks, and returns an op tree expressing a C<given> block.
10730 C<cond> supplies the expression to whose value C<$_> will be locally
10731 aliased, and C<block> supplies the body of the C<given> construct; they
10732 are consumed by this function and become part of the constructed op tree.
10733 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
10739 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
10741 PERL_ARGS_ASSERT_NEWGIVENOP;
10742 PERL_UNUSED_ARG(defsv_off);
10744 assert(!defsv_off);
10745 return newGIVWHENOP(
10746 ref_array_or_hash(cond),
10748 OP_ENTERGIVEN, OP_LEAVEGIVEN,
10753 =for apidoc newWHENOP
10755 Constructs, checks, and returns an op tree expressing a C<when> block.
10756 C<cond> supplies the test expression, and C<block> supplies the block
10757 that will be executed if the test evaluates to true; they are consumed
10758 by this function and become part of the constructed op tree. C<cond>
10759 will be interpreted DWIMically, often as a comparison against C<$_>,
10760 and may be null to generate a C<default> block.
10766 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
10768 const bool cond_llb = (!cond || looks_like_bool(cond));
10771 PERL_ARGS_ASSERT_NEWWHENOP;
10776 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
10778 scalar(ref_array_or_hash(cond)));
10781 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
10785 =for apidoc newDEFEROP
10787 Constructs and returns a deferred-block statement that implements the
10788 C<defer> semantics. The C<block> optree is consumed by this function and
10789 becomes part of the returned optree.
10791 The C<flags> argument carries additional flags to set on the returned op,
10792 including the C<op_private> field.
10798 Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
10800 OP *o, *start, *blockfirst;
10802 PERL_ARGS_ASSERT_NEWDEFEROP;
10804 start = LINKLIST(block);
10806 /* Hide the block inside an OP_NULL with no exection */
10807 block = newUNOP(OP_NULL, 0, block);
10808 block->op_next = block;
10810 o = (OP *)alloc_LOGOP(OP_PUSHDEFER, block, start);
10811 o->op_flags |= OPf_WANT_VOID | (U8)(flags);
10812 o->op_private = (U8)(flags >> 8);
10814 /* Terminate the block */
10815 blockfirst = cUNOPx(block)->op_first;
10816 assert(blockfirst->op_type == OP_SCOPE || blockfirst->op_type == OP_LEAVE);
10817 blockfirst->op_next = NULL;
10823 =for apidoc op_wrap_finally
10825 Wraps the given C<block> optree fragment in its own scoped block, arranging
10826 for the C<finally> optree fragment to be invoked when leaving that block for
10827 any reason. Both optree fragments are consumed and the combined result is
10834 Perl_op_wrap_finally(pTHX_ OP *block, OP *finally)
10836 PERL_ARGS_ASSERT_OP_WRAP_FINALLY;
10838 /* TODO: If block is already an ENTER/LEAVE-wrapped line sequence we can
10839 * just splice the DEFEROP in at the top, for efficiency.
10842 OP *o = newLISTOP(OP_LINESEQ, 0, newDEFEROP((OPpDEFER_FINALLY << 8), finally), block);
10843 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
10844 OpTYPE_set(o, OP_LEAVE);
10849 /* must not conflict with SVf_UTF8 */
10850 #define CV_CKPROTO_CURSTASH 0x1
10853 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
10854 const STRLEN len, const U32 flags)
10856 SV *name = NULL, *msg;
10857 const char * cvp = SvROK(cv)
10858 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
10859 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
10862 STRLEN clen = CvPROTOLEN(cv), plen = len;
10864 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
10866 if (p == NULL && cvp == NULL)
10869 if (!ckWARN_d(WARN_PROTOTYPE))
10873 p = S_strip_spaces(aTHX_ p, &plen);
10874 cvp = S_strip_spaces(aTHX_ cvp, &clen);
10875 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
10876 if (plen == clen && memEQ(cvp, p, plen))
10879 if (flags & SVf_UTF8) {
10880 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
10884 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
10890 msg = sv_newmortal();
10895 gv_efullname3(name = sv_newmortal(), gv, NULL);
10896 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
10897 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
10898 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
10899 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
10900 sv_catpvs(name, "::");
10902 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
10903 assert (CvNAMED(SvRV_const(gv)));
10904 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
10906 else sv_catsv(name, (SV *)gv);
10908 else name = (SV *)gv;
10910 sv_setpvs(msg, "Prototype mismatch:");
10912 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
10914 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
10915 UTF8fARG(SvUTF8(cv),clen,cvp)
10918 sv_catpvs(msg, ": none");
10919 sv_catpvs(msg, " vs ");
10921 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
10923 sv_catpvs(msg, "none");
10924 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
10927 static void const_sv_xsub(pTHX_ CV* cv);
10928 static void const_av_xsub(pTHX_ CV* cv);
10932 =for apidoc_section $optree_manipulation
10934 =for apidoc cv_const_sv
10936 If C<cv> is a constant sub eligible for inlining, returns the constant
10937 value returned by the sub. Otherwise, returns C<NULL>.
10939 Constant subs can be created with C<newCONSTSUB> or as described in
10940 L<perlsub/"Constant Functions">.
10945 Perl_cv_const_sv(const CV *const cv)
10950 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
10952 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10953 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
10958 Perl_cv_const_sv_or_av(const CV * const cv)
10962 if (SvROK(cv)) return SvRV((SV *)cv);
10963 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
10964 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10967 /* op_const_sv: examine an optree to determine whether it's in-lineable.
10968 * Can be called in 2 ways:
10971 * look for a single OP_CONST with attached value: return the value
10973 * allow_lex && !CvCONST(cv);
10975 * examine the clone prototype, and if contains only a single
10976 * OP_CONST, return the value; or if it contains a single PADSV ref-
10977 * erencing an outer lexical, turn on CvCONST to indicate the CV is
10978 * a candidate for "constizing" at clone time, and return NULL.
10982 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
10985 bool padsv = FALSE;
10990 for (; o; o = o->op_next) {
10991 const OPCODE type = o->op_type;
10993 if (type == OP_NEXTSTATE || type == OP_LINESEQ
10995 || type == OP_PUSHMARK)
10997 if (type == OP_DBSTATE)
10999 if (type == OP_LEAVESUB)
11003 if (type == OP_CONST && cSVOPo->op_sv)
11004 sv = cSVOPo->op_sv;
11005 else if (type == OP_UNDEF && !o->op_private) {
11009 else if (allow_lex && type == OP_PADSV) {
11010 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
11012 sv = &PL_sv_undef; /* an arbitrary non-null value */
11030 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
11031 PADNAME * const name, SV ** const const_svp)
11034 assert (o || name);
11035 assert (const_svp);
11037 if (CvFLAGS(PL_compcv)) {
11038 /* might have had built-in attrs applied */
11039 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
11040 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
11041 && ckWARN(WARN_MISC))
11043 /* protect against fatal warnings leaking compcv */
11044 SAVEFREESV(PL_compcv);
11045 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
11046 SvREFCNT_inc_simple_void_NN(PL_compcv);
11049 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
11050 & ~(CVf_LVALUE * pureperl));
11055 /* redundant check for speed: */
11056 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11057 const line_t oldline = CopLINE(PL_curcop);
11060 : newSVpvn_flags( PadnamePV(name)+1,PadnameLEN(name)-1,
11061 (PadnameUTF8(name)) ? SVf_UTF8|SVs_TEMP : SVs_TEMP
11063 if (PL_parser && PL_parser->copline != NOLINE)
11064 /* This ensures that warnings are reported at the first
11065 line of a redefinition, not the last. */
11066 CopLINE_set(PL_curcop, PL_parser->copline);
11067 /* protect against fatal warnings leaking compcv */
11068 SAVEFREESV(PL_compcv);
11069 report_redefined_cv(namesv, cv, const_svp);
11070 SvREFCNT_inc_simple_void_NN(PL_compcv);
11071 CopLINE_set(PL_curcop, oldline);
11078 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
11083 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11086 CV *compcv = PL_compcv;
11089 PADOFFSET pax = o->op_targ;
11090 CV *outcv = CvOUTSIDE(PL_compcv);
11093 bool reusable = FALSE;
11095 #ifdef PERL_DEBUG_READONLY_OPS
11096 OPSLAB *slab = NULL;
11099 PERL_ARGS_ASSERT_NEWMYSUB;
11101 PL_hints |= HINT_BLOCK_SCOPE;
11103 /* Find the pad slot for storing the new sub.
11104 We cannot use PL_comppad, as it is the pad owned by the new sub. We
11105 need to look in CvOUTSIDE and find the pad belonging to the enclos-
11106 ing sub. And then we need to dig deeper if this is a lexical from
11108 my sub foo; sub { sub foo { } }
11111 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
11112 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
11113 pax = PARENT_PAD_INDEX(name);
11114 outcv = CvOUTSIDE(outcv);
11119 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
11120 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
11121 spot = (CV **)svspot;
11123 if (!(PL_parser && PL_parser->error_count))
11124 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
11127 assert(proto->op_type == OP_CONST);
11128 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11129 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11139 if (PL_parser && PL_parser->error_count) {
11141 SvREFCNT_dec(PL_compcv);
11146 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
11148 svspot = (SV **)(spot = &clonee);
11150 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
11153 assert (SvTYPE(*spot) == SVt_PVCV);
11154 if (CvNAMED(*spot))
11155 hek = CvNAME_HEK(*spot);
11158 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
11159 CvNAME_HEK_set(*spot, hek =
11162 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
11166 CvLEXICAL_on(*spot);
11168 cv = PadnamePROTOCV(name);
11169 svspot = (SV **)(spot = &PadnamePROTOCV(name));
11173 /* This makes sub {}; work as expected. */
11174 if (block->op_type == OP_STUB) {
11175 const line_t l = PL_parser->copline;
11177 block = newSTATEOP(0, NULL, 0);
11178 PL_parser->copline = l;
11180 block = CvLVALUE(compcv)
11181 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
11182 ? newUNOP(OP_LEAVESUBLV, 0,
11183 op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
11184 : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
11185 start = LINKLIST(block);
11186 block->op_next = 0;
11187 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
11188 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
11196 const bool exists = CvROOT(cv) || CvXSUB(cv);
11198 /* if the subroutine doesn't exist and wasn't pre-declared
11199 * with a prototype, assume it will be AUTOLOADed,
11200 * skipping the prototype check
11202 if (exists || SvPOK(cv))
11203 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
11205 /* already defined? */
11207 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
11213 /* just a "sub foo;" when &foo is already defined */
11214 SAVEFREESV(compcv);
11218 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
11225 SvREFCNT_inc_simple_void_NN(const_sv);
11226 SvFLAGS(const_sv) |= SVs_PADTMP;
11228 assert(!CvROOT(cv) && !CvCONST(cv));
11229 cv_forget_slab(cv);
11232 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11233 CvFILE_set_from_cop(cv, PL_curcop);
11234 CvSTASH_set(cv, PL_curstash);
11237 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
11238 CvXSUBANY(cv).any_ptr = const_sv;
11239 CvXSUB(cv) = const_sv_xsub;
11243 CvFLAGS(cv) |= CvMETHOD(compcv);
11245 SvREFCNT_dec(compcv);
11250 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
11251 determine whether this sub definition is in the same scope as its
11252 declaration. If this sub definition is inside an inner named pack-
11253 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
11254 the package sub. So check PadnameOUTER(name) too.
11256 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
11257 assert(!CvWEAKOUTSIDE(compcv));
11258 SvREFCNT_dec(CvOUTSIDE(compcv));
11259 CvWEAKOUTSIDE_on(compcv);
11261 /* XXX else do we have a circular reference? */
11263 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
11264 /* transfer PL_compcv to cv */
11266 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11267 cv_flags_t preserved_flags =
11268 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
11269 PADLIST *const temp_padl = CvPADLIST(cv);
11270 CV *const temp_cv = CvOUTSIDE(cv);
11271 const cv_flags_t other_flags =
11272 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11273 OP * const cvstart = CvSTART(cv);
11277 CvFLAGS(compcv) | preserved_flags;
11278 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
11279 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
11280 CvPADLIST_set(cv, CvPADLIST(compcv));
11281 CvOUTSIDE(compcv) = temp_cv;
11282 CvPADLIST_set(compcv, temp_padl);
11283 CvSTART(cv) = CvSTART(compcv);
11284 CvSTART(compcv) = cvstart;
11285 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11286 CvFLAGS(compcv) |= other_flags;
11289 Safefree(CvFILE(cv));
11293 /* inner references to compcv must be fixed up ... */
11294 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
11295 if (PERLDB_INTER)/* Advice debugger on the new sub. */
11296 ++PL_sub_generation;
11299 /* Might have had built-in attributes applied -- propagate them. */
11300 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
11302 /* ... before we throw it away */
11303 SvREFCNT_dec(compcv);
11304 PL_compcv = compcv = cv;
11313 if (!CvNAME_HEK(cv)) {
11314 if (hek) (void)share_hek_hek(hek);
11317 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
11318 hek = share_hek(PadnamePV(name)+1,
11319 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
11322 CvNAME_HEK_set(cv, hek);
11328 if (CvFILE(cv) && CvDYNFILE(cv))
11329 Safefree(CvFILE(cv));
11330 CvFILE_set_from_cop(cv, PL_curcop);
11331 CvSTASH_set(cv, PL_curstash);
11334 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11336 SvUTF8_on(MUTABLE_SV(cv));
11340 /* If we assign an optree to a PVCV, then we've defined a
11341 * subroutine that the debugger could be able to set a breakpoint
11342 * in, so signal to pp_entereval that it should not throw away any
11343 * saved lines at scope exit. */
11345 PL_breakable_sub_gen++;
11346 CvROOT(cv) = block;
11347 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11348 itself has a refcount. */
11350 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11351 #ifdef PERL_DEBUG_READONLY_OPS
11352 slab = (OPSLAB *)CvSTART(cv);
11354 S_process_optree(aTHX_ cv, block, start);
11359 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11360 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
11364 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11365 SV * const tmpstr = sv_newmortal();
11366 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11367 GV_ADDMULTI, SVt_PVHV);
11369 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11370 CopFILE(PL_curcop),
11372 (long)CopLINE(PL_curcop));
11373 if (HvNAME_HEK(PL_curstash)) {
11374 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
11375 sv_catpvs(tmpstr, "::");
11378 sv_setpvs(tmpstr, "__ANON__::");
11380 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
11381 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
11382 (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
11383 hv = GvHVn(db_postponed);
11384 if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
11385 CV * const pcv = GvCV(db_postponed);
11391 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11399 assert(CvDEPTH(outcv));
11401 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
11403 cv_clone_into(clonee, *spot);
11404 else *spot = cv_clone(clonee);
11405 SvREFCNT_dec_NN(clonee);
11409 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
11410 PADOFFSET depth = CvDEPTH(outcv);
11413 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
11415 *svspot = SvREFCNT_inc_simple_NN(cv);
11416 SvREFCNT_dec(oldcv);
11422 PL_parser->copline = NOLINE;
11423 LEAVE_SCOPE(floor);
11424 #ifdef PERL_DEBUG_READONLY_OPS
11433 =for apidoc newATTRSUB_x
11435 Construct a Perl subroutine, also performing some surrounding jobs.
11437 This function is expected to be called in a Perl compilation context,
11438 and some aspects of the subroutine are taken from global variables
11439 associated with compilation. In particular, C<PL_compcv> represents
11440 the subroutine that is currently being compiled. It must be non-null
11441 when this function is called, and some aspects of the subroutine being
11442 constructed are taken from it. The constructed subroutine may actually
11443 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
11445 If C<block> is null then the subroutine will have no body, and for the
11446 time being it will be an error to call it. This represents a forward
11447 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
11448 non-null then it provides the Perl code of the subroutine body, which
11449 will be executed when the subroutine is called. This body includes
11450 any argument unwrapping code resulting from a subroutine signature or
11451 similar. The pad use of the code must correspond to the pad attached
11452 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
11453 C<leavesublv> op; this function will add such an op. C<block> is consumed
11454 by this function and will become part of the constructed subroutine.
11456 C<proto> specifies the subroutine's prototype, unless one is supplied
11457 as an attribute (see below). If C<proto> is null, then the subroutine
11458 will not have a prototype. If C<proto> is non-null, it must point to a
11459 C<const> op whose value is a string, and the subroutine will have that
11460 string as its prototype. If a prototype is supplied as an attribute, the
11461 attribute takes precedence over C<proto>, but in that case C<proto> should
11462 preferably be null. In any case, C<proto> is consumed by this function.
11464 C<attrs> supplies attributes to be applied the subroutine. A handful of
11465 attributes take effect by built-in means, being applied to C<PL_compcv>
11466 immediately when seen. Other attributes are collected up and attached
11467 to the subroutine by this route. C<attrs> may be null to supply no
11468 attributes, or point to a C<const> op for a single attribute, or point
11469 to a C<list> op whose children apart from the C<pushmark> are C<const>
11470 ops for one or more attributes. Each C<const> op must be a string,
11471 giving the attribute name optionally followed by parenthesised arguments,
11472 in the manner in which attributes appear in Perl source. The attributes
11473 will be applied to the sub by this function. C<attrs> is consumed by
11476 If C<o_is_gv> is false and C<o> is null, then the subroutine will
11477 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
11478 must point to a C<const> OP, which will be consumed by this function,
11479 and its string value supplies a name for the subroutine. The name may
11480 be qualified or unqualified, and if it is unqualified then a default
11481 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
11482 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
11483 by which the subroutine will be named.
11485 If there is already a subroutine of the specified name, then the new
11486 sub will either replace the existing one in the glob or be merged with
11487 the existing one. A warning may be generated about redefinition.
11489 If the subroutine has one of a few special names, such as C<BEGIN> or
11490 C<END>, then it will be claimed by the appropriate queue for automatic
11491 running of phase-related subroutines. In this case the relevant glob will
11492 be left not containing any subroutine, even if it did contain one before.
11493 In the case of C<BEGIN>, the subroutine will be executed and the reference
11494 to it disposed of before this function returns.
11496 The function returns a pointer to the constructed subroutine. If the sub
11497 is anonymous then ownership of one counted reference to the subroutine
11498 is transferred to the caller. If the sub is named then the caller does
11499 not get ownership of a reference. In most such cases, where the sub
11500 has a non-phase name, the sub will be alive at the point it is returned
11501 by virtue of being contained in the glob that names it. A phase-named
11502 subroutine will usually be alive by virtue of the reference owned by the
11503 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11504 been executed, will quite likely have been destroyed already by the
11505 time this function returns, making it erroneous for the caller to make
11506 any use of the returned pointer. It is the caller's responsibility to
11507 ensure that it knows which of these situations applies.
11509 =for apidoc newATTRSUB
11510 Construct a Perl subroutine, also performing some surrounding jobs.
11512 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter set to
11513 FALSE. This means that if C<o> is null, the new sub will be anonymous; otherwise
11514 the name will be derived from C<o> in the way described (as with all other
11515 details) in L<perlintern/C<newATTRSUB_x>>.
11518 Like C<L</newATTRSUB>>, but without attributes.
11523 /* _x = extended */
11525 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
11526 OP *block, bool o_is_gv)
11530 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11532 CV *cv = NULL; /* the previous CV with this name, if any */
11534 const bool ec = PL_parser && PL_parser->error_count;
11535 /* If the subroutine has no body, no attributes, and no builtin attributes
11536 then it's just a sub declaration, and we may be able to get away with
11537 storing with a placeholder scalar in the symbol table, rather than a
11538 full CV. If anything is present then it will take a full CV to
11540 const I32 gv_fetch_flags
11541 = ec ? GV_NOADD_NOINIT :
11542 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
11543 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
11545 const char * const name =
11546 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
11548 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
11549 bool evanescent = FALSE;
11551 #ifdef PERL_DEBUG_READONLY_OPS
11552 OPSLAB *slab = NULL;
11560 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
11561 hek and CvSTASH pointer together can imply the GV. If the name
11562 contains a package name, then GvSTASH(CvGV(cv)) may differ from
11563 CvSTASH, so forego the optimisation if we find any.
11564 Also, we may be called from load_module at run time, so
11565 PL_curstash (which sets CvSTASH) may not point to the stash the
11566 sub is stored in. */
11567 /* XXX This optimization is currently disabled for packages other
11568 than main, since there was too much CPAN breakage. */
11570 ec ? GV_NOADD_NOINIT
11571 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
11572 || PL_curstash != PL_defstash
11573 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
11575 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
11576 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
11578 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
11579 SV * const sv = sv_newmortal();
11580 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
11581 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11582 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11583 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
11585 } else if (PL_curstash) {
11586 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
11589 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
11595 move_proto_attr(&proto, &attrs, gv, 0);
11598 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
11603 assert(proto->op_type == OP_CONST);
11604 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11605 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11621 SvREFCNT_dec(PL_compcv);
11626 if (name && block) {
11627 const char *s = (char *) my_memrchr(name, ':', namlen);
11628 s = s ? s+1 : name;
11629 if (strEQ(s, "BEGIN")) {
11630 if (PL_in_eval & EVAL_KEEPERR)
11631 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
11633 SV * const errsv = ERRSV;
11634 /* force display of errors found but not reported */
11635 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
11636 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
11643 if (!block && SvTYPE(gv) != SVt_PVGV) {
11644 /* If we are not defining a new sub and the existing one is not a
11646 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
11647 /* We are applying attributes to an existing sub, so we need it
11648 upgraded if it is a constant. */
11649 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
11650 gv_init_pvn(gv, PL_curstash, name, namlen,
11651 SVf_UTF8 * name_is_utf8);
11653 else { /* Maybe prototype now, and had at maximum
11654 a prototype or const/sub ref before. */
11655 if (SvTYPE(gv) > SVt_NULL) {
11656 cv_ckproto_len_flags((const CV *)gv,
11657 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11663 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
11665 SvUTF8_on(MUTABLE_SV(gv));
11668 sv_setiv(MUTABLE_SV(gv), -1);
11671 SvREFCNT_dec(PL_compcv);
11672 cv = PL_compcv = NULL;
11677 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
11681 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
11687 /* This makes sub {}; work as expected. */
11688 if (block->op_type == OP_STUB) {
11689 const line_t l = PL_parser->copline;
11691 block = newSTATEOP(0, NULL, 0);
11692 PL_parser->copline = l;
11694 block = CvLVALUE(PL_compcv)
11695 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
11696 && (!isGV(gv) || !GvASSUMECV(gv)))
11697 ? newUNOP(OP_LEAVESUBLV, 0,
11698 op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
11699 : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
11700 start = LINKLIST(block);
11701 block->op_next = 0;
11702 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
11704 S_op_const_sv(aTHX_ start, PL_compcv,
11705 cBOOL(CvCLONE(PL_compcv)));
11712 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
11713 cv_ckproto_len_flags((const CV *)gv,
11714 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11715 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
11717 /* All the other code for sub redefinition warnings expects the
11718 clobbered sub to be a CV. Instead of making all those code
11719 paths more complex, just inline the RV version here. */
11720 const line_t oldline = CopLINE(PL_curcop);
11721 assert(IN_PERL_COMPILETIME);
11722 if (PL_parser && PL_parser->copline != NOLINE)
11723 /* This ensures that warnings are reported at the first
11724 line of a redefinition, not the last. */
11725 CopLINE_set(PL_curcop, PL_parser->copline);
11726 /* protect against fatal warnings leaking compcv */
11727 SAVEFREESV(PL_compcv);
11729 if (ckWARN(WARN_REDEFINE)
11730 || ( ckWARN_d(WARN_REDEFINE)
11731 && ( !const_sv || SvRV(gv) == const_sv
11732 || sv_cmp(SvRV(gv), const_sv) ))) {
11734 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11735 "Constant subroutine %" SVf " redefined",
11736 SVfARG(cSVOPo->op_sv));
11739 SvREFCNT_inc_simple_void_NN(PL_compcv);
11740 CopLINE_set(PL_curcop, oldline);
11741 SvREFCNT_dec(SvRV(gv));
11746 const bool exists = CvROOT(cv) || CvXSUB(cv);
11748 /* if the subroutine doesn't exist and wasn't pre-declared
11749 * with a prototype, assume it will be AUTOLOADed,
11750 * skipping the prototype check
11752 if (exists || SvPOK(cv))
11753 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
11754 /* already defined (or promised)? */
11755 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
11756 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
11762 /* just a "sub foo;" when &foo is already defined */
11763 SAVEFREESV(PL_compcv);
11770 SvREFCNT_inc_simple_void_NN(const_sv);
11771 SvFLAGS(const_sv) |= SVs_PADTMP;
11773 assert(!CvROOT(cv) && !CvCONST(cv));
11774 cv_forget_slab(cv);
11775 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
11776 CvXSUBANY(cv).any_ptr = const_sv;
11777 CvXSUB(cv) = const_sv_xsub;
11781 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11784 if (isGV(gv) || CvMETHOD(PL_compcv)) {
11785 if (name && isGV(gv))
11786 GvCV_set(gv, NULL);
11787 cv = newCONSTSUB_flags(
11788 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
11792 assert(SvREFCNT((SV*)cv) != 0);
11793 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11797 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11798 prepare_SV_for_RV((SV *)gv);
11799 SvOK_off((SV *)gv);
11802 SvRV_set(gv, const_sv);
11806 SvREFCNT_dec(PL_compcv);
11811 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
11812 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
11815 if (cv) { /* must reuse cv if autoloaded */
11816 /* transfer PL_compcv to cv */
11818 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11819 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
11820 PADLIST *const temp_av = CvPADLIST(cv);
11821 CV *const temp_cv = CvOUTSIDE(cv);
11822 const cv_flags_t other_flags =
11823 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11824 OP * const cvstart = CvSTART(cv);
11828 assert(!CvCVGV_RC(cv));
11829 assert(CvGV(cv) == gv);
11833 PERL_HASH(hash, name, namlen);
11843 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
11845 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
11846 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
11847 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
11848 CvOUTSIDE(PL_compcv) = temp_cv;
11849 CvPADLIST_set(PL_compcv, temp_av);
11850 CvSTART(cv) = CvSTART(PL_compcv);
11851 CvSTART(PL_compcv) = cvstart;
11852 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11853 CvFLAGS(PL_compcv) |= other_flags;
11856 Safefree(CvFILE(cv));
11858 CvFILE_set_from_cop(cv, PL_curcop);
11859 CvSTASH_set(cv, PL_curstash);
11861 /* inner references to PL_compcv must be fixed up ... */
11862 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
11863 if (PERLDB_INTER)/* Advice debugger on the new sub. */
11864 ++PL_sub_generation;
11867 /* Might have had built-in attributes applied -- propagate them. */
11868 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
11870 /* ... before we throw it away */
11871 SvREFCNT_dec(PL_compcv);
11876 if (name && isGV(gv)) {
11879 if (HvENAME_HEK(GvSTASH(gv)))
11880 /* sub Foo::bar { (shift)+1 } */
11881 gv_method_changed(gv);
11885 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11886 prepare_SV_for_RV((SV *)gv);
11887 SvOK_off((SV *)gv);
11890 SvRV_set(gv, (SV *)cv);
11891 if (HvENAME_HEK(PL_curstash))
11892 mro_method_changed_in(PL_curstash);
11896 assert(SvREFCNT((SV*)cv) != 0);
11898 if (!CvHASGV(cv)) {
11903 PERL_HASH(hash, name, namlen);
11904 CvNAME_HEK_set(cv, share_hek(name,
11910 CvFILE_set_from_cop(cv, PL_curcop);
11911 CvSTASH_set(cv, PL_curstash);
11915 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11917 SvUTF8_on(MUTABLE_SV(cv));
11921 /* If we assign an optree to a PVCV, then we've defined a
11922 * subroutine that the debugger could be able to set a breakpoint
11923 * in, so signal to pp_entereval that it should not throw away any
11924 * saved lines at scope exit. */
11926 PL_breakable_sub_gen++;
11927 CvROOT(cv) = block;
11928 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11929 itself has a refcount. */
11931 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11932 #ifdef PERL_DEBUG_READONLY_OPS
11933 slab = (OPSLAB *)CvSTART(cv);
11935 S_process_optree(aTHX_ cv, block, start);
11940 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11941 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
11942 ? GvSTASH(CvGV(cv))
11946 apply_attrs(stash, MUTABLE_SV(cv), attrs);
11948 SvREFCNT_inc_simple_void_NN(cv);
11951 if (block && has_name) {
11952 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11953 SV * const tmpstr = cv_name(cv,NULL,0);
11954 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11955 GV_ADDMULTI, SVt_PVHV);
11957 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11958 CopFILE(PL_curcop),
11960 (long)CopLINE(PL_curcop));
11961 (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
11962 hv = GvHVn(db_postponed);
11963 if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
11964 CV * const pcv = GvCV(db_postponed);
11970 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11976 if (PL_parser && PL_parser->error_count)
11977 clear_special_blocks(name, gv, cv);
11980 process_special_blocks(floor, name, gv, cv);
11986 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11988 PL_parser->copline = NOLINE;
11989 LEAVE_SCOPE(floor);
11991 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11993 #ifdef PERL_DEBUG_READONLY_OPS
11997 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11998 pad_add_weakref(cv);
12004 S_clear_special_blocks(pTHX_ const char *const fullname,
12005 GV *const gv, CV *const cv) {
12009 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
12011 colon = strrchr(fullname,':');
12012 name = colon ? colon + 1 : fullname;
12014 if ((*name == 'B' && strEQ(name, "BEGIN"))
12015 || (*name == 'E' && strEQ(name, "END"))
12016 || (*name == 'U' && strEQ(name, "UNITCHECK"))
12017 || (*name == 'C' && strEQ(name, "CHECK"))
12018 || (*name == 'I' && strEQ(name, "INIT"))) {
12023 GvCV_set(gv, NULL);
12024 SvREFCNT_dec_NN(MUTABLE_SV(cv));
12028 /* Returns true if the sub has been freed. */
12030 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
12034 const char *const colon = strrchr(fullname,':');
12035 const char *const name = colon ? colon + 1 : fullname;
12037 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
12039 if (*name == 'B') {
12040 if (strEQ(name, "BEGIN")) {
12041 const I32 oldscope = PL_scopestack_ix;
12044 if (floor) LEAVE_SCOPE(floor);
12047 SAVEVPTR(PL_curcop);
12048 if (PL_curcop == &PL_compiling) {
12049 /* Avoid pushing the "global" &PL_compiling onto the
12050 * context stack. For example, a stack trace inside
12051 * nested use's would show all calls coming from whoever
12052 * most recently updated PL_compiling.cop_file and
12053 * cop_line. So instead, temporarily set PL_curcop to a
12054 * private copy of &PL_compiling. PL_curcop will soon be
12055 * set to point back to &PL_compiling anyway but only
12056 * after the temp value has been pushed onto the context
12057 * stack as blk_oldcop.
12058 * This is slightly hacky, but necessary. Note also
12059 * that in the brief window before PL_curcop is set back
12060 * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
12061 * will give the wrong answer.
12063 PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL);
12064 CopLINE_set(PL_curcop, CopLINE(&PL_compiling));
12065 SAVEFREEOP(PL_curcop);
12068 PUSHSTACKi(PERLSI_REQUIRE);
12069 SAVECOPFILE(&PL_compiling);
12070 SAVECOPLINE(&PL_compiling);
12072 DEBUG_x( dump_sub(gv) );
12073 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
12074 GvCV_set(gv,0); /* cv has been hijacked */
12075 call_list(oldscope, PL_beginav);
12079 return !PL_savebegin;
12084 if (*name == 'E') {
12085 if (strEQ(name, "END")) {
12086 DEBUG_x( dump_sub(gv) );
12087 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
12090 } else if (*name == 'U') {
12091 if (strEQ(name, "UNITCHECK")) {
12092 /* It's never too late to run a unitcheck block */
12093 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
12097 } else if (*name == 'C') {
12098 if (strEQ(name, "CHECK")) {
12100 /* diag_listed_as: Too late to run %s block */
12101 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
12102 "Too late to run CHECK block");
12103 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
12107 } else if (*name == 'I') {
12108 if (strEQ(name, "INIT")) {
12110 /* diag_listed_as: Too late to run %s block */
12111 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
12112 "Too late to run INIT block");
12113 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
12119 DEBUG_x( dump_sub(gv) );
12121 GvCV_set(gv,0); /* cv has been hijacked */
12127 =for apidoc newCONSTSUB
12129 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
12130 rather than of counted length, and no flags are set. (This means that
12131 C<name> is always interpreted as Latin-1.)
12137 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
12139 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
12143 =for apidoc newCONSTSUB_flags
12145 Construct a constant subroutine, also performing some surrounding
12146 jobs. A scalar constant-valued subroutine is eligible for inlining
12147 at compile-time, and in Perl code can be created by S<C<sub FOO () {
12148 123 }>>. Other kinds of constant subroutine have other treatment.
12150 The subroutine will have an empty prototype and will ignore any arguments
12151 when called. Its constant behaviour is determined by C<sv>. If C<sv>
12152 is null, the subroutine will yield an empty list. If C<sv> points to a
12153 scalar, the subroutine will always yield that scalar. If C<sv> points
12154 to an array, the subroutine will always yield a list of the elements of
12155 that array in list context, or the number of elements in the array in
12156 scalar context. This function takes ownership of one counted reference
12157 to the scalar or array, and will arrange for the object to live as long
12158 as the subroutine does. If C<sv> points to a scalar then the inlining
12159 assumes that the value of the scalar will never change, so the caller
12160 must ensure that the scalar is not subsequently written to. If C<sv>
12161 points to an array then no such assumption is made, so it is ostensibly
12162 safe to mutate the array or its elements, but whether this is really
12163 supported has not been determined.
12165 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
12166 Other aspects of the subroutine will be left in their default state.
12167 The caller is free to mutate the subroutine beyond its initial state
12168 after this function has returned.
12170 If C<name> is null then the subroutine will be anonymous, with its
12171 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
12172 subroutine will be named accordingly, referenced by the appropriate glob.
12173 C<name> is a string of length C<len> bytes giving a sigilless symbol
12174 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
12175 otherwise. The name may be either qualified or unqualified. If the
12176 name is unqualified then it defaults to being in the stash specified by
12177 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
12178 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
12181 C<flags> should not have bits set other than C<SVf_UTF8>.
12183 If there is already a subroutine of the specified name, then the new sub
12184 will replace the existing one in the glob. A warning may be generated
12185 about the redefinition.
12187 If the subroutine has one of a few special names, such as C<BEGIN> or
12188 C<END>, then it will be claimed by the appropriate queue for automatic
12189 running of phase-related subroutines. In this case the relevant glob will
12190 be left not containing any subroutine, even if it did contain one before.
12191 Execution of the subroutine will likely be a no-op, unless C<sv> was
12192 a tied array or the caller modified the subroutine in some interesting
12193 way before it was executed. In the case of C<BEGIN>, the treatment is
12194 buggy: the sub will be executed when only half built, and may be deleted
12195 prematurely, possibly causing a crash.
12197 The function returns a pointer to the constructed subroutine. If the sub
12198 is anonymous then ownership of one counted reference to the subroutine
12199 is transferred to the caller. If the sub is named then the caller does
12200 not get ownership of a reference. In most such cases, where the sub
12201 has a non-phase name, the sub will be alive at the point it is returned
12202 by virtue of being contained in the glob that names it. A phase-named
12203 subroutine will usually be alive by virtue of the reference owned by
12204 the phase's automatic run queue. A C<BEGIN> subroutine may have been
12205 destroyed already by the time this function returns, but currently bugs
12206 occur in that case before the caller gets control. It is the caller's
12207 responsibility to ensure that it knows which of these situations applies.
12213 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
12217 const char *const file = CopFILE(PL_curcop);
12221 if (IN_PERL_RUNTIME) {
12222 /* at runtime, it's not safe to manipulate PL_curcop: it may be
12223 * an op shared between threads. Use a non-shared COP for our
12225 SAVEVPTR(PL_curcop);
12226 SAVECOMPILEWARNINGS();
12227 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
12228 PL_curcop = &PL_compiling;
12230 SAVECOPLINE(PL_curcop);
12231 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
12234 PL_hints &= ~HINT_BLOCK_SCOPE;
12237 SAVEGENERICSV(PL_curstash);
12238 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
12241 /* Protect sv against leakage caused by fatal warnings. */
12242 if (sv) SAVEFREESV(sv);
12244 /* file becomes the CvFILE. For an XS, it's usually static storage,
12245 and so doesn't get free()d. (It's expected to be from the C pre-
12246 processor __FILE__ directive). But we need a dynamically allocated one,
12247 and we need it to get freed. */
12248 cv = newXS_len_flags(name, len,
12249 sv && SvTYPE(sv) == SVt_PVAV
12252 file ? file : "", "",
12253 &sv, XS_DYNAMIC_FILENAME | flags);
12255 assert(SvREFCNT((SV*)cv) != 0);
12256 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
12267 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
12268 static storage, as it is used directly as CvFILE(), without a copy being made.
12274 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
12276 PERL_ARGS_ASSERT_NEWXS;
12277 return newXS_len_flags(
12278 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
12283 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
12284 const char *const filename, const char *const proto,
12287 PERL_ARGS_ASSERT_NEWXS_FLAGS;
12288 return newXS_len_flags(
12289 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
12294 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
12296 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
12297 return newXS_len_flags(
12298 name, strlen(name), subaddr, NULL, NULL, NULL, 0
12303 =for apidoc newXS_len_flags
12305 Construct an XS subroutine, also performing some surrounding jobs.
12307 The subroutine will have the entry point C<subaddr>. It will have
12308 the prototype specified by the nul-terminated string C<proto>, or
12309 no prototype if C<proto> is null. The prototype string is copied;
12310 the caller can mutate the supplied string afterwards. If C<filename>
12311 is non-null, it must be a nul-terminated filename, and the subroutine
12312 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
12313 point directly to the supplied string, which must be static. If C<flags>
12314 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
12317 Other aspects of the subroutine will be left in their default state.
12318 If anything else needs to be done to the subroutine for it to function
12319 correctly, it is the caller's responsibility to do that after this
12320 function has constructed it. However, beware of the subroutine
12321 potentially being destroyed before this function returns, as described
12324 If C<name> is null then the subroutine will be anonymous, with its
12325 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
12326 subroutine will be named accordingly, referenced by the appropriate glob.
12327 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
12328 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
12329 The name may be either qualified or unqualified, with the stash defaulting
12330 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
12331 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
12332 they have there, such as C<GV_ADDWARN>. The symbol is always added to
12333 the stash if necessary, with C<GV_ADDMULTI> semantics.
12335 If there is already a subroutine of the specified name, then the new sub
12336 will replace the existing one in the glob. A warning may be generated
12337 about the redefinition. If the old subroutine was C<CvCONST> then the
12338 decision about whether to warn is influenced by an expectation about
12339 whether the new subroutine will become a constant of similar value.
12340 That expectation is determined by C<const_svp>. (Note that the call to
12341 this function doesn't make the new subroutine C<CvCONST> in any case;
12342 that is left to the caller.) If C<const_svp> is null then it indicates
12343 that the new subroutine will not become a constant. If C<const_svp>
12344 is non-null then it indicates that the new subroutine will become a
12345 constant, and it points to an C<SV*> that provides the constant value
12346 that the subroutine will have.
12348 If the subroutine has one of a few special names, such as C<BEGIN> or
12349 C<END>, then it will be claimed by the appropriate queue for automatic
12350 running of phase-related subroutines. In this case the relevant glob will
12351 be left not containing any subroutine, even if it did contain one before.
12352 In the case of C<BEGIN>, the subroutine will be executed and the reference
12353 to it disposed of before this function returns, and also before its
12354 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
12355 constructed by this function to be ready for execution then the caller
12356 must prevent this happening by giving the subroutine a different name.
12358 The function returns a pointer to the constructed subroutine. If the sub
12359 is anonymous then ownership of one counted reference to the subroutine
12360 is transferred to the caller. If the sub is named then the caller does
12361 not get ownership of a reference. In most such cases, where the sub
12362 has a non-phase name, the sub will be alive at the point it is returned
12363 by virtue of being contained in the glob that names it. A phase-named
12364 subroutine will usually be alive by virtue of the reference owned by the
12365 phase's automatic run queue. But a C<BEGIN> subroutine, having already
12366 been executed, will quite likely have been destroyed already by the
12367 time this function returns, making it erroneous for the caller to make
12368 any use of the returned pointer. It is the caller's responsibility to
12369 ensure that it knows which of these situations applies.
12375 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
12376 XSUBADDR_t subaddr, const char *const filename,
12377 const char *const proto, SV **const_svp,
12381 bool interleave = FALSE;
12382 bool evanescent = FALSE;
12384 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
12387 GV * const gv = gv_fetchpvn(
12388 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
12389 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
12390 sizeof("__ANON__::__ANON__") - 1,
12391 GV_ADDMULTI | flags, SVt_PVCV);
12393 if ((cv = (name ? GvCV(gv) : NULL))) {
12395 /* just a cached method */
12399 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
12400 /* already defined (or promised) */
12401 /* Redundant check that allows us to avoid creating an SV
12402 most of the time: */
12403 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
12404 report_redefined_cv(newSVpvn_flags(
12405 name,len,(flags&SVf_UTF8)|SVs_TEMP
12416 if (cv) /* must reuse cv if autoloaded */
12419 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12423 if (HvENAME_HEK(GvSTASH(gv)))
12424 gv_method_changed(gv); /* newXS */
12428 assert(SvREFCNT((SV*)cv) != 0);
12432 /* XSUBs can't be perl lang/perl5db.pl debugged
12433 if (PERLDB_LINE_OR_SAVESRC)
12434 (void)gv_fetchfile(filename); */
12435 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
12436 if (flags & XS_DYNAMIC_FILENAME) {
12438 CvFILE(cv) = savepv(filename);
12440 /* NOTE: not copied, as it is expected to be an external constant string */
12441 CvFILE(cv) = (char *)filename;
12444 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
12445 CvFILE(cv) = (char*)PL_xsubfilename;
12448 CvXSUB(cv) = subaddr;
12449 #ifndef MULTIPLICITY
12450 CvHSCXT(cv) = &PL_stack_sp;
12456 evanescent = process_special_blocks(0, name, gv, cv);
12459 } /* <- not a conditional branch */
12462 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12464 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
12465 if (interleave) LEAVE;
12466 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12470 /* Add a stub CV to a typeglob.
12471 * This is the implementation of a forward declaration, 'sub foo';'
12475 Perl_newSTUB(pTHX_ GV *gv, bool fake)
12477 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12479 PERL_ARGS_ASSERT_NEWSTUB;
12480 assert(!GvCVu(gv));
12483 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
12484 gv_method_changed(gv);
12486 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
12490 CvGV_set(cv, cvgv);
12491 CvFILE_set_from_cop(cv, PL_curcop);
12492 CvSTASH_set(cv, PL_curstash);
12498 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
12505 if (PL_parser && PL_parser->error_count) {
12511 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
12512 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
12515 if ((cv = GvFORM(gv))) {
12516 if (ckWARN(WARN_REDEFINE)) {
12517 const line_t oldline = CopLINE(PL_curcop);
12518 if (PL_parser && PL_parser->copline != NOLINE)
12519 CopLINE_set(PL_curcop, PL_parser->copline);
12521 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12522 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
12524 /* diag_listed_as: Format %s redefined */
12525 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12526 "Format STDOUT redefined");
12528 CopLINE_set(PL_curcop, oldline);
12533 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
12535 CvFILE_set_from_cop(cv, PL_curcop);
12538 root = newUNOP(OP_LEAVEWRITE, 0, voidnonfinal(block));
12540 start = LINKLIST(root);
12542 S_process_optree(aTHX_ cv, root, start);
12543 cv_forget_slab(cv);
12548 PL_parser->copline = NOLINE;
12549 LEAVE_SCOPE(floor);
12550 PL_compiling.cop_seq = 0;
12554 Perl_newANONLIST(pTHX_ OP *o)
12556 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
12560 Perl_newANONHASH(pTHX_ OP *o)
12562 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
12566 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
12568 return newANONATTRSUB(floor, proto, NULL, block);
12572 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
12574 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
12576 newSVOP(OP_ANONCODE, 0,
12578 if (CvANONCONST(cv))
12579 anoncode = newUNOP(OP_ANONCONST, 0,
12580 op_convert_list(OP_ENTERSUB,
12581 OPf_STACKED|OPf_WANT_SCALAR,
12583 return newUNOP(OP_REFGEN, 0, anoncode);
12587 Perl_oopsAV(pTHX_ OP *o)
12590 PERL_ARGS_ASSERT_OOPSAV;
12592 switch (o->op_type) {
12595 OpTYPE_set(o, OP_PADAV);
12596 return ref(o, OP_RV2AV);
12600 OpTYPE_set(o, OP_RV2AV);
12605 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
12612 Perl_oopsHV(pTHX_ OP *o)
12615 PERL_ARGS_ASSERT_OOPSHV;
12617 switch (o->op_type) {
12620 OpTYPE_set(o, OP_PADHV);
12621 return ref(o, OP_RV2HV);
12625 OpTYPE_set(o, OP_RV2HV);
12626 /* rv2hv steals the bottom bit for its own uses */
12627 o->op_private &= ~OPpARG1_MASK;
12632 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
12639 Perl_newAVREF(pTHX_ OP *o)
12642 PERL_ARGS_ASSERT_NEWAVREF;
12644 if (o->op_type == OP_PADANY) {
12645 OpTYPE_set(o, OP_PADAV);
12648 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
12649 Perl_croak(aTHX_ "Can't use an array as a reference");
12651 return newUNOP(OP_RV2AV, 0, scalar(o));
12655 Perl_newGVREF(pTHX_ I32 type, OP *o)
12657 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
12658 return newUNOP(OP_NULL, 0, o);
12659 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
12663 Perl_newHVREF(pTHX_ OP *o)
12666 PERL_ARGS_ASSERT_NEWHVREF;
12668 if (o->op_type == OP_PADANY) {
12669 OpTYPE_set(o, OP_PADHV);
12672 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12673 Perl_croak(aTHX_ "Can't use a hash as a reference");
12675 return newUNOP(OP_RV2HV, 0, scalar(o));
12679 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12681 if (o->op_type == OP_PADANY) {
12682 OpTYPE_set(o, OP_PADCV);
12684 return newUNOP(OP_RV2CV, flags, scalar(o));
12688 Perl_newSVREF(pTHX_ OP *o)
12691 PERL_ARGS_ASSERT_NEWSVREF;
12693 if (o->op_type == OP_PADANY) {
12694 OpTYPE_set(o, OP_PADSV);
12698 return newUNOP(OP_RV2SV, 0, scalar(o));
12701 /* Check routines. See the comments at the top of this file for details
12702 * on when these are called */
12705 Perl_ck_anoncode(pTHX_ OP *o)
12707 PERL_ARGS_ASSERT_CK_ANONCODE;
12709 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12710 cSVOPo->op_sv = NULL;
12715 S_io_hints(pTHX_ OP *o)
12717 #if O_BINARY != 0 || O_TEXT != 0
12719 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12721 SV **svp = hv_fetchs(table, "open_IN", FALSE);
12724 const char *d = SvPV_const(*svp, len);
12725 const I32 mode = mode_from_discipline(d, len);
12726 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12728 if (mode & O_BINARY)
12729 o->op_private |= OPpOPEN_IN_RAW;
12733 o->op_private |= OPpOPEN_IN_CRLF;
12737 svp = hv_fetchs(table, "open_OUT", FALSE);
12740 const char *d = SvPV_const(*svp, len);
12741 const I32 mode = mode_from_discipline(d, len);
12742 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12744 if (mode & O_BINARY)
12745 o->op_private |= OPpOPEN_OUT_RAW;
12749 o->op_private |= OPpOPEN_OUT_CRLF;
12754 PERL_UNUSED_CONTEXT;
12755 PERL_UNUSED_ARG(o);
12760 Perl_ck_backtick(pTHX_ OP *o)
12765 PERL_ARGS_ASSERT_CK_BACKTICK;
12767 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12768 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12769 && (gv = gv_override("readpipe",8)))
12771 /* detach rest of siblings from o and its first child */
12772 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12773 newop = S_new_entersubop(aTHX_ gv, sibl);
12775 else if (!(o->op_flags & OPf_KIDS))
12776 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12781 S_io_hints(aTHX_ o);
12786 Perl_ck_bitop(pTHX_ OP *o)
12788 PERL_ARGS_ASSERT_CK_BITOP;
12790 /* get rid of arg count and indicate if in the scope of 'use integer' */
12791 o->op_private = (PL_hints & HINT_INTEGER) ? OPpUSEINT : 0;
12793 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12794 && OP_IS_INFIX_BIT(o->op_type))
12796 const OP * const left = cBINOPo->op_first;
12797 const OP * const right = OpSIBLING(left);
12798 if ((OP_IS_NUMCOMPARE(left->op_type) &&
12799 (left->op_flags & OPf_PARENS) == 0) ||
12800 (OP_IS_NUMCOMPARE(right->op_type) &&
12801 (right->op_flags & OPf_PARENS) == 0))
12802 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12803 "Possible precedence problem on bitwise %s operator",
12804 o->op_type == OP_BIT_OR
12805 ||o->op_type == OP_NBIT_OR ? "|"
12806 : o->op_type == OP_BIT_AND
12807 ||o->op_type == OP_NBIT_AND ? "&"
12808 : o->op_type == OP_BIT_XOR
12809 ||o->op_type == OP_NBIT_XOR ? "^"
12810 : o->op_type == OP_SBIT_OR ? "|."
12811 : o->op_type == OP_SBIT_AND ? "&." : "^."
12817 PERL_STATIC_INLINE bool
12818 is_dollar_bracket(pTHX_ const OP * const o)
12821 PERL_UNUSED_CONTEXT;
12822 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12823 && (kid = cUNOPx(o)->op_first)
12824 && kid->op_type == OP_GV
12825 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12828 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12831 Perl_ck_cmp(pTHX_ OP *o)
12837 OP *indexop, *constop, *start;
12841 PERL_ARGS_ASSERT_CK_CMP;
12843 is_eq = ( o->op_type == OP_EQ
12844 || o->op_type == OP_NE
12845 || o->op_type == OP_I_EQ
12846 || o->op_type == OP_I_NE);
12848 if (!is_eq && ckWARN(WARN_SYNTAX)) {
12849 const OP *kid = cUNOPo->op_first;
12852 ( is_dollar_bracket(aTHX_ kid)
12853 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12855 || ( kid->op_type == OP_CONST
12856 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12860 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12861 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12864 /* convert (index(...) == -1) and variations into
12865 * (r)index/BOOL(,NEG)
12870 indexop = cUNOPo->op_first;
12871 constop = OpSIBLING(indexop);
12873 if (indexop->op_type == OP_CONST) {
12875 indexop = OpSIBLING(constop);
12880 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12883 /* ($lex = index(....)) == -1 */
12884 if (indexop->op_private & OPpTARGET_MY)
12887 if (constop->op_type != OP_CONST)
12890 sv = cSVOPx_sv(constop);
12891 if (!(sv && SvIOK_notUV(sv)))
12895 if (iv != -1 && iv != 0)
12899 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12900 if (!(iv0 ^ reverse))
12904 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12909 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12910 if (!(iv0 ^ reverse))
12914 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12919 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12925 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12931 indexop->op_flags &= ~OPf_PARENS;
12932 indexop->op_flags |= (o->op_flags & OPf_PARENS);
12933 indexop->op_private |= OPpTRUEBOOL;
12935 indexop->op_private |= OPpINDEX_BOOLNEG;
12936 /* cut out the index op and free the eq,const ops */
12937 (void)op_sibling_splice(o, start, 1, NULL);
12945 Perl_ck_concat(pTHX_ OP *o)
12947 const OP * const kid = cUNOPo->op_first;
12949 PERL_ARGS_ASSERT_CK_CONCAT;
12950 PERL_UNUSED_CONTEXT;
12952 /* reuse the padtmp returned by the concat child */
12953 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12954 !(kUNOP->op_first->op_flags & OPf_MOD))
12956 o->op_flags |= OPf_STACKED;
12957 o->op_private |= OPpCONCAT_NESTED;
12963 Perl_ck_spair(pTHX_ OP *o)
12966 PERL_ARGS_ASSERT_CK_SPAIR;
12968 if (o->op_flags & OPf_KIDS) {
12972 const OPCODE type = o->op_type;
12973 o = modkids(ck_fun(o), type);
12974 kid = cUNOPo->op_first;
12975 kidkid = kUNOP->op_first;
12976 newop = OpSIBLING(kidkid);
12978 const OPCODE type = newop->op_type;
12979 if (OpHAS_SIBLING(newop))
12981 if (o->op_type == OP_REFGEN
12982 && ( type == OP_RV2CV
12983 || ( !(newop->op_flags & OPf_PARENS)
12984 && ( type == OP_RV2AV || type == OP_PADAV
12985 || type == OP_RV2HV || type == OP_PADHV))))
12986 NOOP; /* OK (allow srefgen for \@a and \%h) */
12987 else if (OP_GIMME(newop,0) != G_SCALAR)
12990 /* excise first sibling */
12991 op_sibling_splice(kid, NULL, 1, NULL);
12994 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12995 * and OP_CHOMP into OP_SCHOMP */
12996 o->op_ppaddr = PL_ppaddr[++o->op_type];
13001 Perl_ck_delete(pTHX_ OP *o)
13003 PERL_ARGS_ASSERT_CK_DELETE;
13007 if (o->op_flags & OPf_KIDS) {
13008 OP * const kid = cUNOPo->op_first;
13009 switch (kid->op_type) {
13011 o->op_flags |= OPf_SPECIAL;
13014 o->op_private |= OPpSLICE;
13017 o->op_flags |= OPf_SPECIAL;
13022 o->op_flags |= OPf_SPECIAL;
13025 o->op_private |= OPpKVSLICE;
13028 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
13029 "element or slice");
13031 if (kid->op_private & OPpLVAL_INTRO)
13032 o->op_private |= OPpLVAL_INTRO;
13039 Perl_ck_eof(pTHX_ OP *o)
13041 PERL_ARGS_ASSERT_CK_EOF;
13043 if (o->op_flags & OPf_KIDS) {
13045 if (cLISTOPo->op_first->op_type == OP_STUB) {
13047 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
13052 kid = cLISTOPo->op_first;
13053 if (kid->op_type == OP_RV2GV)
13054 kid->op_private |= OPpALLOW_FAKE;
13061 Perl_ck_eval(pTHX_ OP *o)
13064 PERL_ARGS_ASSERT_CK_EVAL;
13066 PL_hints |= HINT_BLOCK_SCOPE;
13067 if (o->op_flags & OPf_KIDS) {
13068 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13071 if (o->op_type == OP_ENTERTRY) {
13074 /* cut whole sibling chain free from o */
13075 op_sibling_splice(o, NULL, -1, NULL);
13078 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
13080 /* establish postfix order */
13081 enter->op_next = (OP*)enter;
13083 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
13084 OpTYPE_set(o, OP_LEAVETRY);
13085 enter->op_other = o;
13090 S_set_haseval(aTHX);
13094 const U8 priv = o->op_private;
13096 /* the newUNOP will recursively call ck_eval(), which will handle
13097 * all the stuff at the end of this function, like adding
13100 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
13102 o->op_targ = (PADOFFSET)PL_hints;
13103 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
13104 if ((PL_hints & HINT_LOCALIZE_HH) != 0
13105 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
13106 /* Store a copy of %^H that pp_entereval can pick up. */
13107 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
13109 STOREFEATUREBITSHH(hh);
13110 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
13111 /* append hhop to only child */
13112 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
13114 o->op_private |= OPpEVAL_HAS_HH;
13116 if (!(o->op_private & OPpEVAL_BYTES)
13117 && FEATURE_UNIEVAL_IS_ENABLED)
13118 o->op_private |= OPpEVAL_UNICODE;
13123 Perl_ck_trycatch(pTHX_ OP *o)
13126 OP *to_free = NULL;
13127 OP *trykid, *catchkid;
13128 OP *catchroot, *catchstart;
13130 PERL_ARGS_ASSERT_CK_TRYCATCH;
13132 trykid = cUNOPo->op_first;
13133 if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) {
13135 trykid = OpSIBLING(trykid);
13137 catchkid = OpSIBLING(trykid);
13139 assert(trykid->op_type == OP_POPTRY);
13140 assert(catchkid->op_type == OP_CATCH);
13142 /* cut whole sibling chain free from o */
13143 op_sibling_splice(o, NULL, -1, NULL);
13148 enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL);
13150 /* establish postfix order */
13151 enter->op_next = (OP*)enter;
13153 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid);
13154 op_append_elem(OP_LINESEQ, (OP*)o, catchkid);
13156 OpTYPE_set(o, OP_LEAVETRYCATCH);
13158 /* The returned optree is actually threaded up slightly nonobviously in
13159 * terms of its ->op_next pointers.
13161 * This way, if the tryblock dies, its retop points at the OP_CATCH, but
13162 * if it does not then its leavetry skips over that and continues
13163 * execution past it.
13166 /* First, link up the actual body of the catch block */
13167 catchroot = OpSIBLING(cUNOPx(catchkid)->op_first);
13168 catchstart = LINKLIST(catchroot);
13169 cLOGOPx(catchkid)->op_other = catchstart;
13171 o->op_next = LINKLIST(o);
13173 /* die within try block should jump to the catch */
13174 enter->op_other = catchkid;
13176 /* after try block that doesn't die, just skip straight to leavetrycatch */
13177 trykid->op_next = o;
13179 /* after catch block, skip back up to the leavetrycatch */
13180 catchroot->op_next = o;
13186 Perl_ck_exec(pTHX_ OP *o)
13188 PERL_ARGS_ASSERT_CK_EXEC;
13190 if (o->op_flags & OPf_STACKED) {
13193 kid = OpSIBLING(cUNOPo->op_first);
13194 if (kid->op_type == OP_RV2GV)
13203 Perl_ck_exists(pTHX_ OP *o)
13205 PERL_ARGS_ASSERT_CK_EXISTS;
13208 if (o->op_flags & OPf_KIDS) {
13209 OP * const kid = cUNOPo->op_first;
13210 if (kid->op_type == OP_ENTERSUB) {
13211 (void) ref(kid, o->op_type);
13212 if (kid->op_type != OP_RV2CV
13213 && !(PL_parser && PL_parser->error_count))
13215 "exists argument is not a subroutine name");
13216 o->op_private |= OPpEXISTS_SUB;
13218 else if (kid->op_type == OP_AELEM)
13219 o->op_flags |= OPf_SPECIAL;
13220 else if (kid->op_type != OP_HELEM)
13221 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
13222 "element or a subroutine");
13229 Perl_ck_rvconst(pTHX_ OP *o)
13231 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13233 PERL_ARGS_ASSERT_CK_RVCONST;
13235 if (o->op_type == OP_RV2HV)
13236 /* rv2hv steals the bottom bit for its own uses */
13237 o->op_private &= ~OPpARG1_MASK;
13239 o->op_private |= (PL_hints & HINT_STRICT_REFS);
13241 if (kid->op_type == OP_CONST) {
13244 SV * const kidsv = kid->op_sv;
13246 /* Is it a constant from cv_const_sv()? */
13247 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
13250 if (SvTYPE(kidsv) == SVt_PVAV) return o;
13251 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
13252 const char *badthing;
13253 switch (o->op_type) {
13255 badthing = "a SCALAR";
13258 badthing = "an ARRAY";
13261 badthing = "a HASH";
13269 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
13270 SVfARG(kidsv), badthing);
13273 * This is a little tricky. We only want to add the symbol if we
13274 * didn't add it in the lexer. Otherwise we get duplicate strict
13275 * warnings. But if we didn't add it in the lexer, we must at
13276 * least pretend like we wanted to add it even if it existed before,
13277 * or we get possible typo warnings. OPpCONST_ENTERED says
13278 * whether the lexer already added THIS instance of this symbol.
13280 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
13281 gv = gv_fetchsv(kidsv,
13282 o->op_type == OP_RV2CV
13283 && o->op_private & OPpMAY_RETURN_CONSTANT
13285 : iscv | !(kid->op_private & OPpCONST_ENTERED),
13288 : o->op_type == OP_RV2SV
13290 : o->op_type == OP_RV2AV
13292 : o->op_type == OP_RV2HV
13299 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
13300 && SvTYPE(SvRV(gv)) != SVt_PVCV)
13301 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
13303 OpTYPE_set(kid, OP_GV);
13304 SvREFCNT_dec(kid->op_sv);
13305 #ifdef USE_ITHREADS
13306 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
13307 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
13308 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
13309 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
13310 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
13312 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
13314 kid->op_private = 0;
13315 /* FAKE globs in the symbol table cause weird bugs (#77810) */
13323 Perl_ck_ftst(pTHX_ OP *o)
13325 const I32 type = o->op_type;
13327 PERL_ARGS_ASSERT_CK_FTST;
13329 if (o->op_flags & OPf_REF) {
13332 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
13333 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13334 const OPCODE kidtype = kid->op_type;
13336 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
13337 && !kid->op_folded) {
13338 OP * const newop = newGVOP(type, OPf_REF,
13339 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
13344 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
13345 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
13347 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
13348 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
13349 array_passed_to_stat, name);
13352 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
13353 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
13356 scalar((OP *) kid);
13357 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
13358 o->op_private |= OPpFT_ACCESS;
13359 if (OP_IS_FILETEST(type)
13360 && OP_IS_FILETEST(kidtype)
13362 o->op_private |= OPpFT_STACKED;
13363 kid->op_private |= OPpFT_STACKING;
13364 if (kidtype == OP_FTTTY && (
13365 !(kid->op_private & OPpFT_STACKED)
13366 || kid->op_private & OPpFT_AFTER_t
13368 o->op_private |= OPpFT_AFTER_t;
13373 if (type == OP_FTTTY)
13374 o = newGVOP(type, OPf_REF, PL_stdingv);
13376 o = newUNOP(type, 0, newDEFSVOP());
13382 Perl_ck_fun(pTHX_ OP *o)
13384 const int type = o->op_type;
13385 I32 oa = PL_opargs[type] >> OASHIFT;
13387 PERL_ARGS_ASSERT_CK_FUN;
13389 if (o->op_flags & OPf_STACKED) {
13390 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
13391 oa &= ~OA_OPTIONAL;
13393 return no_fh_allowed(o);
13396 if (o->op_flags & OPf_KIDS) {
13397 OP *prev_kid = NULL;
13398 OP *kid = cLISTOPo->op_first;
13400 bool seen_optional = FALSE;
13402 if (kid->op_type == OP_PUSHMARK ||
13403 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
13406 kid = OpSIBLING(kid);
13408 if (kid && kid->op_type == OP_COREARGS) {
13409 bool optional = FALSE;
13412 if (oa & OA_OPTIONAL) optional = TRUE;
13415 if (optional) o->op_private |= numargs;
13420 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
13421 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
13422 kid = newDEFSVOP();
13423 /* append kid to chain */
13424 op_sibling_splice(o, prev_kid, 0, kid);
13426 seen_optional = TRUE;
13433 /* list seen where single (scalar) arg expected? */
13434 if (numargs == 1 && !(oa >> 4)
13435 && kid->op_type == OP_LIST && type != OP_SCALAR)
13437 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13439 if (type != OP_DELETE) scalar(kid);
13450 if ((type == OP_PUSH || type == OP_UNSHIFT)
13451 && !OpHAS_SIBLING(kid))
13452 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
13453 "Useless use of %s with no values",
13456 if (kid->op_type == OP_CONST
13457 && ( !SvROK(cSVOPx_sv(kid))
13458 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
13460 bad_type_pv(numargs, "array", o, kid);
13461 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
13462 || kid->op_type == OP_RV2GV) {
13463 bad_type_pv(1, "array", o, kid);
13465 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
13466 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
13467 PL_op_desc[type]), 0);
13470 op_lvalue(kid, type);
13474 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
13475 bad_type_pv(numargs, "hash", o, kid);
13476 op_lvalue(kid, type);
13480 /* replace kid with newop in chain */
13482 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
13483 newop->op_next = newop;
13488 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
13489 if (kid->op_type == OP_CONST &&
13490 (kid->op_private & OPpCONST_BARE))
13492 OP * const newop = newGVOP(OP_GV, 0,
13493 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
13494 /* a first argument is handled by toke.c, ideally we'd
13495 just check here but several ops don't use ck_fun() */
13496 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED && numargs > 1) {
13497 no_bareword_filehandle(SvPVX(cSVOPx_sv((SVOP*)kid)));
13499 /* replace kid with newop in chain */
13500 op_sibling_splice(o, prev_kid, 1, newop);
13504 else if (kid->op_type == OP_READLINE) {
13505 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
13506 bad_type_pv(numargs, "HANDLE", o, kid);
13509 I32 flags = OPf_SPECIAL;
13511 PADOFFSET targ = 0;
13513 /* is this op a FH constructor? */
13514 if (is_handle_constructor(o,numargs)) {
13515 const char *name = NULL;
13518 bool want_dollar = TRUE;
13521 /* Set a flag to tell rv2gv to vivify
13522 * need to "prove" flag does not mean something
13523 * else already - NI-S 1999/05/07
13526 if (kid->op_type == OP_PADSV) {
13528 = PAD_COMPNAME_SV(kid->op_targ);
13529 name = PadnamePV (pn);
13530 len = PadnameLEN(pn);
13531 name_utf8 = PadnameUTF8(pn);
13533 else if (kid->op_type == OP_RV2SV
13534 && kUNOP->op_first->op_type == OP_GV)
13536 GV * const gv = cGVOPx_gv(kUNOP->op_first);
13538 len = GvNAMELEN(gv);
13539 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
13541 else if (kid->op_type == OP_AELEM
13542 || kid->op_type == OP_HELEM)
13545 OP *op = ((BINOP*)kid)->op_first;
13549 const char * const a =
13550 kid->op_type == OP_AELEM ?
13552 if (((op->op_type == OP_RV2AV) ||
13553 (op->op_type == OP_RV2HV)) &&
13554 (firstop = ((UNOP*)op)->op_first) &&
13555 (firstop->op_type == OP_GV)) {
13556 /* packagevar $a[] or $h{} */
13557 GV * const gv = cGVOPx_gv(firstop);
13560 Perl_newSVpvf(aTHX_
13565 else if (op->op_type == OP_PADAV
13566 || op->op_type == OP_PADHV) {
13567 /* lexicalvar $a[] or $h{} */
13568 const char * const padname =
13569 PAD_COMPNAME_PV(op->op_targ);
13572 Perl_newSVpvf(aTHX_
13578 name = SvPV_const(tmpstr, len);
13579 name_utf8 = SvUTF8(tmpstr);
13580 sv_2mortal(tmpstr);
13584 name = "__ANONIO__";
13586 want_dollar = FALSE;
13588 op_lvalue(kid, type);
13592 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
13593 namesv = PAD_SVl(targ);
13594 if (want_dollar && *name != '$')
13595 sv_setpvs(namesv, "$");
13598 sv_catpvn(namesv, name, len);
13599 if ( name_utf8 ) SvUTF8_on(namesv);
13603 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
13605 kid->op_targ = targ;
13606 kid->op_private |= priv;
13612 if ((type == OP_UNDEF || type == OP_POS)
13613 && numargs == 1 && !(oa >> 4)
13614 && kid->op_type == OP_LIST)
13615 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13616 op_lvalue(scalar(kid), type);
13621 kid = OpSIBLING(kid);
13623 /* FIXME - should the numargs or-ing move after the too many
13624 * arguments check? */
13625 o->op_private |= numargs;
13627 return too_many_arguments_pv(o,OP_DESC(o), 0);
13630 else if (PL_opargs[type] & OA_DEFGV) {
13631 /* Ordering of these two is important to keep f_map.t passing. */
13633 return newUNOP(type, 0, newDEFSVOP());
13637 while (oa & OA_OPTIONAL)
13639 if (oa && oa != OA_LIST)
13640 return too_few_arguments_pv(o,OP_DESC(o), 0);
13646 Perl_ck_glob(pTHX_ OP *o)
13650 PERL_ARGS_ASSERT_CK_GLOB;
13653 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13654 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13656 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13660 * \ null - const(wildcard)
13665 * \ mark - glob - rv2cv
13666 * | \ gv(CORE::GLOBAL::glob)
13668 * \ null - const(wildcard)
13670 o->op_flags |= OPf_SPECIAL;
13671 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13672 o = S_new_entersubop(aTHX_ gv, o);
13673 o = newUNOP(OP_NULL, 0, o);
13674 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13677 else o->op_flags &= ~OPf_SPECIAL;
13678 #if !defined(PERL_EXTERNAL_GLOB)
13679 if (!PL_globhook) {
13681 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13682 newSVpvs("File::Glob"), NULL, NULL, NULL);
13685 #endif /* !PERL_EXTERNAL_GLOB */
13686 gv = (GV *)newSV(0);
13687 gv_init(gv, 0, "", 0, 0);
13689 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13690 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13696 Perl_ck_grep(pTHX_ OP *o)
13700 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13702 PERL_ARGS_ASSERT_CK_GREP;
13704 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13706 if (o->op_flags & OPf_STACKED) {
13707 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13708 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13709 return no_fh_allowed(o);
13710 o->op_flags &= ~OPf_STACKED;
13712 kid = OpSIBLING(cLISTOPo->op_first);
13713 if (type == OP_MAPWHILE)
13718 if (PL_parser && PL_parser->error_count)
13720 kid = OpSIBLING(cLISTOPo->op_first);
13721 if (kid->op_type != OP_NULL)
13722 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13723 kid = kUNOP->op_first;
13725 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13726 kid->op_next = (OP*)gwop;
13727 o->op_private = gwop->op_private = 0;
13728 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13730 kid = OpSIBLING(cLISTOPo->op_first);
13731 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13732 op_lvalue(kid, OP_GREPSTART);
13738 Perl_ck_index(pTHX_ OP *o)
13740 PERL_ARGS_ASSERT_CK_INDEX;
13742 if (o->op_flags & OPf_KIDS) {
13743 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13745 kid = OpSIBLING(kid); /* get past "big" */
13746 if (kid && kid->op_type == OP_CONST) {
13747 const bool save_taint = TAINT_get;
13748 SV *sv = kSVOP->op_sv;
13749 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13750 && SvOK(sv) && !SvROK(sv))
13753 sv_copypv(sv, kSVOP->op_sv);
13754 SvREFCNT_dec_NN(kSVOP->op_sv);
13757 if (SvOK(sv)) fbm_compile(sv, 0);
13758 TAINT_set(save_taint);
13759 #ifdef NO_TAINT_SUPPORT
13760 PERL_UNUSED_VAR(save_taint);
13768 Perl_ck_lfun(pTHX_ OP *o)
13770 const OPCODE type = o->op_type;
13772 PERL_ARGS_ASSERT_CK_LFUN;
13774 return modkids(ck_fun(o), type);
13778 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
13780 PERL_ARGS_ASSERT_CK_DEFINED;
13782 if ((o->op_flags & OPf_KIDS)) {
13783 switch (cUNOPo->op_first->op_type) {
13786 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13787 " (Maybe you should just omit the defined()?)");
13788 NOT_REACHED; /* NOTREACHED */
13792 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13793 " (Maybe you should just omit the defined()?)");
13794 NOT_REACHED; /* NOTREACHED */
13805 Perl_ck_readline(pTHX_ OP *o)
13807 PERL_ARGS_ASSERT_CK_READLINE;
13809 if (o->op_flags & OPf_KIDS) {
13810 OP *kid = cLISTOPo->op_first;
13811 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13816 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13824 Perl_ck_rfun(pTHX_ OP *o)
13826 const OPCODE type = o->op_type;
13828 PERL_ARGS_ASSERT_CK_RFUN;
13830 return refkids(ck_fun(o), type);
13834 Perl_ck_listiob(pTHX_ OP *o)
13838 PERL_ARGS_ASSERT_CK_LISTIOB;
13840 kid = cLISTOPo->op_first;
13842 o = force_list(o, TRUE);
13843 kid = cLISTOPo->op_first;
13845 if (kid->op_type == OP_PUSHMARK)
13846 kid = OpSIBLING(kid);
13847 if (kid && o->op_flags & OPf_STACKED)
13848 kid = OpSIBLING(kid);
13849 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
13850 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13851 && !kid->op_folded) {
13852 o->op_flags |= OPf_STACKED; /* make it a filehandle */
13854 /* replace old const op with new OP_RV2GV parent */
13855 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13856 OP_RV2GV, OPf_REF);
13857 kid = OpSIBLING(kid);
13862 op_append_elem(o->op_type, o, newDEFSVOP());
13864 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13865 return listkids(o);
13869 Perl_ck_smartmatch(pTHX_ OP *o)
13871 PERL_ARGS_ASSERT_CK_SMARTMATCH;
13872 if (0 == (o->op_flags & OPf_SPECIAL)) {
13873 OP *first = cBINOPo->op_first;
13874 OP *second = OpSIBLING(first);
13876 /* Implicitly take a reference to an array or hash */
13878 /* remove the original two siblings, then add back the
13879 * (possibly different) first and second sibs.
13881 op_sibling_splice(o, NULL, 1, NULL);
13882 op_sibling_splice(o, NULL, 1, NULL);
13883 first = ref_array_or_hash(first);
13884 second = ref_array_or_hash(second);
13885 op_sibling_splice(o, NULL, 0, second);
13886 op_sibling_splice(o, NULL, 0, first);
13888 /* Implicitly take a reference to a regular expression */
13889 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13890 OpTYPE_set(first, OP_QR);
13892 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13893 OpTYPE_set(second, OP_QR);
13902 S_maybe_targlex(pTHX_ OP *o)
13904 OP * const kid = cLISTOPo->op_first;
13905 /* has a disposable target? */
13906 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13907 && !(kid->op_flags & OPf_STACKED)
13908 /* Cannot steal the second time! */
13909 && !(kid->op_private & OPpTARGET_MY)
13912 OP * const kkid = OpSIBLING(kid);
13914 /* Can just relocate the target. */
13915 if (kkid && kkid->op_type == OP_PADSV
13916 && (!(kkid->op_private & OPpLVAL_INTRO)
13917 || kkid->op_private & OPpPAD_STATE))
13919 kid->op_targ = kkid->op_targ;
13921 /* Now we do not need PADSV and SASSIGN.
13922 * Detach kid and free the rest. */
13923 op_sibling_splice(o, NULL, 1, NULL);
13925 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
13933 Perl_ck_sassign(pTHX_ OP *o)
13935 OP * const kid = cBINOPo->op_first;
13937 PERL_ARGS_ASSERT_CK_SASSIGN;
13939 if (OpHAS_SIBLING(kid)) {
13940 OP *kkid = OpSIBLING(kid);
13941 /* For state variable assignment with attributes, kkid is a list op
13942 whose op_last is a padsv. */
13943 if ((kkid->op_type == OP_PADSV ||
13944 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13945 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13948 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13949 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13950 return S_newONCEOP(aTHX_ o, kkid);
13953 return S_maybe_targlex(aTHX_ o);
13958 Perl_ck_match(pTHX_ OP *o)
13960 PERL_UNUSED_CONTEXT;
13961 PERL_ARGS_ASSERT_CK_MATCH;
13967 Perl_ck_method(pTHX_ OP *o)
13969 SV *sv, *methsv, *rclass;
13970 const char* method;
13973 STRLEN len, nsplit = 0, i;
13975 OP * const kid = cUNOPo->op_first;
13977 PERL_ARGS_ASSERT_CK_METHOD;
13978 if (kid->op_type != OP_CONST) return o;
13982 /* replace ' with :: */
13983 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13984 SvEND(sv) - SvPVX(sv) )))
13987 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13990 method = SvPVX_const(sv);
13992 utf8 = SvUTF8(sv) ? -1 : 1;
13994 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13999 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
14001 if (!nsplit) { /* $proto->method() */
14003 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
14006 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
14008 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
14011 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
14012 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
14013 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
14014 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
14016 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
14017 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
14019 #ifdef USE_ITHREADS
14020 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
14022 cMETHOPx(new_op)->op_rclass_sv = rclass;
14029 Perl_ck_null(pTHX_ OP *o)
14031 PERL_ARGS_ASSERT_CK_NULL;
14032 PERL_UNUSED_CONTEXT;
14037 Perl_ck_open(pTHX_ OP *o)
14039 PERL_ARGS_ASSERT_CK_OPEN;
14041 S_io_hints(aTHX_ o);
14043 /* In case of three-arg dup open remove strictness
14044 * from the last arg if it is a bareword. */
14045 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
14046 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
14050 if ((last->op_type == OP_CONST) && /* The bareword. */
14051 (last->op_private & OPpCONST_BARE) &&
14052 (last->op_private & OPpCONST_STRICT) &&
14053 (oa = OpSIBLING(first)) && /* The fh. */
14054 (oa = OpSIBLING(oa)) && /* The mode. */
14055 (oa->op_type == OP_CONST) &&
14056 SvPOK(((SVOP*)oa)->op_sv) &&
14057 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
14058 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
14059 (last == OpSIBLING(oa))) /* The bareword. */
14060 last->op_private &= ~OPpCONST_STRICT;
14066 Perl_ck_prototype(pTHX_ OP *o)
14068 PERL_ARGS_ASSERT_CK_PROTOTYPE;
14069 if (!(o->op_flags & OPf_KIDS)) {
14071 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
14077 Perl_ck_refassign(pTHX_ OP *o)
14079 OP * const right = cLISTOPo->op_first;
14080 OP * const left = OpSIBLING(right);
14081 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
14084 PERL_ARGS_ASSERT_CK_REFASSIGN;
14086 assert (left->op_type == OP_SREFGEN);
14089 /* we use OPpPAD_STATE in refassign to mean either of those things,
14090 * and the code assumes the two flags occupy the same bit position
14091 * in the various ops below */
14092 assert(OPpPAD_STATE == OPpOUR_INTRO);
14094 switch (varop->op_type) {
14096 o->op_private |= OPpLVREF_AV;
14099 o->op_private |= OPpLVREF_HV;
14103 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
14104 o->op_targ = varop->op_targ;
14105 varop->op_targ = 0;
14106 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
14110 o->op_private |= OPpLVREF_AV;
14112 NOT_REACHED; /* NOTREACHED */
14114 o->op_private |= OPpLVREF_HV;
14118 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
14119 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
14121 /* Point varop to its GV kid, detached. */
14122 varop = op_sibling_splice(varop, NULL, -1, NULL);
14126 OP * const kidparent =
14127 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
14128 OP * const kid = cUNOPx(kidparent)->op_first;
14129 o->op_private |= OPpLVREF_CV;
14130 if (kid->op_type == OP_GV) {
14131 SV *sv = (SV*)cGVOPx_gv(kid);
14133 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
14134 /* a CVREF here confuses pp_refassign, so make sure
14136 CV *const cv = (CV*)SvRV(sv);
14137 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
14138 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
14139 assert(SvTYPE(sv) == SVt_PVGV);
14141 goto detach_and_stack;
14143 if (kid->op_type != OP_PADCV) goto bad;
14144 o->op_targ = kid->op_targ;
14150 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
14151 o->op_private |= OPpLVREF_ELEM;
14154 /* Detach varop. */
14155 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
14159 /* diag_listed_as: Can't modify reference to %s in %s assignment */
14160 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
14165 if (!FEATURE_REFALIASING_IS_ENABLED)
14167 "Experimental aliasing via reference not enabled");
14168 Perl_ck_warner_d(aTHX_
14169 packWARN(WARN_EXPERIMENTAL__REFALIASING),
14170 "Aliasing via reference is experimental");
14172 o->op_flags |= OPf_STACKED;
14173 op_sibling_splice(o, right, 1, varop);
14176 o->op_flags &=~ OPf_STACKED;
14177 op_sibling_splice(o, right, 1, NULL);
14184 Perl_ck_repeat(pTHX_ OP *o)
14186 PERL_ARGS_ASSERT_CK_REPEAT;
14188 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
14190 o->op_private |= OPpREPEAT_DOLIST;
14191 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
14192 kids = force_list(kids, TRUE); /* promote it to a list */
14193 op_sibling_splice(o, NULL, 0, kids); /* and add back */
14201 Perl_ck_require(pTHX_ OP *o)
14205 PERL_ARGS_ASSERT_CK_REQUIRE;
14207 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
14208 SVOP * const kid = (SVOP*)cUNOPo->op_first;
14212 if (kid->op_type == OP_CONST) {
14213 SV * const sv = kid->op_sv;
14214 U32 const was_readonly = SvREADONLY(sv);
14215 if (kid->op_private & OPpCONST_BARE) {
14219 if (was_readonly) {
14220 SvREADONLY_off(sv);
14223 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
14228 /* treat ::foo::bar as foo::bar */
14229 if (len >= 2 && s[0] == ':' && s[1] == ':')
14230 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
14232 DIE(aTHX_ "Bareword in require maps to empty filename");
14234 for (; s < end; s++) {
14235 if (*s == ':' && s[1] == ':') {
14237 Move(s+2, s+1, end - s - 1, char);
14241 SvEND_set(sv, end);
14242 sv_catpvs(sv, ".pm");
14243 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
14244 hek = share_hek(SvPVX(sv),
14245 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
14247 sv_sethek(sv, hek);
14249 SvFLAGS(sv) |= was_readonly;
14251 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
14254 if (SvREFCNT(sv) > 1) {
14255 kid->op_sv = newSVpvn_share(
14256 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
14257 SvREFCNT_dec_NN(sv);
14261 if (was_readonly) SvREADONLY_off(sv);
14262 PERL_HASH(hash, s, len);
14264 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
14266 sv_sethek(sv, hek);
14268 SvFLAGS(sv) |= was_readonly;
14274 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
14275 /* handle override, if any */
14276 && (gv = gv_override("require", 7))) {
14278 if (o->op_flags & OPf_KIDS) {
14279 kid = cUNOPo->op_first;
14280 op_sibling_splice(o, NULL, -1, NULL);
14283 kid = newDEFSVOP();
14286 newop = S_new_entersubop(aTHX_ gv, kid);
14294 Perl_ck_return(pTHX_ OP *o)
14298 PERL_ARGS_ASSERT_CK_RETURN;
14300 kid = OpSIBLING(cLISTOPo->op_first);
14301 if (PL_compcv && CvLVALUE(PL_compcv)) {
14302 for (; kid; kid = OpSIBLING(kid))
14303 op_lvalue(kid, OP_LEAVESUBLV);
14310 Perl_ck_select(pTHX_ OP *o)
14314 PERL_ARGS_ASSERT_CK_SELECT;
14316 if (o->op_flags & OPf_KIDS) {
14317 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14318 if (kid && OpHAS_SIBLING(kid)) {
14319 OpTYPE_set(o, OP_SSELECT);
14321 return fold_constants(op_integerize(op_std_init(o)));
14325 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14326 if (kid && kid->op_type == OP_RV2GV)
14327 kid->op_private &= ~HINT_STRICT_REFS;
14332 Perl_ck_shift(pTHX_ OP *o)
14334 const I32 type = o->op_type;
14336 PERL_ARGS_ASSERT_CK_SHIFT;
14338 if (!(o->op_flags & OPf_KIDS)) {
14341 if (!CvUNIQUE(PL_compcv)) {
14342 o->op_flags |= OPf_SPECIAL;
14346 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
14348 return newUNOP(type, 0, scalar(argop));
14350 return scalar(ck_fun(o));
14354 Perl_ck_sort(pTHX_ OP *o)
14360 PERL_ARGS_ASSERT_CK_SORT;
14362 if (o->op_flags & OPf_STACKED)
14364 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14367 return too_few_arguments_pv(o,OP_DESC(o), 0);
14369 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
14370 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
14372 /* if the first arg is a code block, process it and mark sort as
14374 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
14376 if (kid->op_type == OP_LEAVE)
14377 op_null(kid); /* wipe out leave */
14378 /* Prevent execution from escaping out of the sort block. */
14381 /* provide scalar context for comparison function/block */
14382 kid = scalar(firstkid);
14383 kid->op_next = kid;
14384 o->op_flags |= OPf_SPECIAL;
14386 else if (kid->op_type == OP_CONST
14387 && kid->op_private & OPpCONST_BARE) {
14391 const char * const name = SvPV(kSVOP_sv, len);
14393 assert (len < 256);
14394 Copy(name, tmpbuf+1, len, char);
14395 off = pad_findmy_pvn(tmpbuf, len+1, 0);
14396 if (off != NOT_IN_PAD) {
14397 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
14399 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
14400 sv_catpvs(fq, "::");
14401 sv_catsv(fq, kSVOP_sv);
14402 SvREFCNT_dec_NN(kSVOP_sv);
14406 OP * const padop = newOP(OP_PADCV, 0);
14407 padop->op_targ = off;
14408 /* replace the const op with the pad op */
14409 op_sibling_splice(firstkid, NULL, 1, padop);
14415 firstkid = OpSIBLING(firstkid);
14418 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
14419 /* provide list context for arguments */
14422 op_lvalue(kid, OP_GREPSTART);
14428 /* for sort { X } ..., where X is one of
14429 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
14430 * elide the second child of the sort (the one containing X),
14431 * and set these flags as appropriate
14435 * Also, check and warn on lexical $a, $b.
14439 S_simplify_sort(pTHX_ OP *o)
14441 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14445 const char *gvname;
14448 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
14450 kid = kUNOP->op_first; /* get past null */
14451 if (!(have_scopeop = kid->op_type == OP_SCOPE)
14452 && kid->op_type != OP_LEAVE)
14454 kid = kLISTOP->op_last; /* get past scope */
14455 switch(kid->op_type) {
14459 if (!have_scopeop) goto padkids;
14464 k = kid; /* remember this node*/
14465 if (kBINOP->op_first->op_type != OP_RV2SV
14466 || kBINOP->op_last ->op_type != OP_RV2SV)
14469 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
14470 then used in a comparison. This catches most, but not
14471 all cases. For instance, it catches
14472 sort { my($a); $a <=> $b }
14474 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
14475 (although why you'd do that is anyone's guess).
14479 if (!ckWARN(WARN_SYNTAX)) return;
14480 kid = kBINOP->op_first;
14482 if (kid->op_type == OP_PADSV) {
14483 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
14484 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
14485 && ( PadnamePV(name)[1] == 'a'
14486 || PadnamePV(name)[1] == 'b' ))
14487 /* diag_listed_as: "my %s" used in sort comparison */
14488 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14489 "\"%s %s\" used in sort comparison",
14490 PadnameIsSTATE(name)
14495 } while ((kid = OpSIBLING(kid)));
14498 kid = kBINOP->op_first; /* get past cmp */
14499 if (kUNOP->op_first->op_type != OP_GV)
14501 kid = kUNOP->op_first; /* get past rv2sv */
14503 if (GvSTASH(gv) != PL_curstash)
14505 gvname = GvNAME(gv);
14506 if (*gvname == 'a' && gvname[1] == '\0')
14508 else if (*gvname == 'b' && gvname[1] == '\0')
14513 kid = k; /* back to cmp */
14514 /* already checked above that it is rv2sv */
14515 kid = kBINOP->op_last; /* down to 2nd arg */
14516 if (kUNOP->op_first->op_type != OP_GV)
14518 kid = kUNOP->op_first; /* get past rv2sv */
14520 if (GvSTASH(gv) != PL_curstash)
14522 gvname = GvNAME(gv);
14524 ? !(*gvname == 'a' && gvname[1] == '\0')
14525 : !(*gvname == 'b' && gvname[1] == '\0'))
14527 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
14529 o->op_private |= OPpSORT_DESCEND;
14530 if (k->op_type == OP_NCMP)
14531 o->op_private |= OPpSORT_NUMERIC;
14532 if (k->op_type == OP_I_NCMP)
14533 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
14534 kid = OpSIBLING(cLISTOPo->op_first);
14535 /* cut out and delete old block (second sibling) */
14536 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
14541 Perl_ck_split(pTHX_ OP *o)
14546 PERL_ARGS_ASSERT_CK_SPLIT;
14548 assert(o->op_type == OP_LIST);
14550 if (o->op_flags & OPf_STACKED)
14551 return no_fh_allowed(o);
14553 kid = cLISTOPo->op_first;
14554 /* delete leading NULL node, then add a CONST if no other nodes */
14555 assert(kid->op_type == OP_NULL);
14556 op_sibling_splice(o, NULL, 1,
14557 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
14559 kid = cLISTOPo->op_first;
14561 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
14562 /* remove match expression, and replace with new optree with
14563 * a match op at its head */
14564 op_sibling_splice(o, NULL, 1, NULL);
14565 /* pmruntime will handle split " " behavior with flag==2 */
14566 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
14567 op_sibling_splice(o, NULL, 0, kid);
14570 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
14572 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
14573 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
14574 "Use of /g modifier is meaningless in split");
14577 /* eliminate the split op, and move the match op (plus any children)
14578 * into its place, then convert the match op into a split op. i.e.
14580 * SPLIT MATCH SPLIT(ex-MATCH)
14582 * MATCH - A - B - C => R - A - B - C => R - A - B - C
14588 * (R, if it exists, will be a regcomp op)
14591 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14592 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14593 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14594 OpTYPE_set(kid, OP_SPLIT);
14595 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
14596 kid->op_private = o->op_private;
14599 kid = sibs; /* kid is now the string arg of the split */
14602 kid = newDEFSVOP();
14603 op_append_elem(OP_SPLIT, o, kid);
14607 kid = OpSIBLING(kid);
14609 kid = newSVOP(OP_CONST, 0, newSViv(0));
14610 op_append_elem(OP_SPLIT, o, kid);
14611 o->op_private |= OPpSPLIT_IMPLIM;
14615 if (OpHAS_SIBLING(kid))
14616 return too_many_arguments_pv(o,OP_DESC(o), 0);
14622 Perl_ck_stringify(pTHX_ OP *o)
14624 OP * const kid = OpSIBLING(cUNOPo->op_first);
14625 PERL_ARGS_ASSERT_CK_STRINGIFY;
14626 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14627 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
14628 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
14629 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14631 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14639 Perl_ck_join(pTHX_ OP *o)
14641 OP * const kid = OpSIBLING(cLISTOPo->op_first);
14643 PERL_ARGS_ASSERT_CK_JOIN;
14645 if (kid && kid->op_type == OP_MATCH) {
14646 if (ckWARN(WARN_SYNTAX)) {
14647 const REGEXP *re = PM_GETRE(kPMOP);
14649 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14650 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14651 : newSVpvs_flags( "STRING", SVs_TEMP );
14652 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14653 "/%" SVf "/ should probably be written as \"%" SVf "\"",
14654 SVfARG(msg), SVfARG(msg));
14658 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14659 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14660 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14661 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14663 const OP * const bairn = OpSIBLING(kid); /* the list */
14664 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14665 && OP_GIMME(bairn,0) == G_SCALAR)
14667 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14668 op_sibling_splice(o, kid, 1, NULL));
14678 =for apidoc rv2cv_op_cv
14680 Examines an op, which is expected to identify a subroutine at runtime,
14681 and attempts to determine at compile time which subroutine it identifies.
14682 This is normally used during Perl compilation to determine whether
14683 a prototype can be applied to a function call. C<cvop> is the op
14684 being considered, normally an C<rv2cv> op. A pointer to the identified
14685 subroutine is returned, if it could be determined statically, and a null
14686 pointer is returned if it was not possible to determine statically.
14688 Currently, the subroutine can be identified statically if the RV that the
14689 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14690 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
14691 suitable if the constant value must be an RV pointing to a CV. Details of
14692 this process may change in future versions of Perl. If the C<rv2cv> op
14693 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14694 the subroutine statically: this flag is used to suppress compile-time
14695 magic on a subroutine call, forcing it to use default runtime behaviour.
14697 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14698 of a GV reference is modified. If a GV was examined and its CV slot was
14699 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14700 If the op is not optimised away, and the CV slot is later populated with
14701 a subroutine having a prototype, that flag eventually triggers the warning
14702 "called too early to check prototype".
14704 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14705 of returning a pointer to the subroutine it returns a pointer to the
14706 GV giving the most appropriate name for the subroutine in this context.
14707 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14708 (C<CvANON>) subroutine that is referenced through a GV it will be the
14709 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
14710 A null pointer is returned as usual if there is no statically-determinable
14713 =for apidoc Amnh||OPpEARLY_CV
14714 =for apidoc Amnh||OPpENTERSUB_AMPER
14715 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14716 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14721 /* shared by toke.c:yylex */
14723 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14725 PADNAME *name = PAD_COMPNAME(off);
14726 CV *compcv = PL_compcv;
14727 while (PadnameOUTER(name)) {
14728 assert(PARENT_PAD_INDEX(name));
14729 compcv = CvOUTSIDE(compcv);
14730 name = PadlistNAMESARRAY(CvPADLIST(compcv))
14731 [off = PARENT_PAD_INDEX(name)];
14733 assert(!PadnameIsOUR(name));
14734 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14735 return PadnamePROTOCV(name);
14737 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14741 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14746 PERL_ARGS_ASSERT_RV2CV_OP_CV;
14747 if (flags & ~RV2CVOPCV_FLAG_MASK)
14748 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14749 if (cvop->op_type != OP_RV2CV)
14751 if (cvop->op_private & OPpENTERSUB_AMPER)
14753 if (!(cvop->op_flags & OPf_KIDS))
14755 rvop = cUNOPx(cvop)->op_first;
14756 switch (rvop->op_type) {
14758 gv = cGVOPx_gv(rvop);
14760 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14761 cv = MUTABLE_CV(SvRV(gv));
14765 if (flags & RV2CVOPCV_RETURN_STUB)
14771 if (flags & RV2CVOPCV_MARK_EARLY)
14772 rvop->op_private |= OPpEARLY_CV;
14777 SV *rv = cSVOPx_sv(rvop);
14780 cv = (CV*)SvRV(rv);
14784 cv = find_lexical_cv(rvop->op_targ);
14789 } NOT_REACHED; /* NOTREACHED */
14791 if (SvTYPE((SV*)cv) != SVt_PVCV)
14793 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14794 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14798 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14799 if (CvLEXICAL(cv) || CvNAMED(cv))
14801 if (!CvANON(cv) || !gv)
14811 =for apidoc ck_entersub_args_list
14813 Performs the default fixup of the arguments part of an C<entersub>
14814 op tree. This consists of applying list context to each of the
14815 argument ops. This is the standard treatment used on a call marked
14816 with C<&>, or a method call, or a call through a subroutine reference,
14817 or any other call where the callee can't be identified at compile time,
14818 or a call where the callee has no prototype.
14824 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14828 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14830 aop = cUNOPx(entersubop)->op_first;
14831 if (!OpHAS_SIBLING(aop))
14832 aop = cUNOPx(aop)->op_first;
14833 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14834 /* skip the extra attributes->import() call implicitly added in
14835 * something like foo(my $x : bar)
14837 if ( aop->op_type == OP_ENTERSUB
14838 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14842 op_lvalue(aop, OP_ENTERSUB);
14848 =for apidoc ck_entersub_args_proto
14850 Performs the fixup of the arguments part of an C<entersub> op tree
14851 based on a subroutine prototype. This makes various modifications to
14852 the argument ops, from applying context up to inserting C<refgen> ops,
14853 and checking the number and syntactic types of arguments, as directed by
14854 the prototype. This is the standard treatment used on a subroutine call,
14855 not marked with C<&>, where the callee can be identified at compile time
14856 and has a prototype.
14858 C<protosv> supplies the subroutine prototype to be applied to the call.
14859 It may be a normal defined scalar, of which the string value will be used.
14860 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14861 that has been cast to C<SV*>) which has a prototype. The prototype
14862 supplied, in whichever form, does not need to match the actual callee
14863 referenced by the op tree.
14865 If the argument ops disagree with the prototype, for example by having
14866 an unacceptable number of arguments, a valid op tree is returned anyway.
14867 The error is reflected in the parser state, normally resulting in a single
14868 exception at the top level of parsing which covers all the compilation
14869 errors that occurred. In the error message, the callee is referred to
14870 by the name defined by the C<namegv> parameter.
14876 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14879 const char *proto, *proto_end;
14880 OP *aop, *prev, *cvop, *parent;
14883 I32 contextclass = 0;
14884 const char *e = NULL;
14885 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14886 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14887 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14888 "flags=%lx", (unsigned long) SvFLAGS(protosv));
14889 if (SvTYPE(protosv) == SVt_PVCV)
14890 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14891 else proto = SvPV(protosv, proto_len);
14892 proto = S_strip_spaces(aTHX_ proto, &proto_len);
14893 proto_end = proto + proto_len;
14894 parent = entersubop;
14895 aop = cUNOPx(entersubop)->op_first;
14896 if (!OpHAS_SIBLING(aop)) {
14898 aop = cUNOPx(aop)->op_first;
14901 aop = OpSIBLING(aop);
14902 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14903 while (aop != cvop) {
14906 if (proto >= proto_end)
14908 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14909 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14910 SVfARG(namesv)), SvUTF8(namesv));
14920 /* _ must be at the end */
14921 if (proto[1] && !memCHRs(";@%", proto[1]))
14937 if ( o3->op_type != OP_UNDEF
14938 && (o3->op_type != OP_SREFGEN
14939 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14941 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14943 bad_type_gv(arg, namegv, o3,
14944 arg == 1 ? "block or sub {}" : "sub {}");
14947 /* '*' allows any scalar type, including bareword */
14950 if (o3->op_type == OP_RV2GV)
14951 goto wrapref; /* autoconvert GLOB -> GLOBref */
14952 else if (o3->op_type == OP_CONST)
14953 o3->op_private &= ~OPpCONST_STRICT;
14959 if (o3->op_type == OP_RV2AV ||
14960 o3->op_type == OP_PADAV ||
14961 o3->op_type == OP_RV2HV ||
14962 o3->op_type == OP_PADHV
14968 case '[': case ']':
14975 switch (*proto++) {
14977 if (contextclass++ == 0) {
14978 e = (char *) memchr(proto, ']', proto_end - proto);
14979 if (!e || e == proto)
14987 if (contextclass) {
14988 const char *p = proto;
14989 const char *const end = proto;
14991 while (*--p != '[')
14992 /* \[$] accepts any scalar lvalue */
14994 && Perl_op_lvalue_flags(aTHX_
14996 OP_READ, /* not entersub */
14999 bad_type_gv(arg, namegv, o3,
15000 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
15005 if (o3->op_type == OP_RV2GV)
15008 bad_type_gv(arg, namegv, o3, "symbol");
15011 if (o3->op_type == OP_ENTERSUB
15012 && !(o3->op_flags & OPf_STACKED))
15015 bad_type_gv(arg, namegv, o3, "subroutine");
15018 if (o3->op_type == OP_RV2SV ||
15019 o3->op_type == OP_PADSV ||
15020 o3->op_type == OP_HELEM ||
15021 o3->op_type == OP_AELEM)
15023 if (!contextclass) {
15024 /* \$ accepts any scalar lvalue */
15025 if (Perl_op_lvalue_flags(aTHX_
15027 OP_READ, /* not entersub */
15030 bad_type_gv(arg, namegv, o3, "scalar");
15034 if (o3->op_type == OP_RV2AV ||
15035 o3->op_type == OP_PADAV)
15037 o3->op_flags &=~ OPf_PARENS;
15041 bad_type_gv(arg, namegv, o3, "array");
15044 if (o3->op_type == OP_RV2HV ||
15045 o3->op_type == OP_PADHV)
15047 o3->op_flags &=~ OPf_PARENS;
15051 bad_type_gv(arg, namegv, o3, "hash");
15054 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
15056 if (contextclass && e) {
15061 default: goto oops;
15071 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
15072 SVfARG(cv_name((CV *)namegv, NULL, 0)),
15077 op_lvalue(aop, OP_ENTERSUB);
15079 aop = OpSIBLING(aop);
15081 if (aop == cvop && *proto == '_') {
15082 /* generate an access to $_ */
15083 op_sibling_splice(parent, prev, 0, newDEFSVOP());
15085 if (!optional && proto_end > proto &&
15086 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
15088 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
15089 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
15090 SVfARG(namesv)), SvUTF8(namesv));
15096 =for apidoc ck_entersub_args_proto_or_list
15098 Performs the fixup of the arguments part of an C<entersub> op tree either
15099 based on a subroutine prototype or using default list-context processing.
15100 This is the standard treatment used on a subroutine call, not marked
15101 with C<&>, where the callee can be identified at compile time.
15103 C<protosv> supplies the subroutine prototype to be applied to the call,
15104 or indicates that there is no prototype. It may be a normal scalar,
15105 in which case if it is defined then the string value will be used
15106 as a prototype, and if it is undefined then there is no prototype.
15107 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
15108 that has been cast to C<SV*>), of which the prototype will be used if it
15109 has one. The prototype (or lack thereof) supplied, in whichever form,
15110 does not need to match the actual callee referenced by the op tree.
15112 If the argument ops disagree with the prototype, for example by having
15113 an unacceptable number of arguments, a valid op tree is returned anyway.
15114 The error is reflected in the parser state, normally resulting in a single
15115 exception at the top level of parsing which covers all the compilation
15116 errors that occurred. In the error message, the callee is referred to
15117 by the name defined by the C<namegv> parameter.
15123 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
15124 GV *namegv, SV *protosv)
15126 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
15127 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
15128 return ck_entersub_args_proto(entersubop, namegv, protosv);
15130 return ck_entersub_args_list(entersubop);
15134 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
15136 IV cvflags = SvIVX(protosv);
15137 int opnum = cvflags & 0xffff;
15138 OP *aop = cUNOPx(entersubop)->op_first;
15140 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
15144 if (!OpHAS_SIBLING(aop))
15145 aop = cUNOPx(aop)->op_first;
15146 aop = OpSIBLING(aop);
15147 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
15149 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
15150 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
15151 SVfARG(namesv)), SvUTF8(namesv));
15154 op_free(entersubop);
15155 switch(cvflags >> 16) {
15156 case 'F': return newSVOP(OP_CONST, 0,
15157 newSVpv(CopFILE(PL_curcop),0));
15158 case 'L': return newSVOP(
15160 Perl_newSVpvf(aTHX_
15161 "%" IVdf, (IV)CopLINE(PL_curcop)
15164 case 'P': return newSVOP(OP_CONST, 0,
15166 ? newSVhek(HvNAME_HEK(PL_curstash))
15171 NOT_REACHED; /* NOTREACHED */
15174 OP *prev, *cvop, *first, *parent;
15177 parent = entersubop;
15178 if (!OpHAS_SIBLING(aop)) {
15180 aop = cUNOPx(aop)->op_first;
15183 first = prev = aop;
15184 aop = OpSIBLING(aop);
15185 /* find last sibling */
15187 OpHAS_SIBLING(cvop);
15188 prev = cvop, cvop = OpSIBLING(cvop))
15190 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
15191 /* Usually, OPf_SPECIAL on an op with no args means that it had
15192 * parens, but these have their own meaning for that flag: */
15193 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
15194 && opnum != OP_DELETE && opnum != OP_EXISTS)
15195 flags |= OPf_SPECIAL;
15196 /* excise cvop from end of sibling chain */
15197 op_sibling_splice(parent, prev, 1, NULL);
15199 if (aop == cvop) aop = NULL;
15201 /* detach remaining siblings from the first sibling, then
15202 * dispose of original optree */
15205 op_sibling_splice(parent, first, -1, NULL);
15206 op_free(entersubop);
15208 if (cvflags == (OP_ENTEREVAL | (1<<16)))
15209 flags |= OPpEVAL_BYTES <<8;
15211 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
15213 case OA_BASEOP_OR_UNOP:
15214 case OA_FILESTATOP:
15216 return newOP(opnum,flags); /* zero args */
15218 return newUNOP(opnum,flags,aop); /* one arg */
15219 /* too many args */
15226 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
15227 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
15228 SVfARG(namesv)), SvUTF8(namesv));
15230 nextop = OpSIBLING(aop);
15236 return opnum == OP_RUNCV
15237 ? newPVOP(OP_RUNCV,0,NULL)
15240 return op_convert_list(opnum,0,aop);
15243 NOT_REACHED; /* NOTREACHED */
15248 =for apidoc cv_get_call_checker_flags
15250 Retrieves the function that will be used to fix up a call to C<cv>.
15251 Specifically, the function is applied to an C<entersub> op tree for a
15252 subroutine call, not marked with C<&>, where the callee can be identified
15253 at compile time as C<cv>.
15255 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
15256 for it is returned in C<*ckobj_p>, and control flags are returned in
15257 C<*ckflags_p>. The function is intended to be called in this manner:
15259 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
15261 In this call, C<entersubop> is a pointer to the C<entersub> op,
15262 which may be replaced by the check function, and C<namegv> supplies
15263 the name that should be used by the check function to refer
15264 to the callee of the C<entersub> op if it needs to emit any diagnostics.
15265 It is permitted to apply the check function in non-standard situations,
15266 such as to a call to a different subroutine or to a method call.
15268 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
15269 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
15270 instead, anything that can be used as the first argument to L</cv_name>.
15271 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
15272 check function requires C<namegv> to be a genuine GV.
15274 By default, the check function is
15275 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
15276 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
15277 flag is clear. This implements standard prototype processing. It can
15278 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
15280 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
15281 indicates that the caller only knows about the genuine GV version of
15282 C<namegv>, and accordingly the corresponding bit will always be set in
15283 C<*ckflags_p>, regardless of the check function's recorded requirements.
15284 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
15285 indicates the caller knows about the possibility of passing something
15286 other than a GV as C<namegv>, and accordingly the corresponding bit may
15287 be either set or clear in C<*ckflags_p>, indicating the check function's
15288 recorded requirements.
15290 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
15291 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
15292 (for which see above). All other bits should be clear.
15294 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
15296 =for apidoc cv_get_call_checker
15298 The original form of L</cv_get_call_checker_flags>, which does not return
15299 checker flags. When using a checker function returned by this function,
15300 it is only safe to call it with a genuine GV as its C<namegv> argument.
15306 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
15307 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
15310 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
15311 PERL_UNUSED_CONTEXT;
15312 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
15314 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
15315 *ckobj_p = callmg->mg_obj;
15316 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
15318 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
15319 *ckobj_p = (SV*)cv;
15320 *ckflags_p = gflags & MGf_REQUIRE_GV;
15325 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
15328 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
15329 PERL_UNUSED_CONTEXT;
15330 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
15335 =for apidoc cv_set_call_checker_flags
15337 Sets the function that will be used to fix up a call to C<cv>.
15338 Specifically, the function is applied to an C<entersub> op tree for a
15339 subroutine call, not marked with C<&>, where the callee can be identified
15340 at compile time as C<cv>.
15342 The C-level function pointer is supplied in C<ckfun>, an SV argument for
15343 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
15344 The function should be defined like this:
15346 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
15348 It is intended to be called in this manner:
15350 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
15352 In this call, C<entersubop> is a pointer to the C<entersub> op,
15353 which may be replaced by the check function, and C<namegv> supplies
15354 the name that should be used by the check function to refer
15355 to the callee of the C<entersub> op if it needs to emit any diagnostics.
15356 It is permitted to apply the check function in non-standard situations,
15357 such as to a call to a different subroutine or to a method call.
15359 C<namegv> may not actually be a GV. For efficiency, perl may pass a
15360 CV or other SV instead. Whatever is passed can be used as the first
15361 argument to L</cv_name>. You can force perl to pass a GV by including
15362 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
15364 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
15365 bit currently has a defined meaning (for which see above). All other
15366 bits should be clear.
15368 The current setting for a particular CV can be retrieved by
15369 L</cv_get_call_checker_flags>.
15371 =for apidoc cv_set_call_checker
15373 The original form of L</cv_set_call_checker_flags>, which passes it the
15374 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
15375 of that flag setting is that the check function is guaranteed to get a
15376 genuine GV as its C<namegv> argument.
15382 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
15384 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
15385 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
15389 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
15390 SV *ckobj, U32 ckflags)
15392 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
15393 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
15394 if (SvMAGICAL((SV*)cv))
15395 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
15398 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
15399 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
15401 if (callmg->mg_flags & MGf_REFCOUNTED) {
15402 SvREFCNT_dec(callmg->mg_obj);
15403 callmg->mg_flags &= ~MGf_REFCOUNTED;
15405 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
15406 callmg->mg_obj = ckobj;
15407 if (ckobj != (SV*)cv) {
15408 SvREFCNT_inc_simple_void_NN(ckobj);
15409 callmg->mg_flags |= MGf_REFCOUNTED;
15411 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
15412 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
15417 S_entersub_alloc_targ(pTHX_ OP * const o)
15419 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
15420 o->op_private |= OPpENTERSUB_HASTARG;
15424 Perl_ck_subr(pTHX_ OP *o)
15429 SV **const_class = NULL;
15431 PERL_ARGS_ASSERT_CK_SUBR;
15433 aop = cUNOPx(o)->op_first;
15434 if (!OpHAS_SIBLING(aop))
15435 aop = cUNOPx(aop)->op_first;
15436 aop = OpSIBLING(aop);
15437 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
15438 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
15439 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
15441 o->op_private &= ~1;
15442 o->op_private |= (PL_hints & HINT_STRICT_REFS);
15443 if (PERLDB_SUB && PL_curstash != PL_debstash)
15444 o->op_private |= OPpENTERSUB_DB;
15445 switch (cvop->op_type) {
15447 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
15451 case OP_METHOD_NAMED:
15452 case OP_METHOD_SUPER:
15453 case OP_METHOD_REDIR:
15454 case OP_METHOD_REDIR_SUPER:
15455 o->op_flags |= OPf_REF;
15456 if (aop->op_type == OP_CONST) {
15457 aop->op_private &= ~OPpCONST_STRICT;
15458 const_class = &cSVOPx(aop)->op_sv;
15460 else if (aop->op_type == OP_LIST) {
15461 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
15462 if (sib && sib->op_type == OP_CONST) {
15463 sib->op_private &= ~OPpCONST_STRICT;
15464 const_class = &cSVOPx(sib)->op_sv;
15467 /* make class name a shared cow string to speedup method calls */
15468 /* constant string might be replaced with object, f.e. bigint */
15469 if (const_class && SvPOK(*const_class)) {
15471 const char* str = SvPV(*const_class, len);
15473 SV* const shared = newSVpvn_share(
15474 str, SvUTF8(*const_class)
15475 ? -(SSize_t)len : (SSize_t)len,
15478 if (SvREADONLY(*const_class))
15479 SvREADONLY_on(shared);
15480 SvREFCNT_dec(*const_class);
15481 *const_class = shared;
15488 S_entersub_alloc_targ(aTHX_ o);
15489 return ck_entersub_args_list(o);
15491 Perl_call_checker ckfun;
15494 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
15495 if (CvISXSUB(cv) || !CvROOT(cv))
15496 S_entersub_alloc_targ(aTHX_ o);
15498 /* The original call checker API guarantees that a GV will
15499 be provided with the right name. So, if the old API was
15500 used (or the REQUIRE_GV flag was passed), we have to reify
15501 the CV’s GV, unless this is an anonymous sub. This is not
15502 ideal for lexical subs, as its stringification will include
15503 the package. But it is the best we can do. */
15504 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
15505 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
15508 else namegv = MUTABLE_GV(cv);
15509 /* After a syntax error in a lexical sub, the cv that
15510 rv2cv_op_cv returns may be a nameless stub. */
15511 if (!namegv) return ck_entersub_args_list(o);
15514 return ckfun(aTHX_ o, namegv, ckobj);
15519 Perl_ck_svconst(pTHX_ OP *o)
15521 SV * const sv = cSVOPo->op_sv;
15522 PERL_ARGS_ASSERT_CK_SVCONST;
15523 PERL_UNUSED_CONTEXT;
15524 #ifdef PERL_COPY_ON_WRITE
15525 /* Since the read-only flag may be used to protect a string buffer, we
15526 cannot do copy-on-write with existing read-only scalars that are not
15527 already copy-on-write scalars. To allow $_ = "hello" to do COW with
15528 that constant, mark the constant as COWable here, if it is not
15529 already read-only. */
15530 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
15533 # ifdef PERL_DEBUG_READONLY_COW
15543 Perl_ck_trunc(pTHX_ OP *o)
15545 PERL_ARGS_ASSERT_CK_TRUNC;
15547 if (o->op_flags & OPf_KIDS) {
15548 SVOP *kid = (SVOP*)cUNOPo->op_first;
15550 if (kid->op_type == OP_NULL)
15551 kid = (SVOP*)OpSIBLING(kid);
15552 if (kid && kid->op_type == OP_CONST &&
15553 (kid->op_private & OPpCONST_BARE) &&
15556 o->op_flags |= OPf_SPECIAL;
15557 kid->op_private &= ~OPpCONST_STRICT;
15558 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
15559 no_bareword_filehandle(SvPVX(cSVOPx_sv(kid)));
15567 Perl_ck_substr(pTHX_ OP *o)
15569 PERL_ARGS_ASSERT_CK_SUBSTR;
15572 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15573 OP *kid = cLISTOPo->op_first;
15575 if (kid->op_type == OP_NULL)
15576 kid = OpSIBLING(kid);
15578 /* Historically, substr(delete $foo{bar},...) has been allowed
15579 with 4-arg substr. Keep it working by applying entersub
15581 op_lvalue(kid, OP_ENTERSUB);
15588 Perl_ck_tell(pTHX_ OP *o)
15590 PERL_ARGS_ASSERT_CK_TELL;
15592 if (o->op_flags & OPf_KIDS) {
15593 OP *kid = cLISTOPo->op_first;
15594 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15595 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15600 PERL_STATIC_INLINE OP *
15601 S_last_non_null_kid(OP *o) {
15603 if (cUNOPo->op_flags & OPf_KIDS) {
15604 OP *k = cLISTOPo->op_first;
15606 if (k->op_type != OP_NULL) {
15617 Perl_ck_each(pTHX_ OP *o)
15619 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15620 const unsigned orig_type = o->op_type;
15622 PERL_ARGS_ASSERT_CK_EACH;
15625 switch (kid->op_type) {
15630 /* Catch out an anonhash here, since the behaviour might be
15633 * The typical tree is:
15640 * If the contents of the block is more complex you might get:
15648 * Similarly for the anonlist version below.
15650 if (orig_type == OP_EACH &&
15651 ckWARN(WARN_SYNTAX) &&
15652 (cUNOPx(kid)->op_flags & OPf_KIDS) &&
15653 ( cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
15654 cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
15655 (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
15656 /* look for last non-null kid, since we might have:
15657 each %{ some code ; +{ anon hash } }
15659 OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
15660 if (k && k->op_type == OP_ANONHASH) {
15661 /* diag_listed_as: each on anonymous %s will always start from the beginning */
15662 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous hash will always start from the beginning");
15667 if (orig_type == OP_EACH &&
15668 ckWARN(WARN_SYNTAX) &&
15669 (cUNOPx(kid)->op_flags & OPf_KIDS) &&
15670 (cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
15671 cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
15672 (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
15673 OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
15674 if (k && k->op_type == OP_ANONLIST) {
15675 /* diag_listed_as: each on anonymous %s will always start from the beginning */
15676 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous array will always start from the beginning");
15681 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15682 : orig_type == OP_KEYS ? OP_AKEYS
15686 if (kid->op_private == OPpCONST_BARE
15687 || !SvROK(cSVOPx_sv(kid))
15688 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15689 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
15694 qerror(Perl_mess(aTHX_
15695 "Experimental %s on scalar is now forbidden",
15696 PL_op_desc[orig_type]));
15698 bad_type_pv(1, "hash or array", o, kid);
15706 Perl_ck_length(pTHX_ OP *o)
15708 PERL_ARGS_ASSERT_CK_LENGTH;
15712 if (ckWARN(WARN_SYNTAX)) {
15713 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15717 const bool hash = kid->op_type == OP_PADHV
15718 || kid->op_type == OP_RV2HV;
15719 switch (kid->op_type) {
15724 name = S_op_varname(aTHX_ kid);
15730 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15731 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15733 SVfARG(name), hash ? "keys " : "", SVfARG(name)
15736 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15737 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15738 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15740 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15741 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15742 "length() used on @array (did you mean \"scalar(@array)\"?)");
15751 Perl_ck_isa(pTHX_ OP *o)
15753 OP *classop = cBINOPo->op_last;
15755 PERL_ARGS_ASSERT_CK_ISA;
15757 /* Convert barename into PV */
15758 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15759 /* TODO: Optionally convert package to raw HV here */
15760 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15768 ---------------------------------------------------------
15770 Common vars in list assignment
15772 There now follows some enums and static functions for detecting
15773 common variables in list assignments. Here is a little essay I wrote
15774 for myself when trying to get my head around this. DAPM.
15778 First some random observations:
15780 * If a lexical var is an alias of something else, e.g.
15781 for my $x ($lex, $pkg, $a[0]) {...}
15782 then the act of aliasing will increase the reference count of the SV
15784 * If a package var is an alias of something else, it may still have a
15785 reference count of 1, depending on how the alias was created, e.g.
15786 in *a = *b, $a may have a refcount of 1 since the GP is shared
15787 with a single GvSV pointer to the SV. So If it's an alias of another
15788 package var, then RC may be 1; if it's an alias of another scalar, e.g.
15789 a lexical var or an array element, then it will have RC > 1.
15791 * There are many ways to create a package alias; ultimately, XS code
15792 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
15793 run-time tracing mechanisms are unlikely to be able to catch all cases.
15795 * When the LHS is all my declarations, the same vars can't appear directly
15796 on the RHS, but they can indirectly via closures, aliasing and lvalue
15797 subs. But those techniques all involve an increase in the lexical
15798 scalar's ref count.
15800 * When the LHS is all lexical vars (but not necessarily my declarations),
15801 it is possible for the same lexicals to appear directly on the RHS, and
15802 without an increased ref count, since the stack isn't refcounted.
15803 This case can be detected at compile time by scanning for common lex
15804 vars with PL_generation.
15806 * lvalue subs defeat common var detection, but they do at least
15807 return vars with a temporary ref count increment. Also, you can't
15808 tell at compile time whether a sub call is lvalue.
15813 A: There are a few circumstances where there definitely can't be any
15816 LHS empty: () = (...);
15817 RHS empty: (....) = ();
15818 RHS contains only constants or other 'can't possibly be shared'
15819 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
15820 i.e. they only contain ops not marked as dangerous, whose children
15821 are also not dangerous;
15823 LHS contains a single scalar element: e.g. ($x) = (....); because
15824 after $x has been modified, it won't be used again on the RHS;
15825 RHS contains a single element with no aggregate on LHS: e.g.
15826 ($a,$b,$c) = ($x); again, once $a has been modified, its value
15827 won't be used again.
15829 B: If LHS are all 'my' lexical var declarations (or safe ops, which
15832 my ($a, $b, @c) = ...;
15834 Due to closure and goto tricks, these vars may already have content.
15835 For the same reason, an element on the RHS may be a lexical or package
15836 alias of one of the vars on the left, or share common elements, for
15839 my ($x,$y) = f(); # $x and $y on both sides
15840 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
15845 my @a = @$ra; # elements of @a on both sides
15846 sub f { @a = 1..4; \@a }
15849 First, just consider scalar vars on LHS:
15851 RHS is safe only if (A), or in addition,
15852 * contains only lexical *scalar* vars, where neither side's
15853 lexicals have been flagged as aliases
15855 If RHS is not safe, then it's always legal to check LHS vars for
15856 RC==1, since the only RHS aliases will always be associated
15859 Note that in particular, RHS is not safe if:
15861 * it contains package scalar vars; e.g.:
15864 my ($x, $y) = (2, $x_alias);
15865 sub f { $x = 1; *x_alias = \$x; }
15867 * It contains other general elements, such as flattened or
15868 * spliced or single array or hash elements, e.g.
15871 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
15875 use feature 'refaliasing';
15876 \($a[0], $a[1]) = \($y,$x);
15879 It doesn't matter if the array/hash is lexical or package.
15881 * it contains a function call that happens to be an lvalue
15882 sub which returns one or more of the above, e.g.
15893 (so a sub call on the RHS should be treated the same
15894 as having a package var on the RHS).
15896 * any other "dangerous" thing, such an op or built-in that
15897 returns one of the above, e.g. pp_preinc
15900 If RHS is not safe, what we can do however is at compile time flag
15901 that the LHS are all my declarations, and at run time check whether
15902 all the LHS have RC == 1, and if so skip the full scan.
15904 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
15906 Here the issue is whether there can be elements of @a on the RHS
15907 which will get prematurely freed when @a is cleared prior to
15908 assignment. This is only a problem if the aliasing mechanism
15909 is one which doesn't increase the refcount - only if RC == 1
15910 will the RHS element be prematurely freed.
15912 Because the array/hash is being INTROed, it or its elements
15913 can't directly appear on the RHS:
15915 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
15917 but can indirectly, e.g.:
15921 sub f { @a = 1..3; \@a }
15923 So if the RHS isn't safe as defined by (A), we must always
15924 mortalise and bump the ref count of any remaining RHS elements
15925 when assigning to a non-empty LHS aggregate.
15927 Lexical scalars on the RHS aren't safe if they've been involved in
15930 use feature 'refaliasing';
15933 \(my $lex) = \$pkg;
15934 my @a = ($lex,3); # equivalent to ($a[0],3)
15941 Similarly with lexical arrays and hashes on the RHS:
15955 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
15956 my $a; ($a, my $b) = (....);
15958 The difference between (B) and (C) is that it is now physically
15959 possible for the LHS vars to appear on the RHS too, where they
15960 are not reference counted; but in this case, the compile-time
15961 PL_generation sweep will detect such common vars.
15963 So the rules for (C) differ from (B) in that if common vars are
15964 detected, the runtime "test RC==1" optimisation can no longer be used,
15965 and a full mark and sweep is required
15967 D: As (C), but in addition the LHS may contain package vars.
15969 Since package vars can be aliased without a corresponding refcount
15970 increase, all bets are off. It's only safe if (A). E.g.
15972 my ($x, $y) = (1,2);
15974 for $x_alias ($x) {
15975 ($x_alias, $y) = (3, $x); # whoops
15978 Ditto for LHS aggregate package vars.
15980 E: Any other dangerous ops on LHS, e.g.
15981 (f(), $a[0], @$r) = (...);
15983 this is similar to (E) in that all bets are off. In addition, it's
15984 impossible to determine at compile time whether the LHS
15985 contains a scalar or an aggregate, e.g.
15987 sub f : lvalue { @a }
15990 * ---------------------------------------------------------
15994 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
15995 * that at least one of the things flagged was seen.
15999 AAS_MY_SCALAR = 0x001, /* my $scalar */
16000 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
16001 AAS_LEX_SCALAR = 0x004, /* $lexical */
16002 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
16003 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
16004 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
16005 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
16006 AAS_DANGEROUS = 0x080, /* an op (other than the above)
16007 that's flagged OA_DANGEROUS */
16008 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
16009 not in any of the categories above */
16010 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
16015 /* helper function for S_aassign_scan().
16016 * check a PAD-related op for commonality and/or set its generation number.
16017 * Returns a boolean indicating whether its shared */
16020 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
16022 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
16023 /* lexical used in aliasing */
16027 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
16029 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
16036 Helper function for OPpASSIGN_COMMON* detection in rpeep().
16037 It scans the left or right hand subtree of the aassign op, and returns a
16038 set of flags indicating what sorts of things it found there.
16039 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
16040 set PL_generation on lexical vars; if the latter, we see if
16041 PL_generation matches.
16042 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
16043 This fn will increment it by the number seen. It's not intended to
16044 be an accurate count (especially as many ops can push a variable
16045 number of SVs onto the stack); rather it's used as to test whether there
16046 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
16050 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
16053 OP *effective_top_op = o;
16057 bool top = o == effective_top_op;
16059 OP* next_kid = NULL;
16061 /* first, look for a solitary @_ on the RHS */
16064 && (o->op_flags & OPf_KIDS)
16065 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
16067 OP *kid = cUNOPo->op_first;
16068 if ( ( kid->op_type == OP_PUSHMARK
16069 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
16070 && ((kid = OpSIBLING(kid)))
16071 && !OpHAS_SIBLING(kid)
16072 && kid->op_type == OP_RV2AV
16073 && !(kid->op_flags & OPf_REF)
16074 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
16075 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
16076 && ((kid = cUNOPx(kid)->op_first))
16077 && kid->op_type == OP_GV
16078 && cGVOPx_gv(kid) == PL_defgv
16083 switch (o->op_type) {
16086 all_flags |= AAS_PKG_SCALAR;
16092 /* if !top, could be e.g. @a[0,1] */
16093 all_flags |= (top && (o->op_flags & OPf_REF))
16094 ? ((o->op_private & OPpLVAL_INTRO)
16095 ? AAS_MY_AGG : AAS_LEX_AGG)
16101 int comm = S_aassign_padcheck(aTHX_ o, rhs)
16102 ? AAS_LEX_SCALAR_COMM : 0;
16104 all_flags |= (o->op_private & OPpLVAL_INTRO)
16105 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
16113 if (cUNOPx(o)->op_first->op_type != OP_GV)
16114 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
16116 /* if !top, could be e.g. @a[0,1] */
16117 else if (top && (o->op_flags & OPf_REF))
16118 all_flags |= AAS_PKG_AGG;
16120 all_flags |= AAS_DANGEROUS;
16125 if (cUNOPx(o)->op_first->op_type != OP_GV) {
16127 all_flags |= AAS_DANGEROUS; /* ${expr} */
16130 all_flags |= AAS_PKG_SCALAR; /* $pkg */
16134 if (o->op_private & OPpSPLIT_ASSIGN) {
16135 /* the assign in @a = split() has been optimised away
16136 * and the @a attached directly to the split op
16137 * Treat the array as appearing on the RHS, i.e.
16138 * ... = (@a = split)
16143 if (o->op_flags & OPf_STACKED) {
16144 /* @{expr} = split() - the array expression is tacked
16145 * on as an extra child to split - process kid */
16146 next_kid = cLISTOPo->op_last;
16150 /* ... else array is directly attached to split op */
16152 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
16153 ? ((o->op_private & OPpLVAL_INTRO)
16154 ? AAS_MY_AGG : AAS_LEX_AGG)
16159 /* other args of split can't be returned */
16160 all_flags |= AAS_SAFE_SCALAR;
16164 /* undef on LHS following a var is significant, e.g.
16166 * @a = (($x, undef) = (2 => $x));
16167 * # @a shoul be (2,1) not (2,2)
16169 * undef on RHS counts as a scalar:
16170 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
16172 if ((!rhs && *scalars_p) || rhs)
16174 flags = AAS_SAFE_SCALAR;
16179 /* these are all no-ops; they don't push a potentially common SV
16180 * onto the stack, so they are neither AAS_DANGEROUS nor
16181 * AAS_SAFE_SCALAR */
16184 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
16189 /* these do nothing, but may have children */
16193 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
16195 flags = AAS_DANGEROUS;
16199 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
16200 && (o->op_private & OPpTARGET_MY))
16203 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
16204 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
16208 /* if its an unrecognised, non-dangerous op, assume that it
16209 * is the cause of at least one safe scalar */
16211 flags = AAS_SAFE_SCALAR;
16215 all_flags |= flags;
16217 /* by default, process all kids next
16218 * XXX this assumes that all other ops are "transparent" - i.e. that
16219 * they can return some of their children. While this true for e.g.
16220 * sort and grep, it's not true for e.g. map. We really need a
16221 * 'transparent' flag added to regen/opcodes
16223 if (o->op_flags & OPf_KIDS) {
16224 next_kid = cUNOPo->op_first;
16225 /* these ops do nothing but may have children; but their
16226 * children should also be treated as top-level */
16227 if ( o == effective_top_op
16228 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
16230 effective_top_op = next_kid;
16234 /* If next_kid is set, someone in the code above wanted us to process
16235 * that kid and all its remaining siblings. Otherwise, work our way
16236 * back up the tree */
16238 while (!next_kid) {
16240 return all_flags; /* at top; no parents/siblings to try */
16241 if (OpHAS_SIBLING(o)) {
16242 next_kid = o->op_sibparent;
16243 if (o == effective_top_op)
16244 effective_top_op = next_kid;
16247 if (o == effective_top_op)
16248 effective_top_op = o->op_sibparent;
16249 o = o->op_sibparent; /* try parent's next sibling */
16258 /* Check for in place reverse and sort assignments like "@a = reverse @a"
16259 and modify the optree to make them work inplace */
16262 S_inplace_aassign(pTHX_ OP *o) {
16264 OP *modop, *modop_pushmark;
16266 OP *oleft, *oleft_pushmark;
16268 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
16270 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
16272 assert(cUNOPo->op_first->op_type == OP_NULL);
16273 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
16274 assert(modop_pushmark->op_type == OP_PUSHMARK);
16275 modop = OpSIBLING(modop_pushmark);
16277 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
16280 /* no other operation except sort/reverse */
16281 if (OpHAS_SIBLING(modop))
16284 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
16285 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
16287 if (modop->op_flags & OPf_STACKED) {
16288 /* skip sort subroutine/block */
16289 assert(oright->op_type == OP_NULL);
16290 oright = OpSIBLING(oright);
16293 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
16294 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
16295 assert(oleft_pushmark->op_type == OP_PUSHMARK);
16296 oleft = OpSIBLING(oleft_pushmark);
16298 /* Check the lhs is an array */
16300 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
16301 || OpHAS_SIBLING(oleft)
16302 || (oleft->op_private & OPpLVAL_INTRO)
16306 /* Only one thing on the rhs */
16307 if (OpHAS_SIBLING(oright))
16310 /* check the array is the same on both sides */
16311 if (oleft->op_type == OP_RV2AV) {
16312 if (oright->op_type != OP_RV2AV
16313 || !cUNOPx(oright)->op_first
16314 || cUNOPx(oright)->op_first->op_type != OP_GV
16315 || cUNOPx(oleft )->op_first->op_type != OP_GV
16316 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
16317 cGVOPx_gv(cUNOPx(oright)->op_first)
16321 else if (oright->op_type != OP_PADAV
16322 || oright->op_targ != oleft->op_targ
16326 /* This actually is an inplace assignment */
16328 modop->op_private |= OPpSORT_INPLACE;
16330 /* transfer MODishness etc from LHS arg to RHS arg */
16331 oright->op_flags = oleft->op_flags;
16333 /* remove the aassign op and the lhs */
16335 op_null(oleft_pushmark);
16336 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
16337 op_null(cUNOPx(oleft)->op_first);
16343 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
16344 * that potentially represent a series of one or more aggregate derefs
16345 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
16346 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
16347 * additional ops left in too).
16349 * The caller will have already verified that the first few ops in the
16350 * chain following 'start' indicate a multideref candidate, and will have
16351 * set 'orig_o' to the point further on in the chain where the first index
16352 * expression (if any) begins. 'orig_action' specifies what type of
16353 * beginning has already been determined by the ops between start..orig_o
16354 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
16356 * 'hints' contains any hints flags that need adding (currently just
16357 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
16361 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
16364 UNOP_AUX_item *arg_buf = NULL;
16365 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
16366 int index_skip = -1; /* don't output index arg on this action */
16368 /* similar to regex compiling, do two passes; the first pass
16369 * determines whether the op chain is convertible and calculates the
16370 * buffer size; the second pass populates the buffer and makes any
16371 * changes necessary to ops (such as moving consts to the pad on
16372 * threaded builds).
16374 * NB: for things like Coverity, note that both passes take the same
16375 * path through the logic tree (except for 'if (pass)' bits), since
16376 * both passes are following the same op_next chain; and in
16377 * particular, if it would return early on the second pass, it would
16378 * already have returned early on the first pass.
16380 for (pass = 0; pass < 2; pass++) {
16382 UV action = orig_action;
16383 OP *first_elem_op = NULL; /* first seen aelem/helem */
16384 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
16385 int action_count = 0; /* number of actions seen so far */
16386 int action_ix = 0; /* action_count % (actions per IV) */
16387 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
16388 bool is_last = FALSE; /* no more derefs to follow */
16389 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
16390 UV action_word = 0; /* all actions so far */
16391 UNOP_AUX_item *arg = arg_buf;
16392 UNOP_AUX_item *action_ptr = arg_buf;
16394 arg++; /* reserve slot for first action word */
16397 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
16398 case MDEREF_HV_gvhv_helem:
16399 next_is_hash = TRUE;
16401 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
16402 case MDEREF_AV_gvav_aelem:
16404 #ifdef USE_ITHREADS
16405 arg->pad_offset = cPADOPx(start)->op_padix;
16406 /* stop it being swiped when nulled */
16407 cPADOPx(start)->op_padix = 0;
16409 arg->sv = cSVOPx(start)->op_sv;
16410 cSVOPx(start)->op_sv = NULL;
16416 case MDEREF_HV_padhv_helem:
16417 case MDEREF_HV_padsv_vivify_rv2hv_helem:
16418 next_is_hash = TRUE;
16420 case MDEREF_AV_padav_aelem:
16421 case MDEREF_AV_padsv_vivify_rv2av_aelem:
16423 arg->pad_offset = start->op_targ;
16424 /* we skip setting op_targ = 0 for now, since the intact
16425 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
16426 reset_start_targ = TRUE;
16431 case MDEREF_HV_pop_rv2hv_helem:
16432 next_is_hash = TRUE;
16434 case MDEREF_AV_pop_rv2av_aelem:
16438 NOT_REACHED; /* NOTREACHED */
16443 /* look for another (rv2av/hv; get index;
16444 * aelem/helem/exists/delele) sequence */
16449 UV index_type = MDEREF_INDEX_none;
16451 if (action_count) {
16452 /* if this is not the first lookup, consume the rv2av/hv */
16454 /* for N levels of aggregate lookup, we normally expect
16455 * that the first N-1 [ah]elem ops will be flagged as
16456 * /DEREF (so they autovivifiy if necessary), and the last
16457 * lookup op not to be.
16458 * For other things (like @{$h{k1}{k2}}) extra scope or
16459 * leave ops can appear, so abandon the effort in that
16461 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
16464 /* rv2av or rv2hv sKR/1 */
16466 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16467 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16468 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16471 /* at this point, we wouldn't expect any of these
16472 * possible private flags:
16473 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
16474 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
16476 ASSUME(!(o->op_private &
16477 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
16479 hints = (o->op_private & OPpHINT_STRICT_REFS);
16481 /* make sure the type of the previous /DEREF matches the
16482 * type of the next lookup */
16483 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
16486 action = next_is_hash
16487 ? MDEREF_HV_vivify_rv2hv_helem
16488 : MDEREF_AV_vivify_rv2av_aelem;
16492 /* if this is the second pass, and we're at the depth where
16493 * previously we encountered a non-simple index expression,
16494 * stop processing the index at this point */
16495 if (action_count != index_skip) {
16497 /* look for one or more simple ops that return an array
16498 * index or hash key */
16500 switch (o->op_type) {
16502 /* it may be a lexical var index */
16503 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
16504 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16505 ASSUME(!(o->op_private &
16506 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16508 if ( OP_GIMME(o,0) == G_SCALAR
16509 && !(o->op_flags & (OPf_REF|OPf_MOD))
16510 && o->op_private == 0)
16513 arg->pad_offset = o->op_targ;
16515 index_type = MDEREF_INDEX_padsv;
16521 if (next_is_hash) {
16522 /* it's a constant hash index */
16523 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
16524 /* "use constant foo => FOO; $h{+foo}" for
16525 * some weird FOO, can leave you with constants
16526 * that aren't simple strings. It's not worth
16527 * the extra hassle for those edge cases */
16532 OP * helem_op = o->op_next;
16534 ASSUME( helem_op->op_type == OP_HELEM
16535 || helem_op->op_type == OP_NULL
16537 if (helem_op->op_type == OP_HELEM) {
16538 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
16539 if ( helem_op->op_private & OPpLVAL_INTRO
16540 || rop->op_type != OP_RV2HV
16544 /* on first pass just check; on second pass
16546 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
16551 #ifdef USE_ITHREADS
16552 /* Relocate sv to the pad for thread safety */
16553 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
16554 arg->pad_offset = o->op_targ;
16557 arg->sv = cSVOPx_sv(o);
16562 /* it's a constant array index */
16564 SV *ix_sv = cSVOPo->op_sv;
16569 if ( action_count == 0
16572 && ( action == MDEREF_AV_padav_aelem
16573 || action == MDEREF_AV_gvav_aelem)
16575 maybe_aelemfast = TRUE;
16579 SvREFCNT_dec_NN(cSVOPo->op_sv);
16583 /* we've taken ownership of the SV */
16584 cSVOPo->op_sv = NULL;
16586 index_type = MDEREF_INDEX_const;
16591 /* it may be a package var index */
16593 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
16594 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
16595 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
16596 || o->op_private != 0
16601 if (kid->op_type != OP_RV2SV)
16604 ASSUME(!(kid->op_flags &
16605 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
16606 |OPf_SPECIAL|OPf_PARENS)));
16607 ASSUME(!(kid->op_private &
16609 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
16610 |OPpDEREF|OPpLVAL_INTRO)));
16611 if( (kid->op_flags &~ OPf_PARENS)
16612 != (OPf_WANT_SCALAR|OPf_KIDS)
16613 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
16618 #ifdef USE_ITHREADS
16619 arg->pad_offset = cPADOPx(o)->op_padix;
16620 /* stop it being swiped when nulled */
16621 cPADOPx(o)->op_padix = 0;
16623 arg->sv = cSVOPx(o)->op_sv;
16624 cSVOPo->op_sv = NULL;
16628 index_type = MDEREF_INDEX_gvsv;
16633 } /* action_count != index_skip */
16635 action |= index_type;
16638 /* at this point we have either:
16639 * * detected what looks like a simple index expression,
16640 * and expect the next op to be an [ah]elem, or
16641 * an nulled [ah]elem followed by a delete or exists;
16642 * * found a more complex expression, so something other
16643 * than the above follows.
16646 /* possibly an optimised away [ah]elem (where op_next is
16647 * exists or delete) */
16648 if (o->op_type == OP_NULL)
16651 /* at this point we're looking for an OP_AELEM, OP_HELEM,
16652 * OP_EXISTS or OP_DELETE */
16654 /* if a custom array/hash access checker is in scope,
16655 * abandon optimisation attempt */
16656 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16657 && PL_check[o->op_type] != Perl_ck_null)
16659 /* similarly for customised exists and delete */
16660 if ( (o->op_type == OP_EXISTS)
16661 && PL_check[o->op_type] != Perl_ck_exists)
16663 if ( (o->op_type == OP_DELETE)
16664 && PL_check[o->op_type] != Perl_ck_delete)
16667 if ( o->op_type != OP_AELEM
16668 || (o->op_private &
16669 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
16671 maybe_aelemfast = FALSE;
16673 /* look for aelem/helem/exists/delete. If it's not the last elem
16674 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
16675 * flags; if it's the last, then it mustn't have
16676 * OPpDEREF_AV/HV, but may have lots of other flags, like
16677 * OPpLVAL_INTRO etc
16680 if ( index_type == MDEREF_INDEX_none
16681 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
16682 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
16686 /* we have aelem/helem/exists/delete with valid simple index */
16688 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16689 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
16690 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
16692 /* This doesn't make much sense but is legal:
16693 * @{ local $x[0][0] } = 1
16694 * Since scope exit will undo the autovivification,
16695 * don't bother in the first place. The OP_LEAVE
16696 * assertion is in case there are other cases of both
16697 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
16698 * exit that would undo the local - in which case this
16699 * block of code would need rethinking.
16701 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
16703 OP *n = o->op_next;
16704 while (n && ( n->op_type == OP_NULL
16705 || n->op_type == OP_LIST
16706 || n->op_type == OP_SCALAR))
16708 assert(n && n->op_type == OP_LEAVE);
16710 o->op_private &= ~OPpDEREF;
16715 ASSUME(!(o->op_flags &
16716 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
16717 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
16719 ok = (o->op_flags &~ OPf_PARENS)
16720 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
16721 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
16723 else if (o->op_type == OP_EXISTS) {
16724 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16725 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16726 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
16727 ok = !(o->op_private & ~OPpARG1_MASK);
16729 else if (o->op_type == OP_DELETE) {
16730 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16731 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16732 ASSUME(!(o->op_private &
16733 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
16734 /* don't handle slices or 'local delete'; the latter
16735 * is fairly rare, and has a complex runtime */
16736 ok = !(o->op_private & ~OPpARG1_MASK);
16737 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
16738 /* skip handling run-tome error */
16739 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
16742 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
16743 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
16744 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
16745 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
16746 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
16747 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
16752 if (!first_elem_op)
16756 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
16761 action |= MDEREF_FLAG_last;
16765 /* at this point we have something that started
16766 * promisingly enough (with rv2av or whatever), but failed
16767 * to find a simple index followed by an
16768 * aelem/helem/exists/delete. If this is the first action,
16769 * give up; but if we've already seen at least one
16770 * aelem/helem, then keep them and add a new action with
16771 * MDEREF_INDEX_none, which causes it to do the vivify
16772 * from the end of the previous lookup, and do the deref,
16773 * but stop at that point. So $a[0][expr] will do one
16774 * av_fetch, vivify and deref, then continue executing at
16779 index_skip = action_count;
16780 action |= MDEREF_FLAG_last;
16781 if (index_type != MDEREF_INDEX_none)
16785 action_word |= (action << (action_ix * MDEREF_SHIFT));
16788 /* if there's no space for the next action, reserve a new slot
16789 * for it *before* we start adding args for that action */
16790 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
16792 action_ptr->uv = action_word;
16798 } /* while !is_last */
16803 /* slot reserved for next action word not now needed */
16806 action_ptr->uv = action_word;
16812 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
16813 if (index_skip == -1) {
16814 mderef->op_flags = o->op_flags
16815 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
16816 if (o->op_type == OP_EXISTS)
16817 mderef->op_private = OPpMULTIDEREF_EXISTS;
16818 else if (o->op_type == OP_DELETE)
16819 mderef->op_private = OPpMULTIDEREF_DELETE;
16821 mderef->op_private = o->op_private
16822 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
16824 /* accumulate strictness from every level (although I don't think
16825 * they can actually vary) */
16826 mderef->op_private |= hints;
16828 /* integrate the new multideref op into the optree and the
16831 * In general an op like aelem or helem has two child
16832 * sub-trees: the aggregate expression (a_expr) and the
16833 * index expression (i_expr):
16839 * The a_expr returns an AV or HV, while the i-expr returns an
16840 * index. In general a multideref replaces most or all of a
16841 * multi-level tree, e.g.
16857 * With multideref, all the i_exprs will be simple vars or
16858 * constants, except that i_expr1 may be arbitrary in the case
16859 * of MDEREF_INDEX_none.
16861 * The bottom-most a_expr will be either:
16862 * 1) a simple var (so padXv or gv+rv2Xv);
16863 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
16864 * so a simple var with an extra rv2Xv;
16865 * 3) or an arbitrary expression.
16867 * 'start', the first op in the execution chain, will point to
16868 * 1),2): the padXv or gv op;
16869 * 3): the rv2Xv which forms the last op in the a_expr
16870 * execution chain, and the top-most op in the a_expr
16873 * For all cases, the 'start' node is no longer required,
16874 * but we can't free it since one or more external nodes
16875 * may point to it. E.g. consider
16876 * $h{foo} = $a ? $b : $c
16877 * Here, both the op_next and op_other branches of the
16878 * cond_expr point to the gv[*h] of the hash expression, so
16879 * we can't free the 'start' op.
16881 * For expr->[...], we need to save the subtree containing the
16882 * expression; for the other cases, we just need to save the
16884 * So in all cases, we null the start op and keep it around by
16885 * making it the child of the multideref op; for the expr->
16886 * case, the expr will be a subtree of the start node.
16888 * So in the simple 1,2 case the optree above changes to
16894 * ex-gv (or ex-padxv)
16896 * with the op_next chain being
16898 * -> ex-gv -> multideref -> op-following-ex-exists ->
16900 * In the 3 case, we have
16913 * -> rest-of-a_expr subtree ->
16914 * ex-rv2xv -> multideref -> op-following-ex-exists ->
16917 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
16918 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
16919 * multideref attached as the child, e.g.
16925 * ex-rv2av - i_expr1
16933 /* if we free this op, don't free the pad entry */
16934 if (reset_start_targ)
16935 start->op_targ = 0;
16938 /* Cut the bit we need to save out of the tree and attach to
16939 * the multideref op, then free the rest of the tree */
16941 /* find parent of node to be detached (for use by splice) */
16943 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
16944 || orig_action == MDEREF_HV_pop_rv2hv_helem)
16946 /* there is an arbitrary expression preceding us, e.g.
16947 * expr->[..]? so we need to save the 'expr' subtree */
16948 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
16949 p = cUNOPx(p)->op_first;
16950 ASSUME( start->op_type == OP_RV2AV
16951 || start->op_type == OP_RV2HV);
16954 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
16955 * above for exists/delete. */
16956 while ( (p->op_flags & OPf_KIDS)
16957 && cUNOPx(p)->op_first != start
16959 p = cUNOPx(p)->op_first;
16961 ASSUME(cUNOPx(p)->op_first == start);
16963 /* detach from main tree, and re-attach under the multideref */
16964 op_sibling_splice(mderef, NULL, 0,
16965 op_sibling_splice(p, NULL, 1, NULL));
16968 start->op_next = mderef;
16970 mderef->op_next = index_skip == -1 ? o->op_next : o;
16972 /* excise and free the original tree, and replace with
16973 * the multideref op */
16974 p = op_sibling_splice(top_op, NULL, -1, mderef);
16983 Size_t size = arg - arg_buf;
16985 if (maybe_aelemfast && action_count == 1)
16988 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
16989 sizeof(UNOP_AUX_item) * (size + 1));
16990 /* for dumping etc: store the length in a hidden first slot;
16991 * we set the op_aux pointer to the second slot */
16992 arg_buf->uv = size;
16995 } /* for (pass = ...) */
16998 /* See if the ops following o are such that o will always be executed in
16999 * boolean context: that is, the SV which o pushes onto the stack will
17000 * only ever be consumed by later ops via SvTRUE(sv) or similar.
17001 * If so, set a suitable private flag on o. Normally this will be
17002 * bool_flag; but see below why maybe_flag is needed too.
17004 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
17005 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
17006 * already be taken, so you'll have to give that op two different flags.
17008 * More explanation of 'maybe_flag' and 'safe_and' parameters.
17009 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
17010 * those underlying ops) short-circuit, which means that rather than
17011 * necessarily returning a truth value, they may return the LH argument,
17012 * which may not be boolean. For example in $x = (keys %h || -1), keys
17013 * should return a key count rather than a boolean, even though its
17014 * sort-of being used in boolean context.
17016 * So we only consider such logical ops to provide boolean context to
17017 * their LH argument if they themselves are in void or boolean context.
17018 * However, sometimes the context isn't known until run-time. In this
17019 * case the op is marked with the maybe_flag flag it.
17021 * Consider the following.
17023 * sub f { ....; if (%h) { .... } }
17025 * This is actually compiled as
17027 * sub f { ....; %h && do { .... } }
17029 * Here we won't know until runtime whether the final statement (and hence
17030 * the &&) is in void context and so is safe to return a boolean value.
17031 * So mark o with maybe_flag rather than the bool_flag.
17032 * Note that there is cost associated with determining context at runtime
17033 * (e.g. a call to block_gimme()), so it may not be worth setting (at
17034 * compile time) and testing (at runtime) maybe_flag if the scalar verses
17035 * boolean costs savings are marginal.
17037 * However, we can do slightly better with && (compared to || and //):
17038 * this op only returns its LH argument when that argument is false. In
17039 * this case, as long as the op promises to return a false value which is
17040 * valid in both boolean and scalar contexts, we can mark an op consumed
17041 * by && with bool_flag rather than maybe_flag.
17042 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
17043 * than &PL_sv_no for a false result in boolean context, then it's safe. An
17044 * op which promises to handle this case is indicated by setting safe_and
17049 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
17054 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
17056 /* OPpTARGET_MY and boolean context probably don't mix well.
17057 * If someone finds a valid use case, maybe add an extra flag to this
17058 * function which indicates its safe to do so for this op? */
17059 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
17060 && (o->op_private & OPpTARGET_MY)));
17065 switch (lop->op_type) {
17070 /* these two consume the stack argument in the scalar case,
17071 * and treat it as a boolean in the non linenumber case */
17074 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
17075 || (lop->op_private & OPpFLIP_LINENUM))
17081 /* these never leave the original value on the stack */
17090 /* OR DOR and AND evaluate their arg as a boolean, but then may
17091 * leave the original scalar value on the stack when following the
17092 * op_next route. If not in void context, we need to ensure
17093 * that whatever follows consumes the arg only in boolean context
17105 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
17109 else if (!(lop->op_flags & OPf_WANT)) {
17110 /* unknown context - decide at runtime */
17122 lop = lop->op_next;
17125 o->op_private |= flag;
17130 /* mechanism for deferring recursion in rpeep() */
17132 #define MAX_DEFERRED 4
17136 if (defer_ix == (MAX_DEFERRED-1)) { \
17137 OP **defer = defer_queue[defer_base]; \
17138 CALL_RPEEP(*defer); \
17139 S_prune_chain_head(defer); \
17140 defer_base = (defer_base + 1) % MAX_DEFERRED; \
17143 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
17146 #define IS_AND_OP(o) (o->op_type == OP_AND)
17147 #define IS_OR_OP(o) (o->op_type == OP_OR)
17150 /* A peephole optimizer. We visit the ops in the order they're to execute.
17151 * See the comments at the top of this file for more details about when
17152 * peep() is called */
17155 Perl_rpeep(pTHX_ OP *o)
17158 OP* oldoldop = NULL;
17159 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
17160 int defer_base = 0;
17163 if (!o || o->op_opt)
17166 assert(o->op_type != OP_FREED);
17170 SAVEVPTR(PL_curcop);
17171 for (;; o = o->op_next) {
17172 if (o && o->op_opt)
17175 while (defer_ix >= 0) {
17177 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
17178 CALL_RPEEP(*defer);
17179 S_prune_chain_head(defer);
17186 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
17187 assert(!oldoldop || oldoldop->op_next == oldop);
17188 assert(!oldop || oldop->op_next == o);
17190 /* By default, this op has now been optimised. A couple of cases below
17191 clear this again. */
17195 /* look for a series of 1 or more aggregate derefs, e.g.
17196 * $a[1]{foo}[$i]{$k}
17197 * and replace with a single OP_MULTIDEREF op.
17198 * Each index must be either a const, or a simple variable,
17200 * First, look for likely combinations of starting ops,
17201 * corresponding to (global and lexical variants of)
17203 * $r->[...] $r->{...}
17204 * (preceding expression)->[...]
17205 * (preceding expression)->{...}
17206 * and if so, call maybe_multideref() to do a full inspection
17207 * of the op chain and if appropriate, replace with an
17215 switch (o2->op_type) {
17217 /* $pkg[..] : gv[*pkg]
17218 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
17220 /* Fail if there are new op flag combinations that we're
17221 * not aware of, rather than:
17222 * * silently failing to optimise, or
17223 * * silently optimising the flag away.
17224 * If this ASSUME starts failing, examine what new flag
17225 * has been added to the op, and decide whether the
17226 * optimisation should still occur with that flag, then
17227 * update the code accordingly. This applies to all the
17228 * other ASSUMEs in the block of code too.
17230 ASSUME(!(o2->op_flags &
17231 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
17232 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
17236 if (o2->op_type == OP_RV2AV) {
17237 action = MDEREF_AV_gvav_aelem;
17241 if (o2->op_type == OP_RV2HV) {
17242 action = MDEREF_HV_gvhv_helem;
17246 if (o2->op_type != OP_RV2SV)
17249 /* at this point we've seen gv,rv2sv, so the only valid
17250 * construct left is $pkg->[] or $pkg->{} */
17252 ASSUME(!(o2->op_flags & OPf_STACKED));
17253 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
17254 != (OPf_WANT_SCALAR|OPf_MOD))
17257 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
17258 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
17259 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
17261 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
17262 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
17266 if (o2->op_type == OP_RV2AV) {
17267 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
17270 if (o2->op_type == OP_RV2HV) {
17271 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
17277 /* $lex->[...]: padsv[$lex] sM/DREFAV */
17279 ASSUME(!(o2->op_flags &
17280 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
17281 if ((o2->op_flags &
17282 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
17283 != (OPf_WANT_SCALAR|OPf_MOD))
17286 ASSUME(!(o2->op_private &
17287 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
17288 /* skip if state or intro, or not a deref */
17289 if ( o2->op_private != OPpDEREF_AV
17290 && o2->op_private != OPpDEREF_HV)
17294 if (o2->op_type == OP_RV2AV) {
17295 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
17298 if (o2->op_type == OP_RV2HV) {
17299 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
17306 /* $lex[..]: padav[@lex:1,2] sR *
17307 * or $lex{..}: padhv[%lex:1,2] sR */
17308 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
17309 OPf_REF|OPf_SPECIAL)));
17310 if ((o2->op_flags &
17311 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
17312 != (OPf_WANT_SCALAR|OPf_REF))
17314 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
17316 /* OPf_PARENS isn't currently used in this case;
17317 * if that changes, let us know! */
17318 ASSUME(!(o2->op_flags & OPf_PARENS));
17320 /* at this point, we wouldn't expect any of the remaining
17321 * possible private flags:
17322 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
17323 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
17325 * OPpSLICEWARNING shouldn't affect runtime
17327 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
17329 action = o2->op_type == OP_PADAV
17330 ? MDEREF_AV_padav_aelem
17331 : MDEREF_HV_padhv_helem;
17333 S_maybe_multideref(aTHX_ o, o2, action, 0);
17339 action = o2->op_type == OP_RV2AV
17340 ? MDEREF_AV_pop_rv2av_aelem
17341 : MDEREF_HV_pop_rv2hv_helem;
17344 /* (expr)->[...]: rv2av sKR/1;
17345 * (expr)->{...}: rv2hv sKR/1; */
17347 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
17349 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
17350 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
17351 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
17354 /* at this point, we wouldn't expect any of these
17355 * possible private flags:
17356 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
17357 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
17359 ASSUME(!(o2->op_private &
17360 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
17362 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
17366 S_maybe_multideref(aTHX_ o, o2, action, hints);
17375 switch (o->op_type) {
17377 PL_curcop = ((COP*)o); /* for warnings */
17380 PL_curcop = ((COP*)o); /* for warnings */
17382 /* Optimise a "return ..." at the end of a sub to just be "...".
17383 * This saves 2 ops. Before:
17384 * 1 <;> nextstate(main 1 -e:1) v ->2
17385 * 4 <@> return K ->5
17386 * 2 <0> pushmark s ->3
17387 * - <1> ex-rv2sv sK/1 ->4
17388 * 3 <#> gvsv[*cat] s ->4
17391 * - <@> return K ->-
17392 * - <0> pushmark s ->2
17393 * - <1> ex-rv2sv sK/1 ->-
17394 * 2 <$> gvsv(*cat) s ->3
17397 OP *next = o->op_next;
17398 OP *sibling = OpSIBLING(o);
17399 if ( OP_TYPE_IS(next, OP_PUSHMARK)
17400 && OP_TYPE_IS(sibling, OP_RETURN)
17401 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
17402 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
17403 ||OP_TYPE_IS(sibling->op_next->op_next,
17405 && cUNOPx(sibling)->op_first == next
17406 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
17409 /* Look through the PUSHMARK's siblings for one that
17410 * points to the RETURN */
17411 OP *top = OpSIBLING(next);
17412 while (top && top->op_next) {
17413 if (top->op_next == sibling) {
17414 top->op_next = sibling->op_next;
17415 o->op_next = next->op_next;
17418 top = OpSIBLING(top);
17423 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
17425 * This latter form is then suitable for conversion into padrange
17426 * later on. Convert:
17428 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
17432 * nextstate1 -> listop -> nextstate3
17434 * pushmark -> padop1 -> padop2
17436 if (o->op_next && (
17437 o->op_next->op_type == OP_PADSV
17438 || o->op_next->op_type == OP_PADAV
17439 || o->op_next->op_type == OP_PADHV
17441 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
17442 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
17443 && o->op_next->op_next->op_next && (
17444 o->op_next->op_next->op_next->op_type == OP_PADSV
17445 || o->op_next->op_next->op_next->op_type == OP_PADAV
17446 || o->op_next->op_next->op_next->op_type == OP_PADHV
17448 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
17449 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
17450 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
17451 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
17453 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
17456 ns2 = pad1->op_next;
17457 pad2 = ns2->op_next;
17458 ns3 = pad2->op_next;
17460 /* we assume here that the op_next chain is the same as
17461 * the op_sibling chain */
17462 assert(OpSIBLING(o) == pad1);
17463 assert(OpSIBLING(pad1) == ns2);
17464 assert(OpSIBLING(ns2) == pad2);
17465 assert(OpSIBLING(pad2) == ns3);
17467 /* excise and delete ns2 */
17468 op_sibling_splice(NULL, pad1, 1, NULL);
17471 /* excise pad1 and pad2 */
17472 op_sibling_splice(NULL, o, 2, NULL);
17474 /* create new listop, with children consisting of:
17475 * a new pushmark, pad1, pad2. */
17476 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
17477 newop->op_flags |= OPf_PARENS;
17478 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17480 /* insert newop between o and ns3 */
17481 op_sibling_splice(NULL, o, 0, newop);
17483 /*fixup op_next chain */
17484 newpm = cUNOPx(newop)->op_first; /* pushmark */
17485 o ->op_next = newpm;
17486 newpm->op_next = pad1;
17487 pad1 ->op_next = pad2;
17488 pad2 ->op_next = newop; /* listop */
17489 newop->op_next = ns3;
17491 /* Ensure pushmark has this flag if padops do */
17492 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
17493 newpm->op_flags |= OPf_MOD;
17499 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
17500 to carry two labels. For now, take the easier option, and skip
17501 this optimisation if the first NEXTSTATE has a label. */
17502 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
17503 OP *nextop = o->op_next;
17505 switch (nextop->op_type) {
17510 nextop = nextop->op_next;
17516 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
17519 oldop->op_next = nextop;
17521 /* Skip (old)oldop assignment since the current oldop's
17522 op_next already points to the next op. */
17529 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
17530 if (o->op_next->op_private & OPpTARGET_MY) {
17531 if (o->op_flags & OPf_STACKED) /* chained concats */
17532 break; /* ignore_optimization */
17534 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
17535 o->op_targ = o->op_next->op_targ;
17536 o->op_next->op_targ = 0;
17537 o->op_private |= OPpTARGET_MY;
17540 op_null(o->op_next);
17544 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
17545 break; /* Scalar stub must produce undef. List stub is noop */
17549 if (o->op_targ == OP_NEXTSTATE
17550 || o->op_targ == OP_DBSTATE)
17552 PL_curcop = ((COP*)o);
17554 /* XXX: We avoid setting op_seq here to prevent later calls
17555 to rpeep() from mistakenly concluding that optimisation
17556 has already occurred. This doesn't fix the real problem,
17557 though (See 20010220.007 (#5874)). AMS 20010719 */
17558 /* op_seq functionality is now replaced by op_opt */
17566 oldop->op_next = o->op_next;
17580 convert repeat into a stub with no kids.
17582 if (o->op_next->op_type == OP_CONST
17583 || ( o->op_next->op_type == OP_PADSV
17584 && !(o->op_next->op_private & OPpLVAL_INTRO))
17585 || ( o->op_next->op_type == OP_GV
17586 && o->op_next->op_next->op_type == OP_RV2SV
17587 && !(o->op_next->op_next->op_private
17588 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
17590 const OP *kid = o->op_next->op_next;
17591 if (o->op_next->op_type == OP_GV)
17592 kid = kid->op_next;
17593 /* kid is now the ex-list. */
17594 if (kid->op_type == OP_NULL
17595 && (kid = kid->op_next)->op_type == OP_CONST
17596 /* kid is now the repeat count. */
17597 && kid->op_next->op_type == OP_REPEAT
17598 && kid->op_next->op_private & OPpREPEAT_DOLIST
17599 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
17600 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
17603 o = kid->op_next; /* repeat */
17604 oldop->op_next = o;
17605 op_free(cBINOPo->op_first);
17606 op_free(cBINOPo->op_last );
17607 o->op_flags &=~ OPf_KIDS;
17608 /* stub is a baseop; repeat is a binop */
17609 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
17610 OpTYPE_set(o, OP_STUB);
17616 /* Convert a series of PAD ops for my vars plus support into a
17617 * single padrange op. Basically
17619 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
17621 * becomes, depending on circumstances, one of
17623 * padrange ----------------------------------> (list) -> rest
17624 * padrange --------------------------------------------> rest
17626 * where all the pad indexes are sequential and of the same type
17628 * We convert the pushmark into a padrange op, then skip
17629 * any other pad ops, and possibly some trailing ops.
17630 * Note that we don't null() the skipped ops, to make it
17631 * easier for Deparse to undo this optimisation (and none of
17632 * the skipped ops are holding any resourses). It also makes
17633 * it easier for find_uninit_var(), as it can just ignore
17634 * padrange, and examine the original pad ops.
17638 OP *followop = NULL; /* the op that will follow the padrange op */
17641 PADOFFSET base = 0; /* init only to stop compiler whining */
17642 bool gvoid = 0; /* init only to stop compiler whining */
17643 bool defav = 0; /* seen (...) = @_ */
17644 bool reuse = 0; /* reuse an existing padrange op */
17646 /* look for a pushmark -> gv[_] -> rv2av */
17651 if ( p->op_type == OP_GV
17652 && cGVOPx_gv(p) == PL_defgv
17653 && (rv2av = p->op_next)
17654 && rv2av->op_type == OP_RV2AV
17655 && !(rv2av->op_flags & OPf_REF)
17656 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
17657 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
17659 q = rv2av->op_next;
17660 if (q->op_type == OP_NULL)
17662 if (q->op_type == OP_PUSHMARK) {
17672 /* scan for PAD ops */
17674 for (p = p->op_next; p; p = p->op_next) {
17675 if (p->op_type == OP_NULL)
17678 if (( p->op_type != OP_PADSV
17679 && p->op_type != OP_PADAV
17680 && p->op_type != OP_PADHV
17682 /* any private flag other than INTRO? e.g. STATE */
17683 || (p->op_private & ~OPpLVAL_INTRO)
17687 /* let $a[N] potentially be optimised into AELEMFAST_LEX
17689 if ( p->op_type == OP_PADAV
17691 && p->op_next->op_type == OP_CONST
17692 && p->op_next->op_next
17693 && p->op_next->op_next->op_type == OP_AELEM
17697 /* for 1st padop, note what type it is and the range
17698 * start; for the others, check that it's the same type
17699 * and that the targs are contiguous */
17701 intro = (p->op_private & OPpLVAL_INTRO);
17703 gvoid = OP_GIMME(p,0) == G_VOID;
17706 if ((p->op_private & OPpLVAL_INTRO) != intro)
17708 /* Note that you'd normally expect targs to be
17709 * contiguous in my($a,$b,$c), but that's not the case
17710 * when external modules start doing things, e.g.
17711 * Function::Parameters */
17712 if (p->op_targ != base + count)
17714 assert(p->op_targ == base + count);
17715 /* Either all the padops or none of the padops should
17716 be in void context. Since we only do the optimisa-
17717 tion for av/hv when the aggregate itself is pushed
17718 on to the stack (one item), there is no need to dis-
17719 tinguish list from scalar context. */
17720 if (gvoid != (OP_GIMME(p,0) == G_VOID))
17724 /* for AV, HV, only when we're not flattening */
17725 if ( p->op_type != OP_PADSV
17727 && !(p->op_flags & OPf_REF)
17731 if (count >= OPpPADRANGE_COUNTMASK)
17734 /* there's a biggest base we can fit into a
17735 * SAVEt_CLEARPADRANGE in pp_padrange.
17736 * (The sizeof() stuff will be constant-folded, and is
17737 * intended to avoid getting "comparison is always false"
17738 * compiler warnings. See the comments above
17739 * MEM_WRAP_CHECK for more explanation on why we do this
17740 * in a weird way to avoid compiler warnings.)
17743 && (8*sizeof(base) >
17744 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
17746 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17748 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17752 /* Success! We've got another valid pad op to optimise away */
17754 followop = p->op_next;
17757 if (count < 1 || (count == 1 && !defav))
17760 /* pp_padrange in specifically compile-time void context
17761 * skips pushing a mark and lexicals; in all other contexts
17762 * (including unknown till runtime) it pushes a mark and the
17763 * lexicals. We must be very careful then, that the ops we
17764 * optimise away would have exactly the same effect as the
17766 * In particular in void context, we can only optimise to
17767 * a padrange if we see the complete sequence
17768 * pushmark, pad*v, ...., list
17769 * which has the net effect of leaving the markstack as it
17770 * was. Not pushing onto the stack (whereas padsv does touch
17771 * the stack) makes no difference in void context.
17775 if (followop->op_type == OP_LIST
17776 && OP_GIMME(followop,0) == G_VOID
17779 followop = followop->op_next; /* skip OP_LIST */
17781 /* consolidate two successive my(...);'s */
17784 && oldoldop->op_type == OP_PADRANGE
17785 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
17786 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
17787 && !(oldoldop->op_flags & OPf_SPECIAL)
17790 assert(oldoldop->op_next == oldop);
17791 assert( oldop->op_type == OP_NEXTSTATE
17792 || oldop->op_type == OP_DBSTATE);
17793 assert(oldop->op_next == o);
17796 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
17798 /* Do not assume pad offsets for $c and $d are con-
17803 if ( oldoldop->op_targ + old_count == base
17804 && old_count < OPpPADRANGE_COUNTMASK - count) {
17805 base = oldoldop->op_targ;
17806 count += old_count;
17811 /* if there's any immediately following singleton
17812 * my var's; then swallow them and the associated
17814 * my ($a,$b); my $c; my $d;
17816 * my ($a,$b,$c,$d);
17819 while ( ((p = followop->op_next))
17820 && ( p->op_type == OP_PADSV
17821 || p->op_type == OP_PADAV
17822 || p->op_type == OP_PADHV)
17823 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
17824 && (p->op_private & OPpLVAL_INTRO) == intro
17825 && !(p->op_private & ~OPpLVAL_INTRO)
17827 && ( p->op_next->op_type == OP_NEXTSTATE
17828 || p->op_next->op_type == OP_DBSTATE)
17829 && count < OPpPADRANGE_COUNTMASK
17830 && base + count == p->op_targ
17833 followop = p->op_next;
17841 assert(oldoldop->op_type == OP_PADRANGE);
17842 oldoldop->op_next = followop;
17843 oldoldop->op_private = (intro | count);
17849 /* Convert the pushmark into a padrange.
17850 * To make Deparse easier, we guarantee that a padrange was
17851 * *always* formerly a pushmark */
17852 assert(o->op_type == OP_PUSHMARK);
17853 o->op_next = followop;
17854 OpTYPE_set(o, OP_PADRANGE);
17856 /* bit 7: INTRO; bit 6..0: count */
17857 o->op_private = (intro | count);
17858 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
17859 | gvoid * OPf_WANT_VOID
17860 | (defav ? OPf_SPECIAL : 0));
17866 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17867 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17872 /*'keys %h' in void or scalar context: skip the OP_KEYS
17873 * and perform the functionality directly in the RV2HV/PADHV
17876 if (o->op_flags & OPf_REF) {
17877 OP *k = o->op_next;
17878 U8 want = (k->op_flags & OPf_WANT);
17880 && k->op_type == OP_KEYS
17881 && ( want == OPf_WANT_VOID
17882 || want == OPf_WANT_SCALAR)
17883 && !(k->op_private & OPpMAYBE_LVSUB)
17884 && !(k->op_flags & OPf_MOD)
17886 o->op_next = k->op_next;
17887 o->op_flags &= ~(OPf_REF|OPf_WANT);
17888 o->op_flags |= want;
17889 o->op_private |= (o->op_type == OP_PADHV ?
17890 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
17891 /* for keys(%lex), hold onto the OP_KEYS's targ
17892 * since padhv doesn't have its own targ to return
17894 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
17899 /* see if %h is used in boolean context */
17900 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17901 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17904 if (o->op_type != OP_PADHV)
17908 if ( o->op_type == OP_PADAV
17909 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17911 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17914 /* Skip over state($x) in void context. */
17915 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
17916 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
17918 oldop->op_next = o->op_next;
17919 goto redo_nextstate;
17921 if (o->op_type != OP_PADAV)
17925 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
17926 OP* const pop = (o->op_type == OP_PADAV) ?
17927 o->op_next : o->op_next->op_next;
17929 if (pop && pop->op_type == OP_CONST &&
17930 ((PL_op = pop->op_next)) &&
17931 pop->op_next->op_type == OP_AELEM &&
17932 !(pop->op_next->op_private &
17933 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
17934 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
17937 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
17938 no_bareword_allowed(pop);
17939 if (o->op_type == OP_GV)
17940 op_null(o->op_next);
17941 op_null(pop->op_next);
17943 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
17944 o->op_next = pop->op_next->op_next;
17945 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
17946 o->op_private = (U8)i;
17947 if (o->op_type == OP_GV) {
17950 o->op_type = OP_AELEMFAST;
17953 o->op_type = OP_AELEMFAST_LEX;
17955 if (o->op_type != OP_GV)
17959 /* Remove $foo from the op_next chain in void context. */
17961 && ( o->op_next->op_type == OP_RV2SV
17962 || o->op_next->op_type == OP_RV2AV
17963 || o->op_next->op_type == OP_RV2HV )
17964 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17965 && !(o->op_next->op_private & OPpLVAL_INTRO))
17967 oldop->op_next = o->op_next->op_next;
17968 /* Reprocess the previous op if it is a nextstate, to
17969 allow double-nextstate optimisation. */
17971 if (oldop->op_type == OP_NEXTSTATE) {
17978 o = oldop->op_next;
17981 else if (o->op_next->op_type == OP_RV2SV) {
17982 if (!(o->op_next->op_private & OPpDEREF)) {
17983 op_null(o->op_next);
17984 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
17986 o->op_next = o->op_next->op_next;
17987 OpTYPE_set(o, OP_GVSV);
17990 else if (o->op_next->op_type == OP_READLINE
17991 && o->op_next->op_next->op_type == OP_CONCAT
17992 && (o->op_next->op_next->op_flags & OPf_STACKED))
17994 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
17995 OpTYPE_set(o, OP_RCATLINE);
17996 o->op_flags |= OPf_STACKED;
17997 op_null(o->op_next->op_next);
17998 op_null(o->op_next);
18009 case OP_CMPCHAIN_AND:
18011 while (cLOGOP->op_other->op_type == OP_NULL)
18012 cLOGOP->op_other = cLOGOP->op_other->op_next;
18013 while (o->op_next && ( o->op_type == o->op_next->op_type
18014 || o->op_next->op_type == OP_NULL))
18015 o->op_next = o->op_next->op_next;
18017 /* If we're an OR and our next is an AND in void context, we'll
18018 follow its op_other on short circuit, same for reverse.
18019 We can't do this with OP_DOR since if it's true, its return
18020 value is the underlying value which must be evaluated
18024 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
18025 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
18027 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
18029 o->op_next = ((LOGOP*)o->op_next)->op_other;
18031 DEFER(cLOGOP->op_other);
18036 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
18037 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
18046 case OP_ARGDEFELEM:
18047 while (cLOGOP->op_other->op_type == OP_NULL)
18048 cLOGOP->op_other = cLOGOP->op_other->op_next;
18049 DEFER(cLOGOP->op_other);
18054 while (cLOOP->op_redoop->op_type == OP_NULL)
18055 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
18056 while (cLOOP->op_nextop->op_type == OP_NULL)
18057 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
18058 while (cLOOP->op_lastop->op_type == OP_NULL)
18059 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
18060 /* a while(1) loop doesn't have an op_next that escapes the
18061 * loop, so we have to explicitly follow the op_lastop to
18062 * process the rest of the code */
18063 DEFER(cLOOP->op_lastop);
18067 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
18068 DEFER(cLOGOPo->op_other);
18071 case OP_ENTERTRYCATCH:
18072 assert(cLOGOPo->op_other->op_type == OP_CATCH);
18073 /* catch body is the ->op_other of the OP_CATCH */
18074 DEFER(cLOGOPx(cLOGOPo->op_other)->op_other);
18078 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
18079 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
18080 assert(!(cPMOP->op_pmflags & PMf_ONCE));
18081 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
18082 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
18083 cPMOP->op_pmstashstartu.op_pmreplstart
18084 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
18085 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
18091 if (o->op_flags & OPf_SPECIAL) {
18092 /* first arg is a code block */
18093 OP * const nullop = OpSIBLING(cLISTOP->op_first);
18094 OP * kid = cUNOPx(nullop)->op_first;
18096 assert(nullop->op_type == OP_NULL);
18097 assert(kid->op_type == OP_SCOPE
18098 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
18099 /* since OP_SORT doesn't have a handy op_other-style
18100 * field that can point directly to the start of the code
18101 * block, store it in the otherwise-unused op_next field
18102 * of the top-level OP_NULL. This will be quicker at
18103 * run-time, and it will also allow us to remove leading
18104 * OP_NULLs by just messing with op_nexts without
18105 * altering the basic op_first/op_sibling layout. */
18106 kid = kLISTOP->op_first;
18108 (kid->op_type == OP_NULL
18109 && ( kid->op_targ == OP_NEXTSTATE
18110 || kid->op_targ == OP_DBSTATE ))
18111 || kid->op_type == OP_STUB
18112 || kid->op_type == OP_ENTER
18113 || (PL_parser && PL_parser->error_count));
18114 nullop->op_next = kid->op_next;
18115 DEFER(nullop->op_next);
18118 /* check that RHS of sort is a single plain array */
18119 oright = cUNOPo->op_first;
18120 if (!oright || oright->op_type != OP_PUSHMARK)
18123 if (o->op_private & OPpSORT_INPLACE)
18126 /* reverse sort ... can be optimised. */
18127 if (!OpHAS_SIBLING(cUNOPo)) {
18128 /* Nothing follows us on the list. */
18129 OP * const reverse = o->op_next;
18131 if (reverse->op_type == OP_REVERSE &&
18132 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
18133 OP * const pushmark = cUNOPx(reverse)->op_first;
18134 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
18135 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
18136 /* reverse -> pushmark -> sort */
18137 o->op_private |= OPpSORT_REVERSE;
18139 pushmark->op_next = oright->op_next;
18149 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
18151 LISTOP *enter, *exlist;
18153 if (o->op_private & OPpSORT_INPLACE)
18156 enter = (LISTOP *) o->op_next;
18159 if (enter->op_type == OP_NULL) {
18160 enter = (LISTOP *) enter->op_next;
18164 /* for $a (...) will have OP_GV then OP_RV2GV here.
18165 for (...) just has an OP_GV. */
18166 if (enter->op_type == OP_GV) {
18167 gvop = (OP *) enter;
18168 enter = (LISTOP *) enter->op_next;
18171 if (enter->op_type == OP_RV2GV) {
18172 enter = (LISTOP *) enter->op_next;
18178 if (enter->op_type != OP_ENTERITER)
18181 iter = enter->op_next;
18182 if (!iter || iter->op_type != OP_ITER)
18185 expushmark = enter->op_first;
18186 if (!expushmark || expushmark->op_type != OP_NULL
18187 || expushmark->op_targ != OP_PUSHMARK)
18190 exlist = (LISTOP *) OpSIBLING(expushmark);
18191 if (!exlist || exlist->op_type != OP_NULL
18192 || exlist->op_targ != OP_LIST)
18195 if (exlist->op_last != o) {
18196 /* Mmm. Was expecting to point back to this op. */
18199 theirmark = exlist->op_first;
18200 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
18203 if (OpSIBLING(theirmark) != o) {
18204 /* There's something between the mark and the reverse, eg
18205 for (1, reverse (...))
18210 ourmark = ((LISTOP *)o)->op_first;
18211 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
18214 ourlast = ((LISTOP *)o)->op_last;
18215 if (!ourlast || ourlast->op_next != o)
18218 rv2av = OpSIBLING(ourmark);
18219 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
18220 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
18221 /* We're just reversing a single array. */
18222 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
18223 enter->op_flags |= OPf_STACKED;
18226 /* We don't have control over who points to theirmark, so sacrifice
18228 theirmark->op_next = ourmark->op_next;
18229 theirmark->op_flags = ourmark->op_flags;
18230 ourlast->op_next = gvop ? gvop : (OP *) enter;
18233 enter->op_private |= OPpITER_REVERSED;
18234 iter->op_private |= OPpITER_REVERSED;
18238 o = oldop->op_next;
18240 NOT_REACHED; /* NOTREACHED */
18246 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
18247 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
18252 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
18253 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
18256 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
18258 sv = newRV((SV *)PL_compcv);
18262 OpTYPE_set(o, OP_CONST);
18263 o->op_flags |= OPf_SPECIAL;
18264 cSVOPo->op_sv = sv;
18269 if (OP_GIMME(o,0) == G_VOID
18270 || ( o->op_next->op_type == OP_LINESEQ
18271 && ( o->op_next->op_next->op_type == OP_LEAVESUB
18272 || ( o->op_next->op_next->op_type == OP_RETURN
18273 && !CvLVALUE(PL_compcv)))))
18275 OP *right = cBINOP->op_first;
18294 OP *left = OpSIBLING(right);
18295 if (left->op_type == OP_SUBSTR
18296 && (left->op_private & 7) < 4) {
18298 /* cut out right */
18299 op_sibling_splice(o, NULL, 1, NULL);
18300 /* and insert it as second child of OP_SUBSTR */
18301 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
18303 left->op_private |= OPpSUBSTR_REPL_FIRST;
18305 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
18312 int l, r, lr, lscalars, rscalars;
18314 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
18315 Note that we do this now rather than in newASSIGNOP(),
18316 since only by now are aliased lexicals flagged as such
18318 See the essay "Common vars in list assignment" above for
18319 the full details of the rationale behind all the conditions
18322 PL_generation sorcery:
18323 To detect whether there are common vars, the global var
18324 PL_generation is incremented for each assign op we scan.
18325 Then we run through all the lexical variables on the LHS,
18326 of the assignment, setting a spare slot in each of them to
18327 PL_generation. Then we scan the RHS, and if any lexicals
18328 already have that value, we know we've got commonality.
18329 Also, if the generation number is already set to
18330 PERL_INT_MAX, then the variable is involved in aliasing, so
18331 we also have potential commonality in that case.
18337 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
18340 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
18344 /* After looking for things which are *always* safe, this main
18345 * if/else chain selects primarily based on the type of the
18346 * LHS, gradually working its way down from the more dangerous
18347 * to the more restrictive and thus safer cases */
18349 if ( !l /* () = ....; */
18350 || !r /* .... = (); */
18351 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
18352 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
18353 || (lscalars < 2) /* (undef, $x) = ... */
18355 NOOP; /* always safe */
18357 else if (l & AAS_DANGEROUS) {
18358 /* always dangerous */
18359 o->op_private |= OPpASSIGN_COMMON_SCALAR;
18360 o->op_private |= OPpASSIGN_COMMON_AGG;
18362 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
18363 /* package vars are always dangerous - too many
18364 * aliasing possibilities */
18365 if (l & AAS_PKG_SCALAR)
18366 o->op_private |= OPpASSIGN_COMMON_SCALAR;
18367 if (l & AAS_PKG_AGG)
18368 o->op_private |= OPpASSIGN_COMMON_AGG;
18370 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
18371 |AAS_LEX_SCALAR|AAS_LEX_AGG))
18373 /* LHS contains only lexicals and safe ops */
18375 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
18376 o->op_private |= OPpASSIGN_COMMON_AGG;
18378 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
18379 if (lr & AAS_LEX_SCALAR_COMM)
18380 o->op_private |= OPpASSIGN_COMMON_SCALAR;
18381 else if ( !(l & AAS_LEX_SCALAR)
18382 && (r & AAS_DEFAV))
18386 * as scalar-safe for performance reasons.
18387 * (it will still have been marked _AGG if necessary */
18390 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
18391 /* if there are only lexicals on the LHS and no
18392 * common ones on the RHS, then we assume that the
18393 * only way those lexicals could also get
18394 * on the RHS is via some sort of dereffing or
18397 * ($lex, $x) = (1, $$r)
18398 * and in this case we assume the var must have
18399 * a bumped ref count. So if its ref count is 1,
18400 * it must only be on the LHS.
18402 o->op_private |= OPpASSIGN_COMMON_RC1;
18407 * may have to handle aggregate on LHS, but we can't
18408 * have common scalars. */
18411 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
18413 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
18414 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
18420 /* if the op is used in boolean context, set the TRUEBOOL flag
18421 * which enables an optimisation at runtime which avoids creating
18422 * a stack temporary for known-true package names */
18423 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
18424 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
18428 /* see if the op is used in known boolean context,
18429 * but not if OA_TARGLEX optimisation is enabled */
18430 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
18431 && !(o->op_private & OPpTARGET_MY)
18433 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
18437 /* see if the op is used in known boolean context */
18438 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
18439 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
18443 Perl_cpeep_t cpeep =
18444 XopENTRYCUSTOM(o, xop_peep);
18446 cpeep(aTHX_ o, oldop);
18451 /* did we just null the current op? If so, re-process it to handle
18452 * eliding "empty" ops from the chain */
18453 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
18466 Perl_peep(pTHX_ OP *o)
18472 =for apidoc_section $custom
18474 =for apidoc Perl_custom_op_xop
18475 Return the XOP structure for a given custom op. This macro should be
18476 considered internal to C<OP_NAME> and the other access macros: use them instead.
18477 This macro does call a function. Prior
18478 to 5.19.6, this was implemented as a
18485 /* use PERL_MAGIC_ext to call a function to free the xop structure when
18486 * freeing PL_custom_ops */
18489 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
18493 PERL_UNUSED_ARG(mg);
18494 xop = INT2PTR(XOP *, SvIV(sv));
18495 Safefree(xop->xop_name);
18496 Safefree(xop->xop_desc);
18502 static const MGVTBL custom_op_register_vtbl = {
18507 custom_op_register_free, /* free */
18517 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
18523 static const XOP xop_null = { 0, 0, 0, 0, 0 };
18525 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
18526 assert(o->op_type == OP_CUSTOM);
18528 /* This is wrong. It assumes a function pointer can be cast to IV,
18529 * which isn't guaranteed, but this is what the old custom OP code
18530 * did. In principle it should be safer to Copy the bytes of the
18531 * pointer into a PV: since the new interface is hidden behind
18532 * functions, this can be changed later if necessary. */
18533 /* Change custom_op_xop if this ever happens */
18534 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
18537 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18539 /* See if the op isn't registered, but its name *is* registered.
18540 * That implies someone is using the pre-5.14 API,where only name and
18541 * description could be registered. If so, fake up a real
18543 * We only check for an existing name, and assume no one will have
18544 * just registered a desc */
18545 if (!he && PL_custom_op_names &&
18546 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
18551 /* XXX does all this need to be shared mem? */
18552 Newxz(xop, 1, XOP);
18553 pv = SvPV(HeVAL(he), l);
18554 XopENTRY_set(xop, xop_name, savepvn(pv, l));
18555 if (PL_custom_op_descs &&
18556 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
18558 pv = SvPV(HeVAL(he), l);
18559 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
18561 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
18562 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18563 /* add magic to the SV so that the xop struct (pointed to by
18564 * SvIV(sv)) is freed. Normally a static xop is registered, but
18565 * for this backcompat hack, we've alloced one */
18566 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
18567 &custom_op_register_vtbl, NULL, 0);
18572 xop = (XOP *)&xop_null;
18574 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
18579 if(field == XOPe_xop_ptr) {
18582 const U32 flags = XopFLAGS(xop);
18583 if(flags & field) {
18585 case XOPe_xop_name:
18586 any.xop_name = xop->xop_name;
18588 case XOPe_xop_desc:
18589 any.xop_desc = xop->xop_desc;
18591 case XOPe_xop_class:
18592 any.xop_class = xop->xop_class;
18594 case XOPe_xop_peep:
18595 any.xop_peep = xop->xop_peep;
18600 "panic: custom_op_get_field(): invalid field %d\n",
18606 case XOPe_xop_name:
18607 any.xop_name = XOPd_xop_name;
18609 case XOPe_xop_desc:
18610 any.xop_desc = XOPd_xop_desc;
18612 case XOPe_xop_class:
18613 any.xop_class = XOPd_xop_class;
18615 case XOPe_xop_peep:
18616 any.xop_peep = XOPd_xop_peep;
18629 =for apidoc custom_op_register
18630 Register a custom op. See L<perlguts/"Custom Operators">.
18636 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
18640 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
18642 /* see the comment in custom_op_xop */
18643 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
18645 if (!PL_custom_ops)
18646 PL_custom_ops = newHV();
18648 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
18649 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
18654 =for apidoc core_prototype
18656 This function assigns the prototype of the named core function to C<sv>, or
18657 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
18658 C<NULL> if the core function has no prototype. C<code> is a code as returned
18659 by C<keyword()>. It must not be equal to 0.
18665 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
18668 int i = 0, n = 0, seen_question = 0, defgv = 0;
18670 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
18671 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
18672 bool nullret = FALSE;
18674 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
18678 if (!sv) sv = sv_newmortal();
18680 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
18682 switch (code < 0 ? -code : code) {
18683 case KEY_and : case KEY_chop: case KEY_chomp:
18684 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
18685 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
18686 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
18687 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
18688 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
18689 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
18690 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
18691 case KEY_x : case KEY_xor :
18692 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
18693 case KEY_glob: retsetpvs("_;", OP_GLOB);
18694 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
18695 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
18696 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
18697 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
18698 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
18700 case KEY_evalbytes:
18701 name = "entereval"; break;
18709 while (i < MAXO) { /* The slow way. */
18710 if (strEQ(name, PL_op_name[i])
18711 || strEQ(name, PL_op_desc[i]))
18713 if (nullret) { assert(opnum); *opnum = i; return NULL; }
18720 defgv = PL_opargs[i] & OA_DEFGV;
18721 oa = PL_opargs[i] >> OASHIFT;
18723 if (oa & OA_OPTIONAL && !seen_question && (
18724 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
18729 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
18730 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
18731 /* But globs are already references (kinda) */
18732 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
18736 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
18737 && !scalar_mod_type(NULL, i)) {
18742 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
18746 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
18747 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
18748 str[n-1] = '_'; defgv = 0;
18752 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
18754 sv_setpvn(sv, str, n - 1);
18755 if (opnum) *opnum = i;
18760 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
18763 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
18764 newSVOP(OP_COREARGS,0,coreargssv);
18767 PERL_ARGS_ASSERT_CORESUB_OP;
18771 return op_append_elem(OP_LINESEQ,
18774 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
18781 o = newUNOP(OP_AVHVSWITCH,0,argop);
18782 o->op_private = opnum-OP_EACH;
18784 case OP_SELECT: /* which represents OP_SSELECT as well */
18789 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
18790 newSVOP(OP_CONST, 0, newSVuv(1))
18792 coresub_op(newSVuv((UV)OP_SSELECT), 0,
18794 coresub_op(coreargssv, 0, OP_SELECT)
18798 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
18800 return op_append_elem(
18803 opnum == OP_WANTARRAY || opnum == OP_RUNCV
18804 ? OPpOFFBYONE << 8 : 0)
18806 case OA_BASEOP_OR_UNOP:
18807 if (opnum == OP_ENTEREVAL) {
18808 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
18809 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
18811 else o = newUNOP(opnum,0,argop);
18812 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
18815 if (is_handle_constructor(o, 1))
18816 argop->op_private |= OPpCOREARGS_DEREF1;
18817 if (scalar_mod_type(NULL, opnum))
18818 argop->op_private |= OPpCOREARGS_SCALARMOD;
18822 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
18823 if (is_handle_constructor(o, 2))
18824 argop->op_private |= OPpCOREARGS_DEREF2;
18825 if (opnum == OP_SUBSTR) {
18826 o->op_private |= OPpMAYBE_LVSUB;
18835 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
18836 SV * const *new_const_svp)
18838 const char *hvname;
18839 bool is_const = !!CvCONST(old_cv);
18840 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
18842 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
18844 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
18846 /* They are 2 constant subroutines generated from
18847 the same constant. This probably means that
18848 they are really the "same" proxy subroutine
18849 instantiated in 2 places. Most likely this is
18850 when a constant is exported twice. Don't warn.
18853 (ckWARN(WARN_REDEFINE)
18855 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
18856 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
18857 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
18858 strEQ(hvname, "autouse"))
18862 && ckWARN_d(WARN_REDEFINE)
18863 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
18866 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
18868 ? "Constant subroutine %" SVf " redefined"
18869 : "Subroutine %" SVf " redefined",
18874 =for apidoc_section $hook
18876 These functions provide convenient and thread-safe means of manipulating
18883 =for apidoc wrap_op_checker
18885 Puts a C function into the chain of check functions for a specified op
18886 type. This is the preferred way to manipulate the L</PL_check> array.
18887 C<opcode> specifies which type of op is to be affected. C<new_checker>
18888 is a pointer to the C function that is to be added to that opcode's
18889 check chain, and C<old_checker_p> points to the storage location where a
18890 pointer to the next function in the chain will be stored. The value of
18891 C<new_checker> is written into the L</PL_check> array, while the value
18892 previously stored there is written to C<*old_checker_p>.
18894 L</PL_check> is global to an entire process, and a module wishing to
18895 hook op checking may find itself invoked more than once per process,
18896 typically in different threads. To handle that situation, this function
18897 is idempotent. The location C<*old_checker_p> must initially (once
18898 per process) contain a null pointer. A C variable of static duration
18899 (declared at file scope, typically also marked C<static> to give
18900 it internal linkage) will be implicitly initialised appropriately,
18901 if it does not have an explicit initialiser. This function will only
18902 actually modify the check chain if it finds C<*old_checker_p> to be null.
18903 This function is also thread safe on the small scale. It uses appropriate
18904 locking to avoid race conditions in accessing L</PL_check>.
18906 When this function is called, the function referenced by C<new_checker>
18907 must be ready to be called, except for C<*old_checker_p> being unfilled.
18908 In a threading situation, C<new_checker> may be called immediately,
18909 even before this function has returned. C<*old_checker_p> will always
18910 be appropriately set before C<new_checker> is called. If C<new_checker>
18911 decides not to do anything special with an op that it is given (which
18912 is the usual case for most uses of op check hooking), it must chain the
18913 check function referenced by C<*old_checker_p>.
18915 Taken all together, XS code to hook an op checker should typically look
18916 something like this:
18918 static Perl_check_t nxck_frob;
18919 static OP *myck_frob(pTHX_ OP *op) {
18921 op = nxck_frob(aTHX_ op);
18926 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
18928 If you want to influence compilation of calls to a specific subroutine,
18929 then use L</cv_set_call_checker_flags> rather than hooking checking of
18930 all C<entersub> ops.
18936 Perl_wrap_op_checker(pTHX_ Optype opcode,
18937 Perl_check_t new_checker, Perl_check_t *old_checker_p)
18940 PERL_UNUSED_CONTEXT;
18941 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
18942 if (*old_checker_p) return;
18943 OP_CHECK_MUTEX_LOCK;
18944 if (!*old_checker_p) {
18945 *old_checker_p = PL_check[opcode];
18946 PL_check[opcode] = new_checker;
18948 OP_CHECK_MUTEX_UNLOCK;
18953 /* Efficient sub that returns a constant scalar value. */
18955 const_sv_xsub(pTHX_ CV* cv)
18958 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
18959 PERL_UNUSED_ARG(items);
18969 const_av_xsub(pTHX_ CV* cv)
18972 AV * const av = MUTABLE_AV(XSANY.any_ptr);
18980 if (SvRMAGICAL(av))
18981 Perl_croak(aTHX_ "Magical list constants are not supported");
18982 if (GIMME_V != G_LIST) {
18984 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
18987 EXTEND(SP, AvFILLp(av)+1);
18988 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
18989 XSRETURN(AvFILLp(av)+1);
18992 /* Copy an existing cop->cop_warnings field.
18993 * If it's one of the standard addresses, just re-use the address.
18994 * This is the e implementation for the DUP_WARNINGS() macro
18998 Perl_dup_warnings(pTHX_ STRLEN* warnings)
19001 STRLEN *new_warnings;
19003 if (warnings == NULL || specialWARN(warnings))
19006 size = sizeof(*warnings) + *warnings;
19008 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
19009 Copy(warnings, new_warnings, size, char);
19010 return new_warnings;
19014 * ex: set ts=8 sts=4 sw=4 et: