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 /* This cannot possibly be right, but it was copied from the old slab
471 allocator, to which it was originally added, without explanation, in
474 # define PerlMemShared PerlMem
477 /* make freed ops die if they're inadvertently executed */
482 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
487 /* Return the block of memory used by an op to the free list of
488 * the OP slab associated with that op.
492 Perl_Slab_Free(pTHX_ void *op)
494 OP * const o = (OP *)op;
497 PERL_ARGS_ASSERT_SLAB_FREE;
500 o->op_ppaddr = S_pp_freed;
503 if (!o->op_slabbed) {
505 PerlMemShared_free(op);
510 /* If this op is already freed, our refcount will get screwy. */
511 assert(o->op_type != OP_FREED);
512 o->op_type = OP_FREED;
513 link_freed_op(slab, o);
514 DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p",
515 (void*)o, (void *)OpMySLAB(o), (void*)slab));
516 OpslabREFCNT_dec_padok(slab);
520 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
522 const bool havepad = !!PL_comppad;
523 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
526 PAD_SAVE_SETNULLPAD();
532 /* Free a chain of OP slabs. Should only be called after all ops contained
533 * in it have been freed. At this point, its reference count should be 1,
534 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
535 * and just directly calls opslab_free().
536 * (Note that the reference count which PL_compcv held on the slab should
537 * have been removed once compilation of the sub was complete).
543 Perl_opslab_free(pTHX_ OPSLAB *slab)
546 PERL_ARGS_ASSERT_OPSLAB_FREE;
548 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
549 assert(slab->opslab_refcnt == 1);
550 PerlMemShared_free(slab->opslab_freed);
552 slab2 = slab->opslab_next;
554 slab->opslab_refcnt = ~(size_t)0;
556 #ifdef PERL_DEBUG_READONLY_OPS
557 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
559 if (munmap(slab, OpSLABSizeBytes(slab->opslab_size))) {
560 perror("munmap failed");
564 PerlMemShared_free(slab);
570 /* like opslab_free(), but first calls op_free() on any ops in the slab
571 * not marked as OP_FREED
575 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
579 size_t savestack_count = 0;
581 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
584 OPSLOT *slot = OpSLOToff(slab2, slab2->opslab_free_space);
585 OPSLOT *end = OpSLOToff(slab2, slab2->opslab_size);
587 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
589 if (slot->opslot_op.op_type != OP_FREED
590 && !(slot->opslot_op.op_savefree
596 assert(slot->opslot_op.op_slabbed);
597 op_free(&slot->opslot_op);
598 if (slab->opslab_refcnt == 1) goto free;
601 } while ((slab2 = slab2->opslab_next));
602 /* > 1 because the CV still holds a reference count. */
603 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
605 assert(savestack_count == slab->opslab_refcnt-1);
607 /* Remove the CV’s reference count. */
608 slab->opslab_refcnt--;
615 #ifdef PERL_DEBUG_READONLY_OPS
617 Perl_op_refcnt_inc(pTHX_ OP *o)
620 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
621 if (slab && slab->opslab_readonly) {
634 Perl_op_refcnt_dec(pTHX_ OP *o)
637 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
639 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
641 if (slab && slab->opslab_readonly) {
643 result = --o->op_targ;
646 result = --o->op_targ;
652 * In the following definition, the ", (OP*)0" is just to make the compiler
653 * think the expression is of the right type: croak actually does a Siglongjmp.
655 #define CHECKOP(type,o) \
656 ((PL_op_mask && PL_op_mask[type]) \
657 ? ( op_free((OP*)o), \
658 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
660 : PL_check[type](aTHX_ (OP*)o))
662 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
664 #define OpTYPE_set(o,type) \
666 o->op_type = (OPCODE)type; \
667 o->op_ppaddr = PL_ppaddr[type]; \
671 S_no_fh_allowed(pTHX_ OP *o)
673 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
675 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
681 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
683 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
684 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
689 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
691 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
693 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
698 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
700 PERL_ARGS_ASSERT_BAD_TYPE_PV;
702 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
703 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
707 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
709 SV * const namesv = cv_name((CV *)gv, NULL, 0);
710 PERL_ARGS_ASSERT_BAD_TYPE_GV;
712 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
713 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
717 S_no_bareword_allowed(pTHX_ OP *o)
719 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
721 qerror(Perl_mess(aTHX_
722 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
724 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
727 /* "register" allocation */
730 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
733 const bool is_our = (PL_parser->in_my == KEY_our);
735 PERL_ARGS_ASSERT_ALLOCMY;
737 if (flags & ~SVf_UTF8)
738 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
741 /* complain about "my $<special_var>" etc etc */
745 || ( (flags & SVf_UTF8)
746 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
747 || (name[1] == '_' && len > 2)))
749 const char * const type =
750 PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
751 PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
753 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
755 && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) {
756 /* diag_listed_as: Can't use global %s in %s */
757 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
758 name[0], toCTRL(name[1]),
759 (int)(len - 2), name + 2,
762 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
764 type), flags & SVf_UTF8);
768 /* allocate a spare slot and store the name in that slot */
770 off = pad_add_name_pvn(name, len,
771 (is_our ? padadd_OUR :
772 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
773 PL_parser->in_my_stash,
775 /* $_ is always in main::, even with our */
776 ? (PL_curstash && !memEQs(name,len,"$_")
782 /* anon sub prototypes contains state vars should always be cloned,
783 * otherwise the state var would be shared between anon subs */
785 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
786 CvCLONE_on(PL_compcv);
792 =head1 Optree Manipulation Functions
794 =for apidoc alloccopstash
796 Available only under threaded builds, this function allocates an entry in
797 C<PL_stashpad> for the stash passed to it.
804 Perl_alloccopstash(pTHX_ HV *hv)
806 PADOFFSET off = 0, o = 1;
807 bool found_slot = FALSE;
809 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
811 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
813 for (; o < PL_stashpadmax; ++o) {
814 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
815 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
816 found_slot = TRUE, off = o;
819 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
820 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
821 off = PL_stashpadmax;
822 PL_stashpadmax += 10;
825 PL_stashpad[PL_stashpadix = off] = hv;
830 /* free the body of an op without examining its contents.
831 * Always use this rather than FreeOp directly */
834 S_op_destroy(pTHX_ OP *o)
844 Free an op and its children. Only use this when an op is no longer linked
851 Perl_op_free(pTHX_ OP *o)
856 bool went_up = FALSE; /* whether we reached the current node by
857 following the parent pointer from a child, and
858 so have already seen this node */
860 if (!o || o->op_type == OP_FREED)
863 if (o->op_private & OPpREFCOUNTED) {
864 /* if base of tree is refcounted, just decrement */
865 switch (o->op_type) {
875 refcnt = OpREFCNT_dec(o);
878 /* Need to find and remove any pattern match ops from
879 * the list we maintain for reset(). */
880 find_and_forget_pmops(o);
893 /* free child ops before ourself, (then free ourself "on the
896 if (!went_up && o->op_flags & OPf_KIDS) {
897 next_op = cUNOPo->op_first;
901 /* find the next node to visit, *then* free the current node
902 * (can't rely on o->op_* fields being valid after o has been
905 /* The next node to visit will be either the sibling, or the
906 * parent if no siblings left, or NULL if we've worked our way
907 * back up to the top node in the tree */
908 next_op = (o == top_op) ? NULL : o->op_sibparent;
909 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
911 /* Now process the current node */
913 /* Though ops may be freed twice, freeing the op after its slab is a
915 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
916 /* During the forced freeing of ops after compilation failure, kidops
917 may be freed before their parents. */
918 if (!o || o->op_type == OP_FREED)
923 /* an op should only ever acquire op_private flags that we know about.
924 * If this fails, you may need to fix something in regen/op_private.
925 * Don't bother testing if:
926 * * the op_ppaddr doesn't match the op; someone may have
927 * overridden the op and be doing strange things with it;
928 * * we've errored, as op flags are often left in an
929 * inconsistent state then. Note that an error when
930 * compiling the main program leaves PL_parser NULL, so
931 * we can't spot faults in the main code, only
932 * evaled/required code */
934 if ( o->op_ppaddr == PL_ppaddr[type]
936 && !PL_parser->error_count)
938 assert(!(o->op_private & ~PL_op_private_valid[type]));
943 /* Call the op_free hook if it has been set. Do it now so that it's called
944 * at the right time for refcounted ops, but still before all of the kids
949 type = (OPCODE)o->op_targ;
952 Slab_to_rw(OpSLAB(o));
954 /* COP* is not cleared by op_clear() so that we may track line
955 * numbers etc even after null() */
956 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
968 /* S_op_clear_gv(): free a GV attached to an OP */
972 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
974 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
978 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
979 || o->op_type == OP_MULTIDEREF)
982 ? ((GV*)PAD_SVl(*ixp)) : NULL;
984 ? (GV*)(*svp) : NULL;
986 /* It's possible during global destruction that the GV is freed
987 before the optree. Whilst the SvREFCNT_inc is happy to bump from
988 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
989 will trigger an assertion failure, because the entry to sv_clear
990 checks that the scalar is not already freed. A check of for
991 !SvIS_FREED(gv) turns out to be invalid, because during global
992 destruction the reference count can be forced down to zero
993 (with SVf_BREAK set). In which case raising to 1 and then
994 dropping to 0 triggers cleanup before it should happen. I
995 *think* that this might actually be a general, systematic,
996 weakness of the whole idea of SVf_BREAK, in that code *is*
997 allowed to raise and lower references during global destruction,
998 so any *valid* code that happens to do this during global
999 destruction might well trigger premature cleanup. */
1000 bool still_valid = gv && SvREFCNT(gv);
1003 SvREFCNT_inc_simple_void(gv);
1006 pad_swipe(*ixp, TRUE);
1014 int try_downgrade = SvREFCNT(gv) == 2;
1015 SvREFCNT_dec_NN(gv);
1017 gv_try_downgrade(gv);
1023 Perl_op_clear(pTHX_ OP *o)
1027 PERL_ARGS_ASSERT_OP_CLEAR;
1029 switch (o->op_type) {
1030 case OP_NULL: /* Was holding old type, if any. */
1033 case OP_ENTEREVAL: /* Was holding hints. */
1034 case OP_ARGDEFELEM: /* Was holding signature index. */
1038 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1045 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1047 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1050 case OP_METHOD_REDIR:
1051 case OP_METHOD_REDIR_SUPER:
1053 if (cMETHOPx(o)->op_rclass_targ) {
1054 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1055 cMETHOPx(o)->op_rclass_targ = 0;
1058 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1059 cMETHOPx(o)->op_rclass_sv = NULL;
1062 case OP_METHOD_NAMED:
1063 case OP_METHOD_SUPER:
1064 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1065 cMETHOPx(o)->op_u.op_meth_sv = NULL;
1068 pad_swipe(o->op_targ, 1);
1075 SvREFCNT_dec(cSVOPo->op_sv);
1076 cSVOPo->op_sv = NULL;
1079 Even if op_clear does a pad_free for the target of the op,
1080 pad_free doesn't actually remove the sv that exists in the pad;
1081 instead it lives on. This results in that it could be reused as
1082 a target later on when the pad was reallocated.
1085 pad_swipe(o->op_targ,1);
1095 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1100 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1101 && (o->op_private & OPpTRANS_USE_SVOP))
1104 if (cPADOPo->op_padix > 0) {
1105 pad_swipe(cPADOPo->op_padix, TRUE);
1106 cPADOPo->op_padix = 0;
1109 SvREFCNT_dec(cSVOPo->op_sv);
1110 cSVOPo->op_sv = NULL;
1114 PerlMemShared_free(cPVOPo->op_pv);
1115 cPVOPo->op_pv = NULL;
1119 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1123 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1124 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1126 if (o->op_private & OPpSPLIT_LEX)
1127 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1130 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1132 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1139 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1140 op_free(cPMOPo->op_code_list);
1141 cPMOPo->op_code_list = NULL;
1142 forget_pmop(cPMOPo);
1143 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1144 /* we use the same protection as the "SAFE" version of the PM_ macros
1145 * here since sv_clean_all might release some PMOPs
1146 * after PL_regex_padav has been cleared
1147 * and the clearing of PL_regex_padav needs to
1148 * happen before sv_clean_all
1151 if(PL_regex_pad) { /* We could be in destruction */
1152 const IV offset = (cPMOPo)->op_pmoffset;
1153 ReREFCNT_dec(PM_GETRE(cPMOPo));
1154 PL_regex_pad[offset] = &PL_sv_undef;
1155 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1159 ReREFCNT_dec(PM_GETRE(cPMOPo));
1160 PM_SETRE(cPMOPo, NULL);
1166 PerlMemShared_free(cUNOP_AUXo->op_aux);
1169 case OP_MULTICONCAT:
1171 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1172 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1173 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1174 * utf8 shared strings */
1175 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1176 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1178 PerlMemShared_free(p1);
1180 PerlMemShared_free(p2);
1181 PerlMemShared_free(aux);
1187 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1188 UV actions = items->uv;
1190 bool is_hash = FALSE;
1193 switch (actions & MDEREF_ACTION_MASK) {
1196 actions = (++items)->uv;
1199 case MDEREF_HV_padhv_helem:
1202 case MDEREF_AV_padav_aelem:
1203 pad_free((++items)->pad_offset);
1206 case MDEREF_HV_gvhv_helem:
1209 case MDEREF_AV_gvav_aelem:
1211 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1213 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1217 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1220 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1222 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1224 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1226 goto do_vivify_rv2xv_elem;
1228 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1231 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1232 pad_free((++items)->pad_offset);
1233 goto do_vivify_rv2xv_elem;
1235 case MDEREF_HV_pop_rv2hv_helem:
1236 case MDEREF_HV_vivify_rv2hv_helem:
1239 do_vivify_rv2xv_elem:
1240 case MDEREF_AV_pop_rv2av_aelem:
1241 case MDEREF_AV_vivify_rv2av_aelem:
1243 switch (actions & MDEREF_INDEX_MASK) {
1244 case MDEREF_INDEX_none:
1247 case MDEREF_INDEX_const:
1251 pad_swipe((++items)->pad_offset, 1);
1253 SvREFCNT_dec((++items)->sv);
1259 case MDEREF_INDEX_padsv:
1260 pad_free((++items)->pad_offset);
1262 case MDEREF_INDEX_gvsv:
1264 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1266 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1271 if (actions & MDEREF_FLAG_last)
1284 actions >>= MDEREF_SHIFT;
1287 /* start of malloc is at op_aux[-1], where the length is
1289 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1294 if (o->op_targ > 0) {
1295 pad_free(o->op_targ);
1301 S_cop_free(pTHX_ COP* cop)
1303 PERL_ARGS_ASSERT_COP_FREE;
1306 if (! specialWARN(cop->cop_warnings))
1307 PerlMemShared_free(cop->cop_warnings);
1308 cophh_free(CopHINTHASH_get(cop));
1309 if (PL_curcop == cop)
1314 S_forget_pmop(pTHX_ PMOP *const o)
1316 HV * const pmstash = PmopSTASH(o);
1318 PERL_ARGS_ASSERT_FORGET_PMOP;
1320 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1321 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1323 PMOP **const array = (PMOP**) mg->mg_ptr;
1324 U32 count = mg->mg_len / sizeof(PMOP**);
1328 if (array[i] == o) {
1329 /* Found it. Move the entry at the end to overwrite it. */
1330 array[i] = array[--count];
1331 mg->mg_len = count * sizeof(PMOP**);
1332 /* Could realloc smaller at this point always, but probably
1333 not worth it. Probably worth free()ing if we're the
1336 Safefree(mg->mg_ptr);
1350 S_find_and_forget_pmops(pTHX_ OP *o)
1354 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1357 switch (o->op_type) {
1362 forget_pmop((PMOP*)o);
1365 if (o->op_flags & OPf_KIDS) {
1366 o = cUNOPo->op_first;
1372 return; /* at top; no parents/siblings to try */
1373 if (OpHAS_SIBLING(o)) {
1374 o = o->op_sibparent; /* process next sibling */
1377 o = o->op_sibparent; /*try parent's next sibling */
1386 Neutralizes an op when it is no longer needed, but is still linked to from
1393 Perl_op_null(pTHX_ OP *o)
1396 PERL_ARGS_ASSERT_OP_NULL;
1398 if (o->op_type == OP_NULL)
1401 o->op_targ = o->op_type;
1402 OpTYPE_set(o, OP_NULL);
1406 Perl_op_refcnt_lock(pTHX)
1407 PERL_TSA_ACQUIRE(PL_op_mutex)
1411 PERL_UNUSED_CONTEXT;
1416 Perl_op_refcnt_unlock(pTHX)
1417 PERL_TSA_RELEASE(PL_op_mutex)
1421 PERL_UNUSED_CONTEXT;
1427 =for apidoc op_sibling_splice
1429 A general function for editing the structure of an existing chain of
1430 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1431 you to delete zero or more sequential nodes, replacing them with zero or
1432 more different nodes. Performs the necessary op_first/op_last
1433 housekeeping on the parent node and op_sibling manipulation on the
1434 children. The last deleted node will be marked as the last node by
1435 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1437 Note that op_next is not manipulated, and nodes are not freed; that is the
1438 responsibility of the caller. It also won't create a new list op for an
1439 empty list etc; use higher-level functions like op_append_elem() for that.
1441 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1442 the splicing doesn't affect the first or last op in the chain.
1444 C<start> is the node preceding the first node to be spliced. Node(s)
1445 following it will be deleted, and ops will be inserted after it. If it is
1446 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1449 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1450 If -1 or greater than or equal to the number of remaining kids, all
1451 remaining kids are deleted.
1453 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1454 If C<NULL>, no nodes are inserted.
1456 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1461 action before after returns
1462 ------ ----- ----- -------
1465 splice(P, A, 2, X-Y-Z) | | B-C
1469 splice(P, NULL, 1, X-Y) | | A
1473 splice(P, NULL, 3, NULL) | | A-B-C
1477 splice(P, B, 0, X-Y) | | NULL
1481 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1482 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1488 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1492 OP *last_del = NULL;
1493 OP *last_ins = NULL;
1496 first = OpSIBLING(start);
1500 first = cLISTOPx(parent)->op_first;
1502 assert(del_count >= -1);
1504 if (del_count && first) {
1506 while (--del_count && OpHAS_SIBLING(last_del))
1507 last_del = OpSIBLING(last_del);
1508 rest = OpSIBLING(last_del);
1509 OpLASTSIB_set(last_del, NULL);
1516 while (OpHAS_SIBLING(last_ins))
1517 last_ins = OpSIBLING(last_ins);
1518 OpMAYBESIB_set(last_ins, rest, NULL);
1524 OpMAYBESIB_set(start, insert, NULL);
1528 cLISTOPx(parent)->op_first = insert;
1530 parent->op_flags |= OPf_KIDS;
1532 parent->op_flags &= ~OPf_KIDS;
1536 /* update op_last etc */
1543 /* ought to use OP_CLASS(parent) here, but that can't handle
1544 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1546 type = parent->op_type;
1547 if (type == OP_CUSTOM) {
1549 type = XopENTRYCUSTOM(parent, xop_class);
1552 if (type == OP_NULL)
1553 type = parent->op_targ;
1554 type = PL_opargs[type] & OA_CLASS_MASK;
1557 lastop = last_ins ? last_ins : start ? start : NULL;
1558 if ( type == OA_BINOP
1559 || type == OA_LISTOP
1563 cLISTOPx(parent)->op_last = lastop;
1566 OpLASTSIB_set(lastop, parent);
1568 return last_del ? first : NULL;
1571 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1575 =for apidoc op_parent
1577 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1583 Perl_op_parent(OP *o)
1585 PERL_ARGS_ASSERT_OP_PARENT;
1586 while (OpHAS_SIBLING(o))
1588 return o->op_sibparent;
1591 /* replace the sibling following start with a new UNOP, which becomes
1592 * the parent of the original sibling; e.g.
1594 * op_sibling_newUNOP(P, A, unop-args...)
1602 * where U is the new UNOP.
1604 * parent and start args are the same as for op_sibling_splice();
1605 * type and flags args are as newUNOP().
1607 * Returns the new UNOP.
1611 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1615 kid = op_sibling_splice(parent, start, 1, NULL);
1616 newop = newUNOP(type, flags, kid);
1617 op_sibling_splice(parent, start, 0, newop);
1622 /* lowest-level newLOGOP-style function - just allocates and populates
1623 * the struct. Higher-level stuff should be done by S_new_logop() /
1624 * newLOGOP(). This function exists mainly to avoid op_first assignment
1625 * being spread throughout this file.
1629 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1633 NewOp(1101, logop, 1, LOGOP);
1634 OpTYPE_set(logop, type);
1635 logop->op_first = first;
1636 logop->op_other = other;
1638 logop->op_flags = OPf_KIDS;
1639 while (kid && OpHAS_SIBLING(kid))
1640 kid = OpSIBLING(kid);
1642 OpLASTSIB_set(kid, (OP*)logop);
1647 /* Contextualizers */
1650 =for apidoc op_contextualize
1652 Applies a syntactic context to an op tree representing an expression.
1653 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1654 or C<G_VOID> to specify the context to apply. The modified op tree
1661 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1663 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1665 case G_SCALAR: return scalar(o);
1666 case G_ARRAY: return list(o);
1667 case G_VOID: return scalarvoid(o);
1669 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1676 =for apidoc op_linklist
1677 This function is the implementation of the L</LINKLIST> macro. It should
1678 not be called directly.
1685 Perl_op_linklist(pTHX_ OP *o)
1692 PERL_ARGS_ASSERT_OP_LINKLIST;
1695 /* Descend down the tree looking for any unprocessed subtrees to
1698 if (o->op_flags & OPf_KIDS) {
1699 o = cUNOPo->op_first;
1702 o->op_next = o; /* leaf node; link to self initially */
1705 /* if we're at the top level, there either weren't any children
1706 * to process, or we've worked our way back to the top. */
1710 /* o is now processed. Next, process any sibling subtrees */
1712 if (OpHAS_SIBLING(o)) {
1717 /* Done all the subtrees at this level. Go back up a level and
1718 * link the parent in with all its (processed) children.
1721 o = o->op_sibparent;
1722 assert(!o->op_next);
1723 prevp = &(o->op_next);
1724 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1726 *prevp = kid->op_next;
1727 prevp = &(kid->op_next);
1728 kid = OpSIBLING(kid);
1736 S_scalarkids(pTHX_ OP *o)
1738 if (o && o->op_flags & OPf_KIDS) {
1740 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1747 S_scalarboolean(pTHX_ OP *o)
1749 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1751 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1752 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1753 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1754 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1755 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1756 if (ckWARN(WARN_SYNTAX)) {
1757 const line_t oldline = CopLINE(PL_curcop);
1759 if (PL_parser && PL_parser->copline != NOLINE) {
1760 /* This ensures that warnings are reported at the first line
1761 of the conditional, not the last. */
1762 CopLINE_set(PL_curcop, PL_parser->copline);
1764 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1765 CopLINE_set(PL_curcop, oldline);
1772 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1775 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1776 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1778 const char funny = o->op_type == OP_PADAV
1779 || o->op_type == OP_RV2AV ? '@' : '%';
1780 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1782 if (cUNOPo->op_first->op_type != OP_GV
1783 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1785 return varname(gv, funny, 0, NULL, 0, subscript_type);
1788 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1793 S_op_varname(pTHX_ const OP *o)
1795 return S_op_varname_subscript(aTHX_ o, 1);
1799 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1800 { /* or not so pretty :-) */
1801 if (o->op_type == OP_CONST) {
1803 if (SvPOK(*retsv)) {
1805 *retsv = sv_newmortal();
1806 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1807 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1809 else if (!SvOK(*retsv))
1812 else *retpv = "...";
1816 S_scalar_slice_warning(pTHX_ const OP *o)
1819 const bool h = o->op_type == OP_HSLICE
1820 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1826 SV *keysv = NULL; /* just to silence compiler warnings */
1827 const char *key = NULL;
1829 if (!(o->op_private & OPpSLICEWARNING))
1831 if (PL_parser && PL_parser->error_count)
1832 /* This warning can be nonsensical when there is a syntax error. */
1835 kid = cLISTOPo->op_first;
1836 kid = OpSIBLING(kid); /* get past pushmark */
1837 /* weed out false positives: any ops that can return lists */
1838 switch (kid->op_type) {
1864 /* Don't warn if we have a nulled list either. */
1865 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1868 assert(OpSIBLING(kid));
1869 name = S_op_varname(aTHX_ OpSIBLING(kid));
1870 if (!name) /* XS module fiddling with the op tree */
1872 S_op_pretty(aTHX_ kid, &keysv, &key);
1873 assert(SvPOK(name));
1874 sv_chop(name,SvPVX(name)+1);
1876 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1877 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1878 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1880 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1881 lbrack, key, rbrack);
1883 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1884 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1885 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1887 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1888 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1893 /* apply scalar context to the o subtree */
1896 Perl_scalar(pTHX_ OP *o)
1901 OP *next_kid = NULL; /* what op (if any) to process next */
1904 /* assumes no premature commitment */
1905 if (!o || (PL_parser && PL_parser->error_count)
1906 || (o->op_flags & OPf_WANT)
1907 || o->op_type == OP_RETURN)
1912 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1914 switch (o->op_type) {
1916 scalar(cBINOPo->op_first);
1917 /* convert what initially looked like a list repeat into a
1918 * scalar repeat, e.g. $s = (1) x $n
1920 if (o->op_private & OPpREPEAT_DOLIST) {
1921 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1922 assert(kid->op_type == OP_PUSHMARK);
1923 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1924 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1925 o->op_private &=~ OPpREPEAT_DOLIST;
1933 /* impose scalar context on everything except the condition */
1934 next_kid = OpSIBLING(cUNOPo->op_first);
1938 if (o->op_flags & OPf_KIDS)
1939 next_kid = cUNOPo->op_first; /* do all kids */
1942 /* the children of these ops are usually a list of statements,
1943 * except the leaves, whose first child is a corresponding enter
1948 kid = cLISTOPo->op_first;
1952 kid = cLISTOPo->op_first;
1954 kid = OpSIBLING(kid);
1957 OP *sib = OpSIBLING(kid);
1958 /* Apply void context to all kids except the last, which
1959 * is scalar (ignoring a trailing ex-nextstate in determining
1960 * if it's the last kid). E.g.
1961 * $scalar = do { void; void; scalar }
1962 * Except that 'when's are always scalar, e.g.
1963 * $scalar = do { given(..) {
1964 * when (..) { scalar }
1965 * when (..) { scalar }
1970 || ( !OpHAS_SIBLING(sib)
1971 && sib->op_type == OP_NULL
1972 && ( sib->op_targ == OP_NEXTSTATE
1973 || sib->op_targ == OP_DBSTATE )
1977 /* tail call optimise calling scalar() on the last kid */
1981 else if (kid->op_type == OP_LEAVEWHEN)
1987 NOT_REACHED; /* NOTREACHED */
1991 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1997 /* Warn about scalar context */
1998 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1999 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
2002 const char *key = NULL;
2004 /* This warning can be nonsensical when there is a syntax error. */
2005 if (PL_parser && PL_parser->error_count)
2008 if (!ckWARN(WARN_SYNTAX)) break;
2010 kid = cLISTOPo->op_first;
2011 kid = OpSIBLING(kid); /* get past pushmark */
2012 assert(OpSIBLING(kid));
2013 name = S_op_varname(aTHX_ OpSIBLING(kid));
2014 if (!name) /* XS module fiddling with the op tree */
2016 S_op_pretty(aTHX_ kid, &keysv, &key);
2017 assert(SvPOK(name));
2018 sv_chop(name,SvPVX(name)+1);
2020 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2021 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2022 "%%%" SVf "%c%s%c in scalar context better written "
2023 "as $%" SVf "%c%s%c",
2024 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
2025 lbrack, key, rbrack);
2027 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2028 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2029 "%%%" SVf "%c%" SVf "%c in scalar context better "
2030 "written as $%" SVf "%c%" SVf "%c",
2031 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
2032 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2036 /* If next_kid is set, someone in the code above wanted us to process
2037 * that kid and all its remaining siblings. Otherwise, work our way
2038 * back up the tree */
2042 return top_op; /* at top; no parents/siblings to try */
2043 if (OpHAS_SIBLING(o))
2044 next_kid = o->op_sibparent;
2046 o = o->op_sibparent; /*try parent's next sibling */
2047 switch (o->op_type) {
2053 /* should really restore PL_curcop to its old value, but
2054 * setting it to PL_compiling is better than do nothing */
2055 PL_curcop = &PL_compiling;
2064 /* apply void context to the optree arg */
2067 Perl_scalarvoid(pTHX_ OP *arg)
2073 PERL_ARGS_ASSERT_SCALARVOID;
2077 SV *useless_sv = NULL;
2078 const char* useless = NULL;
2079 OP * next_kid = NULL;
2081 if (o->op_type == OP_NEXTSTATE
2082 || o->op_type == OP_DBSTATE
2083 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2084 || o->op_targ == OP_DBSTATE)))
2085 PL_curcop = (COP*)o; /* for warning below */
2087 /* assumes no premature commitment */
2088 want = o->op_flags & OPf_WANT;
2089 if ((want && want != OPf_WANT_SCALAR)
2090 || (PL_parser && PL_parser->error_count)
2091 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2096 if ((o->op_private & OPpTARGET_MY)
2097 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2099 /* newASSIGNOP has already applied scalar context, which we
2100 leave, as if this op is inside SASSIGN. */
2104 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2106 switch (o->op_type) {
2108 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2112 if (o->op_flags & OPf_STACKED)
2114 if (o->op_type == OP_REPEAT)
2115 scalar(cBINOPo->op_first);
2118 if ((o->op_flags & OPf_STACKED) &&
2119 !(o->op_private & OPpCONCAT_NESTED))
2123 if (o->op_private == 4)
2158 case OP_GETSOCKNAME:
2159 case OP_GETPEERNAME:
2164 case OP_GETPRIORITY:
2189 useless = OP_DESC(o);
2199 case OP_AELEMFAST_LEX:
2203 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2204 /* Otherwise it's "Useless use of grep iterator" */
2205 useless = OP_DESC(o);
2209 if (!(o->op_private & OPpSPLIT_ASSIGN))
2210 useless = OP_DESC(o);
2214 kid = cUNOPo->op_first;
2215 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2216 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2219 useless = "negative pattern binding (!~)";
2223 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2224 useless = "non-destructive substitution (s///r)";
2228 useless = "non-destructive transliteration (tr///r)";
2235 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2236 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2237 useless = "a variable";
2242 if (cSVOPo->op_private & OPpCONST_STRICT)
2243 no_bareword_allowed(o);
2245 if (ckWARN(WARN_VOID)) {
2247 /* don't warn on optimised away booleans, eg
2248 * use constant Foo, 5; Foo || print; */
2249 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2251 /* the constants 0 and 1 are permitted as they are
2252 conventionally used as dummies in constructs like
2253 1 while some_condition_with_side_effects; */
2254 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2256 else if (SvPOK(sv)) {
2257 SV * const dsv = newSVpvs("");
2259 = Perl_newSVpvf(aTHX_
2261 pv_pretty(dsv, SvPVX_const(sv),
2262 SvCUR(sv), 32, NULL, NULL,
2264 | PERL_PV_ESCAPE_NOCLEAR
2265 | PERL_PV_ESCAPE_UNI_DETECT));
2266 SvREFCNT_dec_NN(dsv);
2268 else if (SvOK(sv)) {
2269 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2272 useless = "a constant (undef)";
2275 op_null(o); /* don't execute or even remember it */
2279 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2283 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2287 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2291 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2296 UNOP *refgen, *rv2cv;
2299 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2302 rv2gv = ((BINOP *)o)->op_last;
2303 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2306 refgen = (UNOP *)((BINOP *)o)->op_first;
2308 if (!refgen || (refgen->op_type != OP_REFGEN
2309 && refgen->op_type != OP_SREFGEN))
2312 exlist = (LISTOP *)refgen->op_first;
2313 if (!exlist || exlist->op_type != OP_NULL
2314 || exlist->op_targ != OP_LIST)
2317 if (exlist->op_first->op_type != OP_PUSHMARK
2318 && exlist->op_first != exlist->op_last)
2321 rv2cv = (UNOP*)exlist->op_last;
2323 if (rv2cv->op_type != OP_RV2CV)
2326 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2327 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2328 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2330 o->op_private |= OPpASSIGN_CV_TO_GV;
2331 rv2gv->op_private |= OPpDONT_INIT_GV;
2332 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2344 kid = cLOGOPo->op_first;
2345 if (kid->op_type == OP_NOT
2346 && (kid->op_flags & OPf_KIDS)) {
2347 if (o->op_type == OP_AND) {
2348 OpTYPE_set(o, OP_OR);
2350 OpTYPE_set(o, OP_AND);
2360 next_kid = OpSIBLING(cUNOPo->op_first);
2364 if (o->op_flags & OPf_STACKED)
2371 if (!(o->op_flags & OPf_KIDS))
2382 next_kid = cLISTOPo->op_first;
2385 /* If the first kid after pushmark is something that the padrange
2386 optimisation would reject, then null the list and the pushmark.
2388 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2389 && ( !(kid = OpSIBLING(kid))
2390 || ( kid->op_type != OP_PADSV
2391 && kid->op_type != OP_PADAV
2392 && kid->op_type != OP_PADHV)
2393 || kid->op_private & ~OPpLVAL_INTRO
2394 || !(kid = OpSIBLING(kid))
2395 || ( kid->op_type != OP_PADSV
2396 && kid->op_type != OP_PADAV
2397 && kid->op_type != OP_PADHV)
2398 || kid->op_private & ~OPpLVAL_INTRO)
2400 op_null(cUNOPo->op_first); /* NULL the pushmark */
2401 op_null(o); /* NULL the list */
2413 /* mortalise it, in case warnings are fatal. */
2414 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2415 "Useless use of %" SVf " in void context",
2416 SVfARG(sv_2mortal(useless_sv)));
2419 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2420 "Useless use of %s in void context",
2425 /* if a kid hasn't been nominated to process, continue with the
2426 * next sibling, or if no siblings left, go back to the parent's
2427 * siblings and so on
2431 return arg; /* at top; no parents/siblings to try */
2432 if (OpHAS_SIBLING(o))
2433 next_kid = o->op_sibparent;
2435 o = o->op_sibparent; /*try parent's next sibling */
2445 S_listkids(pTHX_ OP *o)
2447 if (o && o->op_flags & OPf_KIDS) {
2449 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2456 /* apply list context to the o subtree */
2459 Perl_list(pTHX_ OP *o)
2464 OP *next_kid = NULL; /* what op (if any) to process next */
2468 /* assumes no premature commitment */
2469 if (!o || (o->op_flags & OPf_WANT)
2470 || (PL_parser && PL_parser->error_count)
2471 || o->op_type == OP_RETURN)
2476 if ((o->op_private & OPpTARGET_MY)
2477 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2479 goto do_next; /* As if inside SASSIGN */
2482 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2484 switch (o->op_type) {
2486 if (o->op_private & OPpREPEAT_DOLIST
2487 && !(o->op_flags & OPf_STACKED))
2489 list(cBINOPo->op_first);
2490 kid = cBINOPo->op_last;
2491 /* optimise away (.....) x 1 */
2492 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2493 && SvIVX(kSVOP_sv) == 1)
2495 op_null(o); /* repeat */
2496 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2498 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2506 /* impose list context on everything except the condition */
2507 next_kid = OpSIBLING(cUNOPo->op_first);
2511 if (!(o->op_flags & OPf_KIDS))
2513 /* possibly flatten 1..10 into a constant array */
2514 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2515 list(cBINOPo->op_first);
2516 gen_constant_list(o);
2519 next_kid = cUNOPo->op_first; /* do all kids */
2523 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2524 op_null(cUNOPo->op_first); /* NULL the pushmark */
2525 op_null(o); /* NULL the list */
2527 if (o->op_flags & OPf_KIDS)
2528 next_kid = cUNOPo->op_first; /* do all kids */
2531 /* the children of these ops are usually a list of statements,
2532 * except the leaves, whose first child is a corresponding enter
2536 kid = cLISTOPo->op_first;
2540 kid = cLISTOPo->op_first;
2542 kid = OpSIBLING(kid);
2545 OP *sib = OpSIBLING(kid);
2546 /* Apply void context to all kids except the last, which
2548 * @a = do { void; void; list }
2549 * Except that 'when's are always list context, e.g.
2550 * @a = do { given(..) {
2551 * when (..) { list }
2552 * when (..) { list }
2557 /* tail call optimise calling list() on the last kid */
2561 else if (kid->op_type == OP_LEAVEWHEN)
2567 NOT_REACHED; /* NOTREACHED */
2572 /* If next_kid is set, someone in the code above wanted us to process
2573 * that kid and all its remaining siblings. Otherwise, work our way
2574 * back up the tree */
2578 return top_op; /* at top; no parents/siblings to try */
2579 if (OpHAS_SIBLING(o))
2580 next_kid = o->op_sibparent;
2582 o = o->op_sibparent; /*try parent's next sibling */
2583 switch (o->op_type) {
2589 /* should really restore PL_curcop to its old value, but
2590 * setting it to PL_compiling is better than do nothing */
2591 PL_curcop = &PL_compiling;
2603 S_scalarseq(pTHX_ OP *o)
2606 const OPCODE type = o->op_type;
2608 if (type == OP_LINESEQ || type == OP_SCOPE ||
2609 type == OP_LEAVE || type == OP_LEAVETRY)
2612 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2613 if ((sib = OpSIBLING(kid))
2614 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2615 || ( sib->op_targ != OP_NEXTSTATE
2616 && sib->op_targ != OP_DBSTATE )))
2621 PL_curcop = &PL_compiling;
2623 o->op_flags &= ~OPf_PARENS;
2624 if (PL_hints & HINT_BLOCK_SCOPE)
2625 o->op_flags |= OPf_PARENS;
2628 o = newOP(OP_STUB, 0);
2633 S_modkids(pTHX_ OP *o, I32 type)
2635 if (o && o->op_flags & OPf_KIDS) {
2637 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2638 op_lvalue(kid, type);
2644 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2645 * const fields. Also, convert CONST keys to HEK-in-SVs.
2646 * rop is the op that retrieves the hash;
2647 * key_op is the first key
2648 * real if false, only check (and possibly croak); don't update op
2652 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2658 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2660 if (rop->op_first->op_type == OP_PADSV)
2661 /* @$hash{qw(keys here)} */
2662 rop = (UNOP*)rop->op_first;
2664 /* @{$hash}{qw(keys here)} */
2665 if (rop->op_first->op_type == OP_SCOPE
2666 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2668 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2675 lexname = NULL; /* just to silence compiler warnings */
2676 fields = NULL; /* just to silence compiler warnings */
2680 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2681 SvPAD_TYPED(lexname))
2682 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2683 && isGV(*fields) && GvHV(*fields);
2685 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2687 if (key_op->op_type != OP_CONST)
2689 svp = cSVOPx_svp(key_op);
2691 /* make sure it's not a bareword under strict subs */
2692 if (key_op->op_private & OPpCONST_BARE &&
2693 key_op->op_private & OPpCONST_STRICT)
2695 no_bareword_allowed((OP*)key_op);
2698 /* Make the CONST have a shared SV */
2699 if ( !SvIsCOW_shared_hash(sv = *svp)
2700 && SvTYPE(sv) < SVt_PVMG
2706 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2707 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2708 SvREFCNT_dec_NN(sv);
2713 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2715 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2716 "in variable %" PNf " of type %" HEKf,
2717 SVfARG(*svp), PNfARG(lexname),
2718 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2723 /* info returned by S_sprintf_is_multiconcatable() */
2725 struct sprintf_ismc_info {
2726 SSize_t nargs; /* num of args to sprintf (not including the format) */
2727 char *start; /* start of raw format string */
2728 char *end; /* bytes after end of raw format string */
2729 STRLEN total_len; /* total length (in bytes) of format string, not
2730 including '%s' and half of '%%' */
2731 STRLEN variant; /* number of bytes by which total_len_p would grow
2732 if upgraded to utf8 */
2733 bool utf8; /* whether the format is utf8 */
2737 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2738 * i.e. its format argument is a const string with only '%s' and '%%'
2739 * formats, and the number of args is known, e.g.
2740 * sprintf "a=%s f=%s", $a[0], scalar(f());
2742 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2744 * If successful, the sprintf_ismc_info struct pointed to by info will be
2749 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2751 OP *pm, *constop, *kid;
2754 SSize_t nargs, nformats;
2755 STRLEN cur, total_len, variant;
2758 /* if sprintf's behaviour changes, die here so that someone
2759 * can decide whether to enhance this function or skip optimising
2760 * under those new circumstances */
2761 assert(!(o->op_flags & OPf_STACKED));
2762 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2763 assert(!(o->op_private & ~OPpARG4_MASK));
2765 pm = cUNOPo->op_first;
2766 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2768 constop = OpSIBLING(pm);
2769 if (!constop || constop->op_type != OP_CONST)
2771 sv = cSVOPx_sv(constop);
2772 if (SvMAGICAL(sv) || !SvPOK(sv))
2778 /* Scan format for %% and %s and work out how many %s there are.
2779 * Abandon if other format types are found.
2786 for (p = s; p < e; p++) {
2789 if (!UTF8_IS_INVARIANT(*p))
2795 return FALSE; /* lone % at end gives "Invalid conversion" */
2804 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2807 utf8 = cBOOL(SvUTF8(sv));
2811 /* scan args; they must all be in scalar cxt */
2814 kid = OpSIBLING(constop);
2817 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2820 kid = OpSIBLING(kid);
2823 if (nargs != nformats)
2824 return FALSE; /* e.g. sprintf("%s%s", $a); */
2827 info->nargs = nargs;
2830 info->total_len = total_len;
2831 info->variant = variant;
2839 /* S_maybe_multiconcat():
2841 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2842 * convert it (and its children) into an OP_MULTICONCAT. See the code
2843 * comments just before pp_multiconcat() for the full details of what
2844 * OP_MULTICONCAT supports.
2846 * Basically we're looking for an optree with a chain of OP_CONCATS down
2847 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2848 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2856 * STRINGIFY -- PADSV[$x]
2859 * ex-PUSHMARK -- CONCAT/S
2861 * CONCAT/S -- PADSV[$d]
2863 * CONCAT -- CONST["-"]
2865 * PADSV[$a] -- PADSV[$b]
2867 * Note that at this stage the OP_SASSIGN may have already been optimised
2868 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2872 S_maybe_multiconcat(pTHX_ OP *o)
2874 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2875 OP *topop; /* the top-most op in the concat tree (often equals o,
2876 unless there are assign/stringify ops above it */
2877 OP *parentop; /* the parent op of topop (or itself if no parent) */
2878 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2879 OP *targetop; /* the op corresponding to target=... or target.=... */
2880 OP *stringop; /* the OP_STRINGIFY op, if any */
2881 OP *nextop; /* used for recreating the op_next chain without consts */
2882 OP *kid; /* general-purpose op pointer */
2884 UNOP_AUX_item *lenp;
2885 char *const_str, *p;
2886 struct sprintf_ismc_info sprintf_info;
2888 /* store info about each arg in args[];
2889 * toparg is the highest used slot; argp is a general
2890 * pointer to args[] slots */
2892 void *p; /* initially points to const sv (or null for op);
2893 later, set to SvPV(constsv), with ... */
2894 STRLEN len; /* ... len set to SvPV(..., len) */
2895 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2899 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2902 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2903 the last-processed arg will the LHS of one,
2904 as args are processed in reverse order */
2905 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2906 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2907 U8 flags = 0; /* what will become the op_flags and ... */
2908 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2909 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2910 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2911 bool prev_was_const = FALSE; /* previous arg was a const */
2913 /* -----------------------------------------------------------------
2916 * Examine the optree non-destructively to determine whether it's
2917 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2918 * information about the optree in args[].
2928 assert( o->op_type == OP_SASSIGN
2929 || o->op_type == OP_CONCAT
2930 || o->op_type == OP_SPRINTF
2931 || o->op_type == OP_STRINGIFY);
2933 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2935 /* first see if, at the top of the tree, there is an assign,
2936 * append and/or stringify */
2938 if (topop->op_type == OP_SASSIGN) {
2940 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2942 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2944 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2947 topop = cBINOPo->op_first;
2948 targetop = OpSIBLING(topop);
2949 if (!targetop) /* probably some sort of syntax error */
2952 /* don't optimise away assign in 'local $foo = ....' */
2953 if ( (targetop->op_private & OPpLVAL_INTRO)
2954 /* these are the common ops which do 'local', but
2956 && ( targetop->op_type == OP_GVSV
2957 || targetop->op_type == OP_RV2SV
2958 || targetop->op_type == OP_AELEM
2959 || targetop->op_type == OP_HELEM
2964 else if ( topop->op_type == OP_CONCAT
2965 && (topop->op_flags & OPf_STACKED)
2966 && (!(topop->op_private & OPpCONCAT_NESTED))
2971 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2972 * decide what to do about it */
2973 assert(!(o->op_private & OPpTARGET_MY));
2975 /* barf on unknown flags */
2976 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2977 private_flags |= OPpMULTICONCAT_APPEND;
2978 targetop = cBINOPo->op_first;
2980 topop = OpSIBLING(targetop);
2982 /* $x .= <FOO> gets optimised to rcatline instead */
2983 if (topop->op_type == OP_READLINE)
2988 /* Can targetop (the LHS) if it's a padsv, be optimised
2989 * away and use OPpTARGET_MY instead?
2991 if ( (targetop->op_type == OP_PADSV)
2992 && !(targetop->op_private & OPpDEREF)
2993 && !(targetop->op_private & OPpPAD_STATE)
2994 /* we don't support 'my $x .= ...' */
2995 && ( o->op_type == OP_SASSIGN
2996 || !(targetop->op_private & OPpLVAL_INTRO))
3001 if (topop->op_type == OP_STRINGIFY) {
3002 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
3006 /* barf on unknown flags */
3007 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
3009 if ((topop->op_private & OPpTARGET_MY)) {
3010 if (o->op_type == OP_SASSIGN)
3011 return; /* can't have two assigns */
3015 private_flags |= OPpMULTICONCAT_STRINGIFY;
3017 topop = cBINOPx(topop)->op_first;
3018 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
3019 topop = OpSIBLING(topop);
3022 if (topop->op_type == OP_SPRINTF) {
3023 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
3025 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
3026 nargs = sprintf_info.nargs;
3027 total_len = sprintf_info.total_len;
3028 variant = sprintf_info.variant;
3029 utf8 = sprintf_info.utf8;
3031 private_flags |= OPpMULTICONCAT_FAKE;
3033 /* we have an sprintf op rather than a concat optree.
3034 * Skip most of the code below which is associated with
3035 * processing that optree. We also skip phase 2, determining
3036 * whether its cost effective to optimise, since for sprintf,
3037 * multiconcat is *always* faster */
3040 /* note that even if the sprintf itself isn't multiconcatable,
3041 * the expression as a whole may be, e.g. in
3042 * $x .= sprintf("%d",...)
3043 * the sprintf op will be left as-is, but the concat/S op may
3044 * be upgraded to multiconcat
3047 else if (topop->op_type == OP_CONCAT) {
3048 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
3051 if ((topop->op_private & OPpTARGET_MY)) {
3052 if (o->op_type == OP_SASSIGN || targmyop)
3053 return; /* can't have two assigns */
3058 /* Is it safe to convert a sassign/stringify/concat op into
3060 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
3061 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
3062 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3063 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
3064 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
3065 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3066 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
3067 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3069 /* Now scan the down the tree looking for a series of
3070 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3071 * stacked). For example this tree:
3076 * CONCAT/STACKED -- EXPR5
3078 * CONCAT/STACKED -- EXPR4
3084 * corresponds to an expression like
3086 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3088 * Record info about each EXPR in args[]: in particular, whether it is
3089 * a stringifiable OP_CONST and if so what the const sv is.
3091 * The reason why the last concat can't be STACKED is the difference
3094 * ((($a .= $a) .= $a) .= $a) .= $a
3097 * $a . $a . $a . $a . $a
3099 * The main difference between the optrees for those two constructs
3100 * is the presence of the last STACKED. As well as modifying $a,
3101 * the former sees the changed $a between each concat, so if $s is
3102 * initially 'a', the first returns 'a' x 16, while the latter returns
3103 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3113 if ( kid->op_type == OP_CONCAT
3117 k1 = cUNOPx(kid)->op_first;
3119 /* shouldn't happen except maybe after compile err? */
3123 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3124 if (kid->op_private & OPpTARGET_MY)
3127 stacked_last = (kid->op_flags & OPf_STACKED);
3139 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3140 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3142 /* At least two spare slots are needed to decompose both
3143 * concat args. If there are no slots left, continue to
3144 * examine the rest of the optree, but don't push new values
3145 * on args[]. If the optree as a whole is legal for conversion
3146 * (in particular that the last concat isn't STACKED), then
3147 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3148 * can be converted into an OP_MULTICONCAT now, with the first
3149 * child of that op being the remainder of the optree -
3150 * which may itself later be converted to a multiconcat op
3154 /* the last arg is the rest of the optree */
3159 else if ( argop->op_type == OP_CONST
3160 && ((sv = cSVOPx_sv(argop)))
3161 /* defer stringification until runtime of 'constant'
3162 * things that might stringify variantly, e.g. the radix
3163 * point of NVs, or overloaded RVs */
3164 && (SvPOK(sv) || SvIOK(sv))
3165 && (!SvGMAGICAL(sv))
3167 if (argop->op_private & OPpCONST_STRICT)
3168 no_bareword_allowed(argop);
3170 utf8 |= cBOOL(SvUTF8(sv));
3173 /* this const may be demoted back to a plain arg later;
3174 * make sure we have enough arg slots left */
3176 prev_was_const = !prev_was_const;
3181 prev_was_const = FALSE;
3191 return; /* we don't support ((A.=B).=C)...) */
3193 /* look for two adjacent consts and don't fold them together:
3196 * $o->concat("a")->concat("b")
3199 * (but $o .= "a" . "b" should still fold)
3202 bool seen_nonconst = FALSE;
3203 for (argp = toparg; argp >= args; argp--) {
3204 if (argp->p == NULL) {
3205 seen_nonconst = TRUE;
3211 /* both previous and current arg were constants;
3212 * leave the current OP_CONST as-is */
3220 /* -----------------------------------------------------------------
3223 * At this point we have determined that the optree *can* be converted
3224 * into a multiconcat. Having gathered all the evidence, we now decide
3225 * whether it *should*.
3229 /* we need at least one concat action, e.g.:
3235 * otherwise we could be doing something like $x = "foo", which
3236 * if treated as a concat, would fail to COW.
3238 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3241 /* Benchmarking seems to indicate that we gain if:
3242 * * we optimise at least two actions into a single multiconcat
3243 * (e.g concat+concat, sassign+concat);
3244 * * or if we can eliminate at least 1 OP_CONST;
3245 * * or if we can eliminate a padsv via OPpTARGET_MY
3249 /* eliminated at least one OP_CONST */
3251 /* eliminated an OP_SASSIGN */
3252 || o->op_type == OP_SASSIGN
3253 /* eliminated an OP_PADSV */
3254 || (!targmyop && is_targable)
3256 /* definitely a net gain to optimise */
3259 /* ... if not, what else? */
3261 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3262 * multiconcat is faster (due to not creating a temporary copy of
3263 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3269 && topop->op_type == OP_CONCAT
3271 PADOFFSET t = targmyop->op_targ;
3272 OP *k1 = cBINOPx(topop)->op_first;
3273 OP *k2 = cBINOPx(topop)->op_last;
3274 if ( k2->op_type == OP_PADSV
3276 && ( k1->op_type != OP_PADSV
3277 || k1->op_targ != t)
3282 /* need at least two concats */
3283 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3288 /* -----------------------------------------------------------------
3291 * At this point the optree has been verified as ok to be optimised
3292 * into an OP_MULTICONCAT. Now start changing things.
3297 /* stringify all const args and determine utf8ness */
3300 for (argp = args; argp <= toparg; argp++) {
3301 SV *sv = (SV*)argp->p;
3303 continue; /* not a const op */
3304 if (utf8 && !SvUTF8(sv))
3305 sv_utf8_upgrade_nomg(sv);
3306 argp->p = SvPV_nomg(sv, argp->len);
3307 total_len += argp->len;
3309 /* see if any strings would grow if converted to utf8 */
3311 variant += variant_under_utf8_count((U8 *) argp->p,
3312 (U8 *) argp->p + argp->len);
3316 /* create and populate aux struct */
3320 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3321 sizeof(UNOP_AUX_item)
3323 PERL_MULTICONCAT_HEADER_SIZE
3324 + ((nargs + 1) * (variant ? 2 : 1))
3327 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3329 /* Extract all the non-const expressions from the concat tree then
3330 * dispose of the old tree, e.g. convert the tree from this:
3334 * STRINGIFY -- TARGET
3336 * ex-PUSHMARK -- CONCAT
3351 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3353 * except that if EXPRi is an OP_CONST, it's discarded.
3355 * During the conversion process, EXPR ops are stripped from the tree
3356 * and unshifted onto o. Finally, any of o's remaining original
3357 * childen are discarded and o is converted into an OP_MULTICONCAT.
3359 * In this middle of this, o may contain both: unshifted args on the
3360 * left, and some remaining original args on the right. lastkidop
3361 * is set to point to the right-most unshifted arg to delineate
3362 * between the two sets.
3367 /* create a copy of the format with the %'s removed, and record
3368 * the sizes of the const string segments in the aux struct */
3370 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3372 p = sprintf_info.start;
3375 for (; p < sprintf_info.end; p++) {
3379 (lenp++)->ssize = q - oldq;
3386 lenp->ssize = q - oldq;
3387 assert((STRLEN)(q - const_str) == total_len);
3389 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3390 * may or may not be topop) The pushmark and const ops need to be
3391 * kept in case they're an op_next entry point.
3393 lastkidop = cLISTOPx(topop)->op_last;
3394 kid = cUNOPx(topop)->op_first; /* pushmark */
3396 op_null(OpSIBLING(kid)); /* const */
3398 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3399 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3400 lastkidop->op_next = o;
3405 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3409 /* Concatenate all const strings into const_str.
3410 * Note that args[] contains the RHS args in reverse order, so
3411 * we scan args[] from top to bottom to get constant strings
3414 for (argp = toparg; argp >= args; argp--) {
3416 /* not a const op */
3417 (++lenp)->ssize = -1;
3419 STRLEN l = argp->len;
3420 Copy(argp->p, p, l, char);
3422 if (lenp->ssize == -1)
3433 for (argp = args; argp <= toparg; argp++) {
3434 /* only keep non-const args, except keep the first-in-next-chain
3435 * arg no matter what it is (but nulled if OP_CONST), because it
3436 * may be the entry point to this subtree from the previous
3439 bool last = (argp == toparg);
3442 /* set prev to the sibling *before* the arg to be cut out,
3443 * e.g. when cutting EXPR:
3448 * prev= CONCAT -- EXPR
3451 if (argp == args && kid->op_type != OP_CONCAT) {
3452 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3453 * so the expression to be cut isn't kid->op_last but
3456 /* find the op before kid */
3458 o2 = cUNOPx(parentop)->op_first;
3459 while (o2 && o2 != kid) {
3467 else if (kid == o && lastkidop)
3468 prev = last ? lastkidop : OpSIBLING(lastkidop);
3470 prev = last ? NULL : cUNOPx(kid)->op_first;
3472 if (!argp->p || last) {
3474 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3475 /* and unshift to front of o */
3476 op_sibling_splice(o, NULL, 0, aop);
3477 /* record the right-most op added to o: later we will
3478 * free anything to the right of it */
3481 aop->op_next = nextop;
3484 /* null the const at start of op_next chain */
3488 nextop = prev->op_next;
3491 /* the last two arguments are both attached to the same concat op */
3492 if (argp < toparg - 1)
3497 /* Populate the aux struct */
3499 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3500 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3501 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3502 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3503 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3505 /* if variant > 0, calculate a variant const string and lengths where
3506 * the utf8 version of the string will take 'variant' more bytes than
3510 char *p = const_str;
3511 STRLEN ulen = total_len + variant;
3512 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3513 UNOP_AUX_item *ulens = lens + (nargs + 1);
3514 char *up = (char*)PerlMemShared_malloc(ulen);
3517 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3518 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3520 for (n = 0; n < (nargs + 1); n++) {
3522 char * orig_up = up;
3523 for (i = (lens++)->ssize; i > 0; i--) {
3525 append_utf8_from_native_byte(c, (U8**)&up);
3527 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3532 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3533 * that op's first child - an ex-PUSHMARK - because the op_next of
3534 * the previous op may point to it (i.e. it's the entry point for
3539 ? op_sibling_splice(o, lastkidop, 1, NULL)
3540 : op_sibling_splice(stringop, NULL, 1, NULL);
3541 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3542 op_sibling_splice(o, NULL, 0, pmop);
3549 * target .= A.B.C...
3555 if (o->op_type == OP_SASSIGN) {
3556 /* Move the target subtree from being the last of o's children
3557 * to being the last of o's preserved children.
3558 * Note the difference between 'target = ...' and 'target .= ...':
3559 * for the former, target is executed last; for the latter,
3562 kid = OpSIBLING(lastkidop);
3563 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3564 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3565 lastkidop->op_next = kid->op_next;
3566 lastkidop = targetop;
3569 /* Move the target subtree from being the first of o's
3570 * original children to being the first of *all* o's children.
3573 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3574 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3577 /* if the RHS of .= doesn't contain a concat (e.g.
3578 * $x .= "foo"), it gets missed by the "strip ops from the
3579 * tree and add to o" loop earlier */
3580 assert(topop->op_type != OP_CONCAT);
3582 /* in e.g. $x .= "$y", move the $y expression
3583 * from being a child of OP_STRINGIFY to being the
3584 * second child of the OP_CONCAT
3586 assert(cUNOPx(stringop)->op_first == topop);
3587 op_sibling_splice(stringop, NULL, 1, NULL);
3588 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3590 assert(topop == OpSIBLING(cBINOPo->op_first));
3599 * my $lex = A.B.C...
3602 * The original padsv op is kept but nulled in case it's the
3603 * entry point for the optree (which it will be for
3606 private_flags |= OPpTARGET_MY;
3607 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3608 o->op_targ = targetop->op_targ;
3609 targetop->op_targ = 0;
3613 flags |= OPf_STACKED;
3615 else if (targmyop) {
3616 private_flags |= OPpTARGET_MY;
3617 if (o != targmyop) {
3618 o->op_targ = targmyop->op_targ;
3619 targmyop->op_targ = 0;
3623 /* detach the emaciated husk of the sprintf/concat optree and free it */
3625 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3631 /* and convert o into a multiconcat */
3633 o->op_flags = (flags|OPf_KIDS|stacked_last
3634 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3635 o->op_private = private_flags;
3636 o->op_type = OP_MULTICONCAT;
3637 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3638 cUNOP_AUXo->op_aux = aux;
3642 /* do all the final processing on an optree (e.g. running the peephole
3643 * optimiser on it), then attach it to cv (if cv is non-null)
3647 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3651 /* XXX for some reason, evals, require and main optrees are
3652 * never attached to their CV; instead they just hang off
3653 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3654 * and get manually freed when appropriate */
3656 startp = &CvSTART(cv);
3658 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3661 optree->op_private |= OPpREFCOUNTED;
3662 OpREFCNT_set(optree, 1);
3663 optimize_optree(optree);
3665 finalize_optree(optree);
3666 S_prune_chain_head(startp);
3669 /* now that optimizer has done its work, adjust pad values */
3670 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3671 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3677 =for apidoc optimize_optree
3679 This function applies some optimisations to the optree in top-down order.
3680 It is called before the peephole optimizer, which processes ops in
3681 execution order. Note that finalize_optree() also does a top-down scan,
3682 but is called *after* the peephole optimizer.
3688 Perl_optimize_optree(pTHX_ OP* o)
3690 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3693 SAVEVPTR(PL_curcop);
3701 /* helper for optimize_optree() which optimises one op then recurses
3702 * to optimise any children.
3706 S_optimize_op(pTHX_ OP* o)
3710 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3713 OP * next_kid = NULL;
3715 assert(o->op_type != OP_FREED);
3717 switch (o->op_type) {
3720 PL_curcop = ((COP*)o); /* for warnings */
3728 S_maybe_multiconcat(aTHX_ o);
3732 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3733 /* we can't assume that op_pmreplroot->op_sibparent == o
3734 * and that it is thus possible to walk back up the tree
3735 * past op_pmreplroot. So, although we try to avoid
3736 * recursing through op trees, do it here. After all,
3737 * there are unlikely to be many nested s///e's within
3738 * the replacement part of a s///e.
3740 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3748 if (o->op_flags & OPf_KIDS)
3749 next_kid = cUNOPo->op_first;
3751 /* if a kid hasn't been nominated to process, continue with the
3752 * next sibling, or if no siblings left, go back to the parent's
3753 * siblings and so on
3757 return; /* at top; no parents/siblings to try */
3758 if (OpHAS_SIBLING(o))
3759 next_kid = o->op_sibparent;
3761 o = o->op_sibparent; /*try parent's next sibling */
3764 /* this label not yet used. Goto here if any code above sets
3774 =for apidoc finalize_optree
3776 This function finalizes the optree. Should be called directly after
3777 the complete optree is built. It does some additional
3778 checking which can't be done in the normal C<ck_>xxx functions and makes
3779 the tree thread-safe.
3784 Perl_finalize_optree(pTHX_ OP* o)
3786 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3789 SAVEVPTR(PL_curcop);
3797 /* Relocate sv to the pad for thread safety.
3798 * Despite being a "constant", the SV is written to,
3799 * for reference counts, sv_upgrade() etc. */
3800 PERL_STATIC_INLINE void
3801 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3804 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3806 ix = pad_alloc(OP_CONST, SVf_READONLY);
3807 SvREFCNT_dec(PAD_SVl(ix));
3808 PAD_SETSV(ix, *svp);
3809 /* XXX I don't know how this isn't readonly already. */
3810 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3817 =for apidoc traverse_op_tree
3819 Return the next op in a depth-first traversal of the op tree,
3820 returning NULL when the traversal is complete.
3822 The initial call must supply the root of the tree as both top and o.
3824 For now it's static, but it may be exposed to the API in the future.
3830 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3833 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3835 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3836 return cUNOPo->op_first;
3838 else if ((sib = OpSIBLING(o))) {
3842 OP *parent = o->op_sibparent;
3843 assert(!(o->op_moresib));
3844 while (parent && parent != top) {
3845 OP *sib = OpSIBLING(parent);
3848 parent = parent->op_sibparent;
3856 S_finalize_op(pTHX_ OP* o)
3859 PERL_ARGS_ASSERT_FINALIZE_OP;
3862 assert(o->op_type != OP_FREED);
3864 switch (o->op_type) {
3867 PL_curcop = ((COP*)o); /* for warnings */
3870 if (OpHAS_SIBLING(o)) {
3871 OP *sib = OpSIBLING(o);
3872 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3873 && ckWARN(WARN_EXEC)
3874 && OpHAS_SIBLING(sib))
3876 const OPCODE type = OpSIBLING(sib)->op_type;
3877 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3878 const line_t oldline = CopLINE(PL_curcop);
3879 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3880 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3881 "Statement unlikely to be reached");
3882 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3883 "\t(Maybe you meant system() when you said exec()?)\n");
3884 CopLINE_set(PL_curcop, oldline);
3891 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3892 GV * const gv = cGVOPo_gv;
3893 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3894 /* XXX could check prototype here instead of just carping */
3895 SV * const sv = sv_newmortal();
3896 gv_efullname3(sv, gv, NULL);
3897 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3898 "%" SVf "() called too early to check prototype",
3905 if (cSVOPo->op_private & OPpCONST_STRICT)
3906 no_bareword_allowed(o);
3910 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3915 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3916 case OP_METHOD_NAMED:
3917 case OP_METHOD_SUPER:
3918 case OP_METHOD_REDIR:
3919 case OP_METHOD_REDIR_SUPER:
3920 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3929 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3932 rop = (UNOP*)((BINOP*)o)->op_first;
3937 S_scalar_slice_warning(aTHX_ o);
3941 kid = OpSIBLING(cLISTOPo->op_first);
3942 if (/* I bet there's always a pushmark... */
3943 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3944 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3949 key_op = (SVOP*)(kid->op_type == OP_CONST
3951 : OpSIBLING(kLISTOP->op_first));
3953 rop = (UNOP*)((LISTOP*)o)->op_last;
3956 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3958 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3962 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3966 S_scalar_slice_warning(aTHX_ o);
3970 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3971 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3979 if (o->op_flags & OPf_KIDS) {
3982 /* check that op_last points to the last sibling, and that
3983 * the last op_sibling/op_sibparent field points back to the
3984 * parent, and that the only ops with KIDS are those which are
3985 * entitled to them */
3986 U32 type = o->op_type;
3990 if (type == OP_NULL) {
3992 /* ck_glob creates a null UNOP with ex-type GLOB
3993 * (which is a list op. So pretend it wasn't a listop */
3994 if (type == OP_GLOB)
3997 family = PL_opargs[type] & OA_CLASS_MASK;
3999 has_last = ( family == OA_BINOP
4000 || family == OA_LISTOP
4001 || family == OA_PMOP
4002 || family == OA_LOOP
4004 assert( has_last /* has op_first and op_last, or ...
4005 ... has (or may have) op_first: */
4006 || family == OA_UNOP
4007 || family == OA_UNOP_AUX
4008 || family == OA_LOGOP
4009 || family == OA_BASEOP_OR_UNOP
4010 || family == OA_FILESTATOP
4011 || family == OA_LOOPEXOP
4012 || family == OA_METHOP
4013 || type == OP_CUSTOM
4014 || type == OP_NULL /* new_logop does this */
4017 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
4018 if (!OpHAS_SIBLING(kid)) {
4020 assert(kid == cLISTOPo->op_last);
4021 assert(kid->op_sibparent == o);
4026 } while (( o = traverse_op_tree(top, o)) != NULL);
4030 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
4033 PadnameLVALUE_on(pn);
4034 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
4036 /* RT #127786: cv can be NULL due to an eval within the DB package
4037 * called from an anon sub - anon subs don't have CvOUTSIDE() set
4038 * unless they contain an eval, but calling eval within DB
4039 * pretends the eval was done in the caller's scope.
4043 assert(CvPADLIST(cv));
4045 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
4046 assert(PadnameLEN(pn));
4047 PadnameLVALUE_on(pn);
4052 S_vivifies(const OPCODE type)
4055 case OP_RV2AV: case OP_ASLICE:
4056 case OP_RV2HV: case OP_KVASLICE:
4057 case OP_RV2SV: case OP_HSLICE:
4058 case OP_AELEMFAST: case OP_KVHSLICE:
4067 /* apply lvalue reference (aliasing) context to the optree o.
4070 * o would be the list ($x,$y) and type would be OP_AASSIGN.
4071 * It may descend and apply this to children too, for example in
4072 * \( $cond ? $x, $y) = (...)
4076 S_lvref(pTHX_ OP *o, I32 type)
4082 switch (o->op_type) {
4084 o = OpSIBLING(cUNOPo->op_first);
4091 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4092 o->op_flags |= OPf_STACKED;
4093 if (o->op_flags & OPf_PARENS) {
4094 if (o->op_private & OPpLVAL_INTRO) {
4095 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4096 "localized parenthesized array in list assignment"));
4100 OpTYPE_set(o, OP_LVAVREF);
4101 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4102 o->op_flags |= OPf_MOD|OPf_REF;
4105 o->op_private |= OPpLVREF_AV;
4109 kid = cUNOPo->op_first;
4110 if (kid->op_type == OP_NULL)
4111 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4113 o->op_private = OPpLVREF_CV;
4114 if (kid->op_type == OP_GV)
4115 o->op_flags |= OPf_STACKED;
4116 else if (kid->op_type == OP_PADCV) {
4117 o->op_targ = kid->op_targ;
4119 op_free(cUNOPo->op_first);
4120 cUNOPo->op_first = NULL;
4121 o->op_flags &=~ OPf_KIDS;
4127 if (o->op_flags & OPf_PARENS) {
4129 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4130 "parenthesized hash in list assignment"));
4133 o->op_private |= OPpLVREF_HV;
4137 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4138 o->op_flags |= OPf_STACKED;
4142 if (o->op_flags & OPf_PARENS) goto parenhash;
4143 o->op_private |= OPpLVREF_HV;
4146 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4150 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4151 if (o->op_flags & OPf_PARENS) goto slurpy;
4152 o->op_private |= OPpLVREF_AV;
4157 o->op_private |= OPpLVREF_ELEM;
4158 o->op_flags |= OPf_STACKED;
4163 OpTYPE_set(o, OP_LVREFSLICE);
4164 o->op_private &= OPpLVAL_INTRO;
4168 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4170 else if (!(o->op_flags & OPf_KIDS))
4173 /* the code formerly only recursed into the first child of
4174 * a non ex-list OP_NULL. if we ever encounter such a null op with
4175 * more than one child, need to decide whether its ok to process
4176 * *all* its kids or not */
4177 assert(o->op_targ == OP_LIST
4178 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4181 o = cLISTOPo->op_first;
4185 if (o->op_flags & OPf_PARENS)
4190 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4191 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4192 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4199 OpTYPE_set(o, OP_LVREF);
4201 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4202 if (type == OP_ENTERLOOP)
4203 o->op_private |= OPpLVREF_ITER;
4208 return; /* at top; no parents/siblings to try */
4209 if (OpHAS_SIBLING(o)) {
4210 o = o->op_sibparent;
4213 o = o->op_sibparent; /*try parent's next sibling */
4219 PERL_STATIC_INLINE bool
4220 S_potential_mod_type(I32 type)
4222 /* Types that only potentially result in modification. */
4223 return type == OP_GREPSTART || type == OP_ENTERSUB
4224 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4229 =for apidoc op_lvalue
4231 Propagate lvalue ("modifiable") context to an op and its children.
4232 C<type> represents the context type, roughly based on the type of op that
4233 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4234 because it has no op type of its own (it is signalled by a flag on
4237 This function detects things that can't be modified, such as C<$x+1>, and
4238 generates errors for them. For example, C<$x+1 = 2> would cause it to be
4239 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4241 It also flags things that need to behave specially in an lvalue context,
4242 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4246 Perl_op_lvalue_flags() is a non-API lower-level interface to
4247 op_lvalue(). The flags param has these bits:
4248 OP_LVALUE_NO_CROAK: return rather than croaking on error
4253 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4257 if (!o || (PL_parser && PL_parser->error_count))
4262 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4264 OP *next_kid = NULL;
4266 if ((o->op_private & OPpTARGET_MY)
4267 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4272 /* elements of a list might be in void context because the list is
4273 in scalar context or because they are attribute sub calls */
4274 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4277 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4279 switch (o->op_type) {
4285 if ((o->op_flags & OPf_PARENS))
4290 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4291 !(o->op_flags & OPf_STACKED)) {
4292 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4293 assert(cUNOPo->op_first->op_type == OP_NULL);
4294 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4297 else { /* lvalue subroutine call */
4298 o->op_private |= OPpLVAL_INTRO;
4299 PL_modcount = RETURN_UNLIMITED_NUMBER;
4300 if (S_potential_mod_type(type)) {
4301 o->op_private |= OPpENTERSUB_INARGS;
4304 else { /* Compile-time error message: */
4305 OP *kid = cUNOPo->op_first;
4310 if (kid->op_type != OP_PUSHMARK) {
4311 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4313 "panic: unexpected lvalue entersub "
4314 "args: type/targ %ld:%" UVuf,
4315 (long)kid->op_type, (UV)kid->op_targ);
4316 kid = kLISTOP->op_first;
4318 while (OpHAS_SIBLING(kid))
4319 kid = OpSIBLING(kid);
4320 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4321 break; /* Postpone until runtime */
4324 kid = kUNOP->op_first;
4325 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4326 kid = kUNOP->op_first;
4327 if (kid->op_type == OP_NULL)
4329 "Unexpected constant lvalue entersub "
4330 "entry via type/targ %ld:%" UVuf,
4331 (long)kid->op_type, (UV)kid->op_targ);
4332 if (kid->op_type != OP_GV) {
4339 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4340 ? MUTABLE_CV(SvRV(gv))
4346 if (flags & OP_LVALUE_NO_CROAK)
4349 namesv = cv_name(cv, NULL, 0);
4350 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4351 "subroutine call of &%" SVf " in %s",
4352 SVfARG(namesv), PL_op_desc[type]),
4360 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4361 /* grep, foreach, subcalls, refgen */
4362 if (S_potential_mod_type(type))
4364 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4365 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4368 type ? PL_op_desc[type] : "local"));
4381 case OP_RIGHT_SHIFT:
4390 if (!(o->op_flags & OPf_STACKED))
4396 if (o->op_flags & OPf_STACKED) {
4400 if (!(o->op_private & OPpREPEAT_DOLIST))
4403 const I32 mods = PL_modcount;
4404 /* we recurse rather than iterate here because we need to
4405 * calculate and use the delta applied to PL_modcount by the
4406 * first child. So in something like
4407 * ($x, ($y) x 3) = split;
4408 * split knows that 4 elements are wanted
4410 modkids(cBINOPo->op_first, type);
4411 if (type != OP_AASSIGN)
4413 kid = cBINOPo->op_last;
4414 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4415 const IV iv = SvIV(kSVOP_sv);
4416 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4418 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4421 PL_modcount = RETURN_UNLIMITED_NUMBER;
4427 next_kid = OpSIBLING(cUNOPo->op_first);
4432 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4433 PL_modcount = RETURN_UNLIMITED_NUMBER;
4434 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4435 fiable since some contexts need to know. */
4436 o->op_flags |= OPf_MOD;
4441 if (scalar_mod_type(o, type))
4443 ref(cUNOPo->op_first, o->op_type);
4450 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4451 if (type == OP_LEAVESUBLV && (
4452 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4453 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4455 o->op_private |= OPpMAYBE_LVSUB;
4459 PL_modcount = RETURN_UNLIMITED_NUMBER;
4465 if (type == OP_LEAVESUBLV)
4466 o->op_private |= OPpMAYBE_LVSUB;
4470 if (type == OP_LEAVESUBLV
4471 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4472 o->op_private |= OPpMAYBE_LVSUB;
4476 PL_hints |= HINT_BLOCK_SCOPE;
4477 if (type == OP_LEAVESUBLV)
4478 o->op_private |= OPpMAYBE_LVSUB;
4483 ref(cUNOPo->op_first, o->op_type);
4487 PL_hints |= HINT_BLOCK_SCOPE;
4497 case OP_AELEMFAST_LEX:
4504 PL_modcount = RETURN_UNLIMITED_NUMBER;
4505 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4507 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4508 fiable since some contexts need to know. */
4509 o->op_flags |= OPf_MOD;
4512 if (scalar_mod_type(o, type))
4514 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4515 && type == OP_LEAVESUBLV)
4516 o->op_private |= OPpMAYBE_LVSUB;
4520 if (!type) /* local() */
4521 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4522 PNfARG(PAD_COMPNAME(o->op_targ)));
4523 if (!(o->op_private & OPpLVAL_INTRO)
4524 || ( type != OP_SASSIGN && type != OP_AASSIGN
4525 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4526 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4534 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4538 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4544 if (type == OP_LEAVESUBLV)
4545 o->op_private |= OPpMAYBE_LVSUB;
4546 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4547 /* we recurse rather than iterate here because the child
4548 * needs to be processed with a different 'type' parameter */
4550 /* substr and vec */
4551 /* If this op is in merely potential (non-fatal) modifiable
4552 context, then apply OP_ENTERSUB context to
4553 the kid op (to avoid croaking). Other-
4554 wise pass this op’s own type so the correct op is mentioned
4555 in error messages. */
4556 op_lvalue(OpSIBLING(cBINOPo->op_first),
4557 S_potential_mod_type(type)
4565 ref(cBINOPo->op_first, o->op_type);
4566 if (type == OP_ENTERSUB &&
4567 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4568 o->op_private |= OPpLVAL_DEFER;
4569 if (type == OP_LEAVESUBLV)
4570 o->op_private |= OPpMAYBE_LVSUB;
4577 o->op_private |= OPpLVALUE;
4583 if (o->op_flags & OPf_KIDS)
4584 next_kid = cLISTOPo->op_last;
4589 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4591 else if (!(o->op_flags & OPf_KIDS))
4594 if (o->op_targ != OP_LIST) {
4595 OP *sib = OpSIBLING(cLISTOPo->op_first);
4596 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4603 * compared with things like OP_MATCH which have the argument
4609 * so handle specially to correctly get "Can't modify" croaks etc
4612 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4614 /* this should trigger a "Can't modify transliteration" err */
4615 op_lvalue(sib, type);
4617 next_kid = cBINOPo->op_first;
4618 /* we assume OP_NULLs which aren't ex-list have no more than 2
4619 * children. If this assumption is wrong, increase the scan
4621 assert( !OpHAS_SIBLING(next_kid)
4622 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4628 next_kid = cLISTOPo->op_first;
4636 if (type == OP_LEAVESUBLV
4637 || !S_vivifies(cLOGOPo->op_first->op_type))
4638 next_kid = cLOGOPo->op_first;
4639 else if (type == OP_LEAVESUBLV
4640 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4641 next_kid = OpSIBLING(cLOGOPo->op_first);
4645 if (type == OP_NULL) { /* local */
4647 if (!FEATURE_MYREF_IS_ENABLED)
4648 Perl_croak(aTHX_ "The experimental declared_refs "
4649 "feature is not enabled");
4650 Perl_ck_warner_d(aTHX_
4651 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4652 "Declaring references is experimental");
4653 next_kid = cUNOPo->op_first;
4656 if (type != OP_AASSIGN && type != OP_SASSIGN
4657 && type != OP_ENTERLOOP)
4659 /* Don’t bother applying lvalue context to the ex-list. */
4660 kid = cUNOPx(cUNOPo->op_first)->op_first;
4661 assert (!OpHAS_SIBLING(kid));
4664 if (type == OP_NULL) /* local */
4666 if (type != OP_AASSIGN) goto nomod;
4667 kid = cUNOPo->op_first;
4670 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4671 S_lvref(aTHX_ kid, type);
4672 if (!PL_parser || PL_parser->error_count == ec) {
4673 if (!FEATURE_REFALIASING_IS_ENABLED)
4675 "Experimental aliasing via reference not enabled");
4676 Perl_ck_warner_d(aTHX_
4677 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4678 "Aliasing via reference is experimental");
4681 if (o->op_type == OP_REFGEN)
4682 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4687 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4688 /* This is actually @array = split. */
4689 PL_modcount = RETURN_UNLIMITED_NUMBER;
4695 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4699 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4700 their argument is a filehandle; thus \stat(".") should not set
4702 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4705 if (type != OP_LEAVESUBLV)
4706 o->op_flags |= OPf_MOD;
4708 if (type == OP_AASSIGN || type == OP_SASSIGN)
4709 o->op_flags |= OPf_SPECIAL
4710 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4711 else if (!type) { /* local() */
4714 o->op_private |= OPpLVAL_INTRO;
4715 o->op_flags &= ~OPf_SPECIAL;
4716 PL_hints |= HINT_BLOCK_SCOPE;
4721 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4722 "Useless localization of %s", OP_DESC(o));
4725 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4726 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4727 o->op_flags |= OPf_REF;
4732 return top_op; /* at top; no parents/siblings to try */
4733 if (OpHAS_SIBLING(o)) {
4734 next_kid = o->op_sibparent;
4735 if (!OpHAS_SIBLING(next_kid)) {
4736 /* a few node types don't recurse into their second child */
4737 OP *parent = next_kid->op_sibparent;
4738 I32 ptype = parent->op_type;
4739 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
4740 || ( (ptype == OP_AND || ptype == OP_OR)
4741 && (type != OP_LEAVESUBLV
4742 && S_vivifies(next_kid->op_type))
4745 /*try parent's next sibling */
4752 o = o->op_sibparent; /*try parent's next sibling */
4763 S_scalar_mod_type(const OP *o, I32 type)
4768 if (o && o->op_type == OP_RV2GV)
4792 case OP_RIGHT_SHIFT:
4821 S_is_handle_constructor(const OP *o, I32 numargs)
4823 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4825 switch (o->op_type) {
4833 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4846 S_refkids(pTHX_ OP *o, I32 type)
4848 if (o && o->op_flags & OPf_KIDS) {
4850 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4857 /* Apply reference (autovivification) context to the subtree at o.
4859 * push @{expression}, ....;
4860 * o will be the head of 'expression' and type will be OP_RV2AV.
4861 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4863 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4864 * set_op_ref is true.
4866 * Also calls scalar(o).
4870 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4874 PERL_ARGS_ASSERT_DOREF;
4876 if (PL_parser && PL_parser->error_count)
4880 switch (o->op_type) {
4882 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4883 !(o->op_flags & OPf_STACKED)) {
4884 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4885 assert(cUNOPo->op_first->op_type == OP_NULL);
4886 /* disable pushmark */
4887 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4888 o->op_flags |= OPf_SPECIAL;
4890 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4891 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4892 : type == OP_RV2HV ? OPpDEREF_HV
4894 o->op_flags |= OPf_MOD;
4900 o = OpSIBLING(cUNOPo->op_first);
4904 if (type == OP_DEFINED)
4905 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4908 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4909 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4910 : type == OP_RV2HV ? OPpDEREF_HV
4912 o->op_flags |= OPf_MOD;
4914 if (o->op_flags & OPf_KIDS) {
4916 o = cUNOPo->op_first;
4924 o->op_flags |= OPf_REF;
4927 if (type == OP_DEFINED)
4928 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4930 o = cUNOPo->op_first;
4936 o->op_flags |= OPf_REF;
4941 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4943 o = cBINOPo->op_first;
4948 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4949 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4950 : type == OP_RV2HV ? OPpDEREF_HV
4952 o->op_flags |= OPf_MOD;
4955 o = cBINOPo->op_first;
4964 if (!(o->op_flags & OPf_KIDS))
4966 o = cLISTOPo->op_last;
4975 return scalar(top_op); /* at top; no parents/siblings to try */
4976 if (OpHAS_SIBLING(o)) {
4977 o = o->op_sibparent;
4978 /* Normally skip all siblings and go straight to the parent;
4979 * the only op that requires two children to be processed
4980 * is OP_COND_EXPR */
4981 if (!OpHAS_SIBLING(o)
4982 && o->op_sibparent->op_type == OP_COND_EXPR)
4986 o = o->op_sibparent; /*try parent's next sibling */
4993 S_dup_attrlist(pTHX_ OP *o)
4997 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4999 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
5000 * where the first kid is OP_PUSHMARK and the remaining ones
5001 * are OP_CONST. We need to push the OP_CONST values.
5003 if (o->op_type == OP_CONST)
5004 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
5006 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5008 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
5009 if (o->op_type == OP_CONST)
5010 rop = op_append_elem(OP_LIST, rop,
5011 newSVOP(OP_CONST, o->op_flags,
5012 SvREFCNT_inc_NN(cSVOPo->op_sv)));
5019 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
5021 PERL_ARGS_ASSERT_APPLY_ATTRS;
5023 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
5025 /* fake up C<use attributes $pkg,$rv,@attrs> */
5027 #define ATTRSMODULE "attributes"
5028 #define ATTRSMODULE_PM "attributes.pm"
5031 aTHX_ PERL_LOADMOD_IMPORT_OPS,
5032 newSVpvs(ATTRSMODULE),
5034 op_prepend_elem(OP_LIST,
5035 newSVOP(OP_CONST, 0, stashsv),
5036 op_prepend_elem(OP_LIST,
5037 newSVOP(OP_CONST, 0,
5039 dup_attrlist(attrs))));
5044 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
5046 OP *pack, *imop, *arg;
5047 SV *meth, *stashsv, **svp;
5049 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
5054 assert(target->op_type == OP_PADSV ||
5055 target->op_type == OP_PADHV ||
5056 target->op_type == OP_PADAV);
5058 /* Ensure that attributes.pm is loaded. */
5059 /* Don't force the C<use> if we don't need it. */
5060 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
5061 if (svp && *svp != &PL_sv_undef)
5062 NOOP; /* already in %INC */
5064 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5065 newSVpvs(ATTRSMODULE), NULL);
5067 /* Need package name for method call. */
5068 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
5070 /* Build up the real arg-list. */
5071 stashsv = newSVhek(HvNAME_HEK(stash));
5073 arg = newOP(OP_PADSV, 0);
5074 arg->op_targ = target->op_targ;
5075 arg = op_prepend_elem(OP_LIST,
5076 newSVOP(OP_CONST, 0, stashsv),
5077 op_prepend_elem(OP_LIST,
5078 newUNOP(OP_REFGEN, 0,
5080 dup_attrlist(attrs)));
5082 /* Fake up a method call to import */
5083 meth = newSVpvs_share("import");
5084 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
5085 op_append_elem(OP_LIST,
5086 op_prepend_elem(OP_LIST, pack, arg),
5087 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5089 /* Combine the ops. */
5090 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
5094 =notfor apidoc apply_attrs_string
5096 Attempts to apply a list of attributes specified by the C<attrstr> and
5097 C<len> arguments to the subroutine identified by the C<cv> argument which
5098 is expected to be associated with the package identified by the C<stashpv>
5099 argument (see L<attributes>). It gets this wrong, though, in that it
5100 does not correctly identify the boundaries of the individual attribute
5101 specifications within C<attrstr>. This is not really intended for the
5102 public API, but has to be listed here for systems such as AIX which
5103 need an explicit export list for symbols. (It's called from XS code
5104 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
5105 to respect attribute syntax properly would be welcome.
5111 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
5112 const char *attrstr, STRLEN len)
5116 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
5119 len = strlen(attrstr);
5123 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
5125 const char * const sstr = attrstr;
5126 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
5127 attrs = op_append_elem(OP_LIST, attrs,
5128 newSVOP(OP_CONST, 0,
5129 newSVpvn(sstr, attrstr-sstr)));
5133 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5134 newSVpvs(ATTRSMODULE),
5135 NULL, op_prepend_elem(OP_LIST,
5136 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5137 op_prepend_elem(OP_LIST,
5138 newSVOP(OP_CONST, 0,
5139 newRV(MUTABLE_SV(cv))),
5144 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5147 OP *new_proto = NULL;
5152 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5158 if (o->op_type == OP_CONST) {
5159 pv = SvPV(cSVOPo_sv, pvlen);
5160 if (memBEGINs(pv, pvlen, "prototype(")) {
5161 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5162 SV ** const tmpo = cSVOPx_svp(o);
5163 SvREFCNT_dec(cSVOPo_sv);
5168 } else if (o->op_type == OP_LIST) {
5170 assert(o->op_flags & OPf_KIDS);
5171 lasto = cLISTOPo->op_first;
5172 assert(lasto->op_type == OP_PUSHMARK);
5173 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5174 if (o->op_type == OP_CONST) {
5175 pv = SvPV(cSVOPo_sv, pvlen);
5176 if (memBEGINs(pv, pvlen, "prototype(")) {
5177 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5178 SV ** const tmpo = cSVOPx_svp(o);
5179 SvREFCNT_dec(cSVOPo_sv);
5181 if (new_proto && ckWARN(WARN_MISC)) {
5183 const char * newp = SvPV(cSVOPo_sv, new_len);
5184 Perl_warner(aTHX_ packWARN(WARN_MISC),
5185 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5186 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5192 /* excise new_proto from the list */
5193 op_sibling_splice(*attrs, lasto, 1, NULL);
5200 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5201 would get pulled in with no real need */
5202 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5211 svname = sv_newmortal();
5212 gv_efullname3(svname, name, NULL);
5214 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5215 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5217 svname = (SV *)name;
5218 if (ckWARN(WARN_ILLEGALPROTO))
5219 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5221 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5222 STRLEN old_len, new_len;
5223 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5224 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5226 if (curstash && svname == (SV *)name
5227 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5228 svname = sv_2mortal(newSVsv(PL_curstname));
5229 sv_catpvs(svname, "::");
5230 sv_catsv(svname, (SV *)name);
5233 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5234 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5236 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5237 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5247 S_cant_declare(pTHX_ OP *o)
5249 if (o->op_type == OP_NULL
5250 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5251 o = cUNOPo->op_first;
5252 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5253 o->op_type == OP_NULL
5254 && o->op_flags & OPf_SPECIAL
5257 PL_parser->in_my == KEY_our ? "our" :
5258 PL_parser->in_my == KEY_state ? "state" :
5263 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5266 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5268 PERL_ARGS_ASSERT_MY_KID;
5270 if (!o || (PL_parser && PL_parser->error_count))
5275 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5277 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5278 my_kid(kid, attrs, imopsp);
5280 } else if (type == OP_UNDEF || type == OP_STUB) {
5282 } else if (type == OP_RV2SV || /* "our" declaration */
5285 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5286 S_cant_declare(aTHX_ o);
5288 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5290 PL_parser->in_my = FALSE;
5291 PL_parser->in_my_stash = NULL;
5292 apply_attrs(GvSTASH(gv),
5293 (type == OP_RV2SV ? GvSVn(gv) :
5294 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5295 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5298 o->op_private |= OPpOUR_INTRO;
5301 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5302 if (!FEATURE_MYREF_IS_ENABLED)
5303 Perl_croak(aTHX_ "The experimental declared_refs "
5304 "feature is not enabled");
5305 Perl_ck_warner_d(aTHX_
5306 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5307 "Declaring references is experimental");
5308 /* Kid is a nulled OP_LIST, handled above. */
5309 my_kid(cUNOPo->op_first, attrs, imopsp);
5312 else if (type != OP_PADSV &&
5315 type != OP_PUSHMARK)
5317 S_cant_declare(aTHX_ o);
5320 else if (attrs && type != OP_PUSHMARK) {
5324 PL_parser->in_my = FALSE;
5325 PL_parser->in_my_stash = NULL;
5327 /* check for C<my Dog $spot> when deciding package */
5328 stash = PAD_COMPNAME_TYPE(o->op_targ);
5330 stash = PL_curstash;
5331 apply_attrs_my(stash, o, attrs, imopsp);
5333 o->op_flags |= OPf_MOD;
5334 o->op_private |= OPpLVAL_INTRO;
5336 o->op_private |= OPpPAD_STATE;
5341 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5344 int maybe_scalar = 0;
5346 PERL_ARGS_ASSERT_MY_ATTRS;
5348 /* [perl #17376]: this appears to be premature, and results in code such as
5349 C< our(%x); > executing in list mode rather than void mode */
5351 if (o->op_flags & OPf_PARENS)
5361 o = my_kid(o, attrs, &rops);
5363 if (maybe_scalar && o->op_type == OP_PADSV) {
5364 o = scalar(op_append_list(OP_LIST, rops, o));
5365 o->op_private |= OPpLVAL_INTRO;
5368 /* The listop in rops might have a pushmark at the beginning,
5369 which will mess up list assignment. */
5370 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5371 if (rops->op_type == OP_LIST &&
5372 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5374 OP * const pushmark = lrops->op_first;
5375 /* excise pushmark */
5376 op_sibling_splice(rops, NULL, 1, NULL);
5379 o = op_append_list(OP_LIST, o, rops);
5382 PL_parser->in_my = FALSE;
5383 PL_parser->in_my_stash = NULL;
5388 Perl_sawparens(pTHX_ OP *o)
5390 PERL_UNUSED_CONTEXT;
5392 o->op_flags |= OPf_PARENS;
5397 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5401 const OPCODE ltype = left->op_type;
5402 const OPCODE rtype = right->op_type;
5404 PERL_ARGS_ASSERT_BIND_MATCH;
5406 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5407 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5409 const char * const desc
5411 rtype == OP_SUBST || rtype == OP_TRANS
5412 || rtype == OP_TRANSR
5414 ? (int)rtype : OP_MATCH];
5415 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5417 S_op_varname(aTHX_ left);
5419 Perl_warner(aTHX_ packWARN(WARN_MISC),
5420 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5421 desc, SVfARG(name), SVfARG(name));
5423 const char * const sample = (isary
5424 ? "@array" : "%hash");
5425 Perl_warner(aTHX_ packWARN(WARN_MISC),
5426 "Applying %s to %s will act on scalar(%s)",
5427 desc, sample, sample);
5431 if (rtype == OP_CONST &&
5432 cSVOPx(right)->op_private & OPpCONST_BARE &&
5433 cSVOPx(right)->op_private & OPpCONST_STRICT)
5435 no_bareword_allowed(right);
5438 /* !~ doesn't make sense with /r, so error on it for now */
5439 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5441 /* diag_listed_as: Using !~ with %s doesn't make sense */
5442 yyerror("Using !~ with s///r doesn't make sense");
5443 if (rtype == OP_TRANSR && type == OP_NOT)
5444 /* diag_listed_as: Using !~ with %s doesn't make sense */
5445 yyerror("Using !~ with tr///r doesn't make sense");
5447 ismatchop = (rtype == OP_MATCH ||
5448 rtype == OP_SUBST ||
5449 rtype == OP_TRANS || rtype == OP_TRANSR)
5450 && !(right->op_flags & OPf_SPECIAL);
5451 if (ismatchop && right->op_private & OPpTARGET_MY) {
5453 right->op_private &= ~OPpTARGET_MY;
5455 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5456 if (left->op_type == OP_PADSV
5457 && !(left->op_private & OPpLVAL_INTRO))
5459 right->op_targ = left->op_targ;
5464 right->op_flags |= OPf_STACKED;
5465 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5466 ! (rtype == OP_TRANS &&
5467 right->op_private & OPpTRANS_IDENTICAL) &&
5468 ! (rtype == OP_SUBST &&
5469 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5470 left = op_lvalue(left, rtype);
5471 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5472 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5474 o = op_prepend_elem(rtype, scalar(left), right);
5477 return newUNOP(OP_NOT, 0, scalar(o));
5481 return bind_match(type, left,
5482 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5486 Perl_invert(pTHX_ OP *o)
5490 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5494 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
5500 left = newOP(OP_NULL, 0);
5502 right = newOP(OP_NULL, 0);
5505 NewOp(0, bop, 1, BINOP);
5507 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5508 OpTYPE_set(op, type);
5509 cBINOPx(op)->op_flags = OPf_KIDS;
5510 cBINOPx(op)->op_private = 2;
5511 cBINOPx(op)->op_first = left;
5512 cBINOPx(op)->op_last = right;
5513 OpMORESIB_set(left, right);
5514 OpLASTSIB_set(right, op);
5519 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
5524 PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
5526 right = newOP(OP_NULL, 0);
5528 NewOp(0, bop, 1, BINOP);
5530 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5531 OpTYPE_set(op, type);
5532 if (ch->op_type != OP_NULL) {
5534 OP *nch, *cleft, *cright;
5535 NewOp(0, lch, 1, UNOP);
5537 OpTYPE_set(nch, OP_NULL);
5538 nch->op_flags = OPf_KIDS;
5539 cleft = cBINOPx(ch)->op_first;
5540 cright = cBINOPx(ch)->op_last;
5541 cBINOPx(ch)->op_first = NULL;
5542 cBINOPx(ch)->op_last = NULL;
5543 cBINOPx(ch)->op_private = 0;
5544 cBINOPx(ch)->op_flags = 0;
5545 cUNOPx(nch)->op_first = cright;
5546 OpMORESIB_set(cright, ch);
5547 OpMORESIB_set(ch, cleft);
5548 OpLASTSIB_set(cleft, nch);
5551 OpMORESIB_set(right, op);
5552 OpMORESIB_set(op, cUNOPx(ch)->op_first);
5553 cUNOPx(ch)->op_first = right;
5558 Perl_cmpchain_finish(pTHX_ OP *ch)
5561 PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
5562 if (ch->op_type != OP_NULL) {
5563 OPCODE cmpoptype = ch->op_type;
5564 ch = CHECKOP(cmpoptype, ch);
5565 if(!ch->op_next && ch->op_type == cmpoptype)
5566 ch = fold_constants(op_integerize(op_std_init(ch)));
5570 OP *rightarg = cUNOPx(ch)->op_first;
5571 cUNOPx(ch)->op_first = OpSIBLING(rightarg);
5572 OpLASTSIB_set(rightarg, NULL);
5574 OP *cmpop = cUNOPx(ch)->op_first;
5575 OP *leftarg = OpSIBLING(cmpop);
5576 OPCODE cmpoptype = cmpop->op_type;
5579 is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
5580 OpLASTSIB_set(cmpop, NULL);
5581 OpLASTSIB_set(leftarg, NULL);
5585 nextrightarg = NULL;
5587 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
5588 leftarg = newOP(OP_NULL, 0);
5590 cBINOPx(cmpop)->op_first = leftarg;
5591 cBINOPx(cmpop)->op_last = rightarg;
5592 OpMORESIB_set(leftarg, rightarg);
5593 OpLASTSIB_set(rightarg, cmpop);
5594 cmpop->op_flags = OPf_KIDS;
5595 cmpop->op_private = 2;
5596 cmpop = CHECKOP(cmpoptype, cmpop);
5597 if(!cmpop->op_next && cmpop->op_type == cmpoptype)
5598 cmpop = fold_constants(op_integerize(op_std_init(cmpop)));
5599 condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
5603 rightarg = nextrightarg;
5609 =for apidoc op_scope
5611 Wraps up an op tree with some additional ops so that at runtime a dynamic
5612 scope will be created. The original ops run in the new dynamic scope,
5613 and then, provided that they exit normally, the scope will be unwound.
5614 The additional ops used to create and unwind the dynamic scope will
5615 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5616 instead if the ops are simple enough to not need the full dynamic scope
5623 Perl_op_scope(pTHX_ OP *o)
5626 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5627 o = op_prepend_elem(OP_LINESEQ,
5628 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
5629 OpTYPE_set(o, OP_LEAVE);
5631 else if (o->op_type == OP_LINESEQ) {
5633 OpTYPE_set(o, OP_SCOPE);
5634 kid = ((LISTOP*)o)->op_first;
5635 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5638 /* The following deals with things like 'do {1 for 1}' */
5639 kid = OpSIBLING(kid);
5641 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5646 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5652 Perl_op_unscope(pTHX_ OP *o)
5654 if (o && o->op_type == OP_LINESEQ) {
5655 OP *kid = cLISTOPo->op_first;
5656 for(; kid; kid = OpSIBLING(kid))
5657 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5664 =for apidoc block_start
5666 Handles compile-time scope entry.
5667 Arranges for hints to be restored on block
5668 exit and also handles pad sequence numbers to make lexical variables scope
5669 right. Returns a savestack index for use with C<block_end>.
5675 Perl_block_start(pTHX_ int full)
5677 const int retval = PL_savestack_ix;
5679 PL_compiling.cop_seq = PL_cop_seqmax;
5681 pad_block_start(full);
5683 PL_hints &= ~HINT_BLOCK_SCOPE;
5684 SAVECOMPILEWARNINGS();
5685 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5686 SAVEI32(PL_compiling.cop_seq);
5687 PL_compiling.cop_seq = 0;
5689 CALL_BLOCK_HOOKS(bhk_start, full);
5695 =for apidoc block_end
5697 Handles compile-time scope exit. C<floor>
5698 is the savestack index returned by
5699 C<block_start>, and C<seq> is the body of the block. Returns the block,
5706 Perl_block_end(pTHX_ I32 floor, OP *seq)
5708 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5709 OP* retval = scalarseq(seq);
5712 /* XXX Is the null PL_parser check necessary here? */
5713 assert(PL_parser); /* Let’s find out under debugging builds. */
5714 if (PL_parser && PL_parser->parsed_sub) {
5715 o = newSTATEOP(0, NULL, NULL);
5717 retval = op_append_elem(OP_LINESEQ, retval, o);
5720 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5724 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5728 /* pad_leavemy has created a sequence of introcv ops for all my
5729 subs declared in the block. We have to replicate that list with
5730 clonecv ops, to deal with this situation:
5735 sub s1 { state sub foo { \&s2 } }
5738 Originally, I was going to have introcv clone the CV and turn
5739 off the stale flag. Since &s1 is declared before &s2, the
5740 introcv op for &s1 is executed (on sub entry) before the one for
5741 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5742 cloned, since it is a state sub) closes over &s2 and expects
5743 to see it in its outer CV’s pad. If the introcv op clones &s1,
5744 then &s2 is still marked stale. Since &s1 is not active, and
5745 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5746 ble will not stay shared’ warning. Because it is the same stub
5747 that will be used when the introcv op for &s2 is executed, clos-
5748 ing over it is safe. Hence, we have to turn off the stale flag
5749 on all lexical subs in the block before we clone any of them.
5750 Hence, having introcv clone the sub cannot work. So we create a
5751 list of ops like this:
5775 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5776 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5777 for (;; kid = OpSIBLING(kid)) {
5778 OP *newkid = newOP(OP_CLONECV, 0);
5779 newkid->op_targ = kid->op_targ;
5780 o = op_append_elem(OP_LINESEQ, o, newkid);
5781 if (kid == last) break;
5783 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5786 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5792 =head1 Compile-time scope hooks
5794 =for apidoc blockhook_register
5796 Register a set of hooks to be called when the Perl lexical scope changes
5797 at compile time. See L<perlguts/"Compile-time scope hooks">.
5803 Perl_blockhook_register(pTHX_ BHK *hk)
5805 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5807 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5811 Perl_newPROG(pTHX_ OP *o)
5815 PERL_ARGS_ASSERT_NEWPROG;
5822 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5823 ((PL_in_eval & EVAL_KEEPERR)
5824 ? OPf_SPECIAL : 0), o);
5827 assert(CxTYPE(cx) == CXt_EVAL);
5829 if ((cx->blk_gimme & G_WANT) == G_VOID)
5830 scalarvoid(PL_eval_root);
5831 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5834 scalar(PL_eval_root);
5836 start = op_linklist(PL_eval_root);
5837 PL_eval_root->op_next = 0;
5838 i = PL_savestack_ix;
5841 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5843 PL_savestack_ix = i;
5846 if (o->op_type == OP_STUB) {
5847 /* This block is entered if nothing is compiled for the main
5848 program. This will be the case for an genuinely empty main
5849 program, or one which only has BEGIN blocks etc, so already
5852 Historically (5.000) the guard above was !o. However, commit
5853 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5854 c71fccf11fde0068, changed perly.y so that newPROG() is now
5855 called with the output of block_end(), which returns a new
5856 OP_STUB for the case of an empty optree. ByteLoader (and
5857 maybe other things) also take this path, because they set up
5858 PL_main_start and PL_main_root directly, without generating an
5861 If the parsing the main program aborts (due to parse errors,
5862 or due to BEGIN or similar calling exit), then newPROG()
5863 isn't even called, and hence this code path and its cleanups
5864 are skipped. This shouldn't make a make a difference:
5865 * a non-zero return from perl_parse is a failure, and
5866 perl_destruct() should be called immediately.
5867 * however, if exit(0) is called during the parse, then
5868 perl_parse() returns 0, and perl_run() is called. As
5869 PL_main_start will be NULL, perl_run() will return
5870 promptly, and the exit code will remain 0.
5873 PL_comppad_name = 0;
5875 S_op_destroy(aTHX_ o);
5878 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5879 PL_curcop = &PL_compiling;
5880 start = LINKLIST(PL_main_root);
5881 PL_main_root->op_next = 0;
5882 S_process_optree(aTHX_ NULL, PL_main_root, start);
5883 if (!PL_parser->error_count)
5884 /* on error, leave CV slabbed so that ops left lying around
5885 * will eb cleaned up. Else unslab */
5886 cv_forget_slab(PL_compcv);
5889 /* Register with debugger */
5891 CV * const cv = get_cvs("DB::postponed", 0);
5895 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5897 call_sv(MUTABLE_SV(cv), G_DISCARD);
5904 Perl_localize(pTHX_ OP *o, I32 lex)
5906 PERL_ARGS_ASSERT_LOCALIZE;
5908 if (o->op_flags & OPf_PARENS)
5909 /* [perl #17376]: this appears to be premature, and results in code such as
5910 C< our(%x); > executing in list mode rather than void mode */
5917 if ( PL_parser->bufptr > PL_parser->oldbufptr
5918 && PL_parser->bufptr[-1] == ','
5919 && ckWARN(WARN_PARENTHESIS))
5921 char *s = PL_parser->bufptr;
5924 /* some heuristics to detect a potential error */
5925 while (*s && (memCHRs(", \t\n", *s)))
5929 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
5931 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5934 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5936 while (*s && (memCHRs(", \t\n", *s)))
5942 if (sigil && (*s == ';' || *s == '=')) {
5943 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5944 "Parentheses missing around \"%s\" list",
5946 ? (PL_parser->in_my == KEY_our
5948 : PL_parser->in_my == KEY_state
5958 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5959 PL_parser->in_my = FALSE;
5960 PL_parser->in_my_stash = NULL;
5965 Perl_jmaybe(pTHX_ OP *o)
5967 PERL_ARGS_ASSERT_JMAYBE;
5969 if (o->op_type == OP_LIST) {
5971 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5972 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5977 PERL_STATIC_INLINE OP *
5978 S_op_std_init(pTHX_ OP *o)
5980 I32 type = o->op_type;
5982 PERL_ARGS_ASSERT_OP_STD_INIT;
5984 if (PL_opargs[type] & OA_RETSCALAR)
5986 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5987 o->op_targ = pad_alloc(type, SVs_PADTMP);
5992 PERL_STATIC_INLINE OP *
5993 S_op_integerize(pTHX_ OP *o)
5995 I32 type = o->op_type;
5997 PERL_ARGS_ASSERT_OP_INTEGERIZE;
5999 /* integerize op. */
6000 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
6002 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
6005 if (type == OP_NEGATE)
6006 /* XXX might want a ck_negate() for this */
6007 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
6012 /* This function exists solely to provide a scope to limit
6013 setjmp/longjmp() messing with auto variables. It cannot be inlined because
6017 S_fold_constants_eval(pTHX) {
6033 S_fold_constants(pTHX_ OP *const o)
6037 I32 type = o->op_type;
6042 SV * const oldwarnhook = PL_warnhook;
6043 SV * const olddiehook = PL_diehook;
6045 U8 oldwarn = PL_dowarn;
6048 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
6050 if (!(PL_opargs[type] & OA_FOLDCONST))
6059 #ifdef USE_LOCALE_CTYPE
6060 if (IN_LC_COMPILETIME(LC_CTYPE))
6069 #ifdef USE_LOCALE_COLLATE
6070 if (IN_LC_COMPILETIME(LC_COLLATE))
6075 /* XXX what about the numeric ops? */
6076 #ifdef USE_LOCALE_NUMERIC
6077 if (IN_LC_COMPILETIME(LC_NUMERIC))
6082 if (!OpHAS_SIBLING(cLISTOPo->op_first)
6083 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
6086 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
6087 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
6089 const char *s = SvPVX_const(sv);
6090 while (s < SvEND(sv)) {
6091 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
6098 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
6101 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
6102 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
6106 if (PL_parser && PL_parser->error_count)
6107 goto nope; /* Don't try to run w/ errors */
6109 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
6110 switch (curop->op_type) {
6112 if ( (curop->op_private & OPpCONST_BARE)
6113 && (curop->op_private & OPpCONST_STRICT)) {
6114 no_bareword_allowed(curop);
6122 /* Foldable; move to next op in list */
6126 /* No other op types are considered foldable */
6131 curop = LINKLIST(o);
6132 old_next = o->op_next;
6136 old_cxix = cxstack_ix;
6137 create_eval_scope(NULL, G_FAKINGEVAL);
6139 /* Verify that we don't need to save it: */
6140 assert(PL_curcop == &PL_compiling);
6141 StructCopy(&PL_compiling, ¬_compiling, COP);
6142 PL_curcop = ¬_compiling;
6143 /* The above ensures that we run with all the correct hints of the
6144 currently compiling COP, but that IN_PERL_RUNTIME is true. */
6145 assert(IN_PERL_RUNTIME);
6146 PL_warnhook = PERL_WARNHOOK_FATAL;
6149 /* Effective $^W=1. */
6150 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6151 PL_dowarn |= G_WARN_ON;
6153 ret = S_fold_constants_eval(aTHX);
6157 sv = *(PL_stack_sp--);
6158 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
6159 pad_swipe(o->op_targ, FALSE);
6161 else if (SvTEMP(sv)) { /* grab mortal temp? */
6162 SvREFCNT_inc_simple_void(sv);
6165 else { assert(SvIMMORTAL(sv)); }
6168 /* Something tried to die. Abandon constant folding. */
6169 /* Pretend the error never happened. */
6171 o->op_next = old_next;
6174 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
6175 PL_warnhook = oldwarnhook;
6176 PL_diehook = olddiehook;
6177 /* XXX note that this croak may fail as we've already blown away
6178 * the stack - eg any nested evals */
6179 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6181 PL_dowarn = oldwarn;
6182 PL_warnhook = oldwarnhook;
6183 PL_diehook = olddiehook;
6184 PL_curcop = &PL_compiling;
6186 /* if we croaked, depending on how we croaked the eval scope
6187 * may or may not have already been popped */
6188 if (cxstack_ix > old_cxix) {
6189 assert(cxstack_ix == old_cxix + 1);
6190 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6191 delete_eval_scope();
6196 /* OP_STRINGIFY and constant folding are used to implement qq.
6197 Here the constant folding is an implementation detail that we
6198 want to hide. If the stringify op is itself already marked
6199 folded, however, then it is actually a folded join. */
6200 is_stringify = type == OP_STRINGIFY && !o->op_folded;
6205 else if (!SvIMMORTAL(sv)) {
6209 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6210 if (!is_stringify) newop->op_folded = 1;
6217 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6218 * the constant value being an AV holding the flattened range.
6222 S_gen_constant_list(pTHX_ OP *o)
6224 OP *curop, *old_next;
6225 SV * const oldwarnhook = PL_warnhook;
6226 SV * const olddiehook = PL_diehook;
6228 U8 oldwarn = PL_dowarn;
6238 if (PL_parser && PL_parser->error_count)
6239 return; /* Don't attempt to run with errors */
6241 curop = LINKLIST(o);
6242 old_next = o->op_next;
6244 op_was_null = o->op_type == OP_NULL;
6245 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6246 o->op_type = OP_CUSTOM;
6249 o->op_type = OP_NULL;
6250 S_prune_chain_head(&curop);
6253 old_cxix = cxstack_ix;
6254 create_eval_scope(NULL, G_FAKINGEVAL);
6256 old_curcop = PL_curcop;
6257 StructCopy(old_curcop, ¬_compiling, COP);
6258 PL_curcop = ¬_compiling;
6259 /* The above ensures that we run with all the correct hints of the
6260 current COP, but that IN_PERL_RUNTIME is true. */
6261 assert(IN_PERL_RUNTIME);
6262 PL_warnhook = PERL_WARNHOOK_FATAL;
6266 /* Effective $^W=1. */
6267 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6268 PL_dowarn |= G_WARN_ON;
6272 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6273 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6275 Perl_pp_pushmark(aTHX);
6278 assert (!(curop->op_flags & OPf_SPECIAL));
6279 assert(curop->op_type == OP_RANGE);
6280 Perl_pp_anonlist(aTHX);
6284 o->op_next = old_next;
6288 PL_warnhook = oldwarnhook;
6289 PL_diehook = olddiehook;
6290 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6295 PL_dowarn = oldwarn;
6296 PL_warnhook = oldwarnhook;
6297 PL_diehook = olddiehook;
6298 PL_curcop = old_curcop;
6300 if (cxstack_ix > old_cxix) {
6301 assert(cxstack_ix == old_cxix + 1);
6302 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6303 delete_eval_scope();
6308 OpTYPE_set(o, OP_RV2AV);
6309 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6310 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6311 o->op_opt = 0; /* needs to be revisited in rpeep() */
6312 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6314 /* replace subtree with an OP_CONST */
6315 curop = ((UNOP*)o)->op_first;
6316 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6319 if (AvFILLp(av) != -1)
6320 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6323 SvREADONLY_on(*svp);
6331 =head1 Optree Manipulation Functions
6334 /* List constructors */
6337 =for apidoc op_append_elem
6339 Append an item to the list of ops contained directly within a list-type
6340 op, returning the lengthened list. C<first> is the list-type op,
6341 and C<last> is the op to append to the list. C<optype> specifies the
6342 intended opcode for the list. If C<first> is not already a list of the
6343 right type, it will be upgraded into one. If either C<first> or C<last>
6344 is null, the other is returned unchanged.
6350 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6358 if (first->op_type != (unsigned)type
6359 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6361 return newLISTOP(type, 0, first, last);
6364 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6365 first->op_flags |= OPf_KIDS;
6370 =for apidoc op_append_list
6372 Concatenate the lists of ops contained directly within two list-type ops,
6373 returning the combined list. C<first> and C<last> are the list-type ops
6374 to concatenate. C<optype> specifies the intended opcode for the list.
6375 If either C<first> or C<last> is not already a list of the right type,
6376 it will be upgraded into one. If either C<first> or C<last> is null,
6377 the other is returned unchanged.
6383 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6391 if (first->op_type != (unsigned)type)
6392 return op_prepend_elem(type, first, last);
6394 if (last->op_type != (unsigned)type)
6395 return op_append_elem(type, first, last);
6397 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6398 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6399 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6400 first->op_flags |= (last->op_flags & OPf_KIDS);
6402 S_op_destroy(aTHX_ last);
6408 =for apidoc op_prepend_elem
6410 Prepend an item to the list of ops contained directly within a list-type
6411 op, returning the lengthened list. C<first> is the op to prepend to the
6412 list, and C<last> is the list-type op. C<optype> specifies the intended
6413 opcode for the list. If C<last> is not already a list of the right type,
6414 it will be upgraded into one. If either C<first> or C<last> is null,
6415 the other is returned unchanged.
6421 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6429 if (last->op_type == (unsigned)type) {
6430 if (type == OP_LIST) { /* already a PUSHMARK there */
6431 /* insert 'first' after pushmark */
6432 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6433 if (!(first->op_flags & OPf_PARENS))
6434 last->op_flags &= ~OPf_PARENS;
6437 op_sibling_splice(last, NULL, 0, first);
6438 last->op_flags |= OPf_KIDS;
6442 return newLISTOP(type, 0, first, last);
6446 =for apidoc op_convert_list
6448 Converts C<o> into a list op if it is not one already, and then converts it
6449 into the specified C<type>, calling its check function, allocating a target if
6450 it needs one, and folding constants.
6452 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6453 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6454 C<op_convert_list> to make it the right type.
6460 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6462 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6463 if (!o || o->op_type != OP_LIST)
6464 o = force_list(o, 0);
6467 o->op_flags &= ~OPf_WANT;
6468 o->op_private &= ~OPpLVAL_INTRO;
6471 if (!(PL_opargs[type] & OA_MARK))
6472 op_null(cLISTOPo->op_first);
6474 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6475 if (kid2 && kid2->op_type == OP_COREARGS) {
6476 op_null(cLISTOPo->op_first);
6477 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6481 if (type != OP_SPLIT)
6482 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6483 * ck_split() create a real PMOP and leave the op's type as listop
6484 * for now. Otherwise op_free() etc will crash.
6486 OpTYPE_set(o, type);
6488 o->op_flags |= flags;
6489 if (flags & OPf_FOLDED)
6492 o = CHECKOP(type, o);
6493 if (o->op_type != (unsigned)type)
6496 return fold_constants(op_integerize(op_std_init(o)));
6503 =head1 Optree construction
6505 =for apidoc newNULLLIST
6507 Constructs, checks, and returns a new C<stub> op, which represents an
6508 empty list expression.
6514 Perl_newNULLLIST(pTHX)
6516 return newOP(OP_STUB, 0);
6519 /* promote o and any siblings to be a list if its not already; i.e.
6527 * pushmark - o - A - B
6529 * If nullit it true, the list op is nulled.
6533 S_force_list(pTHX_ OP *o, bool nullit)
6535 if (!o || o->op_type != OP_LIST) {
6538 /* manually detach any siblings then add them back later */
6539 rest = OpSIBLING(o);
6540 OpLASTSIB_set(o, NULL);
6542 o = newLISTOP(OP_LIST, 0, o, NULL);
6544 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6552 =for apidoc newLISTOP
6554 Constructs, checks, and returns an op of any list type. C<type> is
6555 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6556 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6557 supply up to two ops to be direct children of the list op; they are
6558 consumed by this function and become part of the constructed op tree.
6560 For most list operators, the check function expects all the kid ops to be
6561 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6562 appropriate. What you want to do in that case is create an op of type
6563 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6564 See L</op_convert_list> for more information.
6571 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6574 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6575 * pushmark is banned. So do it now while existing ops are in a
6576 * consistent state, in case they suddenly get freed */
6577 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6579 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6580 || type == OP_CUSTOM);
6582 NewOp(1101, listop, 1, LISTOP);
6583 OpTYPE_set(listop, type);
6586 listop->op_flags = (U8)flags;
6590 else if (!first && last)
6593 OpMORESIB_set(first, last);
6594 listop->op_first = first;
6595 listop->op_last = last;
6598 OpMORESIB_set(pushop, first);
6599 listop->op_first = pushop;
6600 listop->op_flags |= OPf_KIDS;
6602 listop->op_last = pushop;
6604 if (listop->op_last)
6605 OpLASTSIB_set(listop->op_last, (OP*)listop);
6607 return CHECKOP(type, listop);
6613 Constructs, checks, and returns an op of any base type (any type that
6614 has no extra fields). C<type> is the opcode. C<flags> gives the
6615 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6622 Perl_newOP(pTHX_ I32 type, I32 flags)
6626 if (type == -OP_ENTEREVAL) {
6627 type = OP_ENTEREVAL;
6628 flags |= OPpEVAL_BYTES<<8;
6631 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6632 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6633 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6634 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6636 NewOp(1101, o, 1, OP);
6637 OpTYPE_set(o, type);
6638 o->op_flags = (U8)flags;
6641 o->op_private = (U8)(0 | (flags >> 8));
6642 if (PL_opargs[type] & OA_RETSCALAR)
6644 if (PL_opargs[type] & OA_TARGET)
6645 o->op_targ = pad_alloc(type, SVs_PADTMP);
6646 return CHECKOP(type, o);
6652 Constructs, checks, and returns an op of any unary type. C<type> is
6653 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6654 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6655 bits, the eight bits of C<op_private>, except that the bit with value 1
6656 is automatically set. C<first> supplies an optional op to be the direct
6657 child of the unary op; it is consumed by this function and become part
6658 of the constructed op tree.
6660 =for apidoc Amnh||OPf_KIDS
6666 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6670 if (type == -OP_ENTEREVAL) {
6671 type = OP_ENTEREVAL;
6672 flags |= OPpEVAL_BYTES<<8;
6675 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6676 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6677 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6678 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6679 || type == OP_SASSIGN
6680 || type == OP_ENTERTRY
6681 || type == OP_CUSTOM
6682 || type == OP_NULL );
6685 first = newOP(OP_STUB, 0);
6686 if (PL_opargs[type] & OA_MARK)
6687 first = force_list(first, 1);
6689 NewOp(1101, unop, 1, UNOP);
6690 OpTYPE_set(unop, type);
6691 unop->op_first = first;
6692 unop->op_flags = (U8)(flags | OPf_KIDS);
6693 unop->op_private = (U8)(1 | (flags >> 8));
6695 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6696 OpLASTSIB_set(first, (OP*)unop);
6698 unop = (UNOP*) CHECKOP(type, unop);
6702 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6706 =for apidoc newUNOP_AUX
6708 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6709 initialised to C<aux>
6715 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6719 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6720 || type == OP_CUSTOM);
6722 NewOp(1101, unop, 1, UNOP_AUX);
6723 unop->op_type = (OPCODE)type;
6724 unop->op_ppaddr = PL_ppaddr[type];
6725 unop->op_first = first;
6726 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6727 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6730 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6731 OpLASTSIB_set(first, (OP*)unop);
6733 unop = (UNOP_AUX*) CHECKOP(type, unop);
6735 return op_std_init((OP *) unop);
6739 =for apidoc newMETHOP
6741 Constructs, checks, and returns an op of method type with a method name
6742 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6743 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6744 and, shifted up eight bits, the eight bits of C<op_private>, except that
6745 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6746 op which evaluates method name; it is consumed by this function and
6747 become part of the constructed op tree.
6748 Supported optypes: C<OP_METHOD>.
6754 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6757 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6758 || type == OP_CUSTOM);
6760 NewOp(1101, methop, 1, METHOP);
6762 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6763 methop->op_flags = (U8)(flags | OPf_KIDS);
6764 methop->op_u.op_first = dynamic_meth;
6765 methop->op_private = (U8)(1 | (flags >> 8));
6767 if (!OpHAS_SIBLING(dynamic_meth))
6768 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6772 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6773 methop->op_u.op_meth_sv = const_meth;
6774 methop->op_private = (U8)(0 | (flags >> 8));
6775 methop->op_next = (OP*)methop;
6779 methop->op_rclass_targ = 0;
6781 methop->op_rclass_sv = NULL;
6784 OpTYPE_set(methop, type);
6785 return CHECKOP(type, methop);
6789 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6790 PERL_ARGS_ASSERT_NEWMETHOP;
6791 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6795 =for apidoc newMETHOP_named
6797 Constructs, checks, and returns an op of method type with a constant
6798 method name. C<type> is the opcode. C<flags> gives the eight bits of
6799 C<op_flags>, and, shifted up eight bits, the eight bits of
6800 C<op_private>. C<const_meth> supplies a constant method name;
6801 it must be a shared COW string.
6802 Supported optypes: C<OP_METHOD_NAMED>.
6808 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6809 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6810 return newMETHOP_internal(type, flags, NULL, const_meth);
6814 =for apidoc newBINOP
6816 Constructs, checks, and returns an op of any binary type. C<type>
6817 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6818 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6819 the eight bits of C<op_private>, except that the bit with value 1 or
6820 2 is automatically set as required. C<first> and C<last> supply up to
6821 two ops to be the direct children of the binary op; they are consumed
6822 by this function and become part of the constructed op tree.
6828 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6832 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6833 || type == OP_NULL || type == OP_CUSTOM);
6835 NewOp(1101, binop, 1, BINOP);
6838 first = newOP(OP_NULL, 0);
6840 OpTYPE_set(binop, type);
6841 binop->op_first = first;
6842 binop->op_flags = (U8)(flags | OPf_KIDS);
6845 binop->op_private = (U8)(1 | (flags >> 8));
6848 binop->op_private = (U8)(2 | (flags >> 8));
6849 OpMORESIB_set(first, last);
6852 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6853 OpLASTSIB_set(last, (OP*)binop);
6855 binop->op_last = OpSIBLING(binop->op_first);
6857 OpLASTSIB_set(binop->op_last, (OP*)binop);
6859 binop = (BINOP*)CHECKOP(type, binop);
6860 if (binop->op_next || binop->op_type != (OPCODE)type)
6863 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6867 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
6869 const char indent[] = " ";
6871 UV len = _invlist_len(invlist);
6872 UV * array = invlist_array(invlist);
6875 PERL_ARGS_ASSERT_INVMAP_DUMP;
6877 for (i = 0; i < len; i++) {
6878 UV start = array[i];
6879 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
6881 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
6882 if (end == IV_MAX) {
6883 PerlIO_printf(Perl_debug_log, " .. INFTY");
6885 else if (end != start) {
6886 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
6889 PerlIO_printf(Perl_debug_log, " ");
6892 PerlIO_printf(Perl_debug_log, "\t");
6894 if (map[i] == TR_UNLISTED) {
6895 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
6897 else if (map[i] == TR_SPECIAL_HANDLING) {
6898 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
6901 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
6906 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6907 * containing the search and replacement strings, assemble into
6908 * a translation table attached as o->op_pv.
6909 * Free expr and repl.
6910 * It expects the toker to have already set the
6911 * OPpTRANS_COMPLEMENT
6914 * flags as appropriate; this function may add
6916 * OPpTRANS_CAN_FORCE_UTF8
6917 * OPpTRANS_IDENTICAL
6923 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6925 /* This function compiles a tr///, from data gathered from toke.c, into a
6926 * form suitable for use by do_trans() in doop.c at runtime.
6928 * It first normalizes the data, while discarding extraneous inputs; then
6929 * writes out the compiled data. The normalization allows for complete
6930 * analysis, and avoids some false negatives and positives earlier versions
6933 * The normalization form is an inversion map (described below in detail).
6934 * This is essentially the compiled form for tr///'s that require UTF-8,
6935 * and its easy to use it to write the 257-byte table for tr///'s that
6936 * don't need UTF-8. That table is identical to what's been in use for
6937 * many perl versions, except that it doesn't handle some edge cases that
6938 * it used to, involving code points above 255. The UTF-8 form now handles
6939 * these. (This could be changed with extra coding should it shown to be
6942 * If the complement (/c) option is specified, the lhs string (tstr) is
6943 * parsed into an inversion list. Complementing these is trivial. Then a
6944 * complemented tstr is built from that, and used thenceforth. This hides
6945 * the fact that it was complemented from almost all successive code.
6947 * One of the important characteristics to know about the input is whether
6948 * the transliteration may be done in place, or does a temporary need to be
6949 * allocated, then copied. If the replacement for every character in every
6950 * possible string takes up no more bytes than the character it
6951 * replaces, then it can be edited in place. Otherwise the replacement
6952 * could overwrite a byte we are about to read, depending on the strings
6953 * being processed. The comments and variable names here refer to this as
6954 * "growing". Some inputs won't grow, and might even shrink under /d, but
6955 * some inputs could grow, so we have to assume any given one might grow.
6956 * On very long inputs, the temporary could eat up a lot of memory, so we
6957 * want to avoid it if possible. For non-UTF-8 inputs, everything is
6958 * single-byte, so can be edited in place, unless there is something in the
6959 * pattern that could force it into UTF-8. The inversion map makes it
6960 * feasible to determine this. Previous versions of this code pretty much
6961 * punted on determining if UTF-8 could be edited in place. Now, this code
6962 * is rigorous in making that determination.
6964 * Another characteristic we need to know is whether the lhs and rhs are
6965 * identical. If so, and no other flags are present, the only effect of
6966 * the tr/// is to count the characters present in the input that are
6967 * mentioned in the lhs string. The implementation of that is easier and
6968 * runs faster than the more general case. Normalizing here allows for
6969 * accurate determination of this. Previously there were false negatives
6972 * Instead of 'transliterated', the comments here use 'unmapped' for the
6973 * characters that are left unchanged by the operation; otherwise they are
6976 * The lhs of the tr/// is here referred to as the t side.
6977 * The rhs of the tr/// is here referred to as the r side.
6980 SV * const tstr = ((SVOP*)expr)->op_sv;
6981 SV * const rstr = ((SVOP*)repl)->op_sv;
6984 const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
6985 const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
6988 UV t_count = 0, r_count = 0; /* Number of characters in search and
6989 replacement lists */
6991 /* khw thinks some of the private flags for this op are quaintly named.
6992 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
6993 * character when represented in UTF-8 is longer than the original
6994 * character's UTF-8 representation */
6995 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6996 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6997 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6999 /* Set to true if there is some character < 256 in the lhs that maps to
7000 * above 255. If so, a non-UTF-8 match string can be forced into being in
7001 * UTF-8 by a tr/// operation. */
7002 bool can_force_utf8 = FALSE;
7004 /* What is the maximum expansion factor in UTF-8 transliterations. If a
7005 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
7006 * expansion factor is 1.5. This number is used at runtime to calculate
7007 * how much space to allocate for non-inplace transliterations. Without
7008 * this number, the worst case is 14, which is extremely unlikely to happen
7009 * in real life, and could require significant memory overhead. */
7010 NV max_expansion = 1.;
7012 UV t_range_count, r_range_count, min_range_count;
7017 UV t_cp_end = (UV) -1;
7021 UV final_map = TR_UNLISTED; /* The final character in the replacement
7022 list, updated as we go along. Initialize
7023 to something illegal */
7025 bool rstr_utf8 = cBOOL(SvUTF8(rstr));
7026 bool tstr_utf8 = cBOOL(SvUTF8(tstr));
7028 const U8* tend = t + tlen;
7029 const U8* rend = r + rlen;
7031 SV * inverted_tstr = NULL;
7036 /* This routine implements detection of a transliteration having a longer
7037 * UTF-8 representation than its source, by partitioning all the possible
7038 * code points of the platform into equivalence classes of the same UTF-8
7039 * byte length in the first pass. As it constructs the mappings, it carves
7040 * these up into smaller chunks, but doesn't merge any together. This
7041 * makes it easy to find the instances it's looking for. A second pass is
7042 * done after this has been determined which merges things together to
7043 * shrink the table for runtime. The table below is used for both ASCII
7044 * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically
7045 * increasing for code points below 256. To correct for that, the macro
7046 * CP_ADJUST defined below converts those code points to ASCII in the first
7047 * pass, and we use the ASCII partition values. That works because the
7048 * growth factor will be unaffected, which is all that is calculated during
7049 * the first pass. */
7050 UV PL_partition_by_byte_length[] = {
7052 0x80, /* Below this is 1 byte representations */
7053 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */
7054 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */
7055 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */
7056 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */
7057 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */
7061 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */
7066 PERL_ARGS_ASSERT_PMTRANS;
7068 PL_hints |= HINT_BLOCK_SCOPE;
7070 /* If /c, the search list is sorted and complemented. This is now done by
7071 * creating an inversion list from it, and then trivially inverting that.
7072 * The previous implementation used qsort, but creating the list
7073 * automatically keeps it sorted as we go along */
7076 SV * inverted_tlist = _new_invlist(tlen);
7079 DEBUG_y(PerlIO_printf(Perl_debug_log,
7080 "%s: %d: tstr before inversion=\n%s\n",
7081 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7085 /* Non-utf8 strings don't have ranges, so each character is listed
7088 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
7091 else { /* But UTF-8 strings have been parsed in toke.c to have
7092 * ranges if appropriate. */
7096 /* Get the first character */
7097 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7100 /* If the next byte indicates that this wasn't the first
7101 * element of a range, the range is just this one */
7102 if (t >= tend || *t != RANGE_INDICATOR) {
7103 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
7105 else { /* Otherwise, ignore the indicator byte, and get the
7106 final element, and add the whole range */
7108 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
7111 inverted_tlist = _add_range_to_invlist(inverted_tlist,
7115 } /* End of parse through tstr */
7117 /* The inversion list is done; now invert it */
7118 _invlist_invert(inverted_tlist);
7120 /* Now go through the inverted list and create a new tstr for the rest
7121 * of the routine to use. Since the UTF-8 version can have ranges, and
7122 * can be much more compact than the non-UTF-8 version, we create the
7123 * string in UTF-8 even if not necessary. (This is just an intermediate
7124 * value that gets thrown away anyway.) */
7125 invlist_iterinit(inverted_tlist);
7126 inverted_tstr = newSVpvs("");
7127 while (invlist_iternext(inverted_tlist, &start, &end)) {
7128 U8 temp[UTF8_MAXBYTES];
7131 /* IV_MAX keeps things from going out of bounds */
7132 start = MIN(IV_MAX, start);
7133 end = MIN(IV_MAX, end);
7135 temp_end_pos = uvchr_to_utf8(temp, start);
7136 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7139 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
7140 temp_end_pos = uvchr_to_utf8(temp, end);
7141 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7145 /* Set up so the remainder of the routine uses this complement, instead
7146 * of the actual input */
7147 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
7148 tend = t0 + temp_len;
7151 SvREFCNT_dec_NN(inverted_tlist);
7154 /* For non-/d, an empty rhs means to use the lhs */
7155 if (rlen == 0 && ! del) {
7158 rstr_utf8 = tstr_utf8;
7161 t_invlist = _new_invlist(1);
7163 /* Initialize to a single range */
7164 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7166 /* For the first pass, the lhs is partitioned such that the
7167 * number of UTF-8 bytes required to represent a code point in each
7168 * partition is the same as the number for any other code point in
7169 * that partion. We copy the pre-compiled partion. */
7170 len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
7171 invlist_extend(t_invlist, len);
7172 t_array = invlist_array(t_invlist);
7173 Copy(PL_partition_by_byte_length, t_array, len, UV);
7174 invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
7175 Newx(r_map, len + 1, UV);
7177 /* Parse the (potentially adjusted) input, creating the inversion map.
7178 * This is done in two passes. The first pass is to determine if the
7179 * transliteration can be done in place. The inversion map it creates
7180 * could be used, but generally would be larger and slower to run than the
7181 * output of the second pass, which starts with a more compact table and
7182 * allows more ranges to be merged */
7183 for (pass2 = 0; pass2 < 2; pass2++) {
7185 /* Initialize to a single range */
7186 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7188 /* In the second pass, we just have the single range */
7190 t_array = invlist_array(t_invlist);
7193 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
7194 * so as to get the well-behaved length 1 vs length 2 boundary. Only code
7195 * points below 256 differ between the two character sets in this regard. For
7196 * these, we also can't have any ranges, as they have to be individually
7199 # define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x))
7200 # define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256))
7201 # define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
7203 # define CP_ADJUST(x) (x)
7204 # define FORCE_RANGE_LEN_1(x) 0
7205 # define CP_SKIP(x) UVCHR_SKIP(x)
7208 /* And the mapping of each of the ranges is initialized. Initially,
7209 * everything is TR_UNLISTED. */
7210 for (i = 0; i < len; i++) {
7211 r_map[i] = TR_UNLISTED;
7218 t_range_count = r_range_count = 0;
7220 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
7221 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7222 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
7223 _byte_dump_string(r, rend - r, 0)));
7224 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
7225 complement, squash, del));
7226 DEBUG_y(invmap_dump(t_invlist, r_map));
7228 /* Now go through the search list constructing an inversion map. The
7229 * input is not necessarily in any particular order. Making it an
7230 * inversion map orders it, potentially simplifying, and makes it easy
7231 * to deal with at run time. This is the only place in core that
7232 * generates an inversion map; if others were introduced, it might be
7233 * better to create general purpose routines to handle them.
7234 * (Inversion maps are created in perl in other places.)
7236 * An inversion map consists of two parallel arrays. One is
7237 * essentially an inversion list: an ordered list of code points such
7238 * that each element gives the first code point of a range of
7239 * consecutive code points that map to the element in the other array
7240 * that has the same index as this one (in other words, the
7241 * corresponding element). Thus the range extends up to (but not
7242 * including) the code point given by the next higher element. In a
7243 * true inversion map, the corresponding element in the other array
7244 * gives the mapping of the first code point in the range, with the
7245 * understanding that the next higher code point in the inversion
7246 * list's range will map to the next higher code point in the map.
7248 * So if at element [i], let's say we have:
7253 * This means that A => a, B => b, C => c.... Let's say that the
7254 * situation is such that:
7258 * This means the sequence that started at [i] stops at K => k. This
7259 * illustrates that you need to look at the next element to find where
7260 * a sequence stops. Except, the highest element in the inversion list
7261 * begins a range that is understood to extend to the platform's
7264 * This routine modifies traditional inversion maps to reserve two
7267 * TR_UNLISTED (or -1) indicates that no code point in the range
7268 * is listed in the tr/// searchlist. At runtime, these are
7269 * always passed through unchanged. In the inversion map, all
7270 * points in the range are mapped to -1, instead of increasing,
7271 * like the 'L' in the example above.
7273 * We start the parse with every code point mapped to this, and as
7274 * we parse and find ones that are listed in the search list, we
7275 * carve out ranges as we go along that override that.
7277 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
7278 * range needs special handling. Again, all code points in the
7279 * range are mapped to -2, instead of increasing.
7281 * Under /d this value means the code point should be deleted from
7282 * the transliteration when encountered.
7284 * Otherwise, it marks that every code point in the range is to
7285 * map to the final character in the replacement list. This
7286 * happens only when the replacement list is shorter than the
7287 * search one, so there are things in the search list that have no
7288 * correspondence in the replacement list. For example, in
7289 * tr/a-z/A/, 'A' is the final value, and the inversion map
7290 * generated for this would be like this:
7295 * 'A' appears once, then the remainder of the range maps to -2.
7296 * The use of -2 isn't strictly necessary, as an inversion map is
7297 * capable of representing this situation, but not nearly so
7298 * compactly, and this is actually quite commonly encountered.
7299 * Indeed, the original design of this code used a full inversion
7300 * map for this. But things like
7302 * generated huge data structures, slowly, and the execution was
7303 * also slow. So the current scheme was implemented.
7305 * So, if the next element in our example is:
7309 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next
7313 * [i+4] S TR_UNLISTED
7315 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is
7316 * the final element in the arrays, every code point from S to infinity
7317 * maps to TR_UNLISTED.
7320 /* Finish up range started in what otherwise would
7321 * have been the final iteration */
7322 while (t < tend || t_range_count > 0) {
7323 bool adjacent_to_range_above = FALSE;
7324 bool adjacent_to_range_below = FALSE;
7326 bool merge_with_range_above = FALSE;
7327 bool merge_with_range_below = FALSE;
7329 UV span, invmap_range_length_remaining;
7333 /* If we are in the middle of processing a range in the 'target'
7334 * side, the previous iteration has set us up. Otherwise, look at
7335 * the next character in the search list */
7336 if (t_range_count <= 0) {
7339 /* Here, not in the middle of a range, and not UTF-8. The
7340 * next code point is the single byte where we're at */
7341 t_cp = CP_ADJUST(*t);
7348 /* Here, not in the middle of a range, and is UTF-8. The
7349 * next code point is the next UTF-8 char in the input. We
7350 * know the input is valid, because the toker constructed
7352 t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
7355 /* UTF-8 strings (only) have been parsed in toke.c to have
7356 * ranges. See if the next byte indicates that this was
7357 * the first element of a range. If so, get the final
7358 * element and calculate the range size. If not, the range
7360 if ( t < tend && *t == RANGE_INDICATOR
7361 && ! FORCE_RANGE_LEN_1(t_cp))
7364 t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
7373 /* Count the total number of listed code points * */
7374 t_count += t_range_count;
7377 /* Similarly, get the next character in the replacement list */
7378 if (r_range_count <= 0) {
7381 /* But if we've exhausted the rhs, there is nothing to map
7382 * to, except the special handling one, and we make the
7383 * range the same size as the lhs one. */
7384 r_cp = TR_SPECIAL_HANDLING;
7385 r_range_count = t_range_count;
7388 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7389 "final_map =%" UVXf "\n", final_map));
7394 r_cp = CP_ADJUST(*r);
7401 r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
7403 if ( r < rend && *r == RANGE_INDICATOR
7404 && ! FORCE_RANGE_LEN_1(r_cp))
7407 r_range_count = valid_utf8_to_uvchr(r,
7408 &r_char_len) - r_cp + 1;
7416 if (r_cp == TR_SPECIAL_HANDLING) {
7417 r_range_count = t_range_count;
7420 /* This is the final character so far */
7421 final_map = r_cp + r_range_count - 1;
7423 r_count += r_range_count;
7427 /* Here, we have the next things ready in both sides. They are
7428 * potentially ranges. We try to process as big a chunk as
7429 * possible at once, but the lhs and rhs must be synchronized, so
7430 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
7432 min_range_count = MIN(t_range_count, r_range_count);
7434 /* Search the inversion list for the entry that contains the input
7435 * code point <cp>. The inversion map was initialized to cover the
7436 * entire range of possible inputs, so this should not fail. So
7437 * the return value is the index into the list's array of the range
7438 * that contains <cp>, that is, 'i' such that array[i] <= cp <
7440 j = _invlist_search(t_invlist, t_cp);
7444 /* Here, the data structure might look like:
7447 * [i-1] J j # J-L => j-l
7448 * [i] M -1 # M => default; as do N, O, P, Q
7449 * [i+1] R x # R => x, S => x+1, T => x+2
7450 * [i+2] U y # U => y, V => y+1, ...
7452 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7454 * where 'x' and 'y' above are not to be taken literally.
7456 * The maximum chunk we can handle in this loop iteration, is the
7457 * smallest of the three components: the lhs 't_', the rhs 'r_',
7458 * and the remainder of the range in element [i]. (In pass 1, that
7459 * range will have everything in it be of the same class; we can't
7460 * cross into another class.) 'min_range_count' already contains
7461 * the smallest of the first two values. The final one is
7462 * irrelevant if the map is to the special indicator */
7464 invmap_range_length_remaining = (i + 1 < len)
7465 ? t_array[i+1] - t_cp
7467 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
7469 /* The end point of this chunk is where we are, plus the span, but
7470 * never larger than the platform's infinity */
7471 t_cp_end = MIN(IV_MAX, t_cp + span - 1);
7473 if (r_cp == TR_SPECIAL_HANDLING) {
7475 /* If unmatched lhs code points map to the final map, use that
7476 * value. This being set to TR_SPECIAL_HANDLING indicates that
7477 * we don't have a final map: unmatched lhs code points are
7479 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
7482 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
7484 /* If something on the lhs is below 256, and something on the
7485 * rhs is above, there is a potential mapping here across that
7486 * boundary. Indeed the only way there isn't is if both sides
7487 * start at the same point. That means they both cross at the
7488 * same time. But otherwise one crosses before the other */
7489 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
7490 can_force_utf8 = TRUE;
7494 /* If a character appears in the search list more than once, the
7495 * 2nd and succeeding occurrences are ignored, so only do this
7496 * range if haven't already processed this character. (The range
7497 * has been set up so that all members in it will be of the same
7499 if (r_map[i] == TR_UNLISTED) {
7500 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7501 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
7502 t_cp, t_cp_end, r_cp, r_cp_end));
7504 /* This is the first definition for this chunk, hence is valid
7505 * and needs to be processed. Here and in the comments below,
7506 * we use the above sample data. The t_cp chunk must be any
7507 * contiguous subset of M, N, O, P, and/or Q.
7509 * In the first pass, calculate if there is any possible input
7510 * string that has a character whose transliteration will be
7511 * longer than it. If none, the transliteration may be done
7512 * in-place, as it can't write over a so-far unread byte.
7513 * Otherwise, a copy must first be made. This could be
7514 * expensive for long inputs.
7516 * In the first pass, the t_invlist has been partitioned so
7517 * that all elements in any single range have the same number
7518 * of bytes in their UTF-8 representations. And the r space is
7519 * either a single byte, or a range of strictly monotonically
7520 * increasing code points. So the final element in the range
7521 * will be represented by no fewer bytes than the initial one.
7522 * That means that if the final code point in the t range has
7523 * at least as many bytes as the final code point in the r,
7524 * then all code points in the t range have at least as many
7525 * bytes as their corresponding r range element. But if that's
7526 * not true, the transliteration of at least the final code
7527 * point grows in length. As an example, suppose we had
7528 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
7529 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
7530 * platforms. We have deliberately set up the data structure
7531 * so that any range in the lhs gets split into chunks for
7532 * processing, such that every code point in a chunk has the
7533 * same number of UTF-8 bytes. We only have to check the final
7534 * code point in the rhs against any code point in the lhs. */
7536 && r_cp_end != TR_SPECIAL_HANDLING
7537 && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
7539 /* Here, we will need to make a copy of the input string
7540 * before doing the transliteration. The worst possible
7541 * case is an expansion ratio of 14:1. This is rare, and
7542 * we'd rather allocate only the necessary amount of extra
7543 * memory for that copy. We can calculate the worst case
7544 * for this particular transliteration is by keeping track
7545 * of the expansion factor for each range.
7547 * Consider tr/\xCB/\X{E000}/. The maximum expansion
7548 * factor is 1 byte going to 3 if the target string is not
7549 * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We
7550 * could pass two different values so doop could choose
7551 * based on the UTF-8ness of the target. But khw thinks
7552 * (perhaps wrongly) that is overkill. It is used only to
7553 * make sure we malloc enough space.
7555 * If no target string can force the result to be UTF-8,
7556 * then we don't have to worry about the case of the target
7557 * string not being UTF-8 */
7558 NV t_size = (can_force_utf8 && t_cp < 256)
7560 : CP_SKIP(t_cp_end);
7561 NV ratio = CP_SKIP(r_cp_end) / t_size;
7563 o->op_private |= OPpTRANS_GROWS;
7565 /* Now that we know it grows, we can keep track of the
7567 if (ratio > max_expansion) {
7568 max_expansion = ratio;
7569 DEBUG_y(PerlIO_printf(Perl_debug_log,
7570 "New expansion factor: %" NVgf "\n",
7575 /* The very first range is marked as adjacent to the
7576 * non-existent range below it, as it causes things to "just
7579 * If the lowest code point in this chunk is M, it adjoins the
7581 if (t_cp == t_array[i]) {
7582 adjacent_to_range_below = TRUE;
7584 /* And if the map has the same offset from the beginning of
7585 * the range as does this new code point (or both are for
7586 * TR_SPECIAL_HANDLING), this chunk can be completely
7587 * merged with the range below. EXCEPT, in the first pass,
7588 * we don't merge ranges whose UTF-8 byte representations
7589 * have different lengths, so that we can more easily
7590 * detect if a replacement is longer than the source, that
7591 * is if it 'grows'. But in the 2nd pass, there's no
7592 * reason to not merge */
7593 if ( (i > 0 && ( pass2
7594 || CP_SKIP(t_array[i-1])
7596 && ( ( r_cp == TR_SPECIAL_HANDLING
7597 && r_map[i-1] == TR_SPECIAL_HANDLING)
7598 || ( r_cp != TR_SPECIAL_HANDLING
7599 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
7601 merge_with_range_below = TRUE;
7605 /* Similarly, if the highest code point in this chunk is 'Q',
7606 * it adjoins the range above, and if the map is suitable, can
7607 * be merged with it */
7608 if ( t_cp_end >= IV_MAX - 1
7610 && t_cp_end + 1 == t_array[i+1]))
7612 adjacent_to_range_above = TRUE;
7615 || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
7616 && ( ( r_cp == TR_SPECIAL_HANDLING
7617 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
7618 || ( r_cp != TR_SPECIAL_HANDLING
7619 && r_cp_end == r_map[i+1] - 1)))
7621 merge_with_range_above = TRUE;
7625 if (merge_with_range_below && merge_with_range_above) {
7627 /* Here the new chunk looks like M => m, ... Q => q; and
7628 * the range above is like R => r, .... Thus, the [i-1]
7629 * and [i+1] ranges should be seamlessly melded so the
7632 * [i-1] J j # J-T => j-t
7633 * [i] U y # U => y, V => y+1, ...
7635 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7637 Move(t_array + i + 2, t_array + i, len - i - 2, UV);
7638 Move(r_map + i + 2, r_map + i, len - i - 2, UV);
7640 invlist_set_len(t_invlist,
7642 *(get_invlist_offset_addr(t_invlist)));
7644 else if (merge_with_range_below) {
7646 /* Here the new chunk looks like M => m, .... But either
7647 * (or both) it doesn't extend all the way up through Q; or
7648 * the range above doesn't start with R => r. */
7649 if (! adjacent_to_range_above) {
7651 /* In the first case, let's say the new chunk extends
7652 * through O. We then want:
7654 * [i-1] J j # J-O => j-o
7655 * [i] P -1 # P => -1, Q => -1
7656 * [i+1] R x # R => x, S => x+1, T => x+2
7657 * [i+2] U y # U => y, V => y+1, ...
7659 * [-1] Z -1 # Z => default; as do Z+1, ...
7662 t_array[i] = t_cp_end + 1;
7663 r_map[i] = TR_UNLISTED;
7665 else { /* Adjoins the range above, but can't merge with it
7666 (because 'x' is not the next map after q) */
7668 * [i-1] J j # J-Q => j-q
7669 * [i] R x # R => x, S => x+1, T => x+2
7670 * [i+1] U y # U => y, V => y+1, ...
7672 * [-1] Z -1 # Z => default; as do Z+1, ...
7676 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7677 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7679 invlist_set_len(t_invlist, len,
7680 *(get_invlist_offset_addr(t_invlist)));
7683 else if (merge_with_range_above) {
7685 /* Here the new chunk ends with Q => q, and the range above
7686 * must start with R => r, so the two can be merged. But
7687 * either (or both) the new chunk doesn't extend all the
7688 * way down to M; or the mapping of the final code point
7689 * range below isn't m */
7690 if (! adjacent_to_range_below) {
7692 /* In the first case, let's assume the new chunk starts
7693 * with P => p. Then, because it's merge-able with the
7694 * range above, that range must be R => r. We want:
7696 * [i-1] J j # J-L => j-l
7697 * [i] M -1 # M => -1, N => -1
7698 * [i+1] P p # P-T => p-t
7699 * [i+2] U y # U => y, V => y+1, ...
7701 * [-1] Z -1 # Z => default; as do Z+1, ...
7704 t_array[i+1] = t_cp;
7707 else { /* Adjoins the range below, but can't merge with it
7710 * [i-1] J j # J-L => j-l
7711 * [i] M x # M-T => x-5 .. x+2
7712 * [i+1] U y # U => y, V => y+1, ...
7714 * [-1] Z -1 # Z => default; as do Z+1, ...
7717 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7718 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7722 invlist_set_len(t_invlist, len,
7723 *(get_invlist_offset_addr(t_invlist)));
7726 else if (adjacent_to_range_below && adjacent_to_range_above) {
7727 /* The new chunk completely fills the gap between the
7728 * ranges on either side, but can't merge with either of
7731 * [i-1] J j # J-L => j-l
7732 * [i] M z # M => z, N => z+1 ... Q => z+4
7733 * [i+1] R x # R => x, S => x+1, T => x+2
7734 * [i+2] U y # U => y, V => y+1, ...
7736 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7740 else if (adjacent_to_range_below) {
7741 /* The new chunk adjoins the range below, but not the range
7742 * above, and can't merge. Let's assume the chunk ends at
7745 * [i-1] J j # J-L => j-l
7746 * [i] M z # M => z, N => z+1, O => z+2
7747 * [i+1] P -1 # P => -1, Q => -1
7748 * [i+2] R x # R => x, S => x+1, T => x+2
7749 * [i+3] U y # U => y, V => y+1, ...
7751 * [-w] Z -1 # Z => default; as do Z+1, ... infinity
7753 invlist_extend(t_invlist, len + 1);
7754 t_array = invlist_array(t_invlist);
7755 Renew(r_map, len + 1, UV);
7757 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7758 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7760 t_array[i+1] = t_cp_end + 1;
7761 r_map[i+1] = TR_UNLISTED;
7763 invlist_set_len(t_invlist, len,
7764 *(get_invlist_offset_addr(t_invlist)));
7766 else if (adjacent_to_range_above) {
7767 /* The new chunk adjoins the range above, but not the range
7768 * below, and can't merge. Let's assume the new chunk
7771 * [i-1] J j # J-L => j-l
7772 * [i] M -1 # M => default, N => default
7773 * [i+1] O z # O => z, P => z+1, Q => z+2
7774 * [i+2] R x # R => x, S => x+1, T => x+2
7775 * [i+3] U y # U => y, V => y+1, ...
7777 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7779 invlist_extend(t_invlist, len + 1);
7780 t_array = invlist_array(t_invlist);
7781 Renew(r_map, len + 1, UV);
7783 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7784 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7785 t_array[i+1] = t_cp;
7788 invlist_set_len(t_invlist, len,
7789 *(get_invlist_offset_addr(t_invlist)));
7792 /* The new chunk adjoins neither the range above, nor the
7793 * range below. Lets assume it is N..P => n..p
7795 * [i-1] J j # J-L => j-l
7796 * [i] M -1 # M => default
7797 * [i+1] N n # N..P => n..p
7798 * [i+2] Q -1 # Q => default
7799 * [i+3] R x # R => x, S => x+1, T => x+2
7800 * [i+4] U y # U => y, V => y+1, ...
7802 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7805 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7806 "Before fixing up: len=%d, i=%d\n",
7807 (int) len, (int) i));
7808 DEBUG_yv(invmap_dump(t_invlist, r_map));
7810 invlist_extend(t_invlist, len + 2);
7811 t_array = invlist_array(t_invlist);
7812 Renew(r_map, len + 2, UV);
7814 Move(t_array + i + 1,
7815 t_array + i + 2 + 1, len - i - (2 - 1), UV);
7817 r_map + i + 2 + 1, len - i - (2 - 1), UV);
7820 invlist_set_len(t_invlist, len,
7821 *(get_invlist_offset_addr(t_invlist)));
7823 t_array[i+1] = t_cp;
7826 t_array[i+2] = t_cp_end + 1;
7827 r_map[i+2] = TR_UNLISTED;
7829 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7830 "After iteration: span=%" UVuf ", t_range_count=%"
7831 UVuf " r_range_count=%" UVuf "\n",
7832 span, t_range_count, r_range_count));
7833 DEBUG_yv(invmap_dump(t_invlist, r_map));
7834 } /* End of this chunk needs to be processed */
7836 /* Done with this chunk. */
7838 if (t_cp >= IV_MAX) {
7841 t_range_count -= span;
7842 if (r_cp != TR_SPECIAL_HANDLING) {
7844 r_range_count -= span;
7850 } /* End of loop through the search list */
7852 /* We don't need an exact count, but we do need to know if there is
7853 * anything left over in the replacement list. So, just assume it's
7854 * one byte per character */
7858 } /* End of passes */
7860 SvREFCNT_dec(inverted_tstr);
7862 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
7863 DEBUG_y(invmap_dump(t_invlist, r_map));
7865 /* We now have normalized the input into an inversion map.
7867 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op
7868 * except for the count, and streamlined runtime code can be used */
7869 if (!del && !squash) {
7871 /* They are identical if they point to same address, or if everything
7872 * maps to UNLISTED or to itself. This catches things that not looking
7873 * at the normalized inversion map doesn't catch, like tr/aa/ab/ or
7874 * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */
7876 for (i = 0; i < len; i++) {
7877 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
7878 goto done_identical_check;
7883 /* Here have gone through entire list, and didn't find any
7884 * non-identical mappings */
7885 o->op_private |= OPpTRANS_IDENTICAL;
7887 done_identical_check: ;
7890 t_array = invlist_array(t_invlist);
7892 /* If has components above 255, we generally need to use the inversion map
7896 && t_array[len-1] > 255
7897 /* If the final range is 0x100-INFINITY and is a special
7898 * mapping, the table implementation can handle it */
7899 && ! ( t_array[len-1] == 256
7900 && ( r_map[len-1] == TR_UNLISTED
7901 || r_map[len-1] == TR_SPECIAL_HANDLING))))
7905 /* A UTF-8 op is generated, indicated by this flag. This op is an
7907 o->op_private |= OPpTRANS_USE_SVOP;
7909 if (can_force_utf8) {
7910 o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
7913 /* The inversion map is pushed; first the list. */
7914 invmap = MUTABLE_AV(newAV());
7915 av_push(invmap, t_invlist);
7917 /* 2nd is the mapping */
7918 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
7919 av_push(invmap, r_map_sv);
7921 /* 3rd is the max possible expansion factor */
7922 av_push(invmap, newSVnv(max_expansion));
7924 /* Characters that are in the search list, but not in the replacement
7925 * list are mapped to the final character in the replacement list */
7926 if (! del && r_count < t_count) {
7927 av_push(invmap, newSVuv(final_map));
7931 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
7932 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
7933 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
7934 SvPADTMP_on(invmap);
7935 SvREADONLY_on(invmap);
7937 cSVOPo->op_sv = (SV *) invmap;
7945 /* The OPtrans_map struct already contains one slot; hence the -1. */
7946 SSize_t struct_size = sizeof(OPtrans_map)
7947 + (256 - 1 + 1)*sizeof(short);
7949 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
7950 * table. Entries with the value TR_UNMAPPED indicate chars not to be
7951 * translated, while TR_DELETE indicates a search char without a
7952 * corresponding replacement char under /d.
7954 * In addition, an extra slot at the end is used to store the final
7955 * repeating char, or TR_R_EMPTY under an empty replacement list, or
7956 * TR_DELETE under /d; which makes the runtime code easier.
7959 /* Indicate this is an op_pv */
7960 o->op_private &= ~OPpTRANS_USE_SVOP;
7962 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7964 cPVOPo->op_pv = (char*)tbl;
7966 for (i = 0; i < len; i++) {
7967 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7968 short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7969 short to = (short) r_map[i];
7971 bool do_increment = TRUE;
7973 /* Any code points above our limit should be irrelevant */
7974 if (t_array[i] >= tbl->size) break;
7976 /* Set up the map */
7977 if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7978 to = (short) final_map;
7979 do_increment = FALSE;
7982 do_increment = FALSE;
7985 /* Create a map for everything in this range. The value increases
7986 * except for the special cases */
7987 for (j = (short) t_array[i]; j < upper; j++) {
7989 if (do_increment) to++;
7993 tbl->map[tbl->size] = del
7997 : (short) TR_R_EMPTY;
7998 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
7999 for (i = 0; i < tbl->size; i++) {
8000 if (tbl->map[i] < 0) {
8001 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
8002 (unsigned) i, tbl->map[i]));
8005 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
8006 (unsigned) i, tbl->map[i]));
8008 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
8009 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
8012 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
8013 (unsigned) tbl->size, tbl->map[tbl->size]));
8015 SvREFCNT_dec(t_invlist);
8017 #if 0 /* code that added excess above-255 chars at the end of the table, in
8018 case we ever want to not use the inversion map implementation for
8025 /* More replacement chars than search chars:
8026 * store excess replacement chars at end of main table.
8029 struct_size += excess;
8030 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
8031 struct_size + excess * sizeof(short));
8032 tbl->size += excess;
8033 cPVOPo->op_pv = (char*)tbl;
8035 for (i = 0; i < excess; i++)
8036 tbl->map[i + 256] = r[j+i];
8039 /* no more replacement chars than search chars */
8045 DEBUG_y(PerlIO_printf(Perl_debug_log,
8046 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
8047 " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
8048 del, squash, complement,
8049 cBOOL(o->op_private & OPpTRANS_IDENTICAL),
8050 cBOOL(o->op_private & OPpTRANS_USE_SVOP),
8051 cBOOL(o->op_private & OPpTRANS_GROWS),
8052 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
8057 if(del && rlen != 0 && r_count == t_count) {
8058 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
8059 } else if(r_count > t_count) {
8060 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
8073 Constructs, checks, and returns an op of any pattern matching type.
8074 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
8075 and, shifted up eight bits, the eight bits of C<op_private>.
8081 Perl_newPMOP(pTHX_ I32 type, I32 flags)
8085 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
8086 || type == OP_CUSTOM);
8088 NewOp(1101, pmop, 1, PMOP);
8089 OpTYPE_set(pmop, type);
8090 pmop->op_flags = (U8)flags;
8091 pmop->op_private = (U8)(0 | (flags >> 8));
8092 if (PL_opargs[type] & OA_RETSCALAR)
8095 if (PL_hints & HINT_RE_TAINT)
8096 pmop->op_pmflags |= PMf_RETAINT;
8097 #ifdef USE_LOCALE_CTYPE
8098 if (IN_LC_COMPILETIME(LC_CTYPE)) {
8099 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
8104 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
8106 if (PL_hints & HINT_RE_FLAGS) {
8107 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8108 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
8110 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
8111 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8112 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
8114 if (reflags && SvOK(reflags)) {
8115 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
8121 assert(SvPOK(PL_regex_pad[0]));
8122 if (SvCUR(PL_regex_pad[0])) {
8123 /* Pop off the "packed" IV from the end. */
8124 SV *const repointer_list = PL_regex_pad[0];
8125 const char *p = SvEND(repointer_list) - sizeof(IV);
8126 const IV offset = *((IV*)p);
8128 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
8130 SvEND_set(repointer_list, p);
8132 pmop->op_pmoffset = offset;
8133 /* This slot should be free, so assert this: */
8134 assert(PL_regex_pad[offset] == &PL_sv_undef);
8136 SV * const repointer = &PL_sv_undef;
8137 av_push(PL_regex_padav, repointer);
8138 pmop->op_pmoffset = av_tindex(PL_regex_padav);
8139 PL_regex_pad = AvARRAY(PL_regex_padav);
8143 return CHECKOP(type, pmop);
8151 /* Any pad names in scope are potentially lvalues. */
8152 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
8153 PADNAME *pn = PAD_COMPNAME_SV(i);
8154 if (!pn || !PadnameLEN(pn))
8156 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
8157 S_mark_padname_lvalue(aTHX_ pn);
8161 /* Given some sort of match op o, and an expression expr containing a
8162 * pattern, either compile expr into a regex and attach it to o (if it's
8163 * constant), or convert expr into a runtime regcomp op sequence (if it's
8166 * Flags currently has 2 bits of meaning:
8167 * 1: isreg indicates that the pattern is part of a regex construct, eg
8168 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
8169 * split "pattern", which aren't. In the former case, expr will be a list
8170 * if the pattern contains more than one term (eg /a$b/).
8171 * 2: The pattern is for a split.
8173 * When the pattern has been compiled within a new anon CV (for
8174 * qr/(?{...})/ ), then floor indicates the savestack level just before
8175 * the new sub was created
8177 * tr/// is also handled.
8181 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
8185 I32 repl_has_vars = 0;
8186 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
8187 bool is_compiletime;
8189 bool isreg = cBOOL(flags & 1);
8190 bool is_split = cBOOL(flags & 2);
8192 PERL_ARGS_ASSERT_PMRUNTIME;
8195 return pmtrans(o, expr, repl);
8198 /* find whether we have any runtime or code elements;
8199 * at the same time, temporarily set the op_next of each DO block;
8200 * then when we LINKLIST, this will cause the DO blocks to be excluded
8201 * from the op_next chain (and from having LINKLIST recursively
8202 * applied to them). We fix up the DOs specially later */
8206 if (expr->op_type == OP_LIST) {
8208 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8209 if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
8211 assert(!child->op_next);
8212 if (UNLIKELY(!OpHAS_SIBLING(child))) {
8213 assert(PL_parser && PL_parser->error_count);
8214 /* This can happen with qr/ (?{(^{})/. Just fake up
8215 the op we were expecting to see, to avoid crashing
8217 op_sibling_splice(expr, child, 0,
8218 newSVOP(OP_CONST, 0, &PL_sv_no));
8220 child->op_next = OpSIBLING(child);
8222 else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
8226 else if (expr->op_type != OP_CONST)
8231 /* fix up DO blocks; treat each one as a separate little sub;
8232 * also, mark any arrays as LIST/REF */
8234 if (expr->op_type == OP_LIST) {
8236 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8238 if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
8239 assert( !(child->op_flags & OPf_WANT));
8240 /* push the array rather than its contents. The regex
8241 * engine will retrieve and join the elements later */
8242 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
8246 if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
8248 child->op_next = NULL; /* undo temporary hack from above */
8251 if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
8252 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
8254 assert(leaveop->op_first->op_type == OP_ENTER);
8255 assert(OpHAS_SIBLING(leaveop->op_first));
8256 child->op_next = OpSIBLING(leaveop->op_first);
8258 assert(leaveop->op_flags & OPf_KIDS);
8259 assert(leaveop->op_last->op_next == (OP*)leaveop);
8260 leaveop->op_next = NULL; /* stop on last op */
8261 op_null((OP*)leaveop);
8265 OP *scope = cLISTOPx(child)->op_first;
8266 assert(scope->op_type == OP_SCOPE);
8267 assert(scope->op_flags & OPf_KIDS);
8268 scope->op_next = NULL; /* stop on last op */
8272 /* XXX optimize_optree() must be called on o before
8273 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
8274 * currently cope with a peephole-optimised optree.
8275 * Calling optimize_optree() here ensures that condition
8276 * is met, but may mean optimize_optree() is applied
8277 * to the same optree later (where hopefully it won't do any
8278 * harm as it can't convert an op to multiconcat if it's
8279 * already been converted */
8280 optimize_optree(child);
8282 /* have to peep the DOs individually as we've removed it from
8283 * the op_next chain */
8285 S_prune_chain_head(&(child->op_next));
8287 /* runtime finalizes as part of finalizing whole tree */
8288 finalize_optree(child);
8291 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
8292 assert( !(expr->op_flags & OPf_WANT));
8293 /* push the array rather than its contents. The regex
8294 * engine will retrieve and join the elements later */
8295 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
8298 PL_hints |= HINT_BLOCK_SCOPE;
8300 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
8302 if (is_compiletime) {
8303 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
8304 regexp_engine const *eng = current_re_engine();
8307 /* make engine handle split ' ' specially */
8308 pm->op_pmflags |= PMf_SPLIT;
8309 rx_flags |= RXf_SPLIT;
8312 if (!has_code || !eng->op_comp) {
8313 /* compile-time simple constant pattern */
8315 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
8316 /* whoops! we guessed that a qr// had a code block, but we
8317 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
8318 * that isn't required now. Note that we have to be pretty
8319 * confident that nothing used that CV's pad while the
8320 * regex was parsed, except maybe op targets for \Q etc.
8321 * If there were any op targets, though, they should have
8322 * been stolen by constant folding.
8326 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
8327 while (++i <= AvFILLp(PL_comppad)) {
8328 # ifdef USE_PAD_RESET
8329 /* under USE_PAD_RESET, pad swipe replaces a swiped
8330 * folded constant with a fresh padtmp */
8331 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
8333 assert(!PL_curpad[i]);
8337 /* This LEAVE_SCOPE will restore PL_compcv to point to the
8338 * outer CV (the one whose slab holds the pm op). The
8339 * inner CV (which holds expr) will be freed later, once
8340 * all the entries on the parse stack have been popped on
8341 * return from this function. Which is why its safe to
8342 * call op_free(expr) below.
8345 pm->op_pmflags &= ~PMf_HAS_CV;
8348 /* Skip compiling if parser found an error for this pattern */
8349 if (pm->op_pmflags & PMf_HAS_ERROR) {
8355 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8356 rx_flags, pm->op_pmflags)
8357 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8358 rx_flags, pm->op_pmflags)
8363 /* compile-time pattern that includes literal code blocks */
8367 /* Skip compiling if parser found an error for this pattern */
8368 if (pm->op_pmflags & PMf_HAS_ERROR) {
8372 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8375 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
8378 if (pm->op_pmflags & PMf_HAS_CV) {
8380 /* this QR op (and the anon sub we embed it in) is never
8381 * actually executed. It's just a placeholder where we can
8382 * squirrel away expr in op_code_list without the peephole
8383 * optimiser etc processing it for a second time */
8384 OP *qr = newPMOP(OP_QR, 0);
8385 ((PMOP*)qr)->op_code_list = expr;
8387 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
8388 SvREFCNT_inc_simple_void(PL_compcv);
8389 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8390 ReANY(re)->qr_anoncv = cv;
8392 /* attach the anon CV to the pad so that
8393 * pad_fixup_inner_anons() can find it */
8394 (void)pad_add_anon(cv, o->op_type);
8395 SvREFCNT_inc_simple_void(cv);
8398 pm->op_code_list = expr;
8403 /* runtime pattern: build chain of regcomp etc ops */
8405 PADOFFSET cv_targ = 0;
8407 reglist = isreg && expr->op_type == OP_LIST;
8412 pm->op_code_list = expr;
8413 /* don't free op_code_list; its ops are embedded elsewhere too */
8414 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
8418 /* make engine handle split ' ' specially */
8419 pm->op_pmflags |= PMf_SPLIT;
8421 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
8422 * to allow its op_next to be pointed past the regcomp and
8423 * preceding stacking ops;
8424 * OP_REGCRESET is there to reset taint before executing the
8426 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
8427 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
8429 if (pm->op_pmflags & PMf_HAS_CV) {
8430 /* we have a runtime qr with literal code. This means
8431 * that the qr// has been wrapped in a new CV, which
8432 * means that runtime consts, vars etc will have been compiled
8433 * against a new pad. So... we need to execute those ops
8434 * within the environment of the new CV. So wrap them in a call
8435 * to a new anon sub. i.e. for
8439 * we build an anon sub that looks like
8441 * sub { "a", $b, '(?{...})' }
8443 * and call it, passing the returned list to regcomp.
8444 * Or to put it another way, the list of ops that get executed
8448 * ------ -------------------
8449 * pushmark (for regcomp)
8450 * pushmark (for entersub)
8454 * regcreset regcreset
8456 * const("a") const("a")
8458 * const("(?{...})") const("(?{...})")
8463 SvREFCNT_inc_simple_void(PL_compcv);
8464 CvLVALUE_on(PL_compcv);
8465 /* these lines are just an unrolled newANONATTRSUB */
8466 expr = newSVOP(OP_ANONCODE, 0,
8467 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
8468 cv_targ = expr->op_targ;
8469 expr = newUNOP(OP_REFGEN, 0, expr);
8471 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
8474 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
8475 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
8476 | (reglist ? OPf_STACKED : 0);
8477 rcop->op_targ = cv_targ;
8479 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
8480 if (PL_hints & HINT_RE_EVAL)
8481 S_set_haseval(aTHX);
8483 /* establish postfix order */
8484 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
8486 rcop->op_next = expr;
8487 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
8490 rcop->op_next = LINKLIST(expr);
8491 expr->op_next = (OP*)rcop;
8494 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
8500 /* If we are looking at s//.../e with a single statement, get past
8501 the implicit do{}. */
8502 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
8503 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
8504 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
8507 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
8508 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
8509 && !OpHAS_SIBLING(sib))
8512 if (curop->op_type == OP_CONST)
8514 else if (( (curop->op_type == OP_RV2SV ||
8515 curop->op_type == OP_RV2AV ||
8516 curop->op_type == OP_RV2HV ||
8517 curop->op_type == OP_RV2GV)
8518 && cUNOPx(curop)->op_first
8519 && cUNOPx(curop)->op_first->op_type == OP_GV )
8520 || curop->op_type == OP_PADSV
8521 || curop->op_type == OP_PADAV
8522 || curop->op_type == OP_PADHV
8523 || curop->op_type == OP_PADANY) {
8531 || !RX_PRELEN(PM_GETRE(pm))
8532 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
8534 pm->op_pmflags |= PMf_CONST; /* const for long enough */
8535 op_prepend_elem(o->op_type, scalar(repl), o);
8538 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
8539 rcop->op_private = 1;
8541 /* establish postfix order */
8542 rcop->op_next = LINKLIST(repl);
8543 repl->op_next = (OP*)rcop;
8545 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
8546 assert(!(pm->op_pmflags & PMf_ONCE));
8547 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
8558 Constructs, checks, and returns an op of any type that involves an
8559 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
8560 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
8561 takes ownership of one reference to it.
8567 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
8571 PERL_ARGS_ASSERT_NEWSVOP;
8573 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8574 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8575 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8576 || type == OP_CUSTOM);
8578 NewOp(1101, svop, 1, SVOP);
8579 OpTYPE_set(svop, type);
8581 svop->op_next = (OP*)svop;
8582 svop->op_flags = (U8)flags;
8583 svop->op_private = (U8)(0 | (flags >> 8));
8584 if (PL_opargs[type] & OA_RETSCALAR)
8586 if (PL_opargs[type] & OA_TARGET)
8587 svop->op_targ = pad_alloc(type, SVs_PADTMP);
8588 return CHECKOP(type, svop);
8592 =for apidoc newDEFSVOP
8594 Constructs and returns an op to access C<$_>.
8600 Perl_newDEFSVOP(pTHX)
8602 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
8608 =for apidoc newPADOP
8610 Constructs, checks, and returns an op of any type that involves a
8611 reference to a pad element. C<type> is the opcode. C<flags> gives the
8612 eight bits of C<op_flags>. A pad slot is automatically allocated, and
8613 is populated with C<sv>; this function takes ownership of one reference
8616 This function only exists if Perl has been compiled to use ithreads.
8622 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
8626 PERL_ARGS_ASSERT_NEWPADOP;
8628 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8629 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8630 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8631 || type == OP_CUSTOM);
8633 NewOp(1101, padop, 1, PADOP);
8634 OpTYPE_set(padop, type);
8636 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
8637 SvREFCNT_dec(PAD_SVl(padop->op_padix));
8638 PAD_SETSV(padop->op_padix, sv);
8640 padop->op_next = (OP*)padop;
8641 padop->op_flags = (U8)flags;
8642 if (PL_opargs[type] & OA_RETSCALAR)
8644 if (PL_opargs[type] & OA_TARGET)
8645 padop->op_targ = pad_alloc(type, SVs_PADTMP);
8646 return CHECKOP(type, padop);
8649 #endif /* USE_ITHREADS */
8654 Constructs, checks, and returns an op of any type that involves an
8655 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
8656 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
8657 reference; calling this function does not transfer ownership of any
8664 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
8666 PERL_ARGS_ASSERT_NEWGVOP;
8669 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8671 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8678 Constructs, checks, and returns an op of any type that involves an
8679 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
8680 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
8681 Depending on the op type, the memory referenced by C<pv> may be freed
8682 when the op is destroyed. If the op is of a freeing type, C<pv> must
8683 have been allocated using C<PerlMemShared_malloc>.
8689 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
8691 const bool utf8 = cBOOL(flags & SVf_UTF8);
8696 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8697 || type == OP_RUNCV || type == OP_CUSTOM
8698 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
8700 NewOp(1101, pvop, 1, PVOP);
8701 OpTYPE_set(pvop, type);
8703 pvop->op_next = (OP*)pvop;
8704 pvop->op_flags = (U8)flags;
8705 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
8706 if (PL_opargs[type] & OA_RETSCALAR)
8708 if (PL_opargs[type] & OA_TARGET)
8709 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
8710 return CHECKOP(type, pvop);
8714 Perl_package(pTHX_ OP *o)
8716 SV *const sv = cSVOPo->op_sv;
8718 PERL_ARGS_ASSERT_PACKAGE;
8720 SAVEGENERICSV(PL_curstash);
8721 save_item(PL_curstname);
8723 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
8725 sv_setsv(PL_curstname, sv);
8727 PL_hints |= HINT_BLOCK_SCOPE;
8728 PL_parser->copline = NOLINE;
8734 Perl_package_version( pTHX_ OP *v )
8736 U32 savehints = PL_hints;
8737 PERL_ARGS_ASSERT_PACKAGE_VERSION;
8738 PL_hints &= ~HINT_STRICT_VARS;
8739 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
8740 PL_hints = savehints;
8745 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
8750 SV *use_version = NULL;
8752 PERL_ARGS_ASSERT_UTILIZE;
8754 if (idop->op_type != OP_CONST)
8755 Perl_croak(aTHX_ "Module name must be constant");
8760 SV * const vesv = ((SVOP*)version)->op_sv;
8762 if (!arg && !SvNIOKp(vesv)) {
8769 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
8770 Perl_croak(aTHX_ "Version number must be a constant number");
8772 /* Make copy of idop so we don't free it twice */
8773 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8775 /* Fake up a method call to VERSION */
8776 meth = newSVpvs_share("VERSION");
8777 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8778 op_append_elem(OP_LIST,
8779 op_prepend_elem(OP_LIST, pack, version),
8780 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
8784 /* Fake up an import/unimport */
8785 if (arg && arg->op_type == OP_STUB) {
8786 imop = arg; /* no import on explicit () */
8788 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
8789 imop = NULL; /* use 5.0; */
8791 use_version = ((SVOP*)idop)->op_sv;
8793 idop->op_private |= OPpCONST_NOVER;
8798 /* Make copy of idop so we don't free it twice */
8799 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8801 /* Fake up a method call to import/unimport */
8803 ? newSVpvs_share("import") : newSVpvs_share("unimport");
8804 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8805 op_append_elem(OP_LIST,
8806 op_prepend_elem(OP_LIST, pack, arg),
8807 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
8811 /* Fake up the BEGIN {}, which does its thing immediately. */
8813 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
8816 op_append_elem(OP_LINESEQ,
8817 op_append_elem(OP_LINESEQ,
8818 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
8819 newSTATEOP(0, NULL, veop)),
8820 newSTATEOP(0, NULL, imop) ));
8824 * feature bundle that corresponds to the required version. */
8825 use_version = sv_2mortal(new_version(use_version));
8826 S_enable_feature_bundle(aTHX_ use_version);
8828 /* If a version >= 5.11.0 is requested, strictures are on by default! */
8829 if (vcmp(use_version,
8830 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
8831 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8832 PL_hints |= HINT_STRICT_REFS;
8833 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8834 PL_hints |= HINT_STRICT_SUBS;
8835 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8836 PL_hints |= HINT_STRICT_VARS;
8838 /* otherwise they are off */
8840 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8841 PL_hints &= ~HINT_STRICT_REFS;
8842 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8843 PL_hints &= ~HINT_STRICT_SUBS;
8844 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8845 PL_hints &= ~HINT_STRICT_VARS;
8849 /* The "did you use incorrect case?" warning used to be here.
8850 * The problem is that on case-insensitive filesystems one
8851 * might get false positives for "use" (and "require"):
8852 * "use Strict" or "require CARP" will work. This causes
8853 * portability problems for the script: in case-strict
8854 * filesystems the script will stop working.
8856 * The "incorrect case" warning checked whether "use Foo"
8857 * imported "Foo" to your namespace, but that is wrong, too:
8858 * there is no requirement nor promise in the language that
8859 * a Foo.pm should or would contain anything in package "Foo".
8861 * There is very little Configure-wise that can be done, either:
8862 * the case-sensitivity of the build filesystem of Perl does not
8863 * help in guessing the case-sensitivity of the runtime environment.
8866 PL_hints |= HINT_BLOCK_SCOPE;
8867 PL_parser->copline = NOLINE;
8868 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
8872 =head1 Embedding Functions
8874 =for apidoc load_module
8876 Loads the module whose name is pointed to by the string part of C<name>.
8877 Note that the actual module name, not its filename, should be given.
8878 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
8879 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
8880 trailing arguments can be used to specify arguments to the module's C<import()>
8881 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
8882 on the flags. The flags argument is a bitwise-ORed collection of any of
8883 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
8884 (or 0 for no flags).
8886 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
8887 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
8888 the trailing optional arguments may be omitted entirely. Otherwise, if
8889 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
8890 exactly one C<OP*>, containing the op tree that produces the relevant import
8891 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
8892 will be used as import arguments; and the list must be terminated with C<(SV*)
8893 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
8894 set, the trailing C<NULL> pointer is needed even if no import arguments are
8895 desired. The reference count for each specified C<SV*> argument is
8896 decremented. In addition, the C<name> argument is modified.
8898 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
8901 =for apidoc Amnh||PERL_LOADMOD_DENY
8902 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
8903 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
8908 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
8912 PERL_ARGS_ASSERT_LOAD_MODULE;
8914 va_start(args, ver);
8915 vload_module(flags, name, ver, &args);
8919 #ifdef PERL_IMPLICIT_CONTEXT
8921 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8925 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8926 va_start(args, ver);
8927 vload_module(flags, name, ver, &args);
8933 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8939 PERL_ARGS_ASSERT_VLOAD_MODULE;
8941 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8942 * that it has a PL_parser to play with while doing that, and also
8943 * that it doesn't mess with any existing parser, by creating a tmp
8944 * new parser with lex_start(). This won't actually be used for much,
8945 * since pp_require() will create another parser for the real work.
8946 * The ENTER/LEAVE pair protect callers from any side effects of use.
8948 * start_subparse() creates a new PL_compcv. This means that any ops
8949 * allocated below will be allocated from that CV's op slab, and so
8950 * will be automatically freed if the utilise() fails
8954 SAVEVPTR(PL_curcop);
8955 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8956 floor = start_subparse(FALSE, 0);
8958 modname = newSVOP(OP_CONST, 0, name);
8959 modname->op_private |= OPpCONST_BARE;
8961 veop = newSVOP(OP_CONST, 0, ver);
8965 if (flags & PERL_LOADMOD_NOIMPORT) {
8966 imop = sawparens(newNULLLIST());
8968 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8969 imop = va_arg(*args, OP*);
8974 sv = va_arg(*args, SV*);
8976 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8977 sv = va_arg(*args, SV*);
8981 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
8985 PERL_STATIC_INLINE OP *
8986 S_new_entersubop(pTHX_ GV *gv, OP *arg)
8988 return newUNOP(OP_ENTERSUB, OPf_STACKED,
8989 newLISTOP(OP_LIST, 0, arg,
8990 newUNOP(OP_RV2CV, 0,
8991 newGVOP(OP_GV, 0, gv))));
8995 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
9000 PERL_ARGS_ASSERT_DOFILE;
9002 if (!force_builtin && (gv = gv_override("do", 2))) {
9003 doop = S_new_entersubop(aTHX_ gv, term);
9006 doop = newUNOP(OP_DOFILE, 0, scalar(term));
9012 =head1 Optree construction
9014 =for apidoc newSLICEOP
9016 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
9017 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
9018 be set automatically, and, shifted up eight bits, the eight bits of
9019 C<op_private>, except that the bit with value 1 or 2 is automatically
9020 set as required. C<listval> and C<subscript> supply the parameters of
9021 the slice; they are consumed by this function and become part of the
9022 constructed op tree.
9028 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
9030 return newBINOP(OP_LSLICE, flags,
9031 list(force_list(subscript, 1)),
9032 list(force_list(listval, 1)) );
9035 #define ASSIGN_SCALAR 0
9036 #define ASSIGN_LIST 1
9037 #define ASSIGN_REF 2
9039 /* given the optree o on the LHS of an assignment, determine whether its:
9040 * ASSIGN_SCALAR $x = ...
9041 * ASSIGN_LIST ($x) = ...
9042 * ASSIGN_REF \$x = ...
9046 S_assignment_type(pTHX_ const OP *o)
9055 if (o->op_type == OP_SREFGEN)
9057 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
9058 type = kid->op_type;
9059 flags = o->op_flags | kid->op_flags;
9060 if (!(flags & OPf_PARENS)
9061 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
9062 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
9066 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
9067 o = cUNOPo->op_first;
9068 flags = o->op_flags;
9070 ret = ASSIGN_SCALAR;
9073 if (type == OP_COND_EXPR) {
9074 OP * const sib = OpSIBLING(cLOGOPo->op_first);
9075 const I32 t = assignment_type(sib);
9076 const I32 f = assignment_type(OpSIBLING(sib));
9078 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
9080 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
9081 yyerror("Assignment to both a list and a scalar");
9082 return ASSIGN_SCALAR;
9085 if (type == OP_LIST &&
9086 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
9087 o->op_private & OPpLVAL_INTRO)
9090 if (type == OP_LIST || flags & OPf_PARENS ||
9091 type == OP_RV2AV || type == OP_RV2HV ||
9092 type == OP_ASLICE || type == OP_HSLICE ||
9093 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
9096 if (type == OP_PADAV || type == OP_PADHV)
9099 if (type == OP_RV2SV)
9106 S_newONCEOP(pTHX_ OP *initop, OP *padop)
9108 const PADOFFSET target = padop->op_targ;
9109 OP *const other = newOP(OP_PADSV,
9111 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
9112 OP *const first = newOP(OP_NULL, 0);
9113 OP *const nullop = newCONDOP(0, first, initop, other);
9114 /* XXX targlex disabled for now; see ticket #124160
9115 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
9117 OP *const condop = first->op_next;
9119 OpTYPE_set(condop, OP_ONCE);
9120 other->op_targ = target;
9121 nullop->op_flags |= OPf_WANT_SCALAR;
9123 /* Store the initializedness of state vars in a separate
9126 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
9127 /* hijacking PADSTALE for uninitialized state variables */
9128 SvPADSTALE_on(PAD_SVl(condop->op_targ));
9134 =for apidoc newASSIGNOP
9136 Constructs, checks, and returns an assignment op. C<left> and C<right>
9137 supply the parameters of the assignment; they are consumed by this
9138 function and become part of the constructed op tree.
9140 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
9141 a suitable conditional optree is constructed. If C<optype> is the opcode
9142 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
9143 performs the binary operation and assigns the result to the left argument.
9144 Either way, if C<optype> is non-zero then C<flags> has no effect.
9146 If C<optype> is zero, then a plain scalar or list assignment is
9147 constructed. Which type of assignment it is is automatically determined.
9148 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9149 will be set automatically, and, shifted up eight bits, the eight bits
9150 of C<op_private>, except that the bit with value 1 or 2 is automatically
9157 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
9163 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
9164 right = scalar(right);
9165 return newLOGOP(optype, 0,
9166 op_lvalue(scalar(left), optype),
9167 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
9170 return newBINOP(optype, OPf_STACKED,
9171 op_lvalue(scalar(left), optype), scalar(right));
9175 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
9176 OP *state_var_op = NULL;
9177 static const char no_list_state[] = "Initialization of state variables"
9178 " in list currently forbidden";
9181 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
9182 left->op_private &= ~ OPpSLICEWARNING;
9185 left = op_lvalue(left, OP_AASSIGN);
9186 curop = list(force_list(left, 1));
9187 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
9188 o->op_private = (U8)(0 | (flags >> 8));
9190 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
9192 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
9193 if (!(left->op_flags & OPf_PARENS) &&
9194 lop->op_type == OP_PUSHMARK &&
9195 (vop = OpSIBLING(lop)) &&
9196 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
9197 !(vop->op_flags & OPf_PARENS) &&
9198 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
9199 (OPpLVAL_INTRO|OPpPAD_STATE) &&
9200 (eop = OpSIBLING(vop)) &&
9201 eop->op_type == OP_ENTERSUB &&
9202 !OpHAS_SIBLING(eop)) {
9206 if ((lop->op_type == OP_PADSV ||
9207 lop->op_type == OP_PADAV ||
9208 lop->op_type == OP_PADHV ||
9209 lop->op_type == OP_PADANY)
9210 && (lop->op_private & OPpPAD_STATE)
9212 yyerror(no_list_state);
9213 lop = OpSIBLING(lop);
9217 else if ( (left->op_private & OPpLVAL_INTRO)
9218 && (left->op_private & OPpPAD_STATE)
9219 && ( left->op_type == OP_PADSV
9220 || left->op_type == OP_PADAV
9221 || left->op_type == OP_PADHV
9222 || left->op_type == OP_PADANY)
9224 /* All single variable list context state assignments, hence
9234 if (left->op_flags & OPf_PARENS)
9235 yyerror(no_list_state);
9237 state_var_op = left;
9240 /* optimise @a = split(...) into:
9241 * @{expr}: split(..., @{expr}) (where @a is not flattened)
9242 * @a, my @a, local @a: split(...) (where @a is attached to
9243 * the split op itself)
9247 && right->op_type == OP_SPLIT
9248 /* don't do twice, e.g. @b = (@a = split) */
9249 && !(right->op_private & OPpSPLIT_ASSIGN))
9253 if ( ( left->op_type == OP_RV2AV
9254 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
9255 || left->op_type == OP_PADAV)
9257 /* @pkg or @lex or local @pkg' or 'my @lex' */
9261 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
9262 = cPADOPx(gvop)->op_padix;
9263 cPADOPx(gvop)->op_padix = 0; /* steal it */
9265 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
9266 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
9267 cSVOPx(gvop)->op_sv = NULL; /* steal it */
9269 right->op_private |=
9270 left->op_private & OPpOUR_INTRO;
9273 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
9274 left->op_targ = 0; /* steal it */
9275 right->op_private |= OPpSPLIT_LEX;
9277 right->op_private |= left->op_private & OPpLVAL_INTRO;
9280 tmpop = cUNOPo->op_first; /* to list (nulled) */
9281 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
9282 assert(OpSIBLING(tmpop) == right);
9283 assert(!OpHAS_SIBLING(right));
9284 /* detach the split subtreee from the o tree,
9285 * then free the residual o tree */
9286 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
9287 op_free(o); /* blow off assign */
9288 right->op_private |= OPpSPLIT_ASSIGN;
9289 right->op_flags &= ~OPf_WANT;
9290 /* "I don't know and I don't care." */
9293 else if (left->op_type == OP_RV2AV) {
9296 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
9297 assert(OpSIBLING(pushop) == left);
9298 /* Detach the array ... */
9299 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
9300 /* ... and attach it to the split. */
9301 op_sibling_splice(right, cLISTOPx(right)->op_last,
9303 right->op_flags |= OPf_STACKED;
9304 /* Detach split and expunge aassign as above. */
9307 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
9308 ((LISTOP*)right)->op_last->op_type == OP_CONST)
9310 /* convert split(...,0) to split(..., PL_modcount+1) */
9312 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
9313 SV * const sv = *svp;
9314 if (SvIOK(sv) && SvIVX(sv) == 0)
9316 if (right->op_private & OPpSPLIT_IMPLIM) {
9317 /* our own SV, created in ck_split */
9319 sv_setiv(sv, PL_modcount+1);
9322 /* SV may belong to someone else */
9324 *svp = newSViv(PL_modcount+1);
9331 o = S_newONCEOP(aTHX_ o, state_var_op);
9334 if (assign_type == ASSIGN_REF)
9335 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
9337 right = newOP(OP_UNDEF, 0);
9338 if (right->op_type == OP_READLINE) {
9339 right->op_flags |= OPf_STACKED;
9340 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
9344 o = newBINOP(OP_SASSIGN, flags,
9345 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
9351 =for apidoc newSTATEOP
9353 Constructs a state op (COP). The state op is normally a C<nextstate> op,
9354 but will be a C<dbstate> op if debugging is enabled for currently-compiled
9355 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
9356 If C<label> is non-null, it supplies the name of a label to attach to
9357 the state op; this function takes ownership of the memory pointed at by
9358 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
9361 If C<o> is null, the state op is returned. Otherwise the state op is
9362 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
9363 is consumed by this function and becomes part of the returned op tree.
9369 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
9371 const U32 seq = intro_my();
9372 const U32 utf8 = flags & SVf_UTF8;
9375 PL_parser->parsed_sub = 0;
9379 NewOp(1101, cop, 1, COP);
9380 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
9381 OpTYPE_set(cop, OP_DBSTATE);
9384 OpTYPE_set(cop, OP_NEXTSTATE);
9386 cop->op_flags = (U8)flags;
9387 CopHINTS_set(cop, PL_hints);
9389 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
9391 cop->op_next = (OP*)cop;
9394 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9395 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
9397 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
9399 PL_hints |= HINT_BLOCK_SCOPE;
9400 /* It seems that we need to defer freeing this pointer, as other parts
9401 of the grammar end up wanting to copy it after this op has been
9406 if (PL_parser->preambling != NOLINE) {
9407 CopLINE_set(cop, PL_parser->preambling);
9408 PL_parser->copline = NOLINE;
9410 else if (PL_parser->copline == NOLINE)
9411 CopLINE_set(cop, CopLINE(PL_curcop));
9413 CopLINE_set(cop, PL_parser->copline);
9414 PL_parser->copline = NOLINE;
9417 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
9419 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
9421 CopSTASH_set(cop, PL_curstash);
9423 if (cop->op_type == OP_DBSTATE) {
9424 /* this line can have a breakpoint - store the cop in IV */
9425 AV *av = CopFILEAVx(PL_curcop);
9427 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
9428 if (svp && *svp != &PL_sv_undef ) {
9429 (void)SvIOK_on(*svp);
9430 SvIV_set(*svp, PTR2IV(cop));
9435 if (flags & OPf_SPECIAL)
9437 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
9441 =for apidoc newLOGOP
9443 Constructs, checks, and returns a logical (flow control) op. C<type>
9444 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
9445 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
9446 the eight bits of C<op_private>, except that the bit with value 1 is
9447 automatically set. C<first> supplies the expression controlling the
9448 flow, and C<other> supplies the side (alternate) chain of ops; they are
9449 consumed by this function and become part of the constructed op tree.
9455 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
9457 PERL_ARGS_ASSERT_NEWLOGOP;
9459 return new_logop(type, flags, &first, &other);
9463 /* See if the optree o contains a single OP_CONST (plus possibly
9464 * surrounding enter/nextstate/null etc). If so, return it, else return
9469 S_search_const(pTHX_ OP *o)
9471 PERL_ARGS_ASSERT_SEARCH_CONST;
9474 switch (o->op_type) {
9478 if (o->op_flags & OPf_KIDS) {
9479 o = cUNOPo->op_first;
9488 if (!(o->op_flags & OPf_KIDS))
9490 kid = cLISTOPo->op_first;
9493 switch (kid->op_type) {
9497 kid = OpSIBLING(kid);
9500 if (kid != cLISTOPo->op_last)
9507 kid = cLISTOPo->op_last;
9519 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
9526 int prepend_not = 0;
9528 PERL_ARGS_ASSERT_NEW_LOGOP;
9533 /* [perl #59802]: Warn about things like "return $a or $b", which
9534 is parsed as "(return $a) or $b" rather than "return ($a or
9535 $b)". NB: This also applies to xor, which is why we do it
9538 switch (first->op_type) {
9542 /* XXX: Perhaps we should emit a stronger warning for these.
9543 Even with the high-precedence operator they don't seem to do
9546 But until we do, fall through here.
9552 /* XXX: Currently we allow people to "shoot themselves in the
9553 foot" by explicitly writing "(return $a) or $b".
9555 Warn unless we are looking at the result from folding or if
9556 the programmer explicitly grouped the operators like this.
9557 The former can occur with e.g.
9559 use constant FEATURE => ( $] >= ... );
9560 sub { not FEATURE and return or do_stuff(); }
9562 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
9563 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9564 "Possible precedence issue with control flow operator");
9565 /* XXX: Should we optimze this to "return $a;" (i.e. remove
9571 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
9572 return newBINOP(type, flags, scalar(first), scalar(other));
9574 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
9575 || type == OP_CUSTOM);
9577 scalarboolean(first);
9579 /* search for a constant op that could let us fold the test */
9580 if ((cstop = search_const(first))) {
9581 if (cstop->op_private & OPpCONST_STRICT)
9582 no_bareword_allowed(cstop);
9583 else if ((cstop->op_private & OPpCONST_BARE))
9584 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
9585 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
9586 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
9587 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
9588 /* Elide the (constant) lhs, since it can't affect the outcome */
9590 if (other->op_type == OP_CONST)
9591 other->op_private |= OPpCONST_SHORTCIRCUIT;
9593 if (other->op_type == OP_LEAVE)
9594 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
9595 else if (other->op_type == OP_MATCH
9596 || other->op_type == OP_SUBST
9597 || other->op_type == OP_TRANSR
9598 || other->op_type == OP_TRANS)
9599 /* Mark the op as being unbindable with =~ */
9600 other->op_flags |= OPf_SPECIAL;
9602 other->op_folded = 1;
9606 /* Elide the rhs, since the outcome is entirely determined by
9607 * the (constant) lhs */
9609 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
9610 const OP *o2 = other;
9611 if ( ! (o2->op_type == OP_LIST
9612 && (( o2 = cUNOPx(o2)->op_first))
9613 && o2->op_type == OP_PUSHMARK
9614 && (( o2 = OpSIBLING(o2))) )
9617 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
9618 || o2->op_type == OP_PADHV)
9619 && o2->op_private & OPpLVAL_INTRO
9620 && !(o2->op_private & OPpPAD_STATE))
9622 Perl_croak(aTHX_ "This use of my() in false conditional is "
9623 "no longer allowed");
9627 if (cstop->op_type == OP_CONST)
9628 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
9633 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
9634 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
9636 const OP * const k1 = ((UNOP*)first)->op_first;
9637 const OP * const k2 = OpSIBLING(k1);
9639 switch (first->op_type)
9642 if (k2 && k2->op_type == OP_READLINE
9643 && (k2->op_flags & OPf_STACKED)
9644 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9646 warnop = k2->op_type;
9651 if (k1->op_type == OP_READDIR
9652 || k1->op_type == OP_GLOB
9653 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9654 || k1->op_type == OP_EACH
9655 || k1->op_type == OP_AEACH)
9657 warnop = ((k1->op_type == OP_NULL)
9658 ? (OPCODE)k1->op_targ : k1->op_type);
9663 const line_t oldline = CopLINE(PL_curcop);
9664 /* This ensures that warnings are reported at the first line
9665 of the construction, not the last. */
9666 CopLINE_set(PL_curcop, PL_parser->copline);
9667 Perl_warner(aTHX_ packWARN(WARN_MISC),
9668 "Value of %s%s can be \"0\"; test with defined()",
9670 ((warnop == OP_READLINE || warnop == OP_GLOB)
9671 ? " construct" : "() operator"));
9672 CopLINE_set(PL_curcop, oldline);
9676 /* optimize AND and OR ops that have NOTs as children */
9677 if (first->op_type == OP_NOT
9678 && (first->op_flags & OPf_KIDS)
9679 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
9680 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
9682 if (type == OP_AND || type == OP_OR) {
9688 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
9690 prepend_not = 1; /* prepend a NOT op later */
9695 logop = alloc_LOGOP(type, first, LINKLIST(other));
9696 logop->op_flags |= (U8)flags;
9697 logop->op_private = (U8)(1 | (flags >> 8));
9699 /* establish postfix order */
9700 logop->op_next = LINKLIST(first);
9701 first->op_next = (OP*)logop;
9702 assert(!OpHAS_SIBLING(first));
9703 op_sibling_splice((OP*)logop, first, 0, other);
9705 CHECKOP(type,logop);
9707 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
9708 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
9716 =for apidoc newCONDOP
9718 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
9719 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9720 will be set automatically, and, shifted up eight bits, the eight bits of
9721 C<op_private>, except that the bit with value 1 is automatically set.
9722 C<first> supplies the expression selecting between the two branches,
9723 and C<trueop> and C<falseop> supply the branches; they are consumed by
9724 this function and become part of the constructed op tree.
9730 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
9737 PERL_ARGS_ASSERT_NEWCONDOP;
9740 return newLOGOP(OP_AND, 0, first, trueop);
9742 return newLOGOP(OP_OR, 0, first, falseop);
9744 scalarboolean(first);
9745 if ((cstop = search_const(first))) {
9746 /* Left or right arm of the conditional? */
9747 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
9748 OP *live = left ? trueop : falseop;
9749 OP *const dead = left ? falseop : trueop;
9750 if (cstop->op_private & OPpCONST_BARE &&
9751 cstop->op_private & OPpCONST_STRICT) {
9752 no_bareword_allowed(cstop);
9756 if (live->op_type == OP_LEAVE)
9757 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
9758 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
9759 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
9760 /* Mark the op as being unbindable with =~ */
9761 live->op_flags |= OPf_SPECIAL;
9762 live->op_folded = 1;
9765 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
9766 logop->op_flags |= (U8)flags;
9767 logop->op_private = (U8)(1 | (flags >> 8));
9768 logop->op_next = LINKLIST(falseop);
9770 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
9773 /* establish postfix order */
9774 start = LINKLIST(first);
9775 first->op_next = (OP*)logop;
9777 /* make first, trueop, falseop siblings */
9778 op_sibling_splice((OP*)logop, first, 0, trueop);
9779 op_sibling_splice((OP*)logop, trueop, 0, falseop);
9781 o = newUNOP(OP_NULL, 0, (OP*)logop);
9783 trueop->op_next = falseop->op_next = o;
9790 =for apidoc newRANGE
9792 Constructs and returns a C<range> op, with subordinate C<flip> and
9793 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
9794 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
9795 for both the C<flip> and C<range> ops, except that the bit with value
9796 1 is automatically set. C<left> and C<right> supply the expressions
9797 controlling the endpoints of the range; they are consumed by this function
9798 and become part of the constructed op tree.
9804 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
9812 PERL_ARGS_ASSERT_NEWRANGE;
9814 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
9815 range->op_flags = OPf_KIDS;
9816 leftstart = LINKLIST(left);
9817 range->op_private = (U8)(1 | (flags >> 8));
9819 /* make left and right siblings */
9820 op_sibling_splice((OP*)range, left, 0, right);
9822 range->op_next = (OP*)range;
9823 flip = newUNOP(OP_FLIP, flags, (OP*)range);
9824 flop = newUNOP(OP_FLOP, 0, flip);
9825 o = newUNOP(OP_NULL, 0, flop);
9827 range->op_next = leftstart;
9829 left->op_next = flip;
9830 right->op_next = flop;
9833 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9834 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9836 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9837 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9838 SvPADTMP_on(PAD_SV(flip->op_targ));
9840 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9841 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9843 /* check barewords before they might be optimized aways */
9844 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9845 no_bareword_allowed(left);
9846 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9847 no_bareword_allowed(right);
9850 if (!flip->op_private || !flop->op_private)
9851 LINKLIST(o); /* blow off optimizer unless constant */
9857 =for apidoc newLOOPOP
9859 Constructs, checks, and returns an op tree expressing a loop. This is
9860 only a loop in the control flow through the op tree; it does not have
9861 the heavyweight loop structure that allows exiting the loop by C<last>
9862 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
9863 top-level op, except that some bits will be set automatically as required.
9864 C<expr> supplies the expression controlling loop iteration, and C<block>
9865 supplies the body of the loop; they are consumed by this function and
9866 become part of the constructed op tree. C<debuggable> is currently
9867 unused and should always be 1.
9873 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9877 const bool once = block && block->op_flags & OPf_SPECIAL &&
9878 block->op_type == OP_NULL;
9880 PERL_UNUSED_ARG(debuggable);
9884 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
9885 || ( expr->op_type == OP_NOT
9886 && cUNOPx(expr)->op_first->op_type == OP_CONST
9887 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9890 /* Return the block now, so that S_new_logop does not try to
9894 return block; /* do {} while 0 does once */
9897 if (expr->op_type == OP_READLINE
9898 || expr->op_type == OP_READDIR
9899 || expr->op_type == OP_GLOB
9900 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9901 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9902 expr = newUNOP(OP_DEFINED, 0,
9903 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9904 } else if (expr->op_flags & OPf_KIDS) {
9905 const OP * const k1 = ((UNOP*)expr)->op_first;
9906 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9907 switch (expr->op_type) {
9909 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9910 && (k2->op_flags & OPf_STACKED)
9911 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9912 expr = newUNOP(OP_DEFINED, 0, expr);
9916 if (k1 && (k1->op_type == OP_READDIR
9917 || k1->op_type == OP_GLOB
9918 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9919 || k1->op_type == OP_EACH
9920 || k1->op_type == OP_AEACH))
9921 expr = newUNOP(OP_DEFINED, 0, expr);
9927 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9928 * op, in listop. This is wrong. [perl #27024] */
9930 block = newOP(OP_NULL, 0);
9931 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9932 o = new_logop(OP_AND, 0, &expr, &listop);
9939 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
9941 if (once && o != listop)
9943 assert(cUNOPo->op_first->op_type == OP_AND
9944 || cUNOPo->op_first->op_type == OP_OR);
9945 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
9949 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
9951 o->op_flags |= flags;
9953 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9958 =for apidoc newWHILEOP
9960 Constructs, checks, and returns an op tree expressing a C<while> loop.
9961 This is a heavyweight loop, with structure that allows exiting the loop
9962 by C<last> and suchlike.
9964 C<loop> is an optional preconstructed C<enterloop> op to use in the
9965 loop; if it is null then a suitable op will be constructed automatically.
9966 C<expr> supplies the loop's controlling expression. C<block> supplies the
9967 main body of the loop, and C<cont> optionally supplies a C<continue> block
9968 that operates as a second half of the body. All of these optree inputs
9969 are consumed by this function and become part of the constructed op tree.
9971 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9972 op and, shifted up eight bits, the eight bits of C<op_private> for
9973 the C<leaveloop> op, except that (in both cases) some bits will be set
9974 automatically. C<debuggable> is currently unused and should always be 1.
9975 C<has_my> can be supplied as true to force the
9976 loop body to be enclosed in its own scope.
9982 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9983 OP *expr, OP *block, OP *cont, I32 has_my)
9991 PERL_UNUSED_ARG(debuggable);
9994 if (expr->op_type == OP_READLINE
9995 || expr->op_type == OP_READDIR
9996 || expr->op_type == OP_GLOB
9997 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9998 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9999 expr = newUNOP(OP_DEFINED, 0,
10000 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
10001 } else if (expr->op_flags & OPf_KIDS) {
10002 const OP * const k1 = ((UNOP*)expr)->op_first;
10003 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
10004 switch (expr->op_type) {
10006 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
10007 && (k2->op_flags & OPf_STACKED)
10008 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
10009 expr = newUNOP(OP_DEFINED, 0, expr);
10013 if (k1 && (k1->op_type == OP_READDIR
10014 || k1->op_type == OP_GLOB
10015 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
10016 || k1->op_type == OP_EACH
10017 || k1->op_type == OP_AEACH))
10018 expr = newUNOP(OP_DEFINED, 0, expr);
10025 block = newOP(OP_NULL, 0);
10026 else if (cont || has_my) {
10027 block = op_scope(block);
10031 next = LINKLIST(cont);
10034 OP * const unstack = newOP(OP_UNSTACK, 0);
10037 cont = op_append_elem(OP_LINESEQ, cont, unstack);
10041 listop = op_append_list(OP_LINESEQ, block, cont);
10043 redo = LINKLIST(listop);
10047 o = new_logop(OP_AND, 0, &expr, &listop);
10048 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
10049 op_free((OP*)loop);
10050 return expr; /* listop already freed by new_logop */
10053 ((LISTOP*)listop)->op_last->op_next =
10054 (o == listop ? redo : LINKLIST(o));
10060 NewOp(1101,loop,1,LOOP);
10061 OpTYPE_set(loop, OP_ENTERLOOP);
10062 loop->op_private = 0;
10063 loop->op_next = (OP*)loop;
10066 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
10068 loop->op_redoop = redo;
10069 loop->op_lastop = o;
10070 o->op_private |= loopflags;
10073 loop->op_nextop = next;
10075 loop->op_nextop = o;
10077 o->op_flags |= flags;
10078 o->op_private |= (flags >> 8);
10083 =for apidoc newFOROP
10085 Constructs, checks, and returns an op tree expressing a C<foreach>
10086 loop (iteration through a list of values). This is a heavyweight loop,
10087 with structure that allows exiting the loop by C<last> and suchlike.
10089 C<sv> optionally supplies the variable that will be aliased to each
10090 item in turn; if null, it defaults to C<$_>.
10091 C<expr> supplies the list of values to iterate over. C<block> supplies
10092 the main body of the loop, and C<cont> optionally supplies a C<continue>
10093 block that operates as a second half of the body. All of these optree
10094 inputs are consumed by this function and become part of the constructed
10097 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10098 op and, shifted up eight bits, the eight bits of C<op_private> for
10099 the C<leaveloop> op, except that (in both cases) some bits will be set
10106 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
10110 PADOFFSET padoff = 0;
10112 I32 iterpflags = 0;
10114 PERL_ARGS_ASSERT_NEWFOROP;
10117 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
10118 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
10119 OpTYPE_set(sv, OP_RV2GV);
10121 /* The op_type check is needed to prevent a possible segfault
10122 * if the loop variable is undeclared and 'strict vars' is in
10123 * effect. This is illegal but is nonetheless parsed, so we
10124 * may reach this point with an OP_CONST where we're expecting
10127 if (cUNOPx(sv)->op_first->op_type == OP_GV
10128 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
10129 iterpflags |= OPpITER_DEF;
10131 else if (sv->op_type == OP_PADSV) { /* private variable */
10132 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
10133 padoff = sv->op_targ;
10137 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
10139 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
10142 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
10144 PADNAME * const pn = PAD_COMPNAME(padoff);
10145 const char * const name = PadnamePV(pn);
10147 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
10148 iterpflags |= OPpITER_DEF;
10152 sv = newGVOP(OP_GV, 0, PL_defgv);
10153 iterpflags |= OPpITER_DEF;
10156 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
10157 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
10158 iterflags |= OPf_STACKED;
10160 else if (expr->op_type == OP_NULL &&
10161 (expr->op_flags & OPf_KIDS) &&
10162 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
10164 /* Basically turn for($x..$y) into the same as for($x,$y), but we
10165 * set the STACKED flag to indicate that these values are to be
10166 * treated as min/max values by 'pp_enteriter'.
10168 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
10169 LOGOP* const range = (LOGOP*) flip->op_first;
10170 OP* const left = range->op_first;
10171 OP* const right = OpSIBLING(left);
10174 range->op_flags &= ~OPf_KIDS;
10175 /* detach range's children */
10176 op_sibling_splice((OP*)range, NULL, -1, NULL);
10178 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
10179 listop->op_first->op_next = range->op_next;
10180 left->op_next = range->op_other;
10181 right->op_next = (OP*)listop;
10182 listop->op_next = listop->op_first;
10185 expr = (OP*)(listop);
10187 iterflags |= OPf_STACKED;
10190 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
10193 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
10194 op_append_elem(OP_LIST, list(expr),
10196 assert(!loop->op_next);
10197 /* for my $x () sets OPpLVAL_INTRO;
10198 * for our $x () sets OPpOUR_INTRO */
10199 loop->op_private = (U8)iterpflags;
10201 /* upgrade loop from a LISTOP to a LOOPOP;
10202 * keep it in-place if there's space */
10203 if (loop->op_slabbed
10204 && OpSLOT(loop)->opslot_size
10205 < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
10207 /* no space; allocate new op */
10209 NewOp(1234,tmp,1,LOOP);
10210 Copy(loop,tmp,1,LISTOP);
10211 assert(loop->op_last->op_sibparent == (OP*)loop);
10212 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
10213 S_op_destroy(aTHX_ (OP*)loop);
10216 else if (!loop->op_slabbed)
10218 /* loop was malloc()ed */
10219 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
10220 OpLASTSIB_set(loop->op_last, (OP*)loop);
10222 loop->op_targ = padoff;
10223 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
10228 =for apidoc newLOOPEX
10230 Constructs, checks, and returns a loop-exiting op (such as C<goto>
10231 or C<last>). C<type> is the opcode. C<label> supplies the parameter
10232 determining the target of the op; it is consumed by this function and
10233 becomes part of the constructed op tree.
10239 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
10243 PERL_ARGS_ASSERT_NEWLOOPEX;
10245 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
10246 || type == OP_CUSTOM);
10248 if (type != OP_GOTO) {
10249 /* "last()" means "last" */
10250 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
10251 o = newOP(type, OPf_SPECIAL);
10255 /* Check whether it's going to be a goto &function */
10256 if (label->op_type == OP_ENTERSUB
10257 && !(label->op_flags & OPf_STACKED))
10258 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
10261 /* Check for a constant argument */
10262 if (label->op_type == OP_CONST) {
10263 SV * const sv = ((SVOP *)label)->op_sv;
10265 const char *s = SvPV_const(sv,l);
10266 if (l == strlen(s)) {
10268 SvUTF8(((SVOP*)label)->op_sv),
10270 SvPV_nolen_const(((SVOP*)label)->op_sv)));
10274 /* If we have already created an op, we do not need the label. */
10277 else o = newUNOP(type, OPf_STACKED, label);
10279 PL_hints |= HINT_BLOCK_SCOPE;
10283 /* if the condition is a literal array or hash
10284 (or @{ ... } etc), make a reference to it.
10287 S_ref_array_or_hash(pTHX_ OP *cond)
10290 && (cond->op_type == OP_RV2AV
10291 || cond->op_type == OP_PADAV
10292 || cond->op_type == OP_RV2HV
10293 || cond->op_type == OP_PADHV))
10295 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
10298 && (cond->op_type == OP_ASLICE
10299 || cond->op_type == OP_KVASLICE
10300 || cond->op_type == OP_HSLICE
10301 || cond->op_type == OP_KVHSLICE)) {
10303 /* anonlist now needs a list from this op, was previously used in
10304 * scalar context */
10305 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
10306 cond->op_flags |= OPf_WANT_LIST;
10308 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
10315 /* These construct the optree fragments representing given()
10318 entergiven and enterwhen are LOGOPs; the op_other pointer
10319 points up to the associated leave op. We need this so we
10320 can put it in the context and make break/continue work.
10321 (Also, of course, pp_enterwhen will jump straight to
10322 op_other if the match fails.)
10326 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
10327 I32 enter_opcode, I32 leave_opcode,
10328 PADOFFSET entertarg)
10333 PERL_ARGS_ASSERT_NEWGIVWHENOP;
10334 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
10336 enterop = alloc_LOGOP(enter_opcode, block, NULL);
10337 enterop->op_targ = 0;
10338 enterop->op_private = 0;
10340 o = newUNOP(leave_opcode, 0, (OP *) enterop);
10343 /* prepend cond if we have one */
10344 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
10346 o->op_next = LINKLIST(cond);
10347 cond->op_next = (OP *) enterop;
10350 /* This is a default {} block */
10351 enterop->op_flags |= OPf_SPECIAL;
10352 o ->op_flags |= OPf_SPECIAL;
10354 o->op_next = (OP *) enterop;
10357 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
10358 entergiven and enterwhen both
10361 enterop->op_next = LINKLIST(block);
10362 block->op_next = enterop->op_other = o;
10368 /* For the purposes of 'when(implied_smartmatch)'
10369 * versus 'when(boolean_expression)',
10370 * does this look like a boolean operation? For these purposes
10371 a boolean operation is:
10372 - a subroutine call [*]
10373 - a logical connective
10374 - a comparison operator
10375 - a filetest operator, with the exception of -s -M -A -C
10376 - defined(), exists() or eof()
10377 - /$re/ or $foo =~ /$re/
10379 [*] possibly surprising
10382 S_looks_like_bool(pTHX_ const OP *o)
10384 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
10386 switch(o->op_type) {
10389 return looks_like_bool(cLOGOPo->op_first);
10393 OP* sibl = OpSIBLING(cLOGOPo->op_first);
10396 looks_like_bool(cLOGOPo->op_first)
10397 && looks_like_bool(sibl));
10403 o->op_flags & OPf_KIDS
10404 && looks_like_bool(cUNOPo->op_first));
10408 case OP_NOT: case OP_XOR:
10410 case OP_EQ: case OP_NE: case OP_LT:
10411 case OP_GT: case OP_LE: case OP_GE:
10413 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
10414 case OP_I_GT: case OP_I_LE: case OP_I_GE:
10416 case OP_SEQ: case OP_SNE: case OP_SLT:
10417 case OP_SGT: case OP_SLE: case OP_SGE:
10419 case OP_SMARTMATCH:
10421 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
10422 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
10423 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
10424 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
10425 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
10426 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
10427 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
10428 case OP_FTTEXT: case OP_FTBINARY:
10430 case OP_DEFINED: case OP_EXISTS:
10431 case OP_MATCH: case OP_EOF:
10439 /* optimised-away (index() != -1) or similar comparison */
10440 if (o->op_private & OPpTRUEBOOL)
10445 /* Detect comparisons that have been optimized away */
10446 if (cSVOPo->op_sv == &PL_sv_yes
10447 || cSVOPo->op_sv == &PL_sv_no)
10460 =for apidoc newGIVENOP
10462 Constructs, checks, and returns an op tree expressing a C<given> block.
10463 C<cond> supplies the expression to whose value C<$_> will be locally
10464 aliased, and C<block> supplies the body of the C<given> construct; they
10465 are consumed by this function and become part of the constructed op tree.
10466 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
10472 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
10474 PERL_ARGS_ASSERT_NEWGIVENOP;
10475 PERL_UNUSED_ARG(defsv_off);
10477 assert(!defsv_off);
10478 return newGIVWHENOP(
10479 ref_array_or_hash(cond),
10481 OP_ENTERGIVEN, OP_LEAVEGIVEN,
10486 =for apidoc newWHENOP
10488 Constructs, checks, and returns an op tree expressing a C<when> block.
10489 C<cond> supplies the test expression, and C<block> supplies the block
10490 that will be executed if the test evaluates to true; they are consumed
10491 by this function and become part of the constructed op tree. C<cond>
10492 will be interpreted DWIMically, often as a comparison against C<$_>,
10493 and may be null to generate a C<default> block.
10499 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
10501 const bool cond_llb = (!cond || looks_like_bool(cond));
10504 PERL_ARGS_ASSERT_NEWWHENOP;
10509 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
10511 scalar(ref_array_or_hash(cond)));
10514 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
10517 /* must not conflict with SVf_UTF8 */
10518 #define CV_CKPROTO_CURSTASH 0x1
10521 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
10522 const STRLEN len, const U32 flags)
10524 SV *name = NULL, *msg;
10525 const char * cvp = SvROK(cv)
10526 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
10527 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
10530 STRLEN clen = CvPROTOLEN(cv), plen = len;
10532 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
10534 if (p == NULL && cvp == NULL)
10537 if (!ckWARN_d(WARN_PROTOTYPE))
10541 p = S_strip_spaces(aTHX_ p, &plen);
10542 cvp = S_strip_spaces(aTHX_ cvp, &clen);
10543 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
10544 if (plen == clen && memEQ(cvp, p, plen))
10547 if (flags & SVf_UTF8) {
10548 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
10552 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
10558 msg = sv_newmortal();
10563 gv_efullname3(name = sv_newmortal(), gv, NULL);
10564 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
10565 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
10566 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
10567 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
10568 sv_catpvs(name, "::");
10570 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
10571 assert (CvNAMED(SvRV_const(gv)));
10572 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
10574 else sv_catsv(name, (SV *)gv);
10576 else name = (SV *)gv;
10578 sv_setpvs(msg, "Prototype mismatch:");
10580 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
10582 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
10583 UTF8fARG(SvUTF8(cv),clen,cvp)
10586 sv_catpvs(msg, ": none");
10587 sv_catpvs(msg, " vs ");
10589 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
10591 sv_catpvs(msg, "none");
10592 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
10595 static void const_sv_xsub(pTHX_ CV* cv);
10596 static void const_av_xsub(pTHX_ CV* cv);
10600 =head1 Optree Manipulation Functions
10602 =for apidoc cv_const_sv
10604 If C<cv> is a constant sub eligible for inlining, returns the constant
10605 value returned by the sub. Otherwise, returns C<NULL>.
10607 Constant subs can be created with C<newCONSTSUB> or as described in
10608 L<perlsub/"Constant Functions">.
10613 Perl_cv_const_sv(const CV *const cv)
10618 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
10620 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10621 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
10626 Perl_cv_const_sv_or_av(const CV * const cv)
10630 if (SvROK(cv)) return SvRV((SV *)cv);
10631 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
10632 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10635 /* op_const_sv: examine an optree to determine whether it's in-lineable.
10636 * Can be called in 2 ways:
10639 * look for a single OP_CONST with attached value: return the value
10641 * allow_lex && !CvCONST(cv);
10643 * examine the clone prototype, and if contains only a single
10644 * OP_CONST, return the value; or if it contains a single PADSV ref-
10645 * erencing an outer lexical, turn on CvCONST to indicate the CV is
10646 * a candidate for "constizing" at clone time, and return NULL.
10650 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
10653 bool padsv = FALSE;
10658 for (; o; o = o->op_next) {
10659 const OPCODE type = o->op_type;
10661 if (type == OP_NEXTSTATE || type == OP_LINESEQ
10663 || type == OP_PUSHMARK)
10665 if (type == OP_DBSTATE)
10667 if (type == OP_LEAVESUB)
10671 if (type == OP_CONST && cSVOPo->op_sv)
10672 sv = cSVOPo->op_sv;
10673 else if (type == OP_UNDEF && !o->op_private) {
10677 else if (allow_lex && type == OP_PADSV) {
10678 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
10680 sv = &PL_sv_undef; /* an arbitrary non-null value */
10698 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10699 PADNAME * const name, SV ** const const_svp)
10702 assert (o || name);
10703 assert (const_svp);
10705 if (CvFLAGS(PL_compcv)) {
10706 /* might have had built-in attrs applied */
10707 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10708 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10709 && ckWARN(WARN_MISC))
10711 /* protect against fatal warnings leaking compcv */
10712 SAVEFREESV(PL_compcv);
10713 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10714 SvREFCNT_inc_simple_void_NN(PL_compcv);
10717 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10718 & ~(CVf_LVALUE * pureperl));
10723 /* redundant check for speed: */
10724 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10725 const line_t oldline = CopLINE(PL_curcop);
10728 : sv_2mortal(newSVpvn_utf8(
10729 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
10731 if (PL_parser && PL_parser->copline != NOLINE)
10732 /* This ensures that warnings are reported at the first
10733 line of a redefinition, not the last. */
10734 CopLINE_set(PL_curcop, PL_parser->copline);
10735 /* protect against fatal warnings leaking compcv */
10736 SAVEFREESV(PL_compcv);
10737 report_redefined_cv(namesv, cv, const_svp);
10738 SvREFCNT_inc_simple_void_NN(PL_compcv);
10739 CopLINE_set(PL_curcop, oldline);
10746 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10751 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10754 CV *compcv = PL_compcv;
10757 PADOFFSET pax = o->op_targ;
10758 CV *outcv = CvOUTSIDE(PL_compcv);
10761 bool reusable = FALSE;
10763 #ifdef PERL_DEBUG_READONLY_OPS
10764 OPSLAB *slab = NULL;
10767 PERL_ARGS_ASSERT_NEWMYSUB;
10769 PL_hints |= HINT_BLOCK_SCOPE;
10771 /* Find the pad slot for storing the new sub.
10772 We cannot use PL_comppad, as it is the pad owned by the new sub. We
10773 need to look in CvOUTSIDE and find the pad belonging to the enclos-
10774 ing sub. And then we need to dig deeper if this is a lexical from
10776 my sub foo; sub { sub foo { } }
10779 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10780 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10781 pax = PARENT_PAD_INDEX(name);
10782 outcv = CvOUTSIDE(outcv);
10787 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10788 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10789 spot = (CV **)svspot;
10791 if (!(PL_parser && PL_parser->error_count))
10792 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10795 assert(proto->op_type == OP_CONST);
10796 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10797 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10807 if (PL_parser && PL_parser->error_count) {
10809 SvREFCNT_dec(PL_compcv);
10814 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10816 svspot = (SV **)(spot = &clonee);
10818 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10821 assert (SvTYPE(*spot) == SVt_PVCV);
10822 if (CvNAMED(*spot))
10823 hek = CvNAME_HEK(*spot);
10826 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10827 CvNAME_HEK_set(*spot, hek =
10830 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10834 CvLEXICAL_on(*spot);
10836 cv = PadnamePROTOCV(name);
10837 svspot = (SV **)(spot = &PadnamePROTOCV(name));
10841 /* This makes sub {}; work as expected. */
10842 if (block->op_type == OP_STUB) {
10843 const line_t l = PL_parser->copline;
10845 block = newSTATEOP(0, NULL, 0);
10846 PL_parser->copline = l;
10848 block = CvLVALUE(compcv)
10849 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10850 ? newUNOP(OP_LEAVESUBLV, 0,
10851 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10852 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10853 start = LINKLIST(block);
10854 block->op_next = 0;
10855 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10856 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10864 const bool exists = CvROOT(cv) || CvXSUB(cv);
10866 /* if the subroutine doesn't exist and wasn't pre-declared
10867 * with a prototype, assume it will be AUTOLOADed,
10868 * skipping the prototype check
10870 if (exists || SvPOK(cv))
10871 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10873 /* already defined? */
10875 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10881 /* just a "sub foo;" when &foo is already defined */
10882 SAVEFREESV(compcv);
10886 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10893 SvREFCNT_inc_simple_void_NN(const_sv);
10894 SvFLAGS(const_sv) |= SVs_PADTMP;
10896 assert(!CvROOT(cv) && !CvCONST(cv));
10897 cv_forget_slab(cv);
10900 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10901 CvFILE_set_from_cop(cv, PL_curcop);
10902 CvSTASH_set(cv, PL_curstash);
10905 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10906 CvXSUBANY(cv).any_ptr = const_sv;
10907 CvXSUB(cv) = const_sv_xsub;
10911 CvFLAGS(cv) |= CvMETHOD(compcv);
10913 SvREFCNT_dec(compcv);
10918 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10919 determine whether this sub definition is in the same scope as its
10920 declaration. If this sub definition is inside an inner named pack-
10921 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10922 the package sub. So check PadnameOUTER(name) too.
10924 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10925 assert(!CvWEAKOUTSIDE(compcv));
10926 SvREFCNT_dec(CvOUTSIDE(compcv));
10927 CvWEAKOUTSIDE_on(compcv);
10929 /* XXX else do we have a circular reference? */
10931 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
10932 /* transfer PL_compcv to cv */
10934 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10935 cv_flags_t preserved_flags =
10936 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10937 PADLIST *const temp_padl = CvPADLIST(cv);
10938 CV *const temp_cv = CvOUTSIDE(cv);
10939 const cv_flags_t other_flags =
10940 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10941 OP * const cvstart = CvSTART(cv);
10945 CvFLAGS(compcv) | preserved_flags;
10946 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10947 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10948 CvPADLIST_set(cv, CvPADLIST(compcv));
10949 CvOUTSIDE(compcv) = temp_cv;
10950 CvPADLIST_set(compcv, temp_padl);
10951 CvSTART(cv) = CvSTART(compcv);
10952 CvSTART(compcv) = cvstart;
10953 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10954 CvFLAGS(compcv) |= other_flags;
10957 Safefree(CvFILE(cv));
10961 /* inner references to compcv must be fixed up ... */
10962 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10963 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10964 ++PL_sub_generation;
10967 /* Might have had built-in attributes applied -- propagate them. */
10968 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10970 /* ... before we throw it away */
10971 SvREFCNT_dec(compcv);
10972 PL_compcv = compcv = cv;
10981 if (!CvNAME_HEK(cv)) {
10982 if (hek) (void)share_hek_hek(hek);
10985 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10986 hek = share_hek(PadnamePV(name)+1,
10987 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10990 CvNAME_HEK_set(cv, hek);
10996 if (CvFILE(cv) && CvDYNFILE(cv))
10997 Safefree(CvFILE(cv));
10998 CvFILE_set_from_cop(cv, PL_curcop);
10999 CvSTASH_set(cv, PL_curstash);
11002 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11004 SvUTF8_on(MUTABLE_SV(cv));
11008 /* If we assign an optree to a PVCV, then we've defined a
11009 * subroutine that the debugger could be able to set a breakpoint
11010 * in, so signal to pp_entereval that it should not throw away any
11011 * saved lines at scope exit. */
11013 PL_breakable_sub_gen++;
11014 CvROOT(cv) = block;
11015 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11016 itself has a refcount. */
11018 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11019 #ifdef PERL_DEBUG_READONLY_OPS
11020 slab = (OPSLAB *)CvSTART(cv);
11022 S_process_optree(aTHX_ cv, block, start);
11027 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11028 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
11032 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11033 SV * const tmpstr = sv_newmortal();
11034 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11035 GV_ADDMULTI, SVt_PVHV);
11037 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11038 CopFILE(PL_curcop),
11040 (long)CopLINE(PL_curcop));
11041 if (HvNAME_HEK(PL_curstash)) {
11042 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
11043 sv_catpvs(tmpstr, "::");
11046 sv_setpvs(tmpstr, "__ANON__::");
11048 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
11049 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
11050 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11051 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11052 hv = GvHVn(db_postponed);
11053 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11054 CV * const pcv = GvCV(db_postponed);
11060 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11068 assert(CvDEPTH(outcv));
11070 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
11072 cv_clone_into(clonee, *spot);
11073 else *spot = cv_clone(clonee);
11074 SvREFCNT_dec_NN(clonee);
11078 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
11079 PADOFFSET depth = CvDEPTH(outcv);
11082 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
11084 *svspot = SvREFCNT_inc_simple_NN(cv);
11085 SvREFCNT_dec(oldcv);
11091 PL_parser->copline = NOLINE;
11092 LEAVE_SCOPE(floor);
11093 #ifdef PERL_DEBUG_READONLY_OPS
11102 =for apidoc newATTRSUB_x
11104 Construct a Perl subroutine, also performing some surrounding jobs.
11106 This function is expected to be called in a Perl compilation context,
11107 and some aspects of the subroutine are taken from global variables
11108 associated with compilation. In particular, C<PL_compcv> represents
11109 the subroutine that is currently being compiled. It must be non-null
11110 when this function is called, and some aspects of the subroutine being
11111 constructed are taken from it. The constructed subroutine may actually
11112 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
11114 If C<block> is null then the subroutine will have no body, and for the
11115 time being it will be an error to call it. This represents a forward
11116 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
11117 non-null then it provides the Perl code of the subroutine body, which
11118 will be executed when the subroutine is called. This body includes
11119 any argument unwrapping code resulting from a subroutine signature or
11120 similar. The pad use of the code must correspond to the pad attached
11121 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
11122 C<leavesublv> op; this function will add such an op. C<block> is consumed
11123 by this function and will become part of the constructed subroutine.
11125 C<proto> specifies the subroutine's prototype, unless one is supplied
11126 as an attribute (see below). If C<proto> is null, then the subroutine
11127 will not have a prototype. If C<proto> is non-null, it must point to a
11128 C<const> op whose value is a string, and the subroutine will have that
11129 string as its prototype. If a prototype is supplied as an attribute, the
11130 attribute takes precedence over C<proto>, but in that case C<proto> should
11131 preferably be null. In any case, C<proto> is consumed by this function.
11133 C<attrs> supplies attributes to be applied the subroutine. A handful of
11134 attributes take effect by built-in means, being applied to C<PL_compcv>
11135 immediately when seen. Other attributes are collected up and attached
11136 to the subroutine by this route. C<attrs> may be null to supply no
11137 attributes, or point to a C<const> op for a single attribute, or point
11138 to a C<list> op whose children apart from the C<pushmark> are C<const>
11139 ops for one or more attributes. Each C<const> op must be a string,
11140 giving the attribute name optionally followed by parenthesised arguments,
11141 in the manner in which attributes appear in Perl source. The attributes
11142 will be applied to the sub by this function. C<attrs> is consumed by
11145 If C<o_is_gv> is false and C<o> is null, then the subroutine will
11146 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
11147 must point to a C<const> op, which will be consumed by this function,
11148 and its string value supplies a name for the subroutine. The name may
11149 be qualified or unqualified, and if it is unqualified then a default
11150 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
11151 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
11152 by which the subroutine will be named.
11154 If there is already a subroutine of the specified name, then the new
11155 sub will either replace the existing one in the glob or be merged with
11156 the existing one. A warning may be generated about redefinition.
11158 If the subroutine has one of a few special names, such as C<BEGIN> or
11159 C<END>, then it will be claimed by the appropriate queue for automatic
11160 running of phase-related subroutines. In this case the relevant glob will
11161 be left not containing any subroutine, even if it did contain one before.
11162 In the case of C<BEGIN>, the subroutine will be executed and the reference
11163 to it disposed of before this function returns.
11165 The function returns a pointer to the constructed subroutine. If the sub
11166 is anonymous then ownership of one counted reference to the subroutine
11167 is transferred to the caller. If the sub is named then the caller does
11168 not get ownership of a reference. In most such cases, where the sub
11169 has a non-phase name, the sub will be alive at the point it is returned
11170 by virtue of being contained in the glob that names it. A phase-named
11171 subroutine will usually be alive by virtue of the reference owned by the
11172 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11173 been executed, will quite likely have been destroyed already by the
11174 time this function returns, making it erroneous for the caller to make
11175 any use of the returned pointer. It is the caller's responsibility to
11176 ensure that it knows which of these situations applies.
11181 /* _x = extended */
11183 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
11184 OP *block, bool o_is_gv)
11188 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11190 CV *cv = NULL; /* the previous CV with this name, if any */
11192 const bool ec = PL_parser && PL_parser->error_count;
11193 /* If the subroutine has no body, no attributes, and no builtin attributes
11194 then it's just a sub declaration, and we may be able to get away with
11195 storing with a placeholder scalar in the symbol table, rather than a
11196 full CV. If anything is present then it will take a full CV to
11198 const I32 gv_fetch_flags
11199 = ec ? GV_NOADD_NOINIT :
11200 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
11201 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
11203 const char * const name =
11204 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
11206 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
11207 bool evanescent = FALSE;
11209 #ifdef PERL_DEBUG_READONLY_OPS
11210 OPSLAB *slab = NULL;
11218 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
11219 hek and CvSTASH pointer together can imply the GV. If the name
11220 contains a package name, then GvSTASH(CvGV(cv)) may differ from
11221 CvSTASH, so forego the optimisation if we find any.
11222 Also, we may be called from load_module at run time, so
11223 PL_curstash (which sets CvSTASH) may not point to the stash the
11224 sub is stored in. */
11225 /* XXX This optimization is currently disabled for packages other
11226 than main, since there was too much CPAN breakage. */
11228 ec ? GV_NOADD_NOINIT
11229 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
11230 || PL_curstash != PL_defstash
11231 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
11233 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
11234 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
11236 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
11237 SV * const sv = sv_newmortal();
11238 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
11239 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11240 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11241 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
11243 } else if (PL_curstash) {
11244 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
11247 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
11253 move_proto_attr(&proto, &attrs, gv, 0);
11256 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
11261 assert(proto->op_type == OP_CONST);
11262 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11263 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11279 SvREFCNT_dec(PL_compcv);
11284 if (name && block) {
11285 const char *s = (char *) my_memrchr(name, ':', namlen);
11286 s = s ? s+1 : name;
11287 if (strEQ(s, "BEGIN")) {
11288 if (PL_in_eval & EVAL_KEEPERR)
11289 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
11291 SV * const errsv = ERRSV;
11292 /* force display of errors found but not reported */
11293 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
11294 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
11301 if (!block && SvTYPE(gv) != SVt_PVGV) {
11302 /* If we are not defining a new sub and the existing one is not a
11304 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
11305 /* We are applying attributes to an existing sub, so we need it
11306 upgraded if it is a constant. */
11307 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
11308 gv_init_pvn(gv, PL_curstash, name, namlen,
11309 SVf_UTF8 * name_is_utf8);
11311 else { /* Maybe prototype now, and had at maximum
11312 a prototype or const/sub ref before. */
11313 if (SvTYPE(gv) > SVt_NULL) {
11314 cv_ckproto_len_flags((const CV *)gv,
11315 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11321 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
11323 SvUTF8_on(MUTABLE_SV(gv));
11326 sv_setiv(MUTABLE_SV(gv), -1);
11329 SvREFCNT_dec(PL_compcv);
11330 cv = PL_compcv = NULL;
11335 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
11339 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
11345 /* This makes sub {}; work as expected. */
11346 if (block->op_type == OP_STUB) {
11347 const line_t l = PL_parser->copline;
11349 block = newSTATEOP(0, NULL, 0);
11350 PL_parser->copline = l;
11352 block = CvLVALUE(PL_compcv)
11353 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
11354 && (!isGV(gv) || !GvASSUMECV(gv)))
11355 ? newUNOP(OP_LEAVESUBLV, 0,
11356 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
11357 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
11358 start = LINKLIST(block);
11359 block->op_next = 0;
11360 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
11362 S_op_const_sv(aTHX_ start, PL_compcv,
11363 cBOOL(CvCLONE(PL_compcv)));
11370 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
11371 cv_ckproto_len_flags((const CV *)gv,
11372 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11373 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
11375 /* All the other code for sub redefinition warnings expects the
11376 clobbered sub to be a CV. Instead of making all those code
11377 paths more complex, just inline the RV version here. */
11378 const line_t oldline = CopLINE(PL_curcop);
11379 assert(IN_PERL_COMPILETIME);
11380 if (PL_parser && PL_parser->copline != NOLINE)
11381 /* This ensures that warnings are reported at the first
11382 line of a redefinition, not the last. */
11383 CopLINE_set(PL_curcop, PL_parser->copline);
11384 /* protect against fatal warnings leaking compcv */
11385 SAVEFREESV(PL_compcv);
11387 if (ckWARN(WARN_REDEFINE)
11388 || ( ckWARN_d(WARN_REDEFINE)
11389 && ( !const_sv || SvRV(gv) == const_sv
11390 || sv_cmp(SvRV(gv), const_sv) ))) {
11392 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11393 "Constant subroutine %" SVf " redefined",
11394 SVfARG(cSVOPo->op_sv));
11397 SvREFCNT_inc_simple_void_NN(PL_compcv);
11398 CopLINE_set(PL_curcop, oldline);
11399 SvREFCNT_dec(SvRV(gv));
11404 const bool exists = CvROOT(cv) || CvXSUB(cv);
11406 /* if the subroutine doesn't exist and wasn't pre-declared
11407 * with a prototype, assume it will be AUTOLOADed,
11408 * skipping the prototype check
11410 if (exists || SvPOK(cv))
11411 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
11412 /* already defined (or promised)? */
11413 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
11414 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
11420 /* just a "sub foo;" when &foo is already defined */
11421 SAVEFREESV(PL_compcv);
11428 SvREFCNT_inc_simple_void_NN(const_sv);
11429 SvFLAGS(const_sv) |= SVs_PADTMP;
11431 assert(!CvROOT(cv) && !CvCONST(cv));
11432 cv_forget_slab(cv);
11433 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
11434 CvXSUBANY(cv).any_ptr = const_sv;
11435 CvXSUB(cv) = const_sv_xsub;
11439 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11442 if (isGV(gv) || CvMETHOD(PL_compcv)) {
11443 if (name && isGV(gv))
11444 GvCV_set(gv, NULL);
11445 cv = newCONSTSUB_flags(
11446 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
11450 assert(SvREFCNT((SV*)cv) != 0);
11451 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11455 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11456 prepare_SV_for_RV((SV *)gv);
11457 SvOK_off((SV *)gv);
11460 SvRV_set(gv, const_sv);
11464 SvREFCNT_dec(PL_compcv);
11469 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
11470 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
11473 if (cv) { /* must reuse cv if autoloaded */
11474 /* transfer PL_compcv to cv */
11476 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11477 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
11478 PADLIST *const temp_av = CvPADLIST(cv);
11479 CV *const temp_cv = CvOUTSIDE(cv);
11480 const cv_flags_t other_flags =
11481 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11482 OP * const cvstart = CvSTART(cv);
11486 assert(!CvCVGV_RC(cv));
11487 assert(CvGV(cv) == gv);
11491 PERL_HASH(hash, name, namlen);
11501 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
11503 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
11504 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
11505 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
11506 CvOUTSIDE(PL_compcv) = temp_cv;
11507 CvPADLIST_set(PL_compcv, temp_av);
11508 CvSTART(cv) = CvSTART(PL_compcv);
11509 CvSTART(PL_compcv) = cvstart;
11510 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11511 CvFLAGS(PL_compcv) |= other_flags;
11514 Safefree(CvFILE(cv));
11516 CvFILE_set_from_cop(cv, PL_curcop);
11517 CvSTASH_set(cv, PL_curstash);
11519 /* inner references to PL_compcv must be fixed up ... */
11520 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
11521 if (PERLDB_INTER)/* Advice debugger on the new sub. */
11522 ++PL_sub_generation;
11525 /* Might have had built-in attributes applied -- propagate them. */
11526 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
11528 /* ... before we throw it away */
11529 SvREFCNT_dec(PL_compcv);
11534 if (name && isGV(gv)) {
11537 if (HvENAME_HEK(GvSTASH(gv)))
11538 /* sub Foo::bar { (shift)+1 } */
11539 gv_method_changed(gv);
11543 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11544 prepare_SV_for_RV((SV *)gv);
11545 SvOK_off((SV *)gv);
11548 SvRV_set(gv, (SV *)cv);
11549 if (HvENAME_HEK(PL_curstash))
11550 mro_method_changed_in(PL_curstash);
11554 assert(SvREFCNT((SV*)cv) != 0);
11556 if (!CvHASGV(cv)) {
11561 PERL_HASH(hash, name, namlen);
11562 CvNAME_HEK_set(cv, share_hek(name,
11568 CvFILE_set_from_cop(cv, PL_curcop);
11569 CvSTASH_set(cv, PL_curstash);
11573 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11575 SvUTF8_on(MUTABLE_SV(cv));
11579 /* If we assign an optree to a PVCV, then we've defined a
11580 * subroutine that the debugger could be able to set a breakpoint
11581 * in, so signal to pp_entereval that it should not throw away any
11582 * saved lines at scope exit. */
11584 PL_breakable_sub_gen++;
11585 CvROOT(cv) = block;
11586 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11587 itself has a refcount. */
11589 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11590 #ifdef PERL_DEBUG_READONLY_OPS
11591 slab = (OPSLAB *)CvSTART(cv);
11593 S_process_optree(aTHX_ cv, block, start);
11598 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11599 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
11600 ? GvSTASH(CvGV(cv))
11604 apply_attrs(stash, MUTABLE_SV(cv), attrs);
11606 SvREFCNT_inc_simple_void_NN(cv);
11609 if (block && has_name) {
11610 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11611 SV * const tmpstr = cv_name(cv,NULL,0);
11612 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11613 GV_ADDMULTI, SVt_PVHV);
11615 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11616 CopFILE(PL_curcop),
11618 (long)CopLINE(PL_curcop));
11619 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11620 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11621 hv = GvHVn(db_postponed);
11622 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11623 CV * const pcv = GvCV(db_postponed);
11629 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11635 if (PL_parser && PL_parser->error_count)
11636 clear_special_blocks(name, gv, cv);
11639 process_special_blocks(floor, name, gv, cv);
11645 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11647 PL_parser->copline = NOLINE;
11648 LEAVE_SCOPE(floor);
11650 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11652 #ifdef PERL_DEBUG_READONLY_OPS
11656 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11657 pad_add_weakref(cv);
11663 S_clear_special_blocks(pTHX_ const char *const fullname,
11664 GV *const gv, CV *const cv) {
11668 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11670 colon = strrchr(fullname,':');
11671 name = colon ? colon + 1 : fullname;
11673 if ((*name == 'B' && strEQ(name, "BEGIN"))
11674 || (*name == 'E' && strEQ(name, "END"))
11675 || (*name == 'U' && strEQ(name, "UNITCHECK"))
11676 || (*name == 'C' && strEQ(name, "CHECK"))
11677 || (*name == 'I' && strEQ(name, "INIT"))) {
11682 GvCV_set(gv, NULL);
11683 SvREFCNT_dec_NN(MUTABLE_SV(cv));
11687 /* Returns true if the sub has been freed. */
11689 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11693 const char *const colon = strrchr(fullname,':');
11694 const char *const name = colon ? colon + 1 : fullname;
11696 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11698 if (*name == 'B') {
11699 if (strEQ(name, "BEGIN")) {
11700 const I32 oldscope = PL_scopestack_ix;
11703 if (floor) LEAVE_SCOPE(floor);
11705 PUSHSTACKi(PERLSI_REQUIRE);
11706 SAVECOPFILE(&PL_compiling);
11707 SAVECOPLINE(&PL_compiling);
11708 SAVEVPTR(PL_curcop);
11710 DEBUG_x( dump_sub(gv) );
11711 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11712 GvCV_set(gv,0); /* cv has been hijacked */
11713 call_list(oldscope, PL_beginav);
11717 return !PL_savebegin;
11722 if (*name == 'E') {
11723 if (strEQ(name, "END")) {
11724 DEBUG_x( dump_sub(gv) );
11725 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11728 } else if (*name == 'U') {
11729 if (strEQ(name, "UNITCHECK")) {
11730 /* It's never too late to run a unitcheck block */
11731 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11735 } else if (*name == 'C') {
11736 if (strEQ(name, "CHECK")) {
11738 /* diag_listed_as: Too late to run %s block */
11739 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11740 "Too late to run CHECK block");
11741 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11745 } else if (*name == 'I') {
11746 if (strEQ(name, "INIT")) {
11748 /* diag_listed_as: Too late to run %s block */
11749 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11750 "Too late to run INIT block");
11751 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11757 DEBUG_x( dump_sub(gv) );
11759 GvCV_set(gv,0); /* cv has been hijacked */
11765 =for apidoc newCONSTSUB
11767 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11768 rather than of counted length, and no flags are set. (This means that
11769 C<name> is always interpreted as Latin-1.)
11775 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11777 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11781 =for apidoc newCONSTSUB_flags
11783 Construct a constant subroutine, also performing some surrounding
11784 jobs. A scalar constant-valued subroutine is eligible for inlining
11785 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11786 123 }>>. Other kinds of constant subroutine have other treatment.
11788 The subroutine will have an empty prototype and will ignore any arguments
11789 when called. Its constant behaviour is determined by C<sv>. If C<sv>
11790 is null, the subroutine will yield an empty list. If C<sv> points to a
11791 scalar, the subroutine will always yield that scalar. If C<sv> points
11792 to an array, the subroutine will always yield a list of the elements of
11793 that array in list context, or the number of elements in the array in
11794 scalar context. This function takes ownership of one counted reference
11795 to the scalar or array, and will arrange for the object to live as long
11796 as the subroutine does. If C<sv> points to a scalar then the inlining
11797 assumes that the value of the scalar will never change, so the caller
11798 must ensure that the scalar is not subsequently written to. If C<sv>
11799 points to an array then no such assumption is made, so it is ostensibly
11800 safe to mutate the array or its elements, but whether this is really
11801 supported has not been determined.
11803 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11804 Other aspects of the subroutine will be left in their default state.
11805 The caller is free to mutate the subroutine beyond its initial state
11806 after this function has returned.
11808 If C<name> is null then the subroutine will be anonymous, with its
11809 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11810 subroutine will be named accordingly, referenced by the appropriate glob.
11811 C<name> is a string of length C<len> bytes giving a sigilless symbol
11812 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11813 otherwise. The name may be either qualified or unqualified. If the
11814 name is unqualified then it defaults to being in the stash specified by
11815 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11816 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11819 C<flags> should not have bits set other than C<SVf_UTF8>.
11821 If there is already a subroutine of the specified name, then the new sub
11822 will replace the existing one in the glob. A warning may be generated
11823 about the redefinition.
11825 If the subroutine has one of a few special names, such as C<BEGIN> or
11826 C<END>, then it will be claimed by the appropriate queue for automatic
11827 running of phase-related subroutines. In this case the relevant glob will
11828 be left not containing any subroutine, even if it did contain one before.
11829 Execution of the subroutine will likely be a no-op, unless C<sv> was
11830 a tied array or the caller modified the subroutine in some interesting
11831 way before it was executed. In the case of C<BEGIN>, the treatment is
11832 buggy: the sub will be executed when only half built, and may be deleted
11833 prematurely, possibly causing a crash.
11835 The function returns a pointer to the constructed subroutine. If the sub
11836 is anonymous then ownership of one counted reference to the subroutine
11837 is transferred to the caller. If the sub is named then the caller does
11838 not get ownership of a reference. In most such cases, where the sub
11839 has a non-phase name, the sub will be alive at the point it is returned
11840 by virtue of being contained in the glob that names it. A phase-named
11841 subroutine will usually be alive by virtue of the reference owned by
11842 the phase's automatic run queue. A C<BEGIN> subroutine may have been
11843 destroyed already by the time this function returns, but currently bugs
11844 occur in that case before the caller gets control. It is the caller's
11845 responsibility to ensure that it knows which of these situations applies.
11851 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11855 const char *const file = CopFILE(PL_curcop);
11859 if (IN_PERL_RUNTIME) {
11860 /* at runtime, it's not safe to manipulate PL_curcop: it may be
11861 * an op shared between threads. Use a non-shared COP for our
11863 SAVEVPTR(PL_curcop);
11864 SAVECOMPILEWARNINGS();
11865 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11866 PL_curcop = &PL_compiling;
11868 SAVECOPLINE(PL_curcop);
11869 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11872 PL_hints &= ~HINT_BLOCK_SCOPE;
11875 SAVEGENERICSV(PL_curstash);
11876 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11879 /* Protect sv against leakage caused by fatal warnings. */
11880 if (sv) SAVEFREESV(sv);
11882 /* file becomes the CvFILE. For an XS, it's usually static storage,
11883 and so doesn't get free()d. (It's expected to be from the C pre-
11884 processor __FILE__ directive). But we need a dynamically allocated one,
11885 and we need it to get freed. */
11886 cv = newXS_len_flags(name, len,
11887 sv && SvTYPE(sv) == SVt_PVAV
11890 file ? file : "", "",
11891 &sv, XS_DYNAMIC_FILENAME | flags);
11893 assert(SvREFCNT((SV*)cv) != 0);
11894 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11905 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
11906 static storage, as it is used directly as CvFILE(), without a copy being made.
11912 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11914 PERL_ARGS_ASSERT_NEWXS;
11915 return newXS_len_flags(
11916 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11921 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11922 const char *const filename, const char *const proto,
11925 PERL_ARGS_ASSERT_NEWXS_FLAGS;
11926 return newXS_len_flags(
11927 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11932 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11934 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11935 return newXS_len_flags(
11936 name, strlen(name), subaddr, NULL, NULL, NULL, 0
11941 =for apidoc newXS_len_flags
11943 Construct an XS subroutine, also performing some surrounding jobs.
11945 The subroutine will have the entry point C<subaddr>. It will have
11946 the prototype specified by the nul-terminated string C<proto>, or
11947 no prototype if C<proto> is null. The prototype string is copied;
11948 the caller can mutate the supplied string afterwards. If C<filename>
11949 is non-null, it must be a nul-terminated filename, and the subroutine
11950 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
11951 point directly to the supplied string, which must be static. If C<flags>
11952 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11955 Other aspects of the subroutine will be left in their default state.
11956 If anything else needs to be done to the subroutine for it to function
11957 correctly, it is the caller's responsibility to do that after this
11958 function has constructed it. However, beware of the subroutine
11959 potentially being destroyed before this function returns, as described
11962 If C<name> is null then the subroutine will be anonymous, with its
11963 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11964 subroutine will be named accordingly, referenced by the appropriate glob.
11965 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11966 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11967 The name may be either qualified or unqualified, with the stash defaulting
11968 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
11969 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11970 they have there, such as C<GV_ADDWARN>. The symbol is always added to
11971 the stash if necessary, with C<GV_ADDMULTI> semantics.
11973 If there is already a subroutine of the specified name, then the new sub
11974 will replace the existing one in the glob. A warning may be generated
11975 about the redefinition. If the old subroutine was C<CvCONST> then the
11976 decision about whether to warn is influenced by an expectation about
11977 whether the new subroutine will become a constant of similar value.
11978 That expectation is determined by C<const_svp>. (Note that the call to
11979 this function doesn't make the new subroutine C<CvCONST> in any case;
11980 that is left to the caller.) If C<const_svp> is null then it indicates
11981 that the new subroutine will not become a constant. If C<const_svp>
11982 is non-null then it indicates that the new subroutine will become a
11983 constant, and it points to an C<SV*> that provides the constant value
11984 that the subroutine will have.
11986 If the subroutine has one of a few special names, such as C<BEGIN> or
11987 C<END>, then it will be claimed by the appropriate queue for automatic
11988 running of phase-related subroutines. In this case the relevant glob will
11989 be left not containing any subroutine, even if it did contain one before.
11990 In the case of C<BEGIN>, the subroutine will be executed and the reference
11991 to it disposed of before this function returns, and also before its
11992 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
11993 constructed by this function to be ready for execution then the caller
11994 must prevent this happening by giving the subroutine a different name.
11996 The function returns a pointer to the constructed subroutine. If the sub
11997 is anonymous then ownership of one counted reference to the subroutine
11998 is transferred to the caller. If the sub is named then the caller does
11999 not get ownership of a reference. In most such cases, where the sub
12000 has a non-phase name, the sub will be alive at the point it is returned
12001 by virtue of being contained in the glob that names it. A phase-named
12002 subroutine will usually be alive by virtue of the reference owned by the
12003 phase's automatic run queue. But a C<BEGIN> subroutine, having already
12004 been executed, will quite likely have been destroyed already by the
12005 time this function returns, making it erroneous for the caller to make
12006 any use of the returned pointer. It is the caller's responsibility to
12007 ensure that it knows which of these situations applies.
12013 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
12014 XSUBADDR_t subaddr, const char *const filename,
12015 const char *const proto, SV **const_svp,
12019 bool interleave = FALSE;
12020 bool evanescent = FALSE;
12022 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
12025 GV * const gv = gv_fetchpvn(
12026 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
12027 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
12028 sizeof("__ANON__::__ANON__") - 1,
12029 GV_ADDMULTI | flags, SVt_PVCV);
12031 if ((cv = (name ? GvCV(gv) : NULL))) {
12033 /* just a cached method */
12037 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
12038 /* already defined (or promised) */
12039 /* Redundant check that allows us to avoid creating an SV
12040 most of the time: */
12041 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
12042 report_redefined_cv(newSVpvn_flags(
12043 name,len,(flags&SVf_UTF8)|SVs_TEMP
12054 if (cv) /* must reuse cv if autoloaded */
12057 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12061 if (HvENAME_HEK(GvSTASH(gv)))
12062 gv_method_changed(gv); /* newXS */
12066 assert(SvREFCNT((SV*)cv) != 0);
12070 /* XSUBs can't be perl lang/perl5db.pl debugged
12071 if (PERLDB_LINE_OR_SAVESRC)
12072 (void)gv_fetchfile(filename); */
12073 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
12074 if (flags & XS_DYNAMIC_FILENAME) {
12076 CvFILE(cv) = savepv(filename);
12078 /* NOTE: not copied, as it is expected to be an external constant string */
12079 CvFILE(cv) = (char *)filename;
12082 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
12083 CvFILE(cv) = (char*)PL_xsubfilename;
12086 CvXSUB(cv) = subaddr;
12087 #ifndef PERL_IMPLICIT_CONTEXT
12088 CvHSCXT(cv) = &PL_stack_sp;
12094 evanescent = process_special_blocks(0, name, gv, cv);
12097 } /* <- not a conditional branch */
12100 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12102 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
12103 if (interleave) LEAVE;
12104 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12108 /* Add a stub CV to a typeglob.
12109 * This is the implementation of a forward declaration, 'sub foo';'
12113 Perl_newSTUB(pTHX_ GV *gv, bool fake)
12115 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12117 PERL_ARGS_ASSERT_NEWSTUB;
12118 assert(!GvCVu(gv));
12121 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
12122 gv_method_changed(gv);
12124 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
12128 CvGV_set(cv, cvgv);
12129 CvFILE_set_from_cop(cv, PL_curcop);
12130 CvSTASH_set(cv, PL_curstash);
12136 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
12143 if (PL_parser && PL_parser->error_count) {
12149 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
12150 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
12153 if ((cv = GvFORM(gv))) {
12154 if (ckWARN(WARN_REDEFINE)) {
12155 const line_t oldline = CopLINE(PL_curcop);
12156 if (PL_parser && PL_parser->copline != NOLINE)
12157 CopLINE_set(PL_curcop, PL_parser->copline);
12159 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12160 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
12162 /* diag_listed_as: Format %s redefined */
12163 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12164 "Format STDOUT redefined");
12166 CopLINE_set(PL_curcop, oldline);
12171 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
12173 CvFILE_set_from_cop(cv, PL_curcop);
12176 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
12178 start = LINKLIST(root);
12180 S_process_optree(aTHX_ cv, root, start);
12181 cv_forget_slab(cv);
12186 PL_parser->copline = NOLINE;
12187 LEAVE_SCOPE(floor);
12188 PL_compiling.cop_seq = 0;
12192 Perl_newANONLIST(pTHX_ OP *o)
12194 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
12198 Perl_newANONHASH(pTHX_ OP *o)
12200 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
12204 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
12206 return newANONATTRSUB(floor, proto, NULL, block);
12210 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
12212 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
12214 newSVOP(OP_ANONCODE, 0,
12216 if (CvANONCONST(cv))
12217 anoncode = newUNOP(OP_ANONCONST, 0,
12218 op_convert_list(OP_ENTERSUB,
12219 OPf_STACKED|OPf_WANT_SCALAR,
12221 return newUNOP(OP_REFGEN, 0, anoncode);
12225 Perl_oopsAV(pTHX_ OP *o)
12228 PERL_ARGS_ASSERT_OOPSAV;
12230 switch (o->op_type) {
12233 OpTYPE_set(o, OP_PADAV);
12234 return ref(o, OP_RV2AV);
12238 OpTYPE_set(o, OP_RV2AV);
12243 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
12250 Perl_oopsHV(pTHX_ OP *o)
12253 PERL_ARGS_ASSERT_OOPSHV;
12255 switch (o->op_type) {
12258 OpTYPE_set(o, OP_PADHV);
12259 return ref(o, OP_RV2HV);
12263 OpTYPE_set(o, OP_RV2HV);
12264 /* rv2hv steals the bottom bit for its own uses */
12265 o->op_private &= ~OPpARG1_MASK;
12270 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
12277 Perl_newAVREF(pTHX_ OP *o)
12280 PERL_ARGS_ASSERT_NEWAVREF;
12282 if (o->op_type == OP_PADANY) {
12283 OpTYPE_set(o, OP_PADAV);
12286 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
12287 Perl_croak(aTHX_ "Can't use an array as a reference");
12289 return newUNOP(OP_RV2AV, 0, scalar(o));
12293 Perl_newGVREF(pTHX_ I32 type, OP *o)
12295 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
12296 return newUNOP(OP_NULL, 0, o);
12297 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
12301 Perl_newHVREF(pTHX_ OP *o)
12304 PERL_ARGS_ASSERT_NEWHVREF;
12306 if (o->op_type == OP_PADANY) {
12307 OpTYPE_set(o, OP_PADHV);
12310 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12311 Perl_croak(aTHX_ "Can't use a hash as a reference");
12313 return newUNOP(OP_RV2HV, 0, scalar(o));
12317 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12319 if (o->op_type == OP_PADANY) {
12320 OpTYPE_set(o, OP_PADCV);
12322 return newUNOP(OP_RV2CV, flags, scalar(o));
12326 Perl_newSVREF(pTHX_ OP *o)
12329 PERL_ARGS_ASSERT_NEWSVREF;
12331 if (o->op_type == OP_PADANY) {
12332 OpTYPE_set(o, OP_PADSV);
12336 return newUNOP(OP_RV2SV, 0, scalar(o));
12339 /* Check routines. See the comments at the top of this file for details
12340 * on when these are called */
12343 Perl_ck_anoncode(pTHX_ OP *o)
12345 PERL_ARGS_ASSERT_CK_ANONCODE;
12347 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12348 cSVOPo->op_sv = NULL;
12353 S_io_hints(pTHX_ OP *o)
12355 #if O_BINARY != 0 || O_TEXT != 0
12357 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12359 SV **svp = hv_fetchs(table, "open_IN", FALSE);
12362 const char *d = SvPV_const(*svp, len);
12363 const I32 mode = mode_from_discipline(d, len);
12364 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12366 if (mode & O_BINARY)
12367 o->op_private |= OPpOPEN_IN_RAW;
12371 o->op_private |= OPpOPEN_IN_CRLF;
12375 svp = hv_fetchs(table, "open_OUT", FALSE);
12378 const char *d = SvPV_const(*svp, len);
12379 const I32 mode = mode_from_discipline(d, len);
12380 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12382 if (mode & O_BINARY)
12383 o->op_private |= OPpOPEN_OUT_RAW;
12387 o->op_private |= OPpOPEN_OUT_CRLF;
12392 PERL_UNUSED_CONTEXT;
12393 PERL_UNUSED_ARG(o);
12398 Perl_ck_backtick(pTHX_ OP *o)
12403 PERL_ARGS_ASSERT_CK_BACKTICK;
12405 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12406 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12407 && (gv = gv_override("readpipe",8)))
12409 /* detach rest of siblings from o and its first child */
12410 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12411 newop = S_new_entersubop(aTHX_ gv, sibl);
12413 else if (!(o->op_flags & OPf_KIDS))
12414 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12419 S_io_hints(aTHX_ o);
12424 Perl_ck_bitop(pTHX_ OP *o)
12426 PERL_ARGS_ASSERT_CK_BITOP;
12428 o->op_private = (U8)(PL_hints & HINT_INTEGER);
12430 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12431 && OP_IS_INFIX_BIT(o->op_type))
12433 const OP * const left = cBINOPo->op_first;
12434 const OP * const right = OpSIBLING(left);
12435 if ((OP_IS_NUMCOMPARE(left->op_type) &&
12436 (left->op_flags & OPf_PARENS) == 0) ||
12437 (OP_IS_NUMCOMPARE(right->op_type) &&
12438 (right->op_flags & OPf_PARENS) == 0))
12439 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12440 "Possible precedence problem on bitwise %s operator",
12441 o->op_type == OP_BIT_OR
12442 ||o->op_type == OP_NBIT_OR ? "|"
12443 : o->op_type == OP_BIT_AND
12444 ||o->op_type == OP_NBIT_AND ? "&"
12445 : o->op_type == OP_BIT_XOR
12446 ||o->op_type == OP_NBIT_XOR ? "^"
12447 : o->op_type == OP_SBIT_OR ? "|."
12448 : o->op_type == OP_SBIT_AND ? "&." : "^."
12454 PERL_STATIC_INLINE bool
12455 is_dollar_bracket(pTHX_ const OP * const o)
12458 PERL_UNUSED_CONTEXT;
12459 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12460 && (kid = cUNOPx(o)->op_first)
12461 && kid->op_type == OP_GV
12462 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12465 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12468 Perl_ck_cmp(pTHX_ OP *o)
12474 OP *indexop, *constop, *start;
12478 PERL_ARGS_ASSERT_CK_CMP;
12480 is_eq = ( o->op_type == OP_EQ
12481 || o->op_type == OP_NE
12482 || o->op_type == OP_I_EQ
12483 || o->op_type == OP_I_NE);
12485 if (!is_eq && ckWARN(WARN_SYNTAX)) {
12486 const OP *kid = cUNOPo->op_first;
12489 ( is_dollar_bracket(aTHX_ kid)
12490 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12492 || ( kid->op_type == OP_CONST
12493 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12497 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12498 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12501 /* convert (index(...) == -1) and variations into
12502 * (r)index/BOOL(,NEG)
12507 indexop = cUNOPo->op_first;
12508 constop = OpSIBLING(indexop);
12510 if (indexop->op_type == OP_CONST) {
12512 indexop = OpSIBLING(constop);
12517 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12520 /* ($lex = index(....)) == -1 */
12521 if (indexop->op_private & OPpTARGET_MY)
12524 if (constop->op_type != OP_CONST)
12527 sv = cSVOPx_sv(constop);
12528 if (!(sv && SvIOK_notUV(sv)))
12532 if (iv != -1 && iv != 0)
12536 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12537 if (!(iv0 ^ reverse))
12541 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12546 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12547 if (!(iv0 ^ reverse))
12551 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12556 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12562 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12568 indexop->op_flags &= ~OPf_PARENS;
12569 indexop->op_flags |= (o->op_flags & OPf_PARENS);
12570 indexop->op_private |= OPpTRUEBOOL;
12572 indexop->op_private |= OPpINDEX_BOOLNEG;
12573 /* cut out the index op and free the eq,const ops */
12574 (void)op_sibling_splice(o, start, 1, NULL);
12582 Perl_ck_concat(pTHX_ OP *o)
12584 const OP * const kid = cUNOPo->op_first;
12586 PERL_ARGS_ASSERT_CK_CONCAT;
12587 PERL_UNUSED_CONTEXT;
12589 /* reuse the padtmp returned by the concat child */
12590 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12591 !(kUNOP->op_first->op_flags & OPf_MOD))
12593 o->op_flags |= OPf_STACKED;
12594 o->op_private |= OPpCONCAT_NESTED;
12600 Perl_ck_spair(pTHX_ OP *o)
12603 PERL_ARGS_ASSERT_CK_SPAIR;
12605 if (o->op_flags & OPf_KIDS) {
12609 const OPCODE type = o->op_type;
12610 o = modkids(ck_fun(o), type);
12611 kid = cUNOPo->op_first;
12612 kidkid = kUNOP->op_first;
12613 newop = OpSIBLING(kidkid);
12615 const OPCODE type = newop->op_type;
12616 if (OpHAS_SIBLING(newop))
12618 if (o->op_type == OP_REFGEN
12619 && ( type == OP_RV2CV
12620 || ( !(newop->op_flags & OPf_PARENS)
12621 && ( type == OP_RV2AV || type == OP_PADAV
12622 || type == OP_RV2HV || type == OP_PADHV))))
12623 NOOP; /* OK (allow srefgen for \@a and \%h) */
12624 else if (OP_GIMME(newop,0) != G_SCALAR)
12627 /* excise first sibling */
12628 op_sibling_splice(kid, NULL, 1, NULL);
12631 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12632 * and OP_CHOMP into OP_SCHOMP */
12633 o->op_ppaddr = PL_ppaddr[++o->op_type];
12638 Perl_ck_delete(pTHX_ OP *o)
12640 PERL_ARGS_ASSERT_CK_DELETE;
12644 if (o->op_flags & OPf_KIDS) {
12645 OP * const kid = cUNOPo->op_first;
12646 switch (kid->op_type) {
12648 o->op_flags |= OPf_SPECIAL;
12651 o->op_private |= OPpSLICE;
12654 o->op_flags |= OPf_SPECIAL;
12659 o->op_flags |= OPf_SPECIAL;
12662 o->op_private |= OPpKVSLICE;
12665 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12666 "element or slice");
12668 if (kid->op_private & OPpLVAL_INTRO)
12669 o->op_private |= OPpLVAL_INTRO;
12676 Perl_ck_eof(pTHX_ OP *o)
12678 PERL_ARGS_ASSERT_CK_EOF;
12680 if (o->op_flags & OPf_KIDS) {
12682 if (cLISTOPo->op_first->op_type == OP_STUB) {
12684 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12689 kid = cLISTOPo->op_first;
12690 if (kid->op_type == OP_RV2GV)
12691 kid->op_private |= OPpALLOW_FAKE;
12698 Perl_ck_eval(pTHX_ OP *o)
12701 PERL_ARGS_ASSERT_CK_EVAL;
12703 PL_hints |= HINT_BLOCK_SCOPE;
12704 if (o->op_flags & OPf_KIDS) {
12705 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12708 if (o->op_type == OP_ENTERTRY) {
12711 /* cut whole sibling chain free from o */
12712 op_sibling_splice(o, NULL, -1, NULL);
12715 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12717 /* establish postfix order */
12718 enter->op_next = (OP*)enter;
12720 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12721 OpTYPE_set(o, OP_LEAVETRY);
12722 enter->op_other = o;
12727 S_set_haseval(aTHX);
12731 const U8 priv = o->op_private;
12733 /* the newUNOP will recursively call ck_eval(), which will handle
12734 * all the stuff at the end of this function, like adding
12737 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12739 o->op_targ = (PADOFFSET)PL_hints;
12740 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12741 if ((PL_hints & HINT_LOCALIZE_HH) != 0
12742 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12743 /* Store a copy of %^H that pp_entereval can pick up. */
12744 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12746 STOREFEATUREBITSHH(hh);
12747 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12748 /* append hhop to only child */
12749 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12751 o->op_private |= OPpEVAL_HAS_HH;
12753 if (!(o->op_private & OPpEVAL_BYTES)
12754 && FEATURE_UNIEVAL_IS_ENABLED)
12755 o->op_private |= OPpEVAL_UNICODE;
12760 Perl_ck_exec(pTHX_ OP *o)
12762 PERL_ARGS_ASSERT_CK_EXEC;
12764 if (o->op_flags & OPf_STACKED) {
12767 kid = OpSIBLING(cUNOPo->op_first);
12768 if (kid->op_type == OP_RV2GV)
12777 Perl_ck_exists(pTHX_ OP *o)
12779 PERL_ARGS_ASSERT_CK_EXISTS;
12782 if (o->op_flags & OPf_KIDS) {
12783 OP * const kid = cUNOPo->op_first;
12784 if (kid->op_type == OP_ENTERSUB) {
12785 (void) ref(kid, o->op_type);
12786 if (kid->op_type != OP_RV2CV
12787 && !(PL_parser && PL_parser->error_count))
12789 "exists argument is not a subroutine name");
12790 o->op_private |= OPpEXISTS_SUB;
12792 else if (kid->op_type == OP_AELEM)
12793 o->op_flags |= OPf_SPECIAL;
12794 else if (kid->op_type != OP_HELEM)
12795 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12796 "element or a subroutine");
12803 Perl_ck_rvconst(pTHX_ OP *o)
12805 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12807 PERL_ARGS_ASSERT_CK_RVCONST;
12809 if (o->op_type == OP_RV2HV)
12810 /* rv2hv steals the bottom bit for its own uses */
12811 o->op_private &= ~OPpARG1_MASK;
12813 o->op_private |= (PL_hints & HINT_STRICT_REFS);
12815 if (kid->op_type == OP_CONST) {
12818 SV * const kidsv = kid->op_sv;
12820 /* Is it a constant from cv_const_sv()? */
12821 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12824 if (SvTYPE(kidsv) == SVt_PVAV) return o;
12825 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12826 const char *badthing;
12827 switch (o->op_type) {
12829 badthing = "a SCALAR";
12832 badthing = "an ARRAY";
12835 badthing = "a HASH";
12843 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12844 SVfARG(kidsv), badthing);
12847 * This is a little tricky. We only want to add the symbol if we
12848 * didn't add it in the lexer. Otherwise we get duplicate strict
12849 * warnings. But if we didn't add it in the lexer, we must at
12850 * least pretend like we wanted to add it even if it existed before,
12851 * or we get possible typo warnings. OPpCONST_ENTERED says
12852 * whether the lexer already added THIS instance of this symbol.
12854 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12855 gv = gv_fetchsv(kidsv,
12856 o->op_type == OP_RV2CV
12857 && o->op_private & OPpMAY_RETURN_CONSTANT
12859 : iscv | !(kid->op_private & OPpCONST_ENTERED),
12862 : o->op_type == OP_RV2SV
12864 : o->op_type == OP_RV2AV
12866 : o->op_type == OP_RV2HV
12873 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12874 && SvTYPE(SvRV(gv)) != SVt_PVCV)
12875 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12877 OpTYPE_set(kid, OP_GV);
12878 SvREFCNT_dec(kid->op_sv);
12879 #ifdef USE_ITHREADS
12880 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12881 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12882 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12883 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12884 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12886 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12888 kid->op_private = 0;
12889 /* FAKE globs in the symbol table cause weird bugs (#77810) */
12897 Perl_ck_ftst(pTHX_ OP *o)
12899 const I32 type = o->op_type;
12901 PERL_ARGS_ASSERT_CK_FTST;
12903 if (o->op_flags & OPf_REF) {
12906 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12907 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12908 const OPCODE kidtype = kid->op_type;
12910 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12911 && !kid->op_folded) {
12912 OP * const newop = newGVOP(type, OPf_REF,
12913 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12918 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12919 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12921 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12922 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12923 array_passed_to_stat, name);
12926 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12927 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12930 scalar((OP *) kid);
12931 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12932 o->op_private |= OPpFT_ACCESS;
12933 if (OP_IS_FILETEST(type)
12934 && OP_IS_FILETEST(kidtype)
12936 o->op_private |= OPpFT_STACKED;
12937 kid->op_private |= OPpFT_STACKING;
12938 if (kidtype == OP_FTTTY && (
12939 !(kid->op_private & OPpFT_STACKED)
12940 || kid->op_private & OPpFT_AFTER_t
12942 o->op_private |= OPpFT_AFTER_t;
12947 if (type == OP_FTTTY)
12948 o = newGVOP(type, OPf_REF, PL_stdingv);
12950 o = newUNOP(type, 0, newDEFSVOP());
12956 Perl_ck_fun(pTHX_ OP *o)
12958 const int type = o->op_type;
12959 I32 oa = PL_opargs[type] >> OASHIFT;
12961 PERL_ARGS_ASSERT_CK_FUN;
12963 if (o->op_flags & OPf_STACKED) {
12964 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12965 oa &= ~OA_OPTIONAL;
12967 return no_fh_allowed(o);
12970 if (o->op_flags & OPf_KIDS) {
12971 OP *prev_kid = NULL;
12972 OP *kid = cLISTOPo->op_first;
12974 bool seen_optional = FALSE;
12976 if (kid->op_type == OP_PUSHMARK ||
12977 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
12980 kid = OpSIBLING(kid);
12982 if (kid && kid->op_type == OP_COREARGS) {
12983 bool optional = FALSE;
12986 if (oa & OA_OPTIONAL) optional = TRUE;
12989 if (optional) o->op_private |= numargs;
12994 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
12995 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
12996 kid = newDEFSVOP();
12997 /* append kid to chain */
12998 op_sibling_splice(o, prev_kid, 0, kid);
13000 seen_optional = TRUE;
13007 /* list seen where single (scalar) arg expected? */
13008 if (numargs == 1 && !(oa >> 4)
13009 && kid->op_type == OP_LIST && type != OP_SCALAR)
13011 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13013 if (type != OP_DELETE) scalar(kid);
13024 if ((type == OP_PUSH || type == OP_UNSHIFT)
13025 && !OpHAS_SIBLING(kid))
13026 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
13027 "Useless use of %s with no values",
13030 if (kid->op_type == OP_CONST
13031 && ( !SvROK(cSVOPx_sv(kid))
13032 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
13034 bad_type_pv(numargs, "array", o, kid);
13035 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
13036 || kid->op_type == OP_RV2GV) {
13037 bad_type_pv(1, "array", o, kid);
13039 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
13040 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
13041 PL_op_desc[type]), 0);
13044 op_lvalue(kid, type);
13048 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
13049 bad_type_pv(numargs, "hash", o, kid);
13050 op_lvalue(kid, type);
13054 /* replace kid with newop in chain */
13056 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
13057 newop->op_next = newop;
13062 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
13063 if (kid->op_type == OP_CONST &&
13064 (kid->op_private & OPpCONST_BARE))
13066 OP * const newop = newGVOP(OP_GV, 0,
13067 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
13068 /* replace kid with newop in chain */
13069 op_sibling_splice(o, prev_kid, 1, newop);
13073 else if (kid->op_type == OP_READLINE) {
13074 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
13075 bad_type_pv(numargs, "HANDLE", o, kid);
13078 I32 flags = OPf_SPECIAL;
13080 PADOFFSET targ = 0;
13082 /* is this op a FH constructor? */
13083 if (is_handle_constructor(o,numargs)) {
13084 const char *name = NULL;
13087 bool want_dollar = TRUE;
13090 /* Set a flag to tell rv2gv to vivify
13091 * need to "prove" flag does not mean something
13092 * else already - NI-S 1999/05/07
13095 if (kid->op_type == OP_PADSV) {
13097 = PAD_COMPNAME_SV(kid->op_targ);
13098 name = PadnamePV (pn);
13099 len = PadnameLEN(pn);
13100 name_utf8 = PadnameUTF8(pn);
13102 else if (kid->op_type == OP_RV2SV
13103 && kUNOP->op_first->op_type == OP_GV)
13105 GV * const gv = cGVOPx_gv(kUNOP->op_first);
13107 len = GvNAMELEN(gv);
13108 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
13110 else if (kid->op_type == OP_AELEM
13111 || kid->op_type == OP_HELEM)
13114 OP *op = ((BINOP*)kid)->op_first;
13118 const char * const a =
13119 kid->op_type == OP_AELEM ?
13121 if (((op->op_type == OP_RV2AV) ||
13122 (op->op_type == OP_RV2HV)) &&
13123 (firstop = ((UNOP*)op)->op_first) &&
13124 (firstop->op_type == OP_GV)) {
13125 /* packagevar $a[] or $h{} */
13126 GV * const gv = cGVOPx_gv(firstop);
13129 Perl_newSVpvf(aTHX_
13134 else if (op->op_type == OP_PADAV
13135 || op->op_type == OP_PADHV) {
13136 /* lexicalvar $a[] or $h{} */
13137 const char * const padname =
13138 PAD_COMPNAME_PV(op->op_targ);
13141 Perl_newSVpvf(aTHX_
13147 name = SvPV_const(tmpstr, len);
13148 name_utf8 = SvUTF8(tmpstr);
13149 sv_2mortal(tmpstr);
13153 name = "__ANONIO__";
13155 want_dollar = FALSE;
13157 op_lvalue(kid, type);
13161 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
13162 namesv = PAD_SVl(targ);
13163 if (want_dollar && *name != '$')
13164 sv_setpvs(namesv, "$");
13167 sv_catpvn(namesv, name, len);
13168 if ( name_utf8 ) SvUTF8_on(namesv);
13172 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
13174 kid->op_targ = targ;
13175 kid->op_private |= priv;
13181 if ((type == OP_UNDEF || type == OP_POS)
13182 && numargs == 1 && !(oa >> 4)
13183 && kid->op_type == OP_LIST)
13184 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13185 op_lvalue(scalar(kid), type);
13190 kid = OpSIBLING(kid);
13192 /* FIXME - should the numargs or-ing move after the too many
13193 * arguments check? */
13194 o->op_private |= numargs;
13196 return too_many_arguments_pv(o,OP_DESC(o), 0);
13199 else if (PL_opargs[type] & OA_DEFGV) {
13200 /* Ordering of these two is important to keep f_map.t passing. */
13202 return newUNOP(type, 0, newDEFSVOP());
13206 while (oa & OA_OPTIONAL)
13208 if (oa && oa != OA_LIST)
13209 return too_few_arguments_pv(o,OP_DESC(o), 0);
13215 Perl_ck_glob(pTHX_ OP *o)
13219 PERL_ARGS_ASSERT_CK_GLOB;
13222 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13223 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13225 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13229 * \ null - const(wildcard)
13234 * \ mark - glob - rv2cv
13235 * | \ gv(CORE::GLOBAL::glob)
13237 * \ null - const(wildcard)
13239 o->op_flags |= OPf_SPECIAL;
13240 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13241 o = S_new_entersubop(aTHX_ gv, o);
13242 o = newUNOP(OP_NULL, 0, o);
13243 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13246 else o->op_flags &= ~OPf_SPECIAL;
13247 #if !defined(PERL_EXTERNAL_GLOB)
13248 if (!PL_globhook) {
13250 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13251 newSVpvs("File::Glob"), NULL, NULL, NULL);
13254 #endif /* !PERL_EXTERNAL_GLOB */
13255 gv = (GV *)newSV(0);
13256 gv_init(gv, 0, "", 0, 0);
13258 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13259 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13265 Perl_ck_grep(pTHX_ OP *o)
13269 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13271 PERL_ARGS_ASSERT_CK_GREP;
13273 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13275 if (o->op_flags & OPf_STACKED) {
13276 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13277 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13278 return no_fh_allowed(o);
13279 o->op_flags &= ~OPf_STACKED;
13281 kid = OpSIBLING(cLISTOPo->op_first);
13282 if (type == OP_MAPWHILE)
13287 if (PL_parser && PL_parser->error_count)
13289 kid = OpSIBLING(cLISTOPo->op_first);
13290 if (kid->op_type != OP_NULL)
13291 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13292 kid = kUNOP->op_first;
13294 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13295 kid->op_next = (OP*)gwop;
13296 o->op_private = gwop->op_private = 0;
13297 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13299 kid = OpSIBLING(cLISTOPo->op_first);
13300 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13301 op_lvalue(kid, OP_GREPSTART);
13307 Perl_ck_index(pTHX_ OP *o)
13309 PERL_ARGS_ASSERT_CK_INDEX;
13311 if (o->op_flags & OPf_KIDS) {
13312 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13314 kid = OpSIBLING(kid); /* get past "big" */
13315 if (kid && kid->op_type == OP_CONST) {
13316 const bool save_taint = TAINT_get;
13317 SV *sv = kSVOP->op_sv;
13318 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13319 && SvOK(sv) && !SvROK(sv))
13322 sv_copypv(sv, kSVOP->op_sv);
13323 SvREFCNT_dec_NN(kSVOP->op_sv);
13326 if (SvOK(sv)) fbm_compile(sv, 0);
13327 TAINT_set(save_taint);
13328 #ifdef NO_TAINT_SUPPORT
13329 PERL_UNUSED_VAR(save_taint);
13337 Perl_ck_lfun(pTHX_ OP *o)
13339 const OPCODE type = o->op_type;
13341 PERL_ARGS_ASSERT_CK_LFUN;
13343 return modkids(ck_fun(o), type);
13347 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
13349 PERL_ARGS_ASSERT_CK_DEFINED;
13351 if ((o->op_flags & OPf_KIDS)) {
13352 switch (cUNOPo->op_first->op_type) {
13355 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13356 " (Maybe you should just omit the defined()?)");
13357 NOT_REACHED; /* NOTREACHED */
13361 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13362 " (Maybe you should just omit the defined()?)");
13363 NOT_REACHED; /* NOTREACHED */
13374 Perl_ck_readline(pTHX_ OP *o)
13376 PERL_ARGS_ASSERT_CK_READLINE;
13378 if (o->op_flags & OPf_KIDS) {
13379 OP *kid = cLISTOPo->op_first;
13380 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13385 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13393 Perl_ck_rfun(pTHX_ OP *o)
13395 const OPCODE type = o->op_type;
13397 PERL_ARGS_ASSERT_CK_RFUN;
13399 return refkids(ck_fun(o), type);
13403 Perl_ck_listiob(pTHX_ OP *o)
13407 PERL_ARGS_ASSERT_CK_LISTIOB;
13409 kid = cLISTOPo->op_first;
13411 o = force_list(o, 1);
13412 kid = cLISTOPo->op_first;
13414 if (kid->op_type == OP_PUSHMARK)
13415 kid = OpSIBLING(kid);
13416 if (kid && o->op_flags & OPf_STACKED)
13417 kid = OpSIBLING(kid);
13418 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
13419 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13420 && !kid->op_folded) {
13421 o->op_flags |= OPf_STACKED; /* make it a filehandle */
13423 /* replace old const op with new OP_RV2GV parent */
13424 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13425 OP_RV2GV, OPf_REF);
13426 kid = OpSIBLING(kid);
13431 op_append_elem(o->op_type, o, newDEFSVOP());
13433 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13434 return listkids(o);
13438 Perl_ck_smartmatch(pTHX_ OP *o)
13440 PERL_ARGS_ASSERT_CK_SMARTMATCH;
13441 if (0 == (o->op_flags & OPf_SPECIAL)) {
13442 OP *first = cBINOPo->op_first;
13443 OP *second = OpSIBLING(first);
13445 /* Implicitly take a reference to an array or hash */
13447 /* remove the original two siblings, then add back the
13448 * (possibly different) first and second sibs.
13450 op_sibling_splice(o, NULL, 1, NULL);
13451 op_sibling_splice(o, NULL, 1, NULL);
13452 first = ref_array_or_hash(first);
13453 second = ref_array_or_hash(second);
13454 op_sibling_splice(o, NULL, 0, second);
13455 op_sibling_splice(o, NULL, 0, first);
13457 /* Implicitly take a reference to a regular expression */
13458 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13459 OpTYPE_set(first, OP_QR);
13461 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13462 OpTYPE_set(second, OP_QR);
13471 S_maybe_targlex(pTHX_ OP *o)
13473 OP * const kid = cLISTOPo->op_first;
13474 /* has a disposable target? */
13475 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13476 && !(kid->op_flags & OPf_STACKED)
13477 /* Cannot steal the second time! */
13478 && !(kid->op_private & OPpTARGET_MY)
13481 OP * const kkid = OpSIBLING(kid);
13483 /* Can just relocate the target. */
13484 if (kkid && kkid->op_type == OP_PADSV
13485 && (!(kkid->op_private & OPpLVAL_INTRO)
13486 || kkid->op_private & OPpPAD_STATE))
13488 kid->op_targ = kkid->op_targ;
13490 /* Now we do not need PADSV and SASSIGN.
13491 * Detach kid and free the rest. */
13492 op_sibling_splice(o, NULL, 1, NULL);
13494 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
13502 Perl_ck_sassign(pTHX_ OP *o)
13504 OP * const kid = cBINOPo->op_first;
13506 PERL_ARGS_ASSERT_CK_SASSIGN;
13508 if (OpHAS_SIBLING(kid)) {
13509 OP *kkid = OpSIBLING(kid);
13510 /* For state variable assignment with attributes, kkid is a list op
13511 whose op_last is a padsv. */
13512 if ((kkid->op_type == OP_PADSV ||
13513 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13514 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13517 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13518 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13519 return S_newONCEOP(aTHX_ o, kkid);
13522 return S_maybe_targlex(aTHX_ o);
13527 Perl_ck_match(pTHX_ OP *o)
13529 PERL_UNUSED_CONTEXT;
13530 PERL_ARGS_ASSERT_CK_MATCH;
13536 Perl_ck_method(pTHX_ OP *o)
13538 SV *sv, *methsv, *rclass;
13539 const char* method;
13542 STRLEN len, nsplit = 0, i;
13544 OP * const kid = cUNOPo->op_first;
13546 PERL_ARGS_ASSERT_CK_METHOD;
13547 if (kid->op_type != OP_CONST) return o;
13551 /* replace ' with :: */
13552 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13553 SvEND(sv) - SvPVX(sv) )))
13556 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13559 method = SvPVX_const(sv);
13561 utf8 = SvUTF8(sv) ? -1 : 1;
13563 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13568 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13570 if (!nsplit) { /* $proto->method() */
13572 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13575 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13577 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13580 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13581 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13582 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13583 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13585 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13586 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13588 #ifdef USE_ITHREADS
13589 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13591 cMETHOPx(new_op)->op_rclass_sv = rclass;
13598 Perl_ck_null(pTHX_ OP *o)
13600 PERL_ARGS_ASSERT_CK_NULL;
13601 PERL_UNUSED_CONTEXT;
13606 Perl_ck_open(pTHX_ OP *o)
13608 PERL_ARGS_ASSERT_CK_OPEN;
13610 S_io_hints(aTHX_ o);
13612 /* In case of three-arg dup open remove strictness
13613 * from the last arg if it is a bareword. */
13614 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13615 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
13619 if ((last->op_type == OP_CONST) && /* The bareword. */
13620 (last->op_private & OPpCONST_BARE) &&
13621 (last->op_private & OPpCONST_STRICT) &&
13622 (oa = OpSIBLING(first)) && /* The fh. */
13623 (oa = OpSIBLING(oa)) && /* The mode. */
13624 (oa->op_type == OP_CONST) &&
13625 SvPOK(((SVOP*)oa)->op_sv) &&
13626 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
13627 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
13628 (last == OpSIBLING(oa))) /* The bareword. */
13629 last->op_private &= ~OPpCONST_STRICT;
13635 Perl_ck_prototype(pTHX_ OP *o)
13637 PERL_ARGS_ASSERT_CK_PROTOTYPE;
13638 if (!(o->op_flags & OPf_KIDS)) {
13640 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13646 Perl_ck_refassign(pTHX_ OP *o)
13648 OP * const right = cLISTOPo->op_first;
13649 OP * const left = OpSIBLING(right);
13650 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13653 PERL_ARGS_ASSERT_CK_REFASSIGN;
13655 assert (left->op_type == OP_SREFGEN);
13658 /* we use OPpPAD_STATE in refassign to mean either of those things,
13659 * and the code assumes the two flags occupy the same bit position
13660 * in the various ops below */
13661 assert(OPpPAD_STATE == OPpOUR_INTRO);
13663 switch (varop->op_type) {
13665 o->op_private |= OPpLVREF_AV;
13668 o->op_private |= OPpLVREF_HV;
13672 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13673 o->op_targ = varop->op_targ;
13674 varop->op_targ = 0;
13675 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13679 o->op_private |= OPpLVREF_AV;
13681 NOT_REACHED; /* NOTREACHED */
13683 o->op_private |= OPpLVREF_HV;
13687 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13688 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13690 /* Point varop to its GV kid, detached. */
13691 varop = op_sibling_splice(varop, NULL, -1, NULL);
13695 OP * const kidparent =
13696 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13697 OP * const kid = cUNOPx(kidparent)->op_first;
13698 o->op_private |= OPpLVREF_CV;
13699 if (kid->op_type == OP_GV) {
13700 SV *sv = (SV*)cGVOPx_gv(kid);
13702 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13703 /* a CVREF here confuses pp_refassign, so make sure
13705 CV *const cv = (CV*)SvRV(sv);
13706 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
13707 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13708 assert(SvTYPE(sv) == SVt_PVGV);
13710 goto detach_and_stack;
13712 if (kid->op_type != OP_PADCV) goto bad;
13713 o->op_targ = kid->op_targ;
13719 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13720 o->op_private |= OPpLVREF_ELEM;
13723 /* Detach varop. */
13724 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13728 /* diag_listed_as: Can't modify reference to %s in %s assignment */
13729 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13734 if (!FEATURE_REFALIASING_IS_ENABLED)
13736 "Experimental aliasing via reference not enabled");
13737 Perl_ck_warner_d(aTHX_
13738 packWARN(WARN_EXPERIMENTAL__REFALIASING),
13739 "Aliasing via reference is experimental");
13741 o->op_flags |= OPf_STACKED;
13742 op_sibling_splice(o, right, 1, varop);
13745 o->op_flags &=~ OPf_STACKED;
13746 op_sibling_splice(o, right, 1, NULL);
13753 Perl_ck_repeat(pTHX_ OP *o)
13755 PERL_ARGS_ASSERT_CK_REPEAT;
13757 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13759 o->op_private |= OPpREPEAT_DOLIST;
13760 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13761 kids = force_list(kids, 1); /* promote it to a list */
13762 op_sibling_splice(o, NULL, 0, kids); /* and add back */
13770 Perl_ck_require(pTHX_ OP *o)
13774 PERL_ARGS_ASSERT_CK_REQUIRE;
13776 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
13777 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13781 if (kid->op_type == OP_CONST) {
13782 SV * const sv = kid->op_sv;
13783 U32 const was_readonly = SvREADONLY(sv);
13784 if (kid->op_private & OPpCONST_BARE) {
13788 if (was_readonly) {
13789 SvREADONLY_off(sv);
13792 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13797 /* treat ::foo::bar as foo::bar */
13798 if (len >= 2 && s[0] == ':' && s[1] == ':')
13799 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13801 DIE(aTHX_ "Bareword in require maps to empty filename");
13803 for (; s < end; s++) {
13804 if (*s == ':' && s[1] == ':') {
13806 Move(s+2, s+1, end - s - 1, char);
13810 SvEND_set(sv, end);
13811 sv_catpvs(sv, ".pm");
13812 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13813 hek = share_hek(SvPVX(sv),
13814 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13816 sv_sethek(sv, hek);
13818 SvFLAGS(sv) |= was_readonly;
13820 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13823 if (SvREFCNT(sv) > 1) {
13824 kid->op_sv = newSVpvn_share(
13825 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13826 SvREFCNT_dec_NN(sv);
13830 if (was_readonly) SvREADONLY_off(sv);
13831 PERL_HASH(hash, s, len);
13833 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13835 sv_sethek(sv, hek);
13837 SvFLAGS(sv) |= was_readonly;
13843 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13844 /* handle override, if any */
13845 && (gv = gv_override("require", 7))) {
13847 if (o->op_flags & OPf_KIDS) {
13848 kid = cUNOPo->op_first;
13849 op_sibling_splice(o, NULL, -1, NULL);
13852 kid = newDEFSVOP();
13855 newop = S_new_entersubop(aTHX_ gv, kid);
13863 Perl_ck_return(pTHX_ OP *o)
13867 PERL_ARGS_ASSERT_CK_RETURN;
13869 kid = OpSIBLING(cLISTOPo->op_first);
13870 if (PL_compcv && CvLVALUE(PL_compcv)) {
13871 for (; kid; kid = OpSIBLING(kid))
13872 op_lvalue(kid, OP_LEAVESUBLV);
13879 Perl_ck_select(pTHX_ OP *o)
13883 PERL_ARGS_ASSERT_CK_SELECT;
13885 if (o->op_flags & OPf_KIDS) {
13886 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13887 if (kid && OpHAS_SIBLING(kid)) {
13888 OpTYPE_set(o, OP_SSELECT);
13890 return fold_constants(op_integerize(op_std_init(o)));
13894 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13895 if (kid && kid->op_type == OP_RV2GV)
13896 kid->op_private &= ~HINT_STRICT_REFS;
13901 Perl_ck_shift(pTHX_ OP *o)
13903 const I32 type = o->op_type;
13905 PERL_ARGS_ASSERT_CK_SHIFT;
13907 if (!(o->op_flags & OPf_KIDS)) {
13910 if (!CvUNIQUE(PL_compcv)) {
13911 o->op_flags |= OPf_SPECIAL;
13915 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13917 return newUNOP(type, 0, scalar(argop));
13919 return scalar(ck_fun(o));
13923 Perl_ck_sort(pTHX_ OP *o)
13927 HV * const hinthv =
13928 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
13931 PERL_ARGS_ASSERT_CK_SORT;
13934 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
13936 const I32 sorthints = (I32)SvIV(*svp);
13937 if ((sorthints & HINT_SORT_STABLE) != 0)
13938 o->op_private |= OPpSORT_STABLE;
13939 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
13940 o->op_private |= OPpSORT_UNSTABLE;
13944 if (o->op_flags & OPf_STACKED)
13946 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13948 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
13949 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
13951 /* if the first arg is a code block, process it and mark sort as
13953 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13955 if (kid->op_type == OP_LEAVE)
13956 op_null(kid); /* wipe out leave */
13957 /* Prevent execution from escaping out of the sort block. */
13960 /* provide scalar context for comparison function/block */
13961 kid = scalar(firstkid);
13962 kid->op_next = kid;
13963 o->op_flags |= OPf_SPECIAL;
13965 else if (kid->op_type == OP_CONST
13966 && kid->op_private & OPpCONST_BARE) {
13970 const char * const name = SvPV(kSVOP_sv, len);
13972 assert (len < 256);
13973 Copy(name, tmpbuf+1, len, char);
13974 off = pad_findmy_pvn(tmpbuf, len+1, 0);
13975 if (off != NOT_IN_PAD) {
13976 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
13978 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
13979 sv_catpvs(fq, "::");
13980 sv_catsv(fq, kSVOP_sv);
13981 SvREFCNT_dec_NN(kSVOP_sv);
13985 OP * const padop = newOP(OP_PADCV, 0);
13986 padop->op_targ = off;
13987 /* replace the const op with the pad op */
13988 op_sibling_splice(firstkid, NULL, 1, padop);
13994 firstkid = OpSIBLING(firstkid);
13997 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13998 /* provide list context for arguments */
14001 op_lvalue(kid, OP_GREPSTART);
14007 /* for sort { X } ..., where X is one of
14008 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
14009 * elide the second child of the sort (the one containing X),
14010 * and set these flags as appropriate
14014 * Also, check and warn on lexical $a, $b.
14018 S_simplify_sort(pTHX_ OP *o)
14020 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14024 const char *gvname;
14027 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
14029 kid = kUNOP->op_first; /* get past null */
14030 if (!(have_scopeop = kid->op_type == OP_SCOPE)
14031 && kid->op_type != OP_LEAVE)
14033 kid = kLISTOP->op_last; /* get past scope */
14034 switch(kid->op_type) {
14038 if (!have_scopeop) goto padkids;
14043 k = kid; /* remember this node*/
14044 if (kBINOP->op_first->op_type != OP_RV2SV
14045 || kBINOP->op_last ->op_type != OP_RV2SV)
14048 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
14049 then used in a comparison. This catches most, but not
14050 all cases. For instance, it catches
14051 sort { my($a); $a <=> $b }
14053 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
14054 (although why you'd do that is anyone's guess).
14058 if (!ckWARN(WARN_SYNTAX)) return;
14059 kid = kBINOP->op_first;
14061 if (kid->op_type == OP_PADSV) {
14062 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
14063 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
14064 && ( PadnamePV(name)[1] == 'a'
14065 || PadnamePV(name)[1] == 'b' ))
14066 /* diag_listed_as: "my %s" used in sort comparison */
14067 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14068 "\"%s %s\" used in sort comparison",
14069 PadnameIsSTATE(name)
14074 } while ((kid = OpSIBLING(kid)));
14077 kid = kBINOP->op_first; /* get past cmp */
14078 if (kUNOP->op_first->op_type != OP_GV)
14080 kid = kUNOP->op_first; /* get past rv2sv */
14082 if (GvSTASH(gv) != PL_curstash)
14084 gvname = GvNAME(gv);
14085 if (*gvname == 'a' && gvname[1] == '\0')
14087 else if (*gvname == 'b' && gvname[1] == '\0')
14092 kid = k; /* back to cmp */
14093 /* already checked above that it is rv2sv */
14094 kid = kBINOP->op_last; /* down to 2nd arg */
14095 if (kUNOP->op_first->op_type != OP_GV)
14097 kid = kUNOP->op_first; /* get past rv2sv */
14099 if (GvSTASH(gv) != PL_curstash)
14101 gvname = GvNAME(gv);
14103 ? !(*gvname == 'a' && gvname[1] == '\0')
14104 : !(*gvname == 'b' && gvname[1] == '\0'))
14106 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
14108 o->op_private |= OPpSORT_DESCEND;
14109 if (k->op_type == OP_NCMP)
14110 o->op_private |= OPpSORT_NUMERIC;
14111 if (k->op_type == OP_I_NCMP)
14112 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
14113 kid = OpSIBLING(cLISTOPo->op_first);
14114 /* cut out and delete old block (second sibling) */
14115 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
14120 Perl_ck_split(pTHX_ OP *o)
14125 PERL_ARGS_ASSERT_CK_SPLIT;
14127 assert(o->op_type == OP_LIST);
14129 if (o->op_flags & OPf_STACKED)
14130 return no_fh_allowed(o);
14132 kid = cLISTOPo->op_first;
14133 /* delete leading NULL node, then add a CONST if no other nodes */
14134 assert(kid->op_type == OP_NULL);
14135 op_sibling_splice(o, NULL, 1,
14136 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
14138 kid = cLISTOPo->op_first;
14140 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
14141 /* remove match expression, and replace with new optree with
14142 * a match op at its head */
14143 op_sibling_splice(o, NULL, 1, NULL);
14144 /* pmruntime will handle split " " behavior with flag==2 */
14145 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
14146 op_sibling_splice(o, NULL, 0, kid);
14149 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
14151 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
14152 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
14153 "Use of /g modifier is meaningless in split");
14156 /* eliminate the split op, and move the match op (plus any children)
14157 * into its place, then convert the match op into a split op. i.e.
14159 * SPLIT MATCH SPLIT(ex-MATCH)
14161 * MATCH - A - B - C => R - A - B - C => R - A - B - C
14167 * (R, if it exists, will be a regcomp op)
14170 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14171 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14172 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14173 OpTYPE_set(kid, OP_SPLIT);
14174 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
14175 kid->op_private = o->op_private;
14178 kid = sibs; /* kid is now the string arg of the split */
14181 kid = newDEFSVOP();
14182 op_append_elem(OP_SPLIT, o, kid);
14186 kid = OpSIBLING(kid);
14188 kid = newSVOP(OP_CONST, 0, newSViv(0));
14189 op_append_elem(OP_SPLIT, o, kid);
14190 o->op_private |= OPpSPLIT_IMPLIM;
14194 if (OpHAS_SIBLING(kid))
14195 return too_many_arguments_pv(o,OP_DESC(o), 0);
14201 Perl_ck_stringify(pTHX_ OP *o)
14203 OP * const kid = OpSIBLING(cUNOPo->op_first);
14204 PERL_ARGS_ASSERT_CK_STRINGIFY;
14205 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14206 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
14207 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
14208 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14210 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14218 Perl_ck_join(pTHX_ OP *o)
14220 OP * const kid = OpSIBLING(cLISTOPo->op_first);
14222 PERL_ARGS_ASSERT_CK_JOIN;
14224 if (kid && kid->op_type == OP_MATCH) {
14225 if (ckWARN(WARN_SYNTAX)) {
14226 const REGEXP *re = PM_GETRE(kPMOP);
14228 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14229 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14230 : newSVpvs_flags( "STRING", SVs_TEMP );
14231 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14232 "/%" SVf "/ should probably be written as \"%" SVf "\"",
14233 SVfARG(msg), SVfARG(msg));
14237 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14238 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14239 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14240 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14242 const OP * const bairn = OpSIBLING(kid); /* the list */
14243 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14244 && OP_GIMME(bairn,0) == G_SCALAR)
14246 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14247 op_sibling_splice(o, kid, 1, NULL));
14257 =for apidoc rv2cv_op_cv
14259 Examines an op, which is expected to identify a subroutine at runtime,
14260 and attempts to determine at compile time which subroutine it identifies.
14261 This is normally used during Perl compilation to determine whether
14262 a prototype can be applied to a function call. C<cvop> is the op
14263 being considered, normally an C<rv2cv> op. A pointer to the identified
14264 subroutine is returned, if it could be determined statically, and a null
14265 pointer is returned if it was not possible to determine statically.
14267 Currently, the subroutine can be identified statically if the RV that the
14268 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14269 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
14270 suitable if the constant value must be an RV pointing to a CV. Details of
14271 this process may change in future versions of Perl. If the C<rv2cv> op
14272 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14273 the subroutine statically: this flag is used to suppress compile-time
14274 magic on a subroutine call, forcing it to use default runtime behaviour.
14276 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14277 of a GV reference is modified. If a GV was examined and its CV slot was
14278 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14279 If the op is not optimised away, and the CV slot is later populated with
14280 a subroutine having a prototype, that flag eventually triggers the warning
14281 "called too early to check prototype".
14283 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14284 of returning a pointer to the subroutine it returns a pointer to the
14285 GV giving the most appropriate name for the subroutine in this context.
14286 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14287 (C<CvANON>) subroutine that is referenced through a GV it will be the
14288 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
14289 A null pointer is returned as usual if there is no statically-determinable
14292 =for apidoc Amnh||OPpEARLY_CV
14293 =for apidoc Amnh||OPpENTERSUB_AMPER
14294 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14295 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14300 /* shared by toke.c:yylex */
14302 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14304 PADNAME *name = PAD_COMPNAME(off);
14305 CV *compcv = PL_compcv;
14306 while (PadnameOUTER(name)) {
14307 assert(PARENT_PAD_INDEX(name));
14308 compcv = CvOUTSIDE(compcv);
14309 name = PadlistNAMESARRAY(CvPADLIST(compcv))
14310 [off = PARENT_PAD_INDEX(name)];
14312 assert(!PadnameIsOUR(name));
14313 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14314 return PadnamePROTOCV(name);
14316 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14320 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14325 PERL_ARGS_ASSERT_RV2CV_OP_CV;
14326 if (flags & ~RV2CVOPCV_FLAG_MASK)
14327 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14328 if (cvop->op_type != OP_RV2CV)
14330 if (cvop->op_private & OPpENTERSUB_AMPER)
14332 if (!(cvop->op_flags & OPf_KIDS))
14334 rvop = cUNOPx(cvop)->op_first;
14335 switch (rvop->op_type) {
14337 gv = cGVOPx_gv(rvop);
14339 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14340 cv = MUTABLE_CV(SvRV(gv));
14344 if (flags & RV2CVOPCV_RETURN_STUB)
14350 if (flags & RV2CVOPCV_MARK_EARLY)
14351 rvop->op_private |= OPpEARLY_CV;
14356 SV *rv = cSVOPx_sv(rvop);
14359 cv = (CV*)SvRV(rv);
14363 cv = find_lexical_cv(rvop->op_targ);
14368 } NOT_REACHED; /* NOTREACHED */
14370 if (SvTYPE((SV*)cv) != SVt_PVCV)
14372 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14373 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14377 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14378 if (CvLEXICAL(cv) || CvNAMED(cv))
14380 if (!CvANON(cv) || !gv)
14390 =for apidoc ck_entersub_args_list
14392 Performs the default fixup of the arguments part of an C<entersub>
14393 op tree. This consists of applying list context to each of the
14394 argument ops. This is the standard treatment used on a call marked
14395 with C<&>, or a method call, or a call through a subroutine reference,
14396 or any other call where the callee can't be identified at compile time,
14397 or a call where the callee has no prototype.
14403 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14407 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14409 aop = cUNOPx(entersubop)->op_first;
14410 if (!OpHAS_SIBLING(aop))
14411 aop = cUNOPx(aop)->op_first;
14412 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14413 /* skip the extra attributes->import() call implicitly added in
14414 * something like foo(my $x : bar)
14416 if ( aop->op_type == OP_ENTERSUB
14417 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14421 op_lvalue(aop, OP_ENTERSUB);
14427 =for apidoc ck_entersub_args_proto
14429 Performs the fixup of the arguments part of an C<entersub> op tree
14430 based on a subroutine prototype. This makes various modifications to
14431 the argument ops, from applying context up to inserting C<refgen> ops,
14432 and checking the number and syntactic types of arguments, as directed by
14433 the prototype. This is the standard treatment used on a subroutine call,
14434 not marked with C<&>, where the callee can be identified at compile time
14435 and has a prototype.
14437 C<protosv> supplies the subroutine prototype to be applied to the call.
14438 It may be a normal defined scalar, of which the string value will be used.
14439 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14440 that has been cast to C<SV*>) which has a prototype. The prototype
14441 supplied, in whichever form, does not need to match the actual callee
14442 referenced by the op tree.
14444 If the argument ops disagree with the prototype, for example by having
14445 an unacceptable number of arguments, a valid op tree is returned anyway.
14446 The error is reflected in the parser state, normally resulting in a single
14447 exception at the top level of parsing which covers all the compilation
14448 errors that occurred. In the error message, the callee is referred to
14449 by the name defined by the C<namegv> parameter.
14455 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14458 const char *proto, *proto_end;
14459 OP *aop, *prev, *cvop, *parent;
14462 I32 contextclass = 0;
14463 const char *e = NULL;
14464 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14465 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14466 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14467 "flags=%lx", (unsigned long) SvFLAGS(protosv));
14468 if (SvTYPE(protosv) == SVt_PVCV)
14469 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14470 else proto = SvPV(protosv, proto_len);
14471 proto = S_strip_spaces(aTHX_ proto, &proto_len);
14472 proto_end = proto + proto_len;
14473 parent = entersubop;
14474 aop = cUNOPx(entersubop)->op_first;
14475 if (!OpHAS_SIBLING(aop)) {
14477 aop = cUNOPx(aop)->op_first;
14480 aop = OpSIBLING(aop);
14481 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14482 while (aop != cvop) {
14485 if (proto >= proto_end)
14487 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14488 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14489 SVfARG(namesv)), SvUTF8(namesv));
14499 /* _ must be at the end */
14500 if (proto[1] && !memCHRs(";@%", proto[1]))
14516 if ( o3->op_type != OP_UNDEF
14517 && (o3->op_type != OP_SREFGEN
14518 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14520 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14522 bad_type_gv(arg, namegv, o3,
14523 arg == 1 ? "block or sub {}" : "sub {}");
14526 /* '*' allows any scalar type, including bareword */
14529 if (o3->op_type == OP_RV2GV)
14530 goto wrapref; /* autoconvert GLOB -> GLOBref */
14531 else if (o3->op_type == OP_CONST)
14532 o3->op_private &= ~OPpCONST_STRICT;
14538 if (o3->op_type == OP_RV2AV ||
14539 o3->op_type == OP_PADAV ||
14540 o3->op_type == OP_RV2HV ||
14541 o3->op_type == OP_PADHV
14547 case '[': case ']':
14554 switch (*proto++) {
14556 if (contextclass++ == 0) {
14557 e = (char *) memchr(proto, ']', proto_end - proto);
14558 if (!e || e == proto)
14566 if (contextclass) {
14567 const char *p = proto;
14568 const char *const end = proto;
14570 while (*--p != '[')
14571 /* \[$] accepts any scalar lvalue */
14573 && Perl_op_lvalue_flags(aTHX_
14575 OP_READ, /* not entersub */
14578 bad_type_gv(arg, namegv, o3,
14579 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14584 if (o3->op_type == OP_RV2GV)
14587 bad_type_gv(arg, namegv, o3, "symbol");
14590 if (o3->op_type == OP_ENTERSUB
14591 && !(o3->op_flags & OPf_STACKED))
14594 bad_type_gv(arg, namegv, o3, "subroutine");
14597 if (o3->op_type == OP_RV2SV ||
14598 o3->op_type == OP_PADSV ||
14599 o3->op_type == OP_HELEM ||
14600 o3->op_type == OP_AELEM)
14602 if (!contextclass) {
14603 /* \$ accepts any scalar lvalue */
14604 if (Perl_op_lvalue_flags(aTHX_
14606 OP_READ, /* not entersub */
14609 bad_type_gv(arg, namegv, o3, "scalar");
14613 if (o3->op_type == OP_RV2AV ||
14614 o3->op_type == OP_PADAV)
14616 o3->op_flags &=~ OPf_PARENS;
14620 bad_type_gv(arg, namegv, o3, "array");
14623 if (o3->op_type == OP_RV2HV ||
14624 o3->op_type == OP_PADHV)
14626 o3->op_flags &=~ OPf_PARENS;
14630 bad_type_gv(arg, namegv, o3, "hash");
14633 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14635 if (contextclass && e) {
14640 default: goto oops;
14650 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14651 SVfARG(cv_name((CV *)namegv, NULL, 0)),
14656 op_lvalue(aop, OP_ENTERSUB);
14658 aop = OpSIBLING(aop);
14660 if (aop == cvop && *proto == '_') {
14661 /* generate an access to $_ */
14662 op_sibling_splice(parent, prev, 0, newDEFSVOP());
14664 if (!optional && proto_end > proto &&
14665 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14667 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14668 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14669 SVfARG(namesv)), SvUTF8(namesv));
14675 =for apidoc ck_entersub_args_proto_or_list
14677 Performs the fixup of the arguments part of an C<entersub> op tree either
14678 based on a subroutine prototype or using default list-context processing.
14679 This is the standard treatment used on a subroutine call, not marked
14680 with C<&>, where the callee can be identified at compile time.
14682 C<protosv> supplies the subroutine prototype to be applied to the call,
14683 or indicates that there is no prototype. It may be a normal scalar,
14684 in which case if it is defined then the string value will be used
14685 as a prototype, and if it is undefined then there is no prototype.
14686 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14687 that has been cast to C<SV*>), of which the prototype will be used if it
14688 has one. The prototype (or lack thereof) supplied, in whichever form,
14689 does not need to match the actual callee referenced by the op tree.
14691 If the argument ops disagree with the prototype, for example by having
14692 an unacceptable number of arguments, a valid op tree is returned anyway.
14693 The error is reflected in the parser state, normally resulting in a single
14694 exception at the top level of parsing which covers all the compilation
14695 errors that occurred. In the error message, the callee is referred to
14696 by the name defined by the C<namegv> parameter.
14702 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14703 GV *namegv, SV *protosv)
14705 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14706 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14707 return ck_entersub_args_proto(entersubop, namegv, protosv);
14709 return ck_entersub_args_list(entersubop);
14713 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14715 IV cvflags = SvIVX(protosv);
14716 int opnum = cvflags & 0xffff;
14717 OP *aop = cUNOPx(entersubop)->op_first;
14719 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14723 if (!OpHAS_SIBLING(aop))
14724 aop = cUNOPx(aop)->op_first;
14725 aop = OpSIBLING(aop);
14726 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14728 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14729 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14730 SVfARG(namesv)), SvUTF8(namesv));
14733 op_free(entersubop);
14734 switch(cvflags >> 16) {
14735 case 'F': return newSVOP(OP_CONST, 0,
14736 newSVpv(CopFILE(PL_curcop),0));
14737 case 'L': return newSVOP(
14739 Perl_newSVpvf(aTHX_
14740 "%" IVdf, (IV)CopLINE(PL_curcop)
14743 case 'P': return newSVOP(OP_CONST, 0,
14745 ? newSVhek(HvNAME_HEK(PL_curstash))
14750 NOT_REACHED; /* NOTREACHED */
14753 OP *prev, *cvop, *first, *parent;
14756 parent = entersubop;
14757 if (!OpHAS_SIBLING(aop)) {
14759 aop = cUNOPx(aop)->op_first;
14762 first = prev = aop;
14763 aop = OpSIBLING(aop);
14764 /* find last sibling */
14766 OpHAS_SIBLING(cvop);
14767 prev = cvop, cvop = OpSIBLING(cvop))
14769 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14770 /* Usually, OPf_SPECIAL on an op with no args means that it had
14771 * parens, but these have their own meaning for that flag: */
14772 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14773 && opnum != OP_DELETE && opnum != OP_EXISTS)
14774 flags |= OPf_SPECIAL;
14775 /* excise cvop from end of sibling chain */
14776 op_sibling_splice(parent, prev, 1, NULL);
14778 if (aop == cvop) aop = NULL;
14780 /* detach remaining siblings from the first sibling, then
14781 * dispose of original optree */
14784 op_sibling_splice(parent, first, -1, NULL);
14785 op_free(entersubop);
14787 if (cvflags == (OP_ENTEREVAL | (1<<16)))
14788 flags |= OPpEVAL_BYTES <<8;
14790 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14792 case OA_BASEOP_OR_UNOP:
14793 case OA_FILESTATOP:
14795 return newOP(opnum,flags); /* zero args */
14797 return newUNOP(opnum,flags,aop); /* one arg */
14798 /* too many args */
14805 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14806 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14807 SVfARG(namesv)), SvUTF8(namesv));
14809 nextop = OpSIBLING(aop);
14815 return opnum == OP_RUNCV
14816 ? newPVOP(OP_RUNCV,0,NULL)
14819 return op_convert_list(opnum,0,aop);
14822 NOT_REACHED; /* NOTREACHED */
14827 =for apidoc cv_get_call_checker_flags
14829 Retrieves the function that will be used to fix up a call to C<cv>.
14830 Specifically, the function is applied to an C<entersub> op tree for a
14831 subroutine call, not marked with C<&>, where the callee can be identified
14832 at compile time as C<cv>.
14834 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14835 for it is returned in C<*ckobj_p>, and control flags are returned in
14836 C<*ckflags_p>. The function is intended to be called in this manner:
14838 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14840 In this call, C<entersubop> is a pointer to the C<entersub> op,
14841 which may be replaced by the check function, and C<namegv> supplies
14842 the name that should be used by the check function to refer
14843 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14844 It is permitted to apply the check function in non-standard situations,
14845 such as to a call to a different subroutine or to a method call.
14847 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
14848 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14849 instead, anything that can be used as the first argument to L</cv_name>.
14850 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14851 check function requires C<namegv> to be a genuine GV.
14853 By default, the check function is
14854 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14855 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14856 flag is clear. This implements standard prototype processing. It can
14857 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14859 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14860 indicates that the caller only knows about the genuine GV version of
14861 C<namegv>, and accordingly the corresponding bit will always be set in
14862 C<*ckflags_p>, regardless of the check function's recorded requirements.
14863 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14864 indicates the caller knows about the possibility of passing something
14865 other than a GV as C<namegv>, and accordingly the corresponding bit may
14866 be either set or clear in C<*ckflags_p>, indicating the check function's
14867 recorded requirements.
14869 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14870 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14871 (for which see above). All other bits should be clear.
14873 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14875 =for apidoc cv_get_call_checker
14877 The original form of L</cv_get_call_checker_flags>, which does not return
14878 checker flags. When using a checker function returned by this function,
14879 it is only safe to call it with a genuine GV as its C<namegv> argument.
14885 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14886 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14889 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14890 PERL_UNUSED_CONTEXT;
14891 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14893 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14894 *ckobj_p = callmg->mg_obj;
14895 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14897 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14898 *ckobj_p = (SV*)cv;
14899 *ckflags_p = gflags & MGf_REQUIRE_GV;
14904 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14907 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14908 PERL_UNUSED_CONTEXT;
14909 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14914 =for apidoc cv_set_call_checker_flags
14916 Sets the function that will be used to fix up a call to C<cv>.
14917 Specifically, the function is applied to an C<entersub> op tree for a
14918 subroutine call, not marked with C<&>, where the callee can be identified
14919 at compile time as C<cv>.
14921 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14922 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14923 The function should be defined like this:
14925 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14927 It is intended to be called in this manner:
14929 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14931 In this call, C<entersubop> is a pointer to the C<entersub> op,
14932 which may be replaced by the check function, and C<namegv> supplies
14933 the name that should be used by the check function to refer
14934 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14935 It is permitted to apply the check function in non-standard situations,
14936 such as to a call to a different subroutine or to a method call.
14938 C<namegv> may not actually be a GV. For efficiency, perl may pass a
14939 CV or other SV instead. Whatever is passed can be used as the first
14940 argument to L</cv_name>. You can force perl to pass a GV by including
14941 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14943 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14944 bit currently has a defined meaning (for which see above). All other
14945 bits should be clear.
14947 The current setting for a particular CV can be retrieved by
14948 L</cv_get_call_checker_flags>.
14950 =for apidoc cv_set_call_checker
14952 The original form of L</cv_set_call_checker_flags>, which passes it the
14953 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
14954 of that flag setting is that the check function is guaranteed to get a
14955 genuine GV as its C<namegv> argument.
14961 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14963 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14964 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14968 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14969 SV *ckobj, U32 ckflags)
14971 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14972 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
14973 if (SvMAGICAL((SV*)cv))
14974 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
14977 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
14978 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
14980 if (callmg->mg_flags & MGf_REFCOUNTED) {
14981 SvREFCNT_dec(callmg->mg_obj);
14982 callmg->mg_flags &= ~MGf_REFCOUNTED;
14984 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
14985 callmg->mg_obj = ckobj;
14986 if (ckobj != (SV*)cv) {
14987 SvREFCNT_inc_simple_void_NN(ckobj);
14988 callmg->mg_flags |= MGf_REFCOUNTED;
14990 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
14991 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
14996 S_entersub_alloc_targ(pTHX_ OP * const o)
14998 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14999 o->op_private |= OPpENTERSUB_HASTARG;
15003 Perl_ck_subr(pTHX_ OP *o)
15008 SV **const_class = NULL;
15010 PERL_ARGS_ASSERT_CK_SUBR;
15012 aop = cUNOPx(o)->op_first;
15013 if (!OpHAS_SIBLING(aop))
15014 aop = cUNOPx(aop)->op_first;
15015 aop = OpSIBLING(aop);
15016 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
15017 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
15018 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
15020 o->op_private &= ~1;
15021 o->op_private |= (PL_hints & HINT_STRICT_REFS);
15022 if (PERLDB_SUB && PL_curstash != PL_debstash)
15023 o->op_private |= OPpENTERSUB_DB;
15024 switch (cvop->op_type) {
15026 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
15030 case OP_METHOD_NAMED:
15031 case OP_METHOD_SUPER:
15032 case OP_METHOD_REDIR:
15033 case OP_METHOD_REDIR_SUPER:
15034 o->op_flags |= OPf_REF;
15035 if (aop->op_type == OP_CONST) {
15036 aop->op_private &= ~OPpCONST_STRICT;
15037 const_class = &cSVOPx(aop)->op_sv;
15039 else if (aop->op_type == OP_LIST) {
15040 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
15041 if (sib && sib->op_type == OP_CONST) {
15042 sib->op_private &= ~OPpCONST_STRICT;
15043 const_class = &cSVOPx(sib)->op_sv;
15046 /* make class name a shared cow string to speedup method calls */
15047 /* constant string might be replaced with object, f.e. bigint */
15048 if (const_class && SvPOK(*const_class)) {
15050 const char* str = SvPV(*const_class, len);
15052 SV* const shared = newSVpvn_share(
15053 str, SvUTF8(*const_class)
15054 ? -(SSize_t)len : (SSize_t)len,
15057 if (SvREADONLY(*const_class))
15058 SvREADONLY_on(shared);
15059 SvREFCNT_dec(*const_class);
15060 *const_class = shared;
15067 S_entersub_alloc_targ(aTHX_ o);
15068 return ck_entersub_args_list(o);
15070 Perl_call_checker ckfun;
15073 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
15074 if (CvISXSUB(cv) || !CvROOT(cv))
15075 S_entersub_alloc_targ(aTHX_ o);
15077 /* The original call checker API guarantees that a GV will
15078 be provided with the right name. So, if the old API was
15079 used (or the REQUIRE_GV flag was passed), we have to reify
15080 the CV’s GV, unless this is an anonymous sub. This is not
15081 ideal for lexical subs, as its stringification will include
15082 the package. But it is the best we can do. */
15083 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
15084 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
15087 else namegv = MUTABLE_GV(cv);
15088 /* After a syntax error in a lexical sub, the cv that
15089 rv2cv_op_cv returns may be a nameless stub. */
15090 if (!namegv) return ck_entersub_args_list(o);
15093 return ckfun(aTHX_ o, namegv, ckobj);
15098 Perl_ck_svconst(pTHX_ OP *o)
15100 SV * const sv = cSVOPo->op_sv;
15101 PERL_ARGS_ASSERT_CK_SVCONST;
15102 PERL_UNUSED_CONTEXT;
15103 #ifdef PERL_COPY_ON_WRITE
15104 /* Since the read-only flag may be used to protect a string buffer, we
15105 cannot do copy-on-write with existing read-only scalars that are not
15106 already copy-on-write scalars. To allow $_ = "hello" to do COW with
15107 that constant, mark the constant as COWable here, if it is not
15108 already read-only. */
15109 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
15112 # ifdef PERL_DEBUG_READONLY_COW
15122 Perl_ck_trunc(pTHX_ OP *o)
15124 PERL_ARGS_ASSERT_CK_TRUNC;
15126 if (o->op_flags & OPf_KIDS) {
15127 SVOP *kid = (SVOP*)cUNOPo->op_first;
15129 if (kid->op_type == OP_NULL)
15130 kid = (SVOP*)OpSIBLING(kid);
15131 if (kid && kid->op_type == OP_CONST &&
15132 (kid->op_private & OPpCONST_BARE) &&
15135 o->op_flags |= OPf_SPECIAL;
15136 kid->op_private &= ~OPpCONST_STRICT;
15143 Perl_ck_substr(pTHX_ OP *o)
15145 PERL_ARGS_ASSERT_CK_SUBSTR;
15148 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15149 OP *kid = cLISTOPo->op_first;
15151 if (kid->op_type == OP_NULL)
15152 kid = OpSIBLING(kid);
15154 /* Historically, substr(delete $foo{bar},...) has been allowed
15155 with 4-arg substr. Keep it working by applying entersub
15157 op_lvalue(kid, OP_ENTERSUB);
15164 Perl_ck_tell(pTHX_ OP *o)
15166 PERL_ARGS_ASSERT_CK_TELL;
15168 if (o->op_flags & OPf_KIDS) {
15169 OP *kid = cLISTOPo->op_first;
15170 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15171 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15177 Perl_ck_each(pTHX_ OP *o)
15179 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15180 const unsigned orig_type = o->op_type;
15182 PERL_ARGS_ASSERT_CK_EACH;
15185 switch (kid->op_type) {
15191 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15192 : orig_type == OP_KEYS ? OP_AKEYS
15196 if (kid->op_private == OPpCONST_BARE
15197 || !SvROK(cSVOPx_sv(kid))
15198 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15199 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
15204 qerror(Perl_mess(aTHX_
15205 "Experimental %s on scalar is now forbidden",
15206 PL_op_desc[orig_type]));
15208 bad_type_pv(1, "hash or array", o, kid);
15216 Perl_ck_length(pTHX_ OP *o)
15218 PERL_ARGS_ASSERT_CK_LENGTH;
15222 if (ckWARN(WARN_SYNTAX)) {
15223 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15227 const bool hash = kid->op_type == OP_PADHV
15228 || kid->op_type == OP_RV2HV;
15229 switch (kid->op_type) {
15234 name = S_op_varname(aTHX_ kid);
15240 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15241 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15243 SVfARG(name), hash ? "keys " : "", SVfARG(name)
15246 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15247 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15248 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15250 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15251 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15252 "length() used on @array (did you mean \"scalar(@array)\"?)");
15261 Perl_ck_isa(pTHX_ OP *o)
15263 OP *classop = cBINOPo->op_last;
15265 PERL_ARGS_ASSERT_CK_ISA;
15267 /* Convert barename into PV */
15268 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15269 /* TODO: Optionally convert package to raw HV here */
15270 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15278 ---------------------------------------------------------
15280 Common vars in list assignment
15282 There now follows some enums and static functions for detecting
15283 common variables in list assignments. Here is a little essay I wrote
15284 for myself when trying to get my head around this. DAPM.
15288 First some random observations:
15290 * If a lexical var is an alias of something else, e.g.
15291 for my $x ($lex, $pkg, $a[0]) {...}
15292 then the act of aliasing will increase the reference count of the SV
15294 * If a package var is an alias of something else, it may still have a
15295 reference count of 1, depending on how the alias was created, e.g.
15296 in *a = *b, $a may have a refcount of 1 since the GP is shared
15297 with a single GvSV pointer to the SV. So If it's an alias of another
15298 package var, then RC may be 1; if it's an alias of another scalar, e.g.
15299 a lexical var or an array element, then it will have RC > 1.
15301 * There are many ways to create a package alias; ultimately, XS code
15302 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
15303 run-time tracing mechanisms are unlikely to be able to catch all cases.
15305 * When the LHS is all my declarations, the same vars can't appear directly
15306 on the RHS, but they can indirectly via closures, aliasing and lvalue
15307 subs. But those techniques all involve an increase in the lexical
15308 scalar's ref count.
15310 * When the LHS is all lexical vars (but not necessarily my declarations),
15311 it is possible for the same lexicals to appear directly on the RHS, and
15312 without an increased ref count, since the stack isn't refcounted.
15313 This case can be detected at compile time by scanning for common lex
15314 vars with PL_generation.
15316 * lvalue subs defeat common var detection, but they do at least
15317 return vars with a temporary ref count increment. Also, you can't
15318 tell at compile time whether a sub call is lvalue.
15323 A: There are a few circumstances where there definitely can't be any
15326 LHS empty: () = (...);
15327 RHS empty: (....) = ();
15328 RHS contains only constants or other 'can't possibly be shared'
15329 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
15330 i.e. they only contain ops not marked as dangerous, whose children
15331 are also not dangerous;
15333 LHS contains a single scalar element: e.g. ($x) = (....); because
15334 after $x has been modified, it won't be used again on the RHS;
15335 RHS contains a single element with no aggregate on LHS: e.g.
15336 ($a,$b,$c) = ($x); again, once $a has been modified, its value
15337 won't be used again.
15339 B: If LHS are all 'my' lexical var declarations (or safe ops, which
15342 my ($a, $b, @c) = ...;
15344 Due to closure and goto tricks, these vars may already have content.
15345 For the same reason, an element on the RHS may be a lexical or package
15346 alias of one of the vars on the left, or share common elements, for
15349 my ($x,$y) = f(); # $x and $y on both sides
15350 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
15355 my @a = @$ra; # elements of @a on both sides
15356 sub f { @a = 1..4; \@a }
15359 First, just consider scalar vars on LHS:
15361 RHS is safe only if (A), or in addition,
15362 * contains only lexical *scalar* vars, where neither side's
15363 lexicals have been flagged as aliases
15365 If RHS is not safe, then it's always legal to check LHS vars for
15366 RC==1, since the only RHS aliases will always be associated
15369 Note that in particular, RHS is not safe if:
15371 * it contains package scalar vars; e.g.:
15374 my ($x, $y) = (2, $x_alias);
15375 sub f { $x = 1; *x_alias = \$x; }
15377 * It contains other general elements, such as flattened or
15378 * spliced or single array or hash elements, e.g.
15381 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
15385 use feature 'refaliasing';
15386 \($a[0], $a[1]) = \($y,$x);
15389 It doesn't matter if the array/hash is lexical or package.
15391 * it contains a function call that happens to be an lvalue
15392 sub which returns one or more of the above, e.g.
15403 (so a sub call on the RHS should be treated the same
15404 as having a package var on the RHS).
15406 * any other "dangerous" thing, such an op or built-in that
15407 returns one of the above, e.g. pp_preinc
15410 If RHS is not safe, what we can do however is at compile time flag
15411 that the LHS are all my declarations, and at run time check whether
15412 all the LHS have RC == 1, and if so skip the full scan.
15414 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
15416 Here the issue is whether there can be elements of @a on the RHS
15417 which will get prematurely freed when @a is cleared prior to
15418 assignment. This is only a problem if the aliasing mechanism
15419 is one which doesn't increase the refcount - only if RC == 1
15420 will the RHS element be prematurely freed.
15422 Because the array/hash is being INTROed, it or its elements
15423 can't directly appear on the RHS:
15425 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
15427 but can indirectly, e.g.:
15431 sub f { @a = 1..3; \@a }
15433 So if the RHS isn't safe as defined by (A), we must always
15434 mortalise and bump the ref count of any remaining RHS elements
15435 when assigning to a non-empty LHS aggregate.
15437 Lexical scalars on the RHS aren't safe if they've been involved in
15440 use feature 'refaliasing';
15443 \(my $lex) = \$pkg;
15444 my @a = ($lex,3); # equivalent to ($a[0],3)
15451 Similarly with lexical arrays and hashes on the RHS:
15465 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
15466 my $a; ($a, my $b) = (....);
15468 The difference between (B) and (C) is that it is now physically
15469 possible for the LHS vars to appear on the RHS too, where they
15470 are not reference counted; but in this case, the compile-time
15471 PL_generation sweep will detect such common vars.
15473 So the rules for (C) differ from (B) in that if common vars are
15474 detected, the runtime "test RC==1" optimisation can no longer be used,
15475 and a full mark and sweep is required
15477 D: As (C), but in addition the LHS may contain package vars.
15479 Since package vars can be aliased without a corresponding refcount
15480 increase, all bets are off. It's only safe if (A). E.g.
15482 my ($x, $y) = (1,2);
15484 for $x_alias ($x) {
15485 ($x_alias, $y) = (3, $x); # whoops
15488 Ditto for LHS aggregate package vars.
15490 E: Any other dangerous ops on LHS, e.g.
15491 (f(), $a[0], @$r) = (...);
15493 this is similar to (E) in that all bets are off. In addition, it's
15494 impossible to determine at compile time whether the LHS
15495 contains a scalar or an aggregate, e.g.
15497 sub f : lvalue { @a }
15500 * ---------------------------------------------------------
15504 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
15505 * that at least one of the things flagged was seen.
15509 AAS_MY_SCALAR = 0x001, /* my $scalar */
15510 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
15511 AAS_LEX_SCALAR = 0x004, /* $lexical */
15512 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
15513 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
15514 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
15515 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
15516 AAS_DANGEROUS = 0x080, /* an op (other than the above)
15517 that's flagged OA_DANGEROUS */
15518 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
15519 not in any of the categories above */
15520 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
15525 /* helper function for S_aassign_scan().
15526 * check a PAD-related op for commonality and/or set its generation number.
15527 * Returns a boolean indicating whether its shared */
15530 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
15532 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
15533 /* lexical used in aliasing */
15537 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
15539 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
15546 Helper function for OPpASSIGN_COMMON* detection in rpeep().
15547 It scans the left or right hand subtree of the aassign op, and returns a
15548 set of flags indicating what sorts of things it found there.
15549 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
15550 set PL_generation on lexical vars; if the latter, we see if
15551 PL_generation matches.
15552 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
15553 This fn will increment it by the number seen. It's not intended to
15554 be an accurate count (especially as many ops can push a variable
15555 number of SVs onto the stack); rather it's used as to test whether there
15556 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
15560 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
15563 OP *effective_top_op = o;
15567 bool top = o == effective_top_op;
15569 OP* next_kid = NULL;
15571 /* first, look for a solitary @_ on the RHS */
15574 && (o->op_flags & OPf_KIDS)
15575 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
15577 OP *kid = cUNOPo->op_first;
15578 if ( ( kid->op_type == OP_PUSHMARK
15579 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
15580 && ((kid = OpSIBLING(kid)))
15581 && !OpHAS_SIBLING(kid)
15582 && kid->op_type == OP_RV2AV
15583 && !(kid->op_flags & OPf_REF)
15584 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15585 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
15586 && ((kid = cUNOPx(kid)->op_first))
15587 && kid->op_type == OP_GV
15588 && cGVOPx_gv(kid) == PL_defgv
15593 switch (o->op_type) {
15596 all_flags |= AAS_PKG_SCALAR;
15602 /* if !top, could be e.g. @a[0,1] */
15603 all_flags |= (top && (o->op_flags & OPf_REF))
15604 ? ((o->op_private & OPpLVAL_INTRO)
15605 ? AAS_MY_AGG : AAS_LEX_AGG)
15611 int comm = S_aassign_padcheck(aTHX_ o, rhs)
15612 ? AAS_LEX_SCALAR_COMM : 0;
15614 all_flags |= (o->op_private & OPpLVAL_INTRO)
15615 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
15623 if (cUNOPx(o)->op_first->op_type != OP_GV)
15624 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
15626 /* if !top, could be e.g. @a[0,1] */
15627 else if (top && (o->op_flags & OPf_REF))
15628 all_flags |= AAS_PKG_AGG;
15630 all_flags |= AAS_DANGEROUS;
15635 if (cUNOPx(o)->op_first->op_type != OP_GV) {
15637 all_flags |= AAS_DANGEROUS; /* ${expr} */
15640 all_flags |= AAS_PKG_SCALAR; /* $pkg */
15644 if (o->op_private & OPpSPLIT_ASSIGN) {
15645 /* the assign in @a = split() has been optimised away
15646 * and the @a attached directly to the split op
15647 * Treat the array as appearing on the RHS, i.e.
15648 * ... = (@a = split)
15653 if (o->op_flags & OPf_STACKED) {
15654 /* @{expr} = split() - the array expression is tacked
15655 * on as an extra child to split - process kid */
15656 next_kid = cLISTOPo->op_last;
15660 /* ... else array is directly attached to split op */
15662 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
15663 ? ((o->op_private & OPpLVAL_INTRO)
15664 ? AAS_MY_AGG : AAS_LEX_AGG)
15669 /* other args of split can't be returned */
15670 all_flags |= AAS_SAFE_SCALAR;
15674 /* undef counts as a scalar on the RHS:
15675 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
15676 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
15680 flags = AAS_SAFE_SCALAR;
15685 /* these are all no-ops; they don't push a potentially common SV
15686 * onto the stack, so they are neither AAS_DANGEROUS nor
15687 * AAS_SAFE_SCALAR */
15690 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
15695 /* these do nothing, but may have children */
15699 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
15701 flags = AAS_DANGEROUS;
15705 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
15706 && (o->op_private & OPpTARGET_MY))
15709 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
15710 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
15714 /* if its an unrecognised, non-dangerous op, assume that it
15715 * is the cause of at least one safe scalar */
15717 flags = AAS_SAFE_SCALAR;
15721 all_flags |= flags;
15723 /* by default, process all kids next
15724 * XXX this assumes that all other ops are "transparent" - i.e. that
15725 * they can return some of their children. While this true for e.g.
15726 * sort and grep, it's not true for e.g. map. We really need a
15727 * 'transparent' flag added to regen/opcodes
15729 if (o->op_flags & OPf_KIDS) {
15730 next_kid = cUNOPo->op_first;
15731 /* these ops do nothing but may have children; but their
15732 * children should also be treated as top-level */
15733 if ( o == effective_top_op
15734 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
15736 effective_top_op = next_kid;
15740 /* If next_kid is set, someone in the code above wanted us to process
15741 * that kid and all its remaining siblings. Otherwise, work our way
15742 * back up the tree */
15744 while (!next_kid) {
15746 return all_flags; /* at top; no parents/siblings to try */
15747 if (OpHAS_SIBLING(o)) {
15748 next_kid = o->op_sibparent;
15749 if (o == effective_top_op)
15750 effective_top_op = next_kid;
15753 if (o == effective_top_op)
15754 effective_top_op = o->op_sibparent;
15755 o = o->op_sibparent; /* try parent's next sibling */
15764 /* Check for in place reverse and sort assignments like "@a = reverse @a"
15765 and modify the optree to make them work inplace */
15768 S_inplace_aassign(pTHX_ OP *o) {
15770 OP *modop, *modop_pushmark;
15772 OP *oleft, *oleft_pushmark;
15774 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
15776 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
15778 assert(cUNOPo->op_first->op_type == OP_NULL);
15779 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
15780 assert(modop_pushmark->op_type == OP_PUSHMARK);
15781 modop = OpSIBLING(modop_pushmark);
15783 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
15786 /* no other operation except sort/reverse */
15787 if (OpHAS_SIBLING(modop))
15790 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
15791 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
15793 if (modop->op_flags & OPf_STACKED) {
15794 /* skip sort subroutine/block */
15795 assert(oright->op_type == OP_NULL);
15796 oright = OpSIBLING(oright);
15799 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
15800 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
15801 assert(oleft_pushmark->op_type == OP_PUSHMARK);
15802 oleft = OpSIBLING(oleft_pushmark);
15804 /* Check the lhs is an array */
15806 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
15807 || OpHAS_SIBLING(oleft)
15808 || (oleft->op_private & OPpLVAL_INTRO)
15812 /* Only one thing on the rhs */
15813 if (OpHAS_SIBLING(oright))
15816 /* check the array is the same on both sides */
15817 if (oleft->op_type == OP_RV2AV) {
15818 if (oright->op_type != OP_RV2AV
15819 || !cUNOPx(oright)->op_first
15820 || cUNOPx(oright)->op_first->op_type != OP_GV
15821 || cUNOPx(oleft )->op_first->op_type != OP_GV
15822 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15823 cGVOPx_gv(cUNOPx(oright)->op_first)
15827 else if (oright->op_type != OP_PADAV
15828 || oright->op_targ != oleft->op_targ
15832 /* This actually is an inplace assignment */
15834 modop->op_private |= OPpSORT_INPLACE;
15836 /* transfer MODishness etc from LHS arg to RHS arg */
15837 oright->op_flags = oleft->op_flags;
15839 /* remove the aassign op and the lhs */
15841 op_null(oleft_pushmark);
15842 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15843 op_null(cUNOPx(oleft)->op_first);
15849 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
15850 * that potentially represent a series of one or more aggregate derefs
15851 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
15852 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
15853 * additional ops left in too).
15855 * The caller will have already verified that the first few ops in the
15856 * chain following 'start' indicate a multideref candidate, and will have
15857 * set 'orig_o' to the point further on in the chain where the first index
15858 * expression (if any) begins. 'orig_action' specifies what type of
15859 * beginning has already been determined by the ops between start..orig_o
15860 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
15862 * 'hints' contains any hints flags that need adding (currently just
15863 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
15867 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
15870 UNOP_AUX_item *arg_buf = NULL;
15871 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
15872 int index_skip = -1; /* don't output index arg on this action */
15874 /* similar to regex compiling, do two passes; the first pass
15875 * determines whether the op chain is convertible and calculates the
15876 * buffer size; the second pass populates the buffer and makes any
15877 * changes necessary to ops (such as moving consts to the pad on
15878 * threaded builds).
15880 * NB: for things like Coverity, note that both passes take the same
15881 * path through the logic tree (except for 'if (pass)' bits), since
15882 * both passes are following the same op_next chain; and in
15883 * particular, if it would return early on the second pass, it would
15884 * already have returned early on the first pass.
15886 for (pass = 0; pass < 2; pass++) {
15888 UV action = orig_action;
15889 OP *first_elem_op = NULL; /* first seen aelem/helem */
15890 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
15891 int action_count = 0; /* number of actions seen so far */
15892 int action_ix = 0; /* action_count % (actions per IV) */
15893 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
15894 bool is_last = FALSE; /* no more derefs to follow */
15895 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
15896 UV action_word = 0; /* all actions so far */
15897 UNOP_AUX_item *arg = arg_buf;
15898 UNOP_AUX_item *action_ptr = arg_buf;
15900 arg++; /* reserve slot for first action word */
15903 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
15904 case MDEREF_HV_gvhv_helem:
15905 next_is_hash = TRUE;
15907 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
15908 case MDEREF_AV_gvav_aelem:
15910 #ifdef USE_ITHREADS
15911 arg->pad_offset = cPADOPx(start)->op_padix;
15912 /* stop it being swiped when nulled */
15913 cPADOPx(start)->op_padix = 0;
15915 arg->sv = cSVOPx(start)->op_sv;
15916 cSVOPx(start)->op_sv = NULL;
15922 case MDEREF_HV_padhv_helem:
15923 case MDEREF_HV_padsv_vivify_rv2hv_helem:
15924 next_is_hash = TRUE;
15926 case MDEREF_AV_padav_aelem:
15927 case MDEREF_AV_padsv_vivify_rv2av_aelem:
15929 arg->pad_offset = start->op_targ;
15930 /* we skip setting op_targ = 0 for now, since the intact
15931 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
15932 reset_start_targ = TRUE;
15937 case MDEREF_HV_pop_rv2hv_helem:
15938 next_is_hash = TRUE;
15940 case MDEREF_AV_pop_rv2av_aelem:
15944 NOT_REACHED; /* NOTREACHED */
15949 /* look for another (rv2av/hv; get index;
15950 * aelem/helem/exists/delele) sequence */
15955 UV index_type = MDEREF_INDEX_none;
15957 if (action_count) {
15958 /* if this is not the first lookup, consume the rv2av/hv */
15960 /* for N levels of aggregate lookup, we normally expect
15961 * that the first N-1 [ah]elem ops will be flagged as
15962 * /DEREF (so they autovivifiy if necessary), and the last
15963 * lookup op not to be.
15964 * For other things (like @{$h{k1}{k2}}) extra scope or
15965 * leave ops can appear, so abandon the effort in that
15967 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
15970 /* rv2av or rv2hv sKR/1 */
15972 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15973 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15974 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15977 /* at this point, we wouldn't expect any of these
15978 * possible private flags:
15979 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
15980 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
15982 ASSUME(!(o->op_private &
15983 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
15985 hints = (o->op_private & OPpHINT_STRICT_REFS);
15987 /* make sure the type of the previous /DEREF matches the
15988 * type of the next lookup */
15989 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
15992 action = next_is_hash
15993 ? MDEREF_HV_vivify_rv2hv_helem
15994 : MDEREF_AV_vivify_rv2av_aelem;
15998 /* if this is the second pass, and we're at the depth where
15999 * previously we encountered a non-simple index expression,
16000 * stop processing the index at this point */
16001 if (action_count != index_skip) {
16003 /* look for one or more simple ops that return an array
16004 * index or hash key */
16006 switch (o->op_type) {
16008 /* it may be a lexical var index */
16009 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
16010 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16011 ASSUME(!(o->op_private &
16012 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16014 if ( OP_GIMME(o,0) == G_SCALAR
16015 && !(o->op_flags & (OPf_REF|OPf_MOD))
16016 && o->op_private == 0)
16019 arg->pad_offset = o->op_targ;
16021 index_type = MDEREF_INDEX_padsv;
16027 if (next_is_hash) {
16028 /* it's a constant hash index */
16029 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
16030 /* "use constant foo => FOO; $h{+foo}" for
16031 * some weird FOO, can leave you with constants
16032 * that aren't simple strings. It's not worth
16033 * the extra hassle for those edge cases */
16038 OP * helem_op = o->op_next;
16040 ASSUME( helem_op->op_type == OP_HELEM
16041 || helem_op->op_type == OP_NULL
16043 if (helem_op->op_type == OP_HELEM) {
16044 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
16045 if ( helem_op->op_private & OPpLVAL_INTRO
16046 || rop->op_type != OP_RV2HV
16050 /* on first pass just check; on second pass
16052 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
16057 #ifdef USE_ITHREADS
16058 /* Relocate sv to the pad for thread safety */
16059 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
16060 arg->pad_offset = o->op_targ;
16063 arg->sv = cSVOPx_sv(o);
16068 /* it's a constant array index */
16070 SV *ix_sv = cSVOPo->op_sv;
16075 if ( action_count == 0
16078 && ( action == MDEREF_AV_padav_aelem
16079 || action == MDEREF_AV_gvav_aelem)
16081 maybe_aelemfast = TRUE;
16085 SvREFCNT_dec_NN(cSVOPo->op_sv);
16089 /* we've taken ownership of the SV */
16090 cSVOPo->op_sv = NULL;
16092 index_type = MDEREF_INDEX_const;
16097 /* it may be a package var index */
16099 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
16100 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
16101 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
16102 || o->op_private != 0
16107 if (kid->op_type != OP_RV2SV)
16110 ASSUME(!(kid->op_flags &
16111 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
16112 |OPf_SPECIAL|OPf_PARENS)));
16113 ASSUME(!(kid->op_private &
16115 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
16116 |OPpDEREF|OPpLVAL_INTRO)));
16117 if( (kid->op_flags &~ OPf_PARENS)
16118 != (OPf_WANT_SCALAR|OPf_KIDS)
16119 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
16124 #ifdef USE_ITHREADS
16125 arg->pad_offset = cPADOPx(o)->op_padix;
16126 /* stop it being swiped when nulled */
16127 cPADOPx(o)->op_padix = 0;
16129 arg->sv = cSVOPx(o)->op_sv;
16130 cSVOPo->op_sv = NULL;
16134 index_type = MDEREF_INDEX_gvsv;
16139 } /* action_count != index_skip */
16141 action |= index_type;
16144 /* at this point we have either:
16145 * * detected what looks like a simple index expression,
16146 * and expect the next op to be an [ah]elem, or
16147 * an nulled [ah]elem followed by a delete or exists;
16148 * * found a more complex expression, so something other
16149 * than the above follows.
16152 /* possibly an optimised away [ah]elem (where op_next is
16153 * exists or delete) */
16154 if (o->op_type == OP_NULL)
16157 /* at this point we're looking for an OP_AELEM, OP_HELEM,
16158 * OP_EXISTS or OP_DELETE */
16160 /* if a custom array/hash access checker is in scope,
16161 * abandon optimisation attempt */
16162 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16163 && PL_check[o->op_type] != Perl_ck_null)
16165 /* similarly for customised exists and delete */
16166 if ( (o->op_type == OP_EXISTS)
16167 && PL_check[o->op_type] != Perl_ck_exists)
16169 if ( (o->op_type == OP_DELETE)
16170 && PL_check[o->op_type] != Perl_ck_delete)
16173 if ( o->op_type != OP_AELEM
16174 || (o->op_private &
16175 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
16177 maybe_aelemfast = FALSE;
16179 /* look for aelem/helem/exists/delete. If it's not the last elem
16180 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
16181 * flags; if it's the last, then it mustn't have
16182 * OPpDEREF_AV/HV, but may have lots of other flags, like
16183 * OPpLVAL_INTRO etc
16186 if ( index_type == MDEREF_INDEX_none
16187 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
16188 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
16192 /* we have aelem/helem/exists/delete with valid simple index */
16194 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16195 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
16196 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
16198 /* This doesn't make much sense but is legal:
16199 * @{ local $x[0][0] } = 1
16200 * Since scope exit will undo the autovivification,
16201 * don't bother in the first place. The OP_LEAVE
16202 * assertion is in case there are other cases of both
16203 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
16204 * exit that would undo the local - in which case this
16205 * block of code would need rethinking.
16207 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
16209 OP *n = o->op_next;
16210 while (n && ( n->op_type == OP_NULL
16211 || n->op_type == OP_LIST
16212 || n->op_type == OP_SCALAR))
16214 assert(n && n->op_type == OP_LEAVE);
16216 o->op_private &= ~OPpDEREF;
16221 ASSUME(!(o->op_flags &
16222 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
16223 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
16225 ok = (o->op_flags &~ OPf_PARENS)
16226 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
16227 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
16229 else if (o->op_type == OP_EXISTS) {
16230 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16231 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16232 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
16233 ok = !(o->op_private & ~OPpARG1_MASK);
16235 else if (o->op_type == OP_DELETE) {
16236 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16237 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16238 ASSUME(!(o->op_private &
16239 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
16240 /* don't handle slices or 'local delete'; the latter
16241 * is fairly rare, and has a complex runtime */
16242 ok = !(o->op_private & ~OPpARG1_MASK);
16243 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
16244 /* skip handling run-tome error */
16245 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
16248 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
16249 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
16250 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
16251 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
16252 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
16253 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
16258 if (!first_elem_op)
16262 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
16267 action |= MDEREF_FLAG_last;
16271 /* at this point we have something that started
16272 * promisingly enough (with rv2av or whatever), but failed
16273 * to find a simple index followed by an
16274 * aelem/helem/exists/delete. If this is the first action,
16275 * give up; but if we've already seen at least one
16276 * aelem/helem, then keep them and add a new action with
16277 * MDEREF_INDEX_none, which causes it to do the vivify
16278 * from the end of the previous lookup, and do the deref,
16279 * but stop at that point. So $a[0][expr] will do one
16280 * av_fetch, vivify and deref, then continue executing at
16285 index_skip = action_count;
16286 action |= MDEREF_FLAG_last;
16287 if (index_type != MDEREF_INDEX_none)
16291 action_word |= (action << (action_ix * MDEREF_SHIFT));
16294 /* if there's no space for the next action, reserve a new slot
16295 * for it *before* we start adding args for that action */
16296 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
16298 action_ptr->uv = action_word;
16304 } /* while !is_last */
16309 /* slot reserved for next action word not now needed */
16312 action_ptr->uv = action_word;
16318 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
16319 if (index_skip == -1) {
16320 mderef->op_flags = o->op_flags
16321 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
16322 if (o->op_type == OP_EXISTS)
16323 mderef->op_private = OPpMULTIDEREF_EXISTS;
16324 else if (o->op_type == OP_DELETE)
16325 mderef->op_private = OPpMULTIDEREF_DELETE;
16327 mderef->op_private = o->op_private
16328 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
16330 /* accumulate strictness from every level (although I don't think
16331 * they can actually vary) */
16332 mderef->op_private |= hints;
16334 /* integrate the new multideref op into the optree and the
16337 * In general an op like aelem or helem has two child
16338 * sub-trees: the aggregate expression (a_expr) and the
16339 * index expression (i_expr):
16345 * The a_expr returns an AV or HV, while the i-expr returns an
16346 * index. In general a multideref replaces most or all of a
16347 * multi-level tree, e.g.
16363 * With multideref, all the i_exprs will be simple vars or
16364 * constants, except that i_expr1 may be arbitrary in the case
16365 * of MDEREF_INDEX_none.
16367 * The bottom-most a_expr will be either:
16368 * 1) a simple var (so padXv or gv+rv2Xv);
16369 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
16370 * so a simple var with an extra rv2Xv;
16371 * 3) or an arbitrary expression.
16373 * 'start', the first op in the execution chain, will point to
16374 * 1),2): the padXv or gv op;
16375 * 3): the rv2Xv which forms the last op in the a_expr
16376 * execution chain, and the top-most op in the a_expr
16379 * For all cases, the 'start' node is no longer required,
16380 * but we can't free it since one or more external nodes
16381 * may point to it. E.g. consider
16382 * $h{foo} = $a ? $b : $c
16383 * Here, both the op_next and op_other branches of the
16384 * cond_expr point to the gv[*h] of the hash expression, so
16385 * we can't free the 'start' op.
16387 * For expr->[...], we need to save the subtree containing the
16388 * expression; for the other cases, we just need to save the
16390 * So in all cases, we null the start op and keep it around by
16391 * making it the child of the multideref op; for the expr->
16392 * case, the expr will be a subtree of the start node.
16394 * So in the simple 1,2 case the optree above changes to
16400 * ex-gv (or ex-padxv)
16402 * with the op_next chain being
16404 * -> ex-gv -> multideref -> op-following-ex-exists ->
16406 * In the 3 case, we have
16419 * -> rest-of-a_expr subtree ->
16420 * ex-rv2xv -> multideref -> op-following-ex-exists ->
16423 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
16424 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
16425 * multideref attached as the child, e.g.
16431 * ex-rv2av - i_expr1
16439 /* if we free this op, don't free the pad entry */
16440 if (reset_start_targ)
16441 start->op_targ = 0;
16444 /* Cut the bit we need to save out of the tree and attach to
16445 * the multideref op, then free the rest of the tree */
16447 /* find parent of node to be detached (for use by splice) */
16449 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
16450 || orig_action == MDEREF_HV_pop_rv2hv_helem)
16452 /* there is an arbitrary expression preceding us, e.g.
16453 * expr->[..]? so we need to save the 'expr' subtree */
16454 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
16455 p = cUNOPx(p)->op_first;
16456 ASSUME( start->op_type == OP_RV2AV
16457 || start->op_type == OP_RV2HV);
16460 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
16461 * above for exists/delete. */
16462 while ( (p->op_flags & OPf_KIDS)
16463 && cUNOPx(p)->op_first != start
16465 p = cUNOPx(p)->op_first;
16467 ASSUME(cUNOPx(p)->op_first == start);
16469 /* detach from main tree, and re-attach under the multideref */
16470 op_sibling_splice(mderef, NULL, 0,
16471 op_sibling_splice(p, NULL, 1, NULL));
16474 start->op_next = mderef;
16476 mderef->op_next = index_skip == -1 ? o->op_next : o;
16478 /* excise and free the original tree, and replace with
16479 * the multideref op */
16480 p = op_sibling_splice(top_op, NULL, -1, mderef);
16489 Size_t size = arg - arg_buf;
16491 if (maybe_aelemfast && action_count == 1)
16494 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
16495 sizeof(UNOP_AUX_item) * (size + 1));
16496 /* for dumping etc: store the length in a hidden first slot;
16497 * we set the op_aux pointer to the second slot */
16498 arg_buf->uv = size;
16501 } /* for (pass = ...) */
16504 /* See if the ops following o are such that o will always be executed in
16505 * boolean context: that is, the SV which o pushes onto the stack will
16506 * only ever be consumed by later ops via SvTRUE(sv) or similar.
16507 * If so, set a suitable private flag on o. Normally this will be
16508 * bool_flag; but see below why maybe_flag is needed too.
16510 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
16511 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
16512 * already be taken, so you'll have to give that op two different flags.
16514 * More explanation of 'maybe_flag' and 'safe_and' parameters.
16515 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
16516 * those underlying ops) short-circuit, which means that rather than
16517 * necessarily returning a truth value, they may return the LH argument,
16518 * which may not be boolean. For example in $x = (keys %h || -1), keys
16519 * should return a key count rather than a boolean, even though its
16520 * sort-of being used in boolean context.
16522 * So we only consider such logical ops to provide boolean context to
16523 * their LH argument if they themselves are in void or boolean context.
16524 * However, sometimes the context isn't known until run-time. In this
16525 * case the op is marked with the maybe_flag flag it.
16527 * Consider the following.
16529 * sub f { ....; if (%h) { .... } }
16531 * This is actually compiled as
16533 * sub f { ....; %h && do { .... } }
16535 * Here we won't know until runtime whether the final statement (and hence
16536 * the &&) is in void context and so is safe to return a boolean value.
16537 * So mark o with maybe_flag rather than the bool_flag.
16538 * Note that there is cost associated with determining context at runtime
16539 * (e.g. a call to block_gimme()), so it may not be worth setting (at
16540 * compile time) and testing (at runtime) maybe_flag if the scalar verses
16541 * boolean costs savings are marginal.
16543 * However, we can do slightly better with && (compared to || and //):
16544 * this op only returns its LH argument when that argument is false. In
16545 * this case, as long as the op promises to return a false value which is
16546 * valid in both boolean and scalar contexts, we can mark an op consumed
16547 * by && with bool_flag rather than maybe_flag.
16548 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
16549 * than &PL_sv_no for a false result in boolean context, then it's safe. An
16550 * op which promises to handle this case is indicated by setting safe_and
16555 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
16560 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
16562 /* OPpTARGET_MY and boolean context probably don't mix well.
16563 * If someone finds a valid use case, maybe add an extra flag to this
16564 * function which indicates its safe to do so for this op? */
16565 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
16566 && (o->op_private & OPpTARGET_MY)));
16571 switch (lop->op_type) {
16576 /* these two consume the stack argument in the scalar case,
16577 * and treat it as a boolean in the non linenumber case */
16580 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
16581 || (lop->op_private & OPpFLIP_LINENUM))
16587 /* these never leave the original value on the stack */
16596 /* OR DOR and AND evaluate their arg as a boolean, but then may
16597 * leave the original scalar value on the stack when following the
16598 * op_next route. If not in void context, we need to ensure
16599 * that whatever follows consumes the arg only in boolean context
16611 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
16615 else if (!(lop->op_flags & OPf_WANT)) {
16616 /* unknown context - decide at runtime */
16628 lop = lop->op_next;
16631 o->op_private |= flag;
16636 /* mechanism for deferring recursion in rpeep() */
16638 #define MAX_DEFERRED 4
16642 if (defer_ix == (MAX_DEFERRED-1)) { \
16643 OP **defer = defer_queue[defer_base]; \
16644 CALL_RPEEP(*defer); \
16645 S_prune_chain_head(defer); \
16646 defer_base = (defer_base + 1) % MAX_DEFERRED; \
16649 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
16652 #define IS_AND_OP(o) (o->op_type == OP_AND)
16653 #define IS_OR_OP(o) (o->op_type == OP_OR)
16656 /* A peephole optimizer. We visit the ops in the order they're to execute.
16657 * See the comments at the top of this file for more details about when
16658 * peep() is called */
16661 Perl_rpeep(pTHX_ OP *o)
16664 OP* oldoldop = NULL;
16665 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
16666 int defer_base = 0;
16669 if (!o || o->op_opt)
16672 assert(o->op_type != OP_FREED);
16676 SAVEVPTR(PL_curcop);
16677 for (;; o = o->op_next) {
16678 if (o && o->op_opt)
16681 while (defer_ix >= 0) {
16683 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
16684 CALL_RPEEP(*defer);
16685 S_prune_chain_head(defer);
16692 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
16693 assert(!oldoldop || oldoldop->op_next == oldop);
16694 assert(!oldop || oldop->op_next == o);
16696 /* By default, this op has now been optimised. A couple of cases below
16697 clear this again. */
16701 /* look for a series of 1 or more aggregate derefs, e.g.
16702 * $a[1]{foo}[$i]{$k}
16703 * and replace with a single OP_MULTIDEREF op.
16704 * Each index must be either a const, or a simple variable,
16706 * First, look for likely combinations of starting ops,
16707 * corresponding to (global and lexical variants of)
16709 * $r->[...] $r->{...}
16710 * (preceding expression)->[...]
16711 * (preceding expression)->{...}
16712 * and if so, call maybe_multideref() to do a full inspection
16713 * of the op chain and if appropriate, replace with an
16721 switch (o2->op_type) {
16723 /* $pkg[..] : gv[*pkg]
16724 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
16726 /* Fail if there are new op flag combinations that we're
16727 * not aware of, rather than:
16728 * * silently failing to optimise, or
16729 * * silently optimising the flag away.
16730 * If this ASSUME starts failing, examine what new flag
16731 * has been added to the op, and decide whether the
16732 * optimisation should still occur with that flag, then
16733 * update the code accordingly. This applies to all the
16734 * other ASSUMEs in the block of code too.
16736 ASSUME(!(o2->op_flags &
16737 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
16738 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
16742 if (o2->op_type == OP_RV2AV) {
16743 action = MDEREF_AV_gvav_aelem;
16747 if (o2->op_type == OP_RV2HV) {
16748 action = MDEREF_HV_gvhv_helem;
16752 if (o2->op_type != OP_RV2SV)
16755 /* at this point we've seen gv,rv2sv, so the only valid
16756 * construct left is $pkg->[] or $pkg->{} */
16758 ASSUME(!(o2->op_flags & OPf_STACKED));
16759 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16760 != (OPf_WANT_SCALAR|OPf_MOD))
16763 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
16764 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
16765 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
16767 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
16768 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
16772 if (o2->op_type == OP_RV2AV) {
16773 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
16776 if (o2->op_type == OP_RV2HV) {
16777 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
16783 /* $lex->[...]: padsv[$lex] sM/DREFAV */
16785 ASSUME(!(o2->op_flags &
16786 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
16787 if ((o2->op_flags &
16788 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16789 != (OPf_WANT_SCALAR|OPf_MOD))
16792 ASSUME(!(o2->op_private &
16793 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16794 /* skip if state or intro, or not a deref */
16795 if ( o2->op_private != OPpDEREF_AV
16796 && o2->op_private != OPpDEREF_HV)
16800 if (o2->op_type == OP_RV2AV) {
16801 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
16804 if (o2->op_type == OP_RV2HV) {
16805 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
16812 /* $lex[..]: padav[@lex:1,2] sR *
16813 * or $lex{..}: padhv[%lex:1,2] sR */
16814 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
16815 OPf_REF|OPf_SPECIAL)));
16816 if ((o2->op_flags &
16817 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16818 != (OPf_WANT_SCALAR|OPf_REF))
16820 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
16822 /* OPf_PARENS isn't currently used in this case;
16823 * if that changes, let us know! */
16824 ASSUME(!(o2->op_flags & OPf_PARENS));
16826 /* at this point, we wouldn't expect any of the remaining
16827 * possible private flags:
16828 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
16829 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
16831 * OPpSLICEWARNING shouldn't affect runtime
16833 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
16835 action = o2->op_type == OP_PADAV
16836 ? MDEREF_AV_padav_aelem
16837 : MDEREF_HV_padhv_helem;
16839 S_maybe_multideref(aTHX_ o, o2, action, 0);
16845 action = o2->op_type == OP_RV2AV
16846 ? MDEREF_AV_pop_rv2av_aelem
16847 : MDEREF_HV_pop_rv2hv_helem;
16850 /* (expr)->[...]: rv2av sKR/1;
16851 * (expr)->{...}: rv2hv sKR/1; */
16853 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
16855 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16856 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
16857 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16860 /* at this point, we wouldn't expect any of these
16861 * possible private flags:
16862 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
16863 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
16865 ASSUME(!(o2->op_private &
16866 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
16868 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
16872 S_maybe_multideref(aTHX_ o, o2, action, hints);
16881 switch (o->op_type) {
16883 PL_curcop = ((COP*)o); /* for warnings */
16886 PL_curcop = ((COP*)o); /* for warnings */
16888 /* Optimise a "return ..." at the end of a sub to just be "...".
16889 * This saves 2 ops. Before:
16890 * 1 <;> nextstate(main 1 -e:1) v ->2
16891 * 4 <@> return K ->5
16892 * 2 <0> pushmark s ->3
16893 * - <1> ex-rv2sv sK/1 ->4
16894 * 3 <#> gvsv[*cat] s ->4
16897 * - <@> return K ->-
16898 * - <0> pushmark s ->2
16899 * - <1> ex-rv2sv sK/1 ->-
16900 * 2 <$> gvsv(*cat) s ->3
16903 OP *next = o->op_next;
16904 OP *sibling = OpSIBLING(o);
16905 if ( OP_TYPE_IS(next, OP_PUSHMARK)
16906 && OP_TYPE_IS(sibling, OP_RETURN)
16907 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
16908 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
16909 ||OP_TYPE_IS(sibling->op_next->op_next,
16911 && cUNOPx(sibling)->op_first == next
16912 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
16915 /* Look through the PUSHMARK's siblings for one that
16916 * points to the RETURN */
16917 OP *top = OpSIBLING(next);
16918 while (top && top->op_next) {
16919 if (top->op_next == sibling) {
16920 top->op_next = sibling->op_next;
16921 o->op_next = next->op_next;
16924 top = OpSIBLING(top);
16929 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
16931 * This latter form is then suitable for conversion into padrange
16932 * later on. Convert:
16934 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
16938 * nextstate1 -> listop -> nextstate3
16940 * pushmark -> padop1 -> padop2
16942 if (o->op_next && (
16943 o->op_next->op_type == OP_PADSV
16944 || o->op_next->op_type == OP_PADAV
16945 || o->op_next->op_type == OP_PADHV
16947 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
16948 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
16949 && o->op_next->op_next->op_next && (
16950 o->op_next->op_next->op_next->op_type == OP_PADSV
16951 || o->op_next->op_next->op_next->op_type == OP_PADAV
16952 || o->op_next->op_next->op_next->op_type == OP_PADHV
16954 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
16955 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
16956 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
16957 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
16959 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
16962 ns2 = pad1->op_next;
16963 pad2 = ns2->op_next;
16964 ns3 = pad2->op_next;
16966 /* we assume here that the op_next chain is the same as
16967 * the op_sibling chain */
16968 assert(OpSIBLING(o) == pad1);
16969 assert(OpSIBLING(pad1) == ns2);
16970 assert(OpSIBLING(ns2) == pad2);
16971 assert(OpSIBLING(pad2) == ns3);
16973 /* excise and delete ns2 */
16974 op_sibling_splice(NULL, pad1, 1, NULL);
16977 /* excise pad1 and pad2 */
16978 op_sibling_splice(NULL, o, 2, NULL);
16980 /* create new listop, with children consisting of:
16981 * a new pushmark, pad1, pad2. */
16982 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
16983 newop->op_flags |= OPf_PARENS;
16984 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16986 /* insert newop between o and ns3 */
16987 op_sibling_splice(NULL, o, 0, newop);
16989 /*fixup op_next chain */
16990 newpm = cUNOPx(newop)->op_first; /* pushmark */
16991 o ->op_next = newpm;
16992 newpm->op_next = pad1;
16993 pad1 ->op_next = pad2;
16994 pad2 ->op_next = newop; /* listop */
16995 newop->op_next = ns3;
16997 /* Ensure pushmark has this flag if padops do */
16998 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
16999 newpm->op_flags |= OPf_MOD;
17005 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
17006 to carry two labels. For now, take the easier option, and skip
17007 this optimisation if the first NEXTSTATE has a label. */
17008 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
17009 OP *nextop = o->op_next;
17011 switch (nextop->op_type) {
17016 nextop = nextop->op_next;
17022 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
17025 oldop->op_next = nextop;
17027 /* Skip (old)oldop assignment since the current oldop's
17028 op_next already points to the next op. */
17035 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
17036 if (o->op_next->op_private & OPpTARGET_MY) {
17037 if (o->op_flags & OPf_STACKED) /* chained concats */
17038 break; /* ignore_optimization */
17040 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
17041 o->op_targ = o->op_next->op_targ;
17042 o->op_next->op_targ = 0;
17043 o->op_private |= OPpTARGET_MY;
17046 op_null(o->op_next);
17050 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
17051 break; /* Scalar stub must produce undef. List stub is noop */
17055 if (o->op_targ == OP_NEXTSTATE
17056 || o->op_targ == OP_DBSTATE)
17058 PL_curcop = ((COP*)o);
17060 /* XXX: We avoid setting op_seq here to prevent later calls
17061 to rpeep() from mistakenly concluding that optimisation
17062 has already occurred. This doesn't fix the real problem,
17063 though (See 20010220.007 (#5874)). AMS 20010719 */
17064 /* op_seq functionality is now replaced by op_opt */
17072 oldop->op_next = o->op_next;
17086 convert repeat into a stub with no kids.
17088 if (o->op_next->op_type == OP_CONST
17089 || ( o->op_next->op_type == OP_PADSV
17090 && !(o->op_next->op_private & OPpLVAL_INTRO))
17091 || ( o->op_next->op_type == OP_GV
17092 && o->op_next->op_next->op_type == OP_RV2SV
17093 && !(o->op_next->op_next->op_private
17094 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
17096 const OP *kid = o->op_next->op_next;
17097 if (o->op_next->op_type == OP_GV)
17098 kid = kid->op_next;
17099 /* kid is now the ex-list. */
17100 if (kid->op_type == OP_NULL
17101 && (kid = kid->op_next)->op_type == OP_CONST
17102 /* kid is now the repeat count. */
17103 && kid->op_next->op_type == OP_REPEAT
17104 && kid->op_next->op_private & OPpREPEAT_DOLIST
17105 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
17106 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
17109 o = kid->op_next; /* repeat */
17110 oldop->op_next = o;
17111 op_free(cBINOPo->op_first);
17112 op_free(cBINOPo->op_last );
17113 o->op_flags &=~ OPf_KIDS;
17114 /* stub is a baseop; repeat is a binop */
17115 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
17116 OpTYPE_set(o, OP_STUB);
17122 /* Convert a series of PAD ops for my vars plus support into a
17123 * single padrange op. Basically
17125 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
17127 * becomes, depending on circumstances, one of
17129 * padrange ----------------------------------> (list) -> rest
17130 * padrange --------------------------------------------> rest
17132 * where all the pad indexes are sequential and of the same type
17134 * We convert the pushmark into a padrange op, then skip
17135 * any other pad ops, and possibly some trailing ops.
17136 * Note that we don't null() the skipped ops, to make it
17137 * easier for Deparse to undo this optimisation (and none of
17138 * the skipped ops are holding any resourses). It also makes
17139 * it easier for find_uninit_var(), as it can just ignore
17140 * padrange, and examine the original pad ops.
17144 OP *followop = NULL; /* the op that will follow the padrange op */
17147 PADOFFSET base = 0; /* init only to stop compiler whining */
17148 bool gvoid = 0; /* init only to stop compiler whining */
17149 bool defav = 0; /* seen (...) = @_ */
17150 bool reuse = 0; /* reuse an existing padrange op */
17152 /* look for a pushmark -> gv[_] -> rv2av */
17157 if ( p->op_type == OP_GV
17158 && cGVOPx_gv(p) == PL_defgv
17159 && (rv2av = p->op_next)
17160 && rv2av->op_type == OP_RV2AV
17161 && !(rv2av->op_flags & OPf_REF)
17162 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
17163 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
17165 q = rv2av->op_next;
17166 if (q->op_type == OP_NULL)
17168 if (q->op_type == OP_PUSHMARK) {
17178 /* scan for PAD ops */
17180 for (p = p->op_next; p; p = p->op_next) {
17181 if (p->op_type == OP_NULL)
17184 if (( p->op_type != OP_PADSV
17185 && p->op_type != OP_PADAV
17186 && p->op_type != OP_PADHV
17188 /* any private flag other than INTRO? e.g. STATE */
17189 || (p->op_private & ~OPpLVAL_INTRO)
17193 /* let $a[N] potentially be optimised into AELEMFAST_LEX
17195 if ( p->op_type == OP_PADAV
17197 && p->op_next->op_type == OP_CONST
17198 && p->op_next->op_next
17199 && p->op_next->op_next->op_type == OP_AELEM
17203 /* for 1st padop, note what type it is and the range
17204 * start; for the others, check that it's the same type
17205 * and that the targs are contiguous */
17207 intro = (p->op_private & OPpLVAL_INTRO);
17209 gvoid = OP_GIMME(p,0) == G_VOID;
17212 if ((p->op_private & OPpLVAL_INTRO) != intro)
17214 /* Note that you'd normally expect targs to be
17215 * contiguous in my($a,$b,$c), but that's not the case
17216 * when external modules start doing things, e.g.
17217 * Function::Parameters */
17218 if (p->op_targ != base + count)
17220 assert(p->op_targ == base + count);
17221 /* Either all the padops or none of the padops should
17222 be in void context. Since we only do the optimisa-
17223 tion for av/hv when the aggregate itself is pushed
17224 on to the stack (one item), there is no need to dis-
17225 tinguish list from scalar context. */
17226 if (gvoid != (OP_GIMME(p,0) == G_VOID))
17230 /* for AV, HV, only when we're not flattening */
17231 if ( p->op_type != OP_PADSV
17233 && !(p->op_flags & OPf_REF)
17237 if (count >= OPpPADRANGE_COUNTMASK)
17240 /* there's a biggest base we can fit into a
17241 * SAVEt_CLEARPADRANGE in pp_padrange.
17242 * (The sizeof() stuff will be constant-folded, and is
17243 * intended to avoid getting "comparison is always false"
17244 * compiler warnings. See the comments above
17245 * MEM_WRAP_CHECK for more explanation on why we do this
17246 * in a weird way to avoid compiler warnings.)
17249 && (8*sizeof(base) >
17250 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
17252 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17254 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17258 /* Success! We've got another valid pad op to optimise away */
17260 followop = p->op_next;
17263 if (count < 1 || (count == 1 && !defav))
17266 /* pp_padrange in specifically compile-time void context
17267 * skips pushing a mark and lexicals; in all other contexts
17268 * (including unknown till runtime) it pushes a mark and the
17269 * lexicals. We must be very careful then, that the ops we
17270 * optimise away would have exactly the same effect as the
17272 * In particular in void context, we can only optimise to
17273 * a padrange if we see the complete sequence
17274 * pushmark, pad*v, ...., list
17275 * which has the net effect of leaving the markstack as it
17276 * was. Not pushing onto the stack (whereas padsv does touch
17277 * the stack) makes no difference in void context.
17281 if (followop->op_type == OP_LIST
17282 && OP_GIMME(followop,0) == G_VOID
17285 followop = followop->op_next; /* skip OP_LIST */
17287 /* consolidate two successive my(...);'s */
17290 && oldoldop->op_type == OP_PADRANGE
17291 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
17292 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
17293 && !(oldoldop->op_flags & OPf_SPECIAL)
17296 assert(oldoldop->op_next == oldop);
17297 assert( oldop->op_type == OP_NEXTSTATE
17298 || oldop->op_type == OP_DBSTATE);
17299 assert(oldop->op_next == o);
17302 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
17304 /* Do not assume pad offsets for $c and $d are con-
17309 if ( oldoldop->op_targ + old_count == base
17310 && old_count < OPpPADRANGE_COUNTMASK - count) {
17311 base = oldoldop->op_targ;
17312 count += old_count;
17317 /* if there's any immediately following singleton
17318 * my var's; then swallow them and the associated
17320 * my ($a,$b); my $c; my $d;
17322 * my ($a,$b,$c,$d);
17325 while ( ((p = followop->op_next))
17326 && ( p->op_type == OP_PADSV
17327 || p->op_type == OP_PADAV
17328 || p->op_type == OP_PADHV)
17329 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
17330 && (p->op_private & OPpLVAL_INTRO) == intro
17331 && !(p->op_private & ~OPpLVAL_INTRO)
17333 && ( p->op_next->op_type == OP_NEXTSTATE
17334 || p->op_next->op_type == OP_DBSTATE)
17335 && count < OPpPADRANGE_COUNTMASK
17336 && base + count == p->op_targ
17339 followop = p->op_next;
17347 assert(oldoldop->op_type == OP_PADRANGE);
17348 oldoldop->op_next = followop;
17349 oldoldop->op_private = (intro | count);
17355 /* Convert the pushmark into a padrange.
17356 * To make Deparse easier, we guarantee that a padrange was
17357 * *always* formerly a pushmark */
17358 assert(o->op_type == OP_PUSHMARK);
17359 o->op_next = followop;
17360 OpTYPE_set(o, OP_PADRANGE);
17362 /* bit 7: INTRO; bit 6..0: count */
17363 o->op_private = (intro | count);
17364 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
17365 | gvoid * OPf_WANT_VOID
17366 | (defav ? OPf_SPECIAL : 0));
17372 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17373 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17378 /*'keys %h' in void or scalar context: skip the OP_KEYS
17379 * and perform the functionality directly in the RV2HV/PADHV
17382 if (o->op_flags & OPf_REF) {
17383 OP *k = o->op_next;
17384 U8 want = (k->op_flags & OPf_WANT);
17386 && k->op_type == OP_KEYS
17387 && ( want == OPf_WANT_VOID
17388 || want == OPf_WANT_SCALAR)
17389 && !(k->op_private & OPpMAYBE_LVSUB)
17390 && !(k->op_flags & OPf_MOD)
17392 o->op_next = k->op_next;
17393 o->op_flags &= ~(OPf_REF|OPf_WANT);
17394 o->op_flags |= want;
17395 o->op_private |= (o->op_type == OP_PADHV ?
17396 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
17397 /* for keys(%lex), hold onto the OP_KEYS's targ
17398 * since padhv doesn't have its own targ to return
17400 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
17405 /* see if %h is used in boolean context */
17406 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17407 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17410 if (o->op_type != OP_PADHV)
17414 if ( o->op_type == OP_PADAV
17415 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17417 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17420 /* Skip over state($x) in void context. */
17421 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
17422 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
17424 oldop->op_next = o->op_next;
17425 goto redo_nextstate;
17427 if (o->op_type != OP_PADAV)
17431 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
17432 OP* const pop = (o->op_type == OP_PADAV) ?
17433 o->op_next : o->op_next->op_next;
17435 if (pop && pop->op_type == OP_CONST &&
17436 ((PL_op = pop->op_next)) &&
17437 pop->op_next->op_type == OP_AELEM &&
17438 !(pop->op_next->op_private &
17439 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
17440 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
17443 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
17444 no_bareword_allowed(pop);
17445 if (o->op_type == OP_GV)
17446 op_null(o->op_next);
17447 op_null(pop->op_next);
17449 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
17450 o->op_next = pop->op_next->op_next;
17451 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
17452 o->op_private = (U8)i;
17453 if (o->op_type == OP_GV) {
17456 o->op_type = OP_AELEMFAST;
17459 o->op_type = OP_AELEMFAST_LEX;
17461 if (o->op_type != OP_GV)
17465 /* Remove $foo from the op_next chain in void context. */
17467 && ( o->op_next->op_type == OP_RV2SV
17468 || o->op_next->op_type == OP_RV2AV
17469 || o->op_next->op_type == OP_RV2HV )
17470 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17471 && !(o->op_next->op_private & OPpLVAL_INTRO))
17473 oldop->op_next = o->op_next->op_next;
17474 /* Reprocess the previous op if it is a nextstate, to
17475 allow double-nextstate optimisation. */
17477 if (oldop->op_type == OP_NEXTSTATE) {
17484 o = oldop->op_next;
17487 else if (o->op_next->op_type == OP_RV2SV) {
17488 if (!(o->op_next->op_private & OPpDEREF)) {
17489 op_null(o->op_next);
17490 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
17492 o->op_next = o->op_next->op_next;
17493 OpTYPE_set(o, OP_GVSV);
17496 else if (o->op_next->op_type == OP_READLINE
17497 && o->op_next->op_next->op_type == OP_CONCAT
17498 && (o->op_next->op_next->op_flags & OPf_STACKED))
17500 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
17501 OpTYPE_set(o, OP_RCATLINE);
17502 o->op_flags |= OPf_STACKED;
17503 op_null(o->op_next->op_next);
17504 op_null(o->op_next);
17515 case OP_CMPCHAIN_AND:
17516 while (cLOGOP->op_other->op_type == OP_NULL)
17517 cLOGOP->op_other = cLOGOP->op_other->op_next;
17518 while (o->op_next && ( o->op_type == o->op_next->op_type
17519 || o->op_next->op_type == OP_NULL))
17520 o->op_next = o->op_next->op_next;
17522 /* If we're an OR and our next is an AND in void context, we'll
17523 follow its op_other on short circuit, same for reverse.
17524 We can't do this with OP_DOR since if it's true, its return
17525 value is the underlying value which must be evaluated
17529 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
17530 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
17532 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17534 o->op_next = ((LOGOP*)o->op_next)->op_other;
17536 DEFER(cLOGOP->op_other);
17541 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17542 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17551 case OP_ARGDEFELEM:
17552 while (cLOGOP->op_other->op_type == OP_NULL)
17553 cLOGOP->op_other = cLOGOP->op_other->op_next;
17554 DEFER(cLOGOP->op_other);
17559 while (cLOOP->op_redoop->op_type == OP_NULL)
17560 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
17561 while (cLOOP->op_nextop->op_type == OP_NULL)
17562 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
17563 while (cLOOP->op_lastop->op_type == OP_NULL)
17564 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
17565 /* a while(1) loop doesn't have an op_next that escapes the
17566 * loop, so we have to explicitly follow the op_lastop to
17567 * process the rest of the code */
17568 DEFER(cLOOP->op_lastop);
17572 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
17573 DEFER(cLOGOPo->op_other);
17577 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17578 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17579 assert(!(cPMOP->op_pmflags & PMf_ONCE));
17580 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
17581 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
17582 cPMOP->op_pmstashstartu.op_pmreplstart
17583 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
17584 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
17590 if (o->op_flags & OPf_SPECIAL) {
17591 /* first arg is a code block */
17592 OP * const nullop = OpSIBLING(cLISTOP->op_first);
17593 OP * kid = cUNOPx(nullop)->op_first;
17595 assert(nullop->op_type == OP_NULL);
17596 assert(kid->op_type == OP_SCOPE
17597 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
17598 /* since OP_SORT doesn't have a handy op_other-style
17599 * field that can point directly to the start of the code
17600 * block, store it in the otherwise-unused op_next field
17601 * of the top-level OP_NULL. This will be quicker at
17602 * run-time, and it will also allow us to remove leading
17603 * OP_NULLs by just messing with op_nexts without
17604 * altering the basic op_first/op_sibling layout. */
17605 kid = kLISTOP->op_first;
17607 (kid->op_type == OP_NULL
17608 && ( kid->op_targ == OP_NEXTSTATE
17609 || kid->op_targ == OP_DBSTATE ))
17610 || kid->op_type == OP_STUB
17611 || kid->op_type == OP_ENTER
17612 || (PL_parser && PL_parser->error_count));
17613 nullop->op_next = kid->op_next;
17614 DEFER(nullop->op_next);
17617 /* check that RHS of sort is a single plain array */
17618 oright = cUNOPo->op_first;
17619 if (!oright || oright->op_type != OP_PUSHMARK)
17622 if (o->op_private & OPpSORT_INPLACE)
17625 /* reverse sort ... can be optimised. */
17626 if (!OpHAS_SIBLING(cUNOPo)) {
17627 /* Nothing follows us on the list. */
17628 OP * const reverse = o->op_next;
17630 if (reverse->op_type == OP_REVERSE &&
17631 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
17632 OP * const pushmark = cUNOPx(reverse)->op_first;
17633 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
17634 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
17635 /* reverse -> pushmark -> sort */
17636 o->op_private |= OPpSORT_REVERSE;
17638 pushmark->op_next = oright->op_next;
17648 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
17650 LISTOP *enter, *exlist;
17652 if (o->op_private & OPpSORT_INPLACE)
17655 enter = (LISTOP *) o->op_next;
17658 if (enter->op_type == OP_NULL) {
17659 enter = (LISTOP *) enter->op_next;
17663 /* for $a (...) will have OP_GV then OP_RV2GV here.
17664 for (...) just has an OP_GV. */
17665 if (enter->op_type == OP_GV) {
17666 gvop = (OP *) enter;
17667 enter = (LISTOP *) enter->op_next;
17670 if (enter->op_type == OP_RV2GV) {
17671 enter = (LISTOP *) enter->op_next;
17677 if (enter->op_type != OP_ENTERITER)
17680 iter = enter->op_next;
17681 if (!iter || iter->op_type != OP_ITER)
17684 expushmark = enter->op_first;
17685 if (!expushmark || expushmark->op_type != OP_NULL
17686 || expushmark->op_targ != OP_PUSHMARK)
17689 exlist = (LISTOP *) OpSIBLING(expushmark);
17690 if (!exlist || exlist->op_type != OP_NULL
17691 || exlist->op_targ != OP_LIST)
17694 if (exlist->op_last != o) {
17695 /* Mmm. Was expecting to point back to this op. */
17698 theirmark = exlist->op_first;
17699 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
17702 if (OpSIBLING(theirmark) != o) {
17703 /* There's something between the mark and the reverse, eg
17704 for (1, reverse (...))
17709 ourmark = ((LISTOP *)o)->op_first;
17710 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
17713 ourlast = ((LISTOP *)o)->op_last;
17714 if (!ourlast || ourlast->op_next != o)
17717 rv2av = OpSIBLING(ourmark);
17718 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
17719 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
17720 /* We're just reversing a single array. */
17721 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
17722 enter->op_flags |= OPf_STACKED;
17725 /* We don't have control over who points to theirmark, so sacrifice
17727 theirmark->op_next = ourmark->op_next;
17728 theirmark->op_flags = ourmark->op_flags;
17729 ourlast->op_next = gvop ? gvop : (OP *) enter;
17732 enter->op_private |= OPpITER_REVERSED;
17733 iter->op_private |= OPpITER_REVERSED;
17737 o = oldop->op_next;
17739 NOT_REACHED; /* NOTREACHED */
17745 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
17746 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
17751 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
17752 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
17755 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
17757 sv = newRV((SV *)PL_compcv);
17761 OpTYPE_set(o, OP_CONST);
17762 o->op_flags |= OPf_SPECIAL;
17763 cSVOPo->op_sv = sv;
17768 if (OP_GIMME(o,0) == G_VOID
17769 || ( o->op_next->op_type == OP_LINESEQ
17770 && ( o->op_next->op_next->op_type == OP_LEAVESUB
17771 || ( o->op_next->op_next->op_type == OP_RETURN
17772 && !CvLVALUE(PL_compcv)))))
17774 OP *right = cBINOP->op_first;
17793 OP *left = OpSIBLING(right);
17794 if (left->op_type == OP_SUBSTR
17795 && (left->op_private & 7) < 4) {
17797 /* cut out right */
17798 op_sibling_splice(o, NULL, 1, NULL);
17799 /* and insert it as second child of OP_SUBSTR */
17800 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
17802 left->op_private |= OPpSUBSTR_REPL_FIRST;
17804 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17811 int l, r, lr, lscalars, rscalars;
17813 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
17814 Note that we do this now rather than in newASSIGNOP(),
17815 since only by now are aliased lexicals flagged as such
17817 See the essay "Common vars in list assignment" above for
17818 the full details of the rationale behind all the conditions
17821 PL_generation sorcery:
17822 To detect whether there are common vars, the global var
17823 PL_generation is incremented for each assign op we scan.
17824 Then we run through all the lexical variables on the LHS,
17825 of the assignment, setting a spare slot in each of them to
17826 PL_generation. Then we scan the RHS, and if any lexicals
17827 already have that value, we know we've got commonality.
17828 Also, if the generation number is already set to
17829 PERL_INT_MAX, then the variable is involved in aliasing, so
17830 we also have potential commonality in that case.
17836 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
17839 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
17843 /* After looking for things which are *always* safe, this main
17844 * if/else chain selects primarily based on the type of the
17845 * LHS, gradually working its way down from the more dangerous
17846 * to the more restrictive and thus safer cases */
17848 if ( !l /* () = ....; */
17849 || !r /* .... = (); */
17850 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
17851 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
17852 || (lscalars < 2) /* ($x, undef) = ... */
17854 NOOP; /* always safe */
17856 else if (l & AAS_DANGEROUS) {
17857 /* always dangerous */
17858 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17859 o->op_private |= OPpASSIGN_COMMON_AGG;
17861 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
17862 /* package vars are always dangerous - too many
17863 * aliasing possibilities */
17864 if (l & AAS_PKG_SCALAR)
17865 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17866 if (l & AAS_PKG_AGG)
17867 o->op_private |= OPpASSIGN_COMMON_AGG;
17869 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
17870 |AAS_LEX_SCALAR|AAS_LEX_AGG))
17872 /* LHS contains only lexicals and safe ops */
17874 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
17875 o->op_private |= OPpASSIGN_COMMON_AGG;
17877 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
17878 if (lr & AAS_LEX_SCALAR_COMM)
17879 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17880 else if ( !(l & AAS_LEX_SCALAR)
17881 && (r & AAS_DEFAV))
17885 * as scalar-safe for performance reasons.
17886 * (it will still have been marked _AGG if necessary */
17889 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
17890 /* if there are only lexicals on the LHS and no
17891 * common ones on the RHS, then we assume that the
17892 * only way those lexicals could also get
17893 * on the RHS is via some sort of dereffing or
17896 * ($lex, $x) = (1, $$r)
17897 * and in this case we assume the var must have
17898 * a bumped ref count. So if its ref count is 1,
17899 * it must only be on the LHS.
17901 o->op_private |= OPpASSIGN_COMMON_RC1;
17906 * may have to handle aggregate on LHS, but we can't
17907 * have common scalars. */
17910 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
17912 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17913 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
17918 /* see if ref() is used in boolean context */
17919 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17920 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17924 /* see if the op is used in known boolean context,
17925 * but not if OA_TARGLEX optimisation is enabled */
17926 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17927 && !(o->op_private & OPpTARGET_MY)
17929 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17933 /* see if the op is used in known boolean context */
17934 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17935 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17939 Perl_cpeep_t cpeep =
17940 XopENTRYCUSTOM(o, xop_peep);
17942 cpeep(aTHX_ o, oldop);
17947 /* did we just null the current op? If so, re-process it to handle
17948 * eliding "empty" ops from the chain */
17949 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
17962 Perl_peep(pTHX_ OP *o)
17968 =head1 Custom Operators
17970 =for apidoc Perl_custom_op_xop
17971 Return the XOP structure for a given custom op. This macro should be
17972 considered internal to C<OP_NAME> and the other access macros: use them instead.
17973 This macro does call a function. Prior
17974 to 5.19.6, this was implemented as a
17981 /* use PERL_MAGIC_ext to call a function to free the xop structure when
17982 * freeing PL_custom_ops */
17985 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
17989 PERL_UNUSED_ARG(mg);
17990 xop = INT2PTR(XOP *, SvIV(sv));
17991 Safefree(xop->xop_name);
17992 Safefree(xop->xop_desc);
17998 static const MGVTBL custom_op_register_vtbl = {
18003 custom_op_register_free, /* free */
18013 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
18019 static const XOP xop_null = { 0, 0, 0, 0, 0 };
18021 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
18022 assert(o->op_type == OP_CUSTOM);
18024 /* This is wrong. It assumes a function pointer can be cast to IV,
18025 * which isn't guaranteed, but this is what the old custom OP code
18026 * did. In principle it should be safer to Copy the bytes of the
18027 * pointer into a PV: since the new interface is hidden behind
18028 * functions, this can be changed later if necessary. */
18029 /* Change custom_op_xop if this ever happens */
18030 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
18033 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18035 /* See if the op isn't registered, but its name *is* registered.
18036 * That implies someone is using the pre-5.14 API,where only name and
18037 * description could be registered. If so, fake up a real
18039 * We only check for an existing name, and assume no one will have
18040 * just registered a desc */
18041 if (!he && PL_custom_op_names &&
18042 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
18047 /* XXX does all this need to be shared mem? */
18048 Newxz(xop, 1, XOP);
18049 pv = SvPV(HeVAL(he), l);
18050 XopENTRY_set(xop, xop_name, savepvn(pv, l));
18051 if (PL_custom_op_descs &&
18052 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
18054 pv = SvPV(HeVAL(he), l);
18055 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
18057 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
18058 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18059 /* add magic to the SV so that the xop struct (pointed to by
18060 * SvIV(sv)) is freed. Normally a static xop is registered, but
18061 * for this backcompat hack, we've alloced one */
18062 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
18063 &custom_op_register_vtbl, NULL, 0);
18068 xop = (XOP *)&xop_null;
18070 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
18074 if(field == XOPe_xop_ptr) {
18077 const U32 flags = XopFLAGS(xop);
18078 if(flags & field) {
18080 case XOPe_xop_name:
18081 any.xop_name = xop->xop_name;
18083 case XOPe_xop_desc:
18084 any.xop_desc = xop->xop_desc;
18086 case XOPe_xop_class:
18087 any.xop_class = xop->xop_class;
18089 case XOPe_xop_peep:
18090 any.xop_peep = xop->xop_peep;
18093 NOT_REACHED; /* NOTREACHED */
18098 case XOPe_xop_name:
18099 any.xop_name = XOPd_xop_name;
18101 case XOPe_xop_desc:
18102 any.xop_desc = XOPd_xop_desc;
18104 case XOPe_xop_class:
18105 any.xop_class = XOPd_xop_class;
18107 case XOPe_xop_peep:
18108 any.xop_peep = XOPd_xop_peep;
18111 NOT_REACHED; /* NOTREACHED */
18116 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
18117 * op.c: In function 'Perl_custom_op_get_field':
18118 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
18119 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
18120 * expands to assert(0), which expands to ((0) ? (void)0 :
18121 * __assert(...)), and gcc doesn't know that __assert can never return. */
18127 =for apidoc custom_op_register
18128 Register a custom op. See L<perlguts/"Custom Operators">.
18134 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
18138 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
18140 /* see the comment in custom_op_xop */
18141 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
18143 if (!PL_custom_ops)
18144 PL_custom_ops = newHV();
18146 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
18147 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
18152 =for apidoc core_prototype
18154 This function assigns the prototype of the named core function to C<sv>, or
18155 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
18156 C<NULL> if the core function has no prototype. C<code> is a code as returned
18157 by C<keyword()>. It must not be equal to 0.
18163 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
18166 int i = 0, n = 0, seen_question = 0, defgv = 0;
18168 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
18169 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
18170 bool nullret = FALSE;
18172 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
18176 if (!sv) sv = sv_newmortal();
18178 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
18180 switch (code < 0 ? -code : code) {
18181 case KEY_and : case KEY_chop: case KEY_chomp:
18182 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
18183 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
18184 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
18185 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
18186 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
18187 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
18188 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
18189 case KEY_x : case KEY_xor :
18190 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
18191 case KEY_glob: retsetpvs("_;", OP_GLOB);
18192 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
18193 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
18194 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
18195 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
18196 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
18198 case KEY_evalbytes:
18199 name = "entereval"; break;
18207 while (i < MAXO) { /* The slow way. */
18208 if (strEQ(name, PL_op_name[i])
18209 || strEQ(name, PL_op_desc[i]))
18211 if (nullret) { assert(opnum); *opnum = i; return NULL; }
18218 defgv = PL_opargs[i] & OA_DEFGV;
18219 oa = PL_opargs[i] >> OASHIFT;
18221 if (oa & OA_OPTIONAL && !seen_question && (
18222 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
18227 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
18228 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
18229 /* But globs are already references (kinda) */
18230 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
18234 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
18235 && !scalar_mod_type(NULL, i)) {
18240 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
18244 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
18245 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
18246 str[n-1] = '_'; defgv = 0;
18250 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
18252 sv_setpvn(sv, str, n - 1);
18253 if (opnum) *opnum = i;
18258 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
18261 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
18262 newSVOP(OP_COREARGS,0,coreargssv);
18265 PERL_ARGS_ASSERT_CORESUB_OP;
18269 return op_append_elem(OP_LINESEQ,
18272 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
18279 o = newUNOP(OP_AVHVSWITCH,0,argop);
18280 o->op_private = opnum-OP_EACH;
18282 case OP_SELECT: /* which represents OP_SSELECT as well */
18287 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
18288 newSVOP(OP_CONST, 0, newSVuv(1))
18290 coresub_op(newSVuv((UV)OP_SSELECT), 0,
18292 coresub_op(coreargssv, 0, OP_SELECT)
18296 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
18298 return op_append_elem(
18301 opnum == OP_WANTARRAY || opnum == OP_RUNCV
18302 ? OPpOFFBYONE << 8 : 0)
18304 case OA_BASEOP_OR_UNOP:
18305 if (opnum == OP_ENTEREVAL) {
18306 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
18307 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
18309 else o = newUNOP(opnum,0,argop);
18310 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
18313 if (is_handle_constructor(o, 1))
18314 argop->op_private |= OPpCOREARGS_DEREF1;
18315 if (scalar_mod_type(NULL, opnum))
18316 argop->op_private |= OPpCOREARGS_SCALARMOD;
18320 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
18321 if (is_handle_constructor(o, 2))
18322 argop->op_private |= OPpCOREARGS_DEREF2;
18323 if (opnum == OP_SUBSTR) {
18324 o->op_private |= OPpMAYBE_LVSUB;
18333 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
18334 SV * const *new_const_svp)
18336 const char *hvname;
18337 bool is_const = !!CvCONST(old_cv);
18338 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
18340 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
18342 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
18344 /* They are 2 constant subroutines generated from
18345 the same constant. This probably means that
18346 they are really the "same" proxy subroutine
18347 instantiated in 2 places. Most likely this is
18348 when a constant is exported twice. Don't warn.
18351 (ckWARN(WARN_REDEFINE)
18353 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
18354 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
18355 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
18356 strEQ(hvname, "autouse"))
18360 && ckWARN_d(WARN_REDEFINE)
18361 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
18364 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
18366 ? "Constant subroutine %" SVf " redefined"
18367 : "Subroutine %" SVf " redefined",
18372 =head1 Hook manipulation
18374 These functions provide convenient and thread-safe means of manipulating
18381 =for apidoc wrap_op_checker
18383 Puts a C function into the chain of check functions for a specified op
18384 type. This is the preferred way to manipulate the L</PL_check> array.
18385 C<opcode> specifies which type of op is to be affected. C<new_checker>
18386 is a pointer to the C function that is to be added to that opcode's
18387 check chain, and C<old_checker_p> points to the storage location where a
18388 pointer to the next function in the chain will be stored. The value of
18389 C<new_checker> is written into the L</PL_check> array, while the value
18390 previously stored there is written to C<*old_checker_p>.
18392 L</PL_check> is global to an entire process, and a module wishing to
18393 hook op checking may find itself invoked more than once per process,
18394 typically in different threads. To handle that situation, this function
18395 is idempotent. The location C<*old_checker_p> must initially (once
18396 per process) contain a null pointer. A C variable of static duration
18397 (declared at file scope, typically also marked C<static> to give
18398 it internal linkage) will be implicitly initialised appropriately,
18399 if it does not have an explicit initialiser. This function will only
18400 actually modify the check chain if it finds C<*old_checker_p> to be null.
18401 This function is also thread safe on the small scale. It uses appropriate
18402 locking to avoid race conditions in accessing L</PL_check>.
18404 When this function is called, the function referenced by C<new_checker>
18405 must be ready to be called, except for C<*old_checker_p> being unfilled.
18406 In a threading situation, C<new_checker> may be called immediately,
18407 even before this function has returned. C<*old_checker_p> will always
18408 be appropriately set before C<new_checker> is called. If C<new_checker>
18409 decides not to do anything special with an op that it is given (which
18410 is the usual case for most uses of op check hooking), it must chain the
18411 check function referenced by C<*old_checker_p>.
18413 Taken all together, XS code to hook an op checker should typically look
18414 something like this:
18416 static Perl_check_t nxck_frob;
18417 static OP *myck_frob(pTHX_ OP *op) {
18419 op = nxck_frob(aTHX_ op);
18424 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
18426 If you want to influence compilation of calls to a specific subroutine,
18427 then use L</cv_set_call_checker_flags> rather than hooking checking of
18428 all C<entersub> ops.
18434 Perl_wrap_op_checker(pTHX_ Optype opcode,
18435 Perl_check_t new_checker, Perl_check_t *old_checker_p)
18438 PERL_UNUSED_CONTEXT;
18439 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
18440 if (*old_checker_p) return;
18441 OP_CHECK_MUTEX_LOCK;
18442 if (!*old_checker_p) {
18443 *old_checker_p = PL_check[opcode];
18444 PL_check[opcode] = new_checker;
18446 OP_CHECK_MUTEX_UNLOCK;
18451 /* Efficient sub that returns a constant scalar value. */
18453 const_sv_xsub(pTHX_ CV* cv)
18456 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
18457 PERL_UNUSED_ARG(items);
18467 const_av_xsub(pTHX_ CV* cv)
18470 AV * const av = MUTABLE_AV(XSANY.any_ptr);
18478 if (SvRMAGICAL(av))
18479 Perl_croak(aTHX_ "Magical list constants are not supported");
18480 if (GIMME_V != G_ARRAY) {
18482 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
18485 EXTEND(SP, AvFILLp(av)+1);
18486 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
18487 XSRETURN(AvFILLp(av)+1);
18490 /* Copy an existing cop->cop_warnings field.
18491 * If it's one of the standard addresses, just re-use the address.
18492 * This is the e implementation for the DUP_WARNINGS() macro
18496 Perl_dup_warnings(pTHX_ STRLEN* warnings)
18499 STRLEN *new_warnings;
18501 if (warnings == NULL || specialWARN(warnings))
18504 size = sizeof(*warnings) + *warnings;
18506 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
18507 Copy(warnings, new_warnings, size, char);
18508 return new_warnings;
18512 * ex: set ts=8 sts=4 sw=4 et: