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 =for apidoc_section $optree_manipulation
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)
1409 PERL_UNUSED_CONTEXT;
1414 Perl_op_refcnt_unlock(pTHX)
1415 PERL_TSA_RELEASE(PL_op_mutex)
1417 PERL_UNUSED_CONTEXT;
1423 =for apidoc op_sibling_splice
1425 A general function for editing the structure of an existing chain of
1426 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1427 you to delete zero or more sequential nodes, replacing them with zero or
1428 more different nodes. Performs the necessary op_first/op_last
1429 housekeeping on the parent node and op_sibling manipulation on the
1430 children. The last deleted node will be marked as the last node by
1431 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1433 Note that op_next is not manipulated, and nodes are not freed; that is the
1434 responsibility of the caller. It also won't create a new list op for an
1435 empty list etc; use higher-level functions like op_append_elem() for that.
1437 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1438 the splicing doesn't affect the first or last op in the chain.
1440 C<start> is the node preceding the first node to be spliced. Node(s)
1441 following it will be deleted, and ops will be inserted after it. If it is
1442 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1445 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1446 If -1 or greater than or equal to the number of remaining kids, all
1447 remaining kids are deleted.
1449 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1450 If C<NULL>, no nodes are inserted.
1452 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1457 action before after returns
1458 ------ ----- ----- -------
1461 splice(P, A, 2, X-Y-Z) | | B-C
1465 splice(P, NULL, 1, X-Y) | | A
1469 splice(P, NULL, 3, NULL) | | A-B-C
1473 splice(P, B, 0, X-Y) | | NULL
1477 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1478 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1484 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1488 OP *last_del = NULL;
1489 OP *last_ins = NULL;
1492 first = OpSIBLING(start);
1496 first = cLISTOPx(parent)->op_first;
1498 assert(del_count >= -1);
1500 if (del_count && first) {
1502 while (--del_count && OpHAS_SIBLING(last_del))
1503 last_del = OpSIBLING(last_del);
1504 rest = OpSIBLING(last_del);
1505 OpLASTSIB_set(last_del, NULL);
1512 while (OpHAS_SIBLING(last_ins))
1513 last_ins = OpSIBLING(last_ins);
1514 OpMAYBESIB_set(last_ins, rest, NULL);
1520 OpMAYBESIB_set(start, insert, NULL);
1524 cLISTOPx(parent)->op_first = insert;
1526 parent->op_flags |= OPf_KIDS;
1528 parent->op_flags &= ~OPf_KIDS;
1532 /* update op_last etc */
1539 /* ought to use OP_CLASS(parent) here, but that can't handle
1540 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1542 type = parent->op_type;
1543 if (type == OP_CUSTOM) {
1545 type = XopENTRYCUSTOM(parent, xop_class);
1548 if (type == OP_NULL)
1549 type = parent->op_targ;
1550 type = PL_opargs[type] & OA_CLASS_MASK;
1553 lastop = last_ins ? last_ins : start ? start : NULL;
1554 if ( type == OA_BINOP
1555 || type == OA_LISTOP
1559 cLISTOPx(parent)->op_last = lastop;
1562 OpLASTSIB_set(lastop, parent);
1564 return last_del ? first : NULL;
1567 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1571 =for apidoc op_parent
1573 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1579 Perl_op_parent(OP *o)
1581 PERL_ARGS_ASSERT_OP_PARENT;
1582 while (OpHAS_SIBLING(o))
1584 return o->op_sibparent;
1587 /* replace the sibling following start with a new UNOP, which becomes
1588 * the parent of the original sibling; e.g.
1590 * op_sibling_newUNOP(P, A, unop-args...)
1598 * where U is the new UNOP.
1600 * parent and start args are the same as for op_sibling_splice();
1601 * type and flags args are as newUNOP().
1603 * Returns the new UNOP.
1607 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1611 kid = op_sibling_splice(parent, start, 1, NULL);
1612 newop = newUNOP(type, flags, kid);
1613 op_sibling_splice(parent, start, 0, newop);
1618 /* lowest-level newLOGOP-style function - just allocates and populates
1619 * the struct. Higher-level stuff should be done by S_new_logop() /
1620 * newLOGOP(). This function exists mainly to avoid op_first assignment
1621 * being spread throughout this file.
1625 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1629 NewOp(1101, logop, 1, LOGOP);
1630 OpTYPE_set(logop, type);
1631 logop->op_first = first;
1632 logop->op_other = other;
1634 logop->op_flags = OPf_KIDS;
1635 while (kid && OpHAS_SIBLING(kid))
1636 kid = OpSIBLING(kid);
1638 OpLASTSIB_set(kid, (OP*)logop);
1643 /* Contextualizers */
1646 =for apidoc op_contextualize
1648 Applies a syntactic context to an op tree representing an expression.
1649 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1650 or C<G_VOID> to specify the context to apply. The modified op tree
1657 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1659 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1661 case G_SCALAR: return scalar(o);
1662 case G_ARRAY: return list(o);
1663 case G_VOID: return scalarvoid(o);
1665 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1672 =for apidoc op_linklist
1673 This function is the implementation of the L</LINKLIST> macro. It should
1674 not be called directly.
1681 Perl_op_linklist(pTHX_ OP *o)
1688 PERL_ARGS_ASSERT_OP_LINKLIST;
1691 /* Descend down the tree looking for any unprocessed subtrees to
1694 if (o->op_flags & OPf_KIDS) {
1695 o = cUNOPo->op_first;
1698 o->op_next = o; /* leaf node; link to self initially */
1701 /* if we're at the top level, there either weren't any children
1702 * to process, or we've worked our way back to the top. */
1706 /* o is now processed. Next, process any sibling subtrees */
1708 if (OpHAS_SIBLING(o)) {
1713 /* Done all the subtrees at this level. Go back up a level and
1714 * link the parent in with all its (processed) children.
1717 o = o->op_sibparent;
1718 assert(!o->op_next);
1719 prevp = &(o->op_next);
1720 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1722 *prevp = kid->op_next;
1723 prevp = &(kid->op_next);
1724 kid = OpSIBLING(kid);
1732 S_scalarkids(pTHX_ OP *o)
1734 if (o && o->op_flags & OPf_KIDS) {
1736 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1743 S_scalarboolean(pTHX_ OP *o)
1745 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1747 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1748 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1749 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1750 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1751 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1752 if (ckWARN(WARN_SYNTAX)) {
1753 const line_t oldline = CopLINE(PL_curcop);
1755 if (PL_parser && PL_parser->copline != NOLINE) {
1756 /* This ensures that warnings are reported at the first line
1757 of the conditional, not the last. */
1758 CopLINE_set(PL_curcop, PL_parser->copline);
1760 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1761 CopLINE_set(PL_curcop, oldline);
1768 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1771 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1772 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1774 const char funny = o->op_type == OP_PADAV
1775 || o->op_type == OP_RV2AV ? '@' : '%';
1776 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1778 if (cUNOPo->op_first->op_type != OP_GV
1779 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1781 return varname(gv, funny, 0, NULL, 0, subscript_type);
1784 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1789 S_op_varname(pTHX_ const OP *o)
1791 return S_op_varname_subscript(aTHX_ o, 1);
1795 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1796 { /* or not so pretty :-) */
1797 if (o->op_type == OP_CONST) {
1799 if (SvPOK(*retsv)) {
1801 *retsv = sv_newmortal();
1802 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1803 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1805 else if (!SvOK(*retsv))
1808 else *retpv = "...";
1812 S_scalar_slice_warning(pTHX_ const OP *o)
1815 const bool h = o->op_type == OP_HSLICE
1816 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1822 SV *keysv = NULL; /* just to silence compiler warnings */
1823 const char *key = NULL;
1825 if (!(o->op_private & OPpSLICEWARNING))
1827 if (PL_parser && PL_parser->error_count)
1828 /* This warning can be nonsensical when there is a syntax error. */
1831 kid = cLISTOPo->op_first;
1832 kid = OpSIBLING(kid); /* get past pushmark */
1833 /* weed out false positives: any ops that can return lists */
1834 switch (kid->op_type) {
1860 /* Don't warn if we have a nulled list either. */
1861 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1864 assert(OpSIBLING(kid));
1865 name = S_op_varname(aTHX_ OpSIBLING(kid));
1866 if (!name) /* XS module fiddling with the op tree */
1868 S_op_pretty(aTHX_ kid, &keysv, &key);
1869 assert(SvPOK(name));
1870 sv_chop(name,SvPVX(name)+1);
1872 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1873 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1874 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1876 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1877 lbrack, key, rbrack);
1879 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1880 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1881 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1883 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1884 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1889 /* apply scalar context to the o subtree */
1892 Perl_scalar(pTHX_ OP *o)
1897 OP *next_kid = NULL; /* what op (if any) to process next */
1900 /* assumes no premature commitment */
1901 if (!o || (PL_parser && PL_parser->error_count)
1902 || (o->op_flags & OPf_WANT)
1903 || o->op_type == OP_RETURN)
1908 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1910 switch (o->op_type) {
1912 scalar(cBINOPo->op_first);
1913 /* convert what initially looked like a list repeat into a
1914 * scalar repeat, e.g. $s = (1) x $n
1916 if (o->op_private & OPpREPEAT_DOLIST) {
1917 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1918 assert(kid->op_type == OP_PUSHMARK);
1919 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1920 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1921 o->op_private &=~ OPpREPEAT_DOLIST;
1929 /* impose scalar context on everything except the condition */
1930 next_kid = OpSIBLING(cUNOPo->op_first);
1934 if (o->op_flags & OPf_KIDS)
1935 next_kid = cUNOPo->op_first; /* do all kids */
1938 /* the children of these ops are usually a list of statements,
1939 * except the leaves, whose first child is a corresponding enter
1944 kid = cLISTOPo->op_first;
1948 kid = cLISTOPo->op_first;
1950 kid = OpSIBLING(kid);
1953 OP *sib = OpSIBLING(kid);
1954 /* Apply void context to all kids except the last, which
1955 * is scalar (ignoring a trailing ex-nextstate in determining
1956 * if it's the last kid). E.g.
1957 * $scalar = do { void; void; scalar }
1958 * Except that 'when's are always scalar, e.g.
1959 * $scalar = do { given(..) {
1960 * when (..) { scalar }
1961 * when (..) { scalar }
1966 || ( !OpHAS_SIBLING(sib)
1967 && sib->op_type == OP_NULL
1968 && ( sib->op_targ == OP_NEXTSTATE
1969 || sib->op_targ == OP_DBSTATE )
1973 /* tail call optimise calling scalar() on the last kid */
1977 else if (kid->op_type == OP_LEAVEWHEN)
1983 NOT_REACHED; /* NOTREACHED */
1987 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1993 /* Warn about scalar context */
1994 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1995 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1998 const char *key = NULL;
2000 /* This warning can be nonsensical when there is a syntax error. */
2001 if (PL_parser && PL_parser->error_count)
2004 if (!ckWARN(WARN_SYNTAX)) break;
2006 kid = cLISTOPo->op_first;
2007 kid = OpSIBLING(kid); /* get past pushmark */
2008 assert(OpSIBLING(kid));
2009 name = S_op_varname(aTHX_ OpSIBLING(kid));
2010 if (!name) /* XS module fiddling with the op tree */
2012 S_op_pretty(aTHX_ kid, &keysv, &key);
2013 assert(SvPOK(name));
2014 sv_chop(name,SvPVX(name)+1);
2016 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2017 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2018 "%%%" SVf "%c%s%c in scalar context better written "
2019 "as $%" SVf "%c%s%c",
2020 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
2021 lbrack, key, rbrack);
2023 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2024 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2025 "%%%" SVf "%c%" SVf "%c in scalar context better "
2026 "written as $%" SVf "%c%" SVf "%c",
2027 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
2028 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2032 /* If next_kid is set, someone in the code above wanted us to process
2033 * that kid and all its remaining siblings. Otherwise, work our way
2034 * back up the tree */
2038 return top_op; /* at top; no parents/siblings to try */
2039 if (OpHAS_SIBLING(o))
2040 next_kid = o->op_sibparent;
2042 o = o->op_sibparent; /*try parent's next sibling */
2043 switch (o->op_type) {
2049 /* should really restore PL_curcop to its old value, but
2050 * setting it to PL_compiling is better than do nothing */
2051 PL_curcop = &PL_compiling;
2060 /* apply void context to the optree arg */
2063 Perl_scalarvoid(pTHX_ OP *arg)
2069 PERL_ARGS_ASSERT_SCALARVOID;
2073 SV *useless_sv = NULL;
2074 const char* useless = NULL;
2075 OP * next_kid = NULL;
2077 if (o->op_type == OP_NEXTSTATE
2078 || o->op_type == OP_DBSTATE
2079 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2080 || o->op_targ == OP_DBSTATE)))
2081 PL_curcop = (COP*)o; /* for warning below */
2083 /* assumes no premature commitment */
2084 want = o->op_flags & OPf_WANT;
2085 if ((want && want != OPf_WANT_SCALAR)
2086 || (PL_parser && PL_parser->error_count)
2087 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2092 if ((o->op_private & OPpTARGET_MY)
2093 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2095 /* newASSIGNOP has already applied scalar context, which we
2096 leave, as if this op is inside SASSIGN. */
2100 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2102 switch (o->op_type) {
2104 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2108 if (o->op_flags & OPf_STACKED)
2110 if (o->op_type == OP_REPEAT)
2111 scalar(cBINOPo->op_first);
2114 if ((o->op_flags & OPf_STACKED) &&
2115 !(o->op_private & OPpCONCAT_NESTED))
2119 if (o->op_private == 4)
2154 case OP_GETSOCKNAME:
2155 case OP_GETPEERNAME:
2160 case OP_GETPRIORITY:
2185 useless = OP_DESC(o);
2195 case OP_AELEMFAST_LEX:
2199 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2200 /* Otherwise it's "Useless use of grep iterator" */
2201 useless = OP_DESC(o);
2205 if (!(o->op_private & OPpSPLIT_ASSIGN))
2206 useless = OP_DESC(o);
2210 kid = cUNOPo->op_first;
2211 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2212 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2215 useless = "negative pattern binding (!~)";
2219 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2220 useless = "non-destructive substitution (s///r)";
2224 useless = "non-destructive transliteration (tr///r)";
2231 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2232 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2233 useless = "a variable";
2238 if (cSVOPo->op_private & OPpCONST_STRICT)
2239 no_bareword_allowed(o);
2241 if (ckWARN(WARN_VOID)) {
2243 /* don't warn on optimised away booleans, eg
2244 * use constant Foo, 5; Foo || print; */
2245 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2247 /* the constants 0 and 1 are permitted as they are
2248 conventionally used as dummies in constructs like
2249 1 while some_condition_with_side_effects; */
2250 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2252 else if (SvPOK(sv)) {
2253 SV * const dsv = newSVpvs("");
2255 = Perl_newSVpvf(aTHX_
2257 pv_pretty(dsv, SvPVX_const(sv),
2258 SvCUR(sv), 32, NULL, NULL,
2260 | PERL_PV_ESCAPE_NOCLEAR
2261 | PERL_PV_ESCAPE_UNI_DETECT));
2262 SvREFCNT_dec_NN(dsv);
2264 else if (SvOK(sv)) {
2265 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2268 useless = "a constant (undef)";
2271 op_null(o); /* don't execute or even remember it */
2275 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2279 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2283 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2287 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2292 UNOP *refgen, *rv2cv;
2295 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2298 rv2gv = ((BINOP *)o)->op_last;
2299 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2302 refgen = (UNOP *)((BINOP *)o)->op_first;
2304 if (!refgen || (refgen->op_type != OP_REFGEN
2305 && refgen->op_type != OP_SREFGEN))
2308 exlist = (LISTOP *)refgen->op_first;
2309 if (!exlist || exlist->op_type != OP_NULL
2310 || exlist->op_targ != OP_LIST)
2313 if (exlist->op_first->op_type != OP_PUSHMARK
2314 && exlist->op_first != exlist->op_last)
2317 rv2cv = (UNOP*)exlist->op_last;
2319 if (rv2cv->op_type != OP_RV2CV)
2322 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2323 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2324 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2326 o->op_private |= OPpASSIGN_CV_TO_GV;
2327 rv2gv->op_private |= OPpDONT_INIT_GV;
2328 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2340 kid = cLOGOPo->op_first;
2341 if (kid->op_type == OP_NOT
2342 && (kid->op_flags & OPf_KIDS)) {
2343 if (o->op_type == OP_AND) {
2344 OpTYPE_set(o, OP_OR);
2346 OpTYPE_set(o, OP_AND);
2356 next_kid = OpSIBLING(cUNOPo->op_first);
2360 if (o->op_flags & OPf_STACKED)
2367 if (!(o->op_flags & OPf_KIDS))
2378 next_kid = cLISTOPo->op_first;
2381 /* If the first kid after pushmark is something that the padrange
2382 optimisation would reject, then null the list and the pushmark.
2384 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2385 && ( !(kid = OpSIBLING(kid))
2386 || ( kid->op_type != OP_PADSV
2387 && kid->op_type != OP_PADAV
2388 && kid->op_type != OP_PADHV)
2389 || kid->op_private & ~OPpLVAL_INTRO
2390 || !(kid = OpSIBLING(kid))
2391 || ( kid->op_type != OP_PADSV
2392 && kid->op_type != OP_PADAV
2393 && kid->op_type != OP_PADHV)
2394 || kid->op_private & ~OPpLVAL_INTRO)
2396 op_null(cUNOPo->op_first); /* NULL the pushmark */
2397 op_null(o); /* NULL the list */
2409 /* mortalise it, in case warnings are fatal. */
2410 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2411 "Useless use of %" SVf " in void context",
2412 SVfARG(sv_2mortal(useless_sv)));
2415 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2416 "Useless use of %s in void context",
2421 /* if a kid hasn't been nominated to process, continue with the
2422 * next sibling, or if no siblings left, go back to the parent's
2423 * siblings and so on
2427 return arg; /* at top; no parents/siblings to try */
2428 if (OpHAS_SIBLING(o))
2429 next_kid = o->op_sibparent;
2431 o = o->op_sibparent; /*try parent's next sibling */
2441 S_listkids(pTHX_ OP *o)
2443 if (o && o->op_flags & OPf_KIDS) {
2445 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2452 /* apply list context to the o subtree */
2455 Perl_list(pTHX_ OP *o)
2460 OP *next_kid = NULL; /* what op (if any) to process next */
2464 /* assumes no premature commitment */
2465 if (!o || (o->op_flags & OPf_WANT)
2466 || (PL_parser && PL_parser->error_count)
2467 || o->op_type == OP_RETURN)
2472 if ((o->op_private & OPpTARGET_MY)
2473 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2475 goto do_next; /* As if inside SASSIGN */
2478 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2480 switch (o->op_type) {
2482 if (o->op_private & OPpREPEAT_DOLIST
2483 && !(o->op_flags & OPf_STACKED))
2485 list(cBINOPo->op_first);
2486 kid = cBINOPo->op_last;
2487 /* optimise away (.....) x 1 */
2488 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2489 && SvIVX(kSVOP_sv) == 1)
2491 op_null(o); /* repeat */
2492 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2494 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2502 /* impose list context on everything except the condition */
2503 next_kid = OpSIBLING(cUNOPo->op_first);
2507 if (!(o->op_flags & OPf_KIDS))
2509 /* possibly flatten 1..10 into a constant array */
2510 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2511 list(cBINOPo->op_first);
2512 gen_constant_list(o);
2515 next_kid = cUNOPo->op_first; /* do all kids */
2519 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2520 op_null(cUNOPo->op_first); /* NULL the pushmark */
2521 op_null(o); /* NULL the list */
2523 if (o->op_flags & OPf_KIDS)
2524 next_kid = cUNOPo->op_first; /* do all kids */
2527 /* the children of these ops are usually a list of statements,
2528 * except the leaves, whose first child is a corresponding enter
2532 kid = cLISTOPo->op_first;
2536 kid = cLISTOPo->op_first;
2538 kid = OpSIBLING(kid);
2541 OP *sib = OpSIBLING(kid);
2542 /* Apply void context to all kids except the last, which
2544 * @a = do { void; void; list }
2545 * Except that 'when's are always list context, e.g.
2546 * @a = do { given(..) {
2547 * when (..) { list }
2548 * when (..) { list }
2553 /* tail call optimise calling list() on the last kid */
2557 else if (kid->op_type == OP_LEAVEWHEN)
2563 NOT_REACHED; /* NOTREACHED */
2568 /* If next_kid is set, someone in the code above wanted us to process
2569 * that kid and all its remaining siblings. Otherwise, work our way
2570 * back up the tree */
2574 return top_op; /* at top; no parents/siblings to try */
2575 if (OpHAS_SIBLING(o))
2576 next_kid = o->op_sibparent;
2578 o = o->op_sibparent; /*try parent's next sibling */
2579 switch (o->op_type) {
2585 /* should really restore PL_curcop to its old value, but
2586 * setting it to PL_compiling is better than do nothing */
2587 PL_curcop = &PL_compiling;
2599 S_scalarseq(pTHX_ OP *o)
2602 const OPCODE type = o->op_type;
2604 if (type == OP_LINESEQ || type == OP_SCOPE ||
2605 type == OP_LEAVE || type == OP_LEAVETRY)
2608 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2609 if ((sib = OpSIBLING(kid))
2610 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2611 || ( sib->op_targ != OP_NEXTSTATE
2612 && sib->op_targ != OP_DBSTATE )))
2617 PL_curcop = &PL_compiling;
2619 o->op_flags &= ~OPf_PARENS;
2620 if (PL_hints & HINT_BLOCK_SCOPE)
2621 o->op_flags |= OPf_PARENS;
2624 o = newOP(OP_STUB, 0);
2629 S_modkids(pTHX_ OP *o, I32 type)
2631 if (o && o->op_flags & OPf_KIDS) {
2633 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2634 op_lvalue(kid, type);
2640 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2641 * const fields. Also, convert CONST keys to HEK-in-SVs.
2642 * rop is the op that retrieves the hash;
2643 * key_op is the first key
2644 * real if false, only check (and possibly croak); don't update op
2648 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2654 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2656 if (rop->op_first->op_type == OP_PADSV)
2657 /* @$hash{qw(keys here)} */
2658 rop = (UNOP*)rop->op_first;
2660 /* @{$hash}{qw(keys here)} */
2661 if (rop->op_first->op_type == OP_SCOPE
2662 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2664 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2671 lexname = NULL; /* just to silence compiler warnings */
2672 fields = NULL; /* just to silence compiler warnings */
2676 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2677 SvPAD_TYPED(lexname))
2678 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2679 && isGV(*fields) && GvHV(*fields);
2681 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2683 if (key_op->op_type != OP_CONST)
2685 svp = cSVOPx_svp(key_op);
2687 /* make sure it's not a bareword under strict subs */
2688 if (key_op->op_private & OPpCONST_BARE &&
2689 key_op->op_private & OPpCONST_STRICT)
2691 no_bareword_allowed((OP*)key_op);
2694 /* Make the CONST have a shared SV */
2695 if ( !SvIsCOW_shared_hash(sv = *svp)
2696 && SvTYPE(sv) < SVt_PVMG
2702 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2703 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2704 SvREFCNT_dec_NN(sv);
2709 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2711 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2712 "in variable %" PNf " of type %" HEKf,
2713 SVfARG(*svp), PNfARG(lexname),
2714 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2719 /* info returned by S_sprintf_is_multiconcatable() */
2721 struct sprintf_ismc_info {
2722 SSize_t nargs; /* num of args to sprintf (not including the format) */
2723 char *start; /* start of raw format string */
2724 char *end; /* bytes after end of raw format string */
2725 STRLEN total_len; /* total length (in bytes) of format string, not
2726 including '%s' and half of '%%' */
2727 STRLEN variant; /* number of bytes by which total_len_p would grow
2728 if upgraded to utf8 */
2729 bool utf8; /* whether the format is utf8 */
2733 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2734 * i.e. its format argument is a const string with only '%s' and '%%'
2735 * formats, and the number of args is known, e.g.
2736 * sprintf "a=%s f=%s", $a[0], scalar(f());
2738 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2740 * If successful, the sprintf_ismc_info struct pointed to by info will be
2745 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2747 OP *pm, *constop, *kid;
2750 SSize_t nargs, nformats;
2751 STRLEN cur, total_len, variant;
2754 /* if sprintf's behaviour changes, die here so that someone
2755 * can decide whether to enhance this function or skip optimising
2756 * under those new circumstances */
2757 assert(!(o->op_flags & OPf_STACKED));
2758 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2759 assert(!(o->op_private & ~OPpARG4_MASK));
2761 pm = cUNOPo->op_first;
2762 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2764 constop = OpSIBLING(pm);
2765 if (!constop || constop->op_type != OP_CONST)
2767 sv = cSVOPx_sv(constop);
2768 if (SvMAGICAL(sv) || !SvPOK(sv))
2774 /* Scan format for %% and %s and work out how many %s there are.
2775 * Abandon if other format types are found.
2782 for (p = s; p < e; p++) {
2785 if (!UTF8_IS_INVARIANT(*p))
2791 return FALSE; /* lone % at end gives "Invalid conversion" */
2800 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2803 utf8 = cBOOL(SvUTF8(sv));
2807 /* scan args; they must all be in scalar cxt */
2810 kid = OpSIBLING(constop);
2813 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2816 kid = OpSIBLING(kid);
2819 if (nargs != nformats)
2820 return FALSE; /* e.g. sprintf("%s%s", $a); */
2823 info->nargs = nargs;
2826 info->total_len = total_len;
2827 info->variant = variant;
2835 /* S_maybe_multiconcat():
2837 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2838 * convert it (and its children) into an OP_MULTICONCAT. See the code
2839 * comments just before pp_multiconcat() for the full details of what
2840 * OP_MULTICONCAT supports.
2842 * Basically we're looking for an optree with a chain of OP_CONCATS down
2843 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2844 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2852 * STRINGIFY -- PADSV[$x]
2855 * ex-PUSHMARK -- CONCAT/S
2857 * CONCAT/S -- PADSV[$d]
2859 * CONCAT -- CONST["-"]
2861 * PADSV[$a] -- PADSV[$b]
2863 * Note that at this stage the OP_SASSIGN may have already been optimised
2864 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2868 S_maybe_multiconcat(pTHX_ OP *o)
2870 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2871 OP *topop; /* the top-most op in the concat tree (often equals o,
2872 unless there are assign/stringify ops above it */
2873 OP *parentop; /* the parent op of topop (or itself if no parent) */
2874 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2875 OP *targetop; /* the op corresponding to target=... or target.=... */
2876 OP *stringop; /* the OP_STRINGIFY op, if any */
2877 OP *nextop; /* used for recreating the op_next chain without consts */
2878 OP *kid; /* general-purpose op pointer */
2880 UNOP_AUX_item *lenp;
2881 char *const_str, *p;
2882 struct sprintf_ismc_info sprintf_info;
2884 /* store info about each arg in args[];
2885 * toparg is the highest used slot; argp is a general
2886 * pointer to args[] slots */
2888 void *p; /* initially points to const sv (or null for op);
2889 later, set to SvPV(constsv), with ... */
2890 STRLEN len; /* ... len set to SvPV(..., len) */
2891 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2895 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2898 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2899 the last-processed arg will the LHS of one,
2900 as args are processed in reverse order */
2901 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2902 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2903 U8 flags = 0; /* what will become the op_flags and ... */
2904 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2905 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2906 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2907 bool prev_was_const = FALSE; /* previous arg was a const */
2909 /* -----------------------------------------------------------------
2912 * Examine the optree non-destructively to determine whether it's
2913 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2914 * information about the optree in args[].
2924 assert( o->op_type == OP_SASSIGN
2925 || o->op_type == OP_CONCAT
2926 || o->op_type == OP_SPRINTF
2927 || o->op_type == OP_STRINGIFY);
2929 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2931 /* first see if, at the top of the tree, there is an assign,
2932 * append and/or stringify */
2934 if (topop->op_type == OP_SASSIGN) {
2936 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2938 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2940 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2943 topop = cBINOPo->op_first;
2944 targetop = OpSIBLING(topop);
2945 if (!targetop) /* probably some sort of syntax error */
2948 /* don't optimise away assign in 'local $foo = ....' */
2949 if ( (targetop->op_private & OPpLVAL_INTRO)
2950 /* these are the common ops which do 'local', but
2952 && ( targetop->op_type == OP_GVSV
2953 || targetop->op_type == OP_RV2SV
2954 || targetop->op_type == OP_AELEM
2955 || targetop->op_type == OP_HELEM
2960 else if ( topop->op_type == OP_CONCAT
2961 && (topop->op_flags & OPf_STACKED)
2962 && (!(topop->op_private & OPpCONCAT_NESTED))
2967 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2968 * decide what to do about it */
2969 assert(!(o->op_private & OPpTARGET_MY));
2971 /* barf on unknown flags */
2972 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2973 private_flags |= OPpMULTICONCAT_APPEND;
2974 targetop = cBINOPo->op_first;
2976 topop = OpSIBLING(targetop);
2978 /* $x .= <FOO> gets optimised to rcatline instead */
2979 if (topop->op_type == OP_READLINE)
2984 /* Can targetop (the LHS) if it's a padsv, be optimised
2985 * away and use OPpTARGET_MY instead?
2987 if ( (targetop->op_type == OP_PADSV)
2988 && !(targetop->op_private & OPpDEREF)
2989 && !(targetop->op_private & OPpPAD_STATE)
2990 /* we don't support 'my $x .= ...' */
2991 && ( o->op_type == OP_SASSIGN
2992 || !(targetop->op_private & OPpLVAL_INTRO))
2997 if (topop->op_type == OP_STRINGIFY) {
2998 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
3002 /* barf on unknown flags */
3003 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
3005 if ((topop->op_private & OPpTARGET_MY)) {
3006 if (o->op_type == OP_SASSIGN)
3007 return; /* can't have two assigns */
3011 private_flags |= OPpMULTICONCAT_STRINGIFY;
3013 topop = cBINOPx(topop)->op_first;
3014 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
3015 topop = OpSIBLING(topop);
3018 if (topop->op_type == OP_SPRINTF) {
3019 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
3021 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
3022 nargs = sprintf_info.nargs;
3023 total_len = sprintf_info.total_len;
3024 variant = sprintf_info.variant;
3025 utf8 = sprintf_info.utf8;
3027 private_flags |= OPpMULTICONCAT_FAKE;
3029 /* we have an sprintf op rather than a concat optree.
3030 * Skip most of the code below which is associated with
3031 * processing that optree. We also skip phase 2, determining
3032 * whether its cost effective to optimise, since for sprintf,
3033 * multiconcat is *always* faster */
3036 /* note that even if the sprintf itself isn't multiconcatable,
3037 * the expression as a whole may be, e.g. in
3038 * $x .= sprintf("%d",...)
3039 * the sprintf op will be left as-is, but the concat/S op may
3040 * be upgraded to multiconcat
3043 else if (topop->op_type == OP_CONCAT) {
3044 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
3047 if ((topop->op_private & OPpTARGET_MY)) {
3048 if (o->op_type == OP_SASSIGN || targmyop)
3049 return; /* can't have two assigns */
3054 /* Is it safe to convert a sassign/stringify/concat op into
3056 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
3057 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
3058 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3059 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
3060 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
3061 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3062 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
3063 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3065 /* Now scan the down the tree looking for a series of
3066 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3067 * stacked). For example this tree:
3072 * CONCAT/STACKED -- EXPR5
3074 * CONCAT/STACKED -- EXPR4
3080 * corresponds to an expression like
3082 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3084 * Record info about each EXPR in args[]: in particular, whether it is
3085 * a stringifiable OP_CONST and if so what the const sv is.
3087 * The reason why the last concat can't be STACKED is the difference
3090 * ((($a .= $a) .= $a) .= $a) .= $a
3093 * $a . $a . $a . $a . $a
3095 * The main difference between the optrees for those two constructs
3096 * is the presence of the last STACKED. As well as modifying $a,
3097 * the former sees the changed $a between each concat, so if $s is
3098 * initially 'a', the first returns 'a' x 16, while the latter returns
3099 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3109 if ( kid->op_type == OP_CONCAT
3113 k1 = cUNOPx(kid)->op_first;
3115 /* shouldn't happen except maybe after compile err? */
3119 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3120 if (kid->op_private & OPpTARGET_MY)
3123 stacked_last = (kid->op_flags & OPf_STACKED);
3135 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3136 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3138 /* At least two spare slots are needed to decompose both
3139 * concat args. If there are no slots left, continue to
3140 * examine the rest of the optree, but don't push new values
3141 * on args[]. If the optree as a whole is legal for conversion
3142 * (in particular that the last concat isn't STACKED), then
3143 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3144 * can be converted into an OP_MULTICONCAT now, with the first
3145 * child of that op being the remainder of the optree -
3146 * which may itself later be converted to a multiconcat op
3150 /* the last arg is the rest of the optree */
3155 else if ( argop->op_type == OP_CONST
3156 && ((sv = cSVOPx_sv(argop)))
3157 /* defer stringification until runtime of 'constant'
3158 * things that might stringify variantly, e.g. the radix
3159 * point of NVs, or overloaded RVs */
3160 && (SvPOK(sv) || SvIOK(sv))
3161 && (!SvGMAGICAL(sv))
3163 if (argop->op_private & OPpCONST_STRICT)
3164 no_bareword_allowed(argop);
3166 utf8 |= cBOOL(SvUTF8(sv));
3169 /* this const may be demoted back to a plain arg later;
3170 * make sure we have enough arg slots left */
3172 prev_was_const = !prev_was_const;
3177 prev_was_const = FALSE;
3187 return; /* we don't support ((A.=B).=C)...) */
3189 /* look for two adjacent consts and don't fold them together:
3192 * $o->concat("a")->concat("b")
3195 * (but $o .= "a" . "b" should still fold)
3198 bool seen_nonconst = FALSE;
3199 for (argp = toparg; argp >= args; argp--) {
3200 if (argp->p == NULL) {
3201 seen_nonconst = TRUE;
3207 /* both previous and current arg were constants;
3208 * leave the current OP_CONST as-is */
3216 /* -----------------------------------------------------------------
3219 * At this point we have determined that the optree *can* be converted
3220 * into a multiconcat. Having gathered all the evidence, we now decide
3221 * whether it *should*.
3225 /* we need at least one concat action, e.g.:
3231 * otherwise we could be doing something like $x = "foo", which
3232 * if treated as a concat, would fail to COW.
3234 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3237 /* Benchmarking seems to indicate that we gain if:
3238 * * we optimise at least two actions into a single multiconcat
3239 * (e.g concat+concat, sassign+concat);
3240 * * or if we can eliminate at least 1 OP_CONST;
3241 * * or if we can eliminate a padsv via OPpTARGET_MY
3245 /* eliminated at least one OP_CONST */
3247 /* eliminated an OP_SASSIGN */
3248 || o->op_type == OP_SASSIGN
3249 /* eliminated an OP_PADSV */
3250 || (!targmyop && is_targable)
3252 /* definitely a net gain to optimise */
3255 /* ... if not, what else? */
3257 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3258 * multiconcat is faster (due to not creating a temporary copy of
3259 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3265 && topop->op_type == OP_CONCAT
3267 PADOFFSET t = targmyop->op_targ;
3268 OP *k1 = cBINOPx(topop)->op_first;
3269 OP *k2 = cBINOPx(topop)->op_last;
3270 if ( k2->op_type == OP_PADSV
3272 && ( k1->op_type != OP_PADSV
3273 || k1->op_targ != t)
3278 /* need at least two concats */
3279 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3284 /* -----------------------------------------------------------------
3287 * At this point the optree has been verified as ok to be optimised
3288 * into an OP_MULTICONCAT. Now start changing things.
3293 /* stringify all const args and determine utf8ness */
3296 for (argp = args; argp <= toparg; argp++) {
3297 SV *sv = (SV*)argp->p;
3299 continue; /* not a const op */
3300 if (utf8 && !SvUTF8(sv))
3301 sv_utf8_upgrade_nomg(sv);
3302 argp->p = SvPV_nomg(sv, argp->len);
3303 total_len += argp->len;
3305 /* see if any strings would grow if converted to utf8 */
3307 variant += variant_under_utf8_count((U8 *) argp->p,
3308 (U8 *) argp->p + argp->len);
3312 /* create and populate aux struct */
3316 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3317 sizeof(UNOP_AUX_item)
3319 PERL_MULTICONCAT_HEADER_SIZE
3320 + ((nargs + 1) * (variant ? 2 : 1))
3323 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3325 /* Extract all the non-const expressions from the concat tree then
3326 * dispose of the old tree, e.g. convert the tree from this:
3330 * STRINGIFY -- TARGET
3332 * ex-PUSHMARK -- CONCAT
3347 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3349 * except that if EXPRi is an OP_CONST, it's discarded.
3351 * During the conversion process, EXPR ops are stripped from the tree
3352 * and unshifted onto o. Finally, any of o's remaining original
3353 * childen are discarded and o is converted into an OP_MULTICONCAT.
3355 * In this middle of this, o may contain both: unshifted args on the
3356 * left, and some remaining original args on the right. lastkidop
3357 * is set to point to the right-most unshifted arg to delineate
3358 * between the two sets.
3363 /* create a copy of the format with the %'s removed, and record
3364 * the sizes of the const string segments in the aux struct */
3366 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3368 p = sprintf_info.start;
3371 for (; p < sprintf_info.end; p++) {
3375 (lenp++)->ssize = q - oldq;
3382 lenp->ssize = q - oldq;
3383 assert((STRLEN)(q - const_str) == total_len);
3385 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3386 * may or may not be topop) The pushmark and const ops need to be
3387 * kept in case they're an op_next entry point.
3389 lastkidop = cLISTOPx(topop)->op_last;
3390 kid = cUNOPx(topop)->op_first; /* pushmark */
3392 op_null(OpSIBLING(kid)); /* const */
3394 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3395 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3396 lastkidop->op_next = o;
3401 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3405 /* Concatenate all const strings into const_str.
3406 * Note that args[] contains the RHS args in reverse order, so
3407 * we scan args[] from top to bottom to get constant strings
3410 for (argp = toparg; argp >= args; argp--) {
3412 /* not a const op */
3413 (++lenp)->ssize = -1;
3415 STRLEN l = argp->len;
3416 Copy(argp->p, p, l, char);
3418 if (lenp->ssize == -1)
3429 for (argp = args; argp <= toparg; argp++) {
3430 /* only keep non-const args, except keep the first-in-next-chain
3431 * arg no matter what it is (but nulled if OP_CONST), because it
3432 * may be the entry point to this subtree from the previous
3435 bool last = (argp == toparg);
3438 /* set prev to the sibling *before* the arg to be cut out,
3439 * e.g. when cutting EXPR:
3444 * prev= CONCAT -- EXPR
3447 if (argp == args && kid->op_type != OP_CONCAT) {
3448 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3449 * so the expression to be cut isn't kid->op_last but
3452 /* find the op before kid */
3454 o2 = cUNOPx(parentop)->op_first;
3455 while (o2 && o2 != kid) {
3463 else if (kid == o && lastkidop)
3464 prev = last ? lastkidop : OpSIBLING(lastkidop);
3466 prev = last ? NULL : cUNOPx(kid)->op_first;
3468 if (!argp->p || last) {
3470 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3471 /* and unshift to front of o */
3472 op_sibling_splice(o, NULL, 0, aop);
3473 /* record the right-most op added to o: later we will
3474 * free anything to the right of it */
3477 aop->op_next = nextop;
3480 /* null the const at start of op_next chain */
3484 nextop = prev->op_next;
3487 /* the last two arguments are both attached to the same concat op */
3488 if (argp < toparg - 1)
3493 /* Populate the aux struct */
3495 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3496 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3497 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3498 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3499 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3501 /* if variant > 0, calculate a variant const string and lengths where
3502 * the utf8 version of the string will take 'variant' more bytes than
3506 char *p = const_str;
3507 STRLEN ulen = total_len + variant;
3508 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3509 UNOP_AUX_item *ulens = lens + (nargs + 1);
3510 char *up = (char*)PerlMemShared_malloc(ulen);
3513 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3514 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3516 for (n = 0; n < (nargs + 1); n++) {
3518 char * orig_up = up;
3519 for (i = (lens++)->ssize; i > 0; i--) {
3521 append_utf8_from_native_byte(c, (U8**)&up);
3523 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3528 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3529 * that op's first child - an ex-PUSHMARK - because the op_next of
3530 * the previous op may point to it (i.e. it's the entry point for
3535 ? op_sibling_splice(o, lastkidop, 1, NULL)
3536 : op_sibling_splice(stringop, NULL, 1, NULL);
3537 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3538 op_sibling_splice(o, NULL, 0, pmop);
3545 * target .= A.B.C...
3551 if (o->op_type == OP_SASSIGN) {
3552 /* Move the target subtree from being the last of o's children
3553 * to being the last of o's preserved children.
3554 * Note the difference between 'target = ...' and 'target .= ...':
3555 * for the former, target is executed last; for the latter,
3558 kid = OpSIBLING(lastkidop);
3559 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3560 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3561 lastkidop->op_next = kid->op_next;
3562 lastkidop = targetop;
3565 /* Move the target subtree from being the first of o's
3566 * original children to being the first of *all* o's children.
3569 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3570 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3573 /* if the RHS of .= doesn't contain a concat (e.g.
3574 * $x .= "foo"), it gets missed by the "strip ops from the
3575 * tree and add to o" loop earlier */
3576 assert(topop->op_type != OP_CONCAT);
3578 /* in e.g. $x .= "$y", move the $y expression
3579 * from being a child of OP_STRINGIFY to being the
3580 * second child of the OP_CONCAT
3582 assert(cUNOPx(stringop)->op_first == topop);
3583 op_sibling_splice(stringop, NULL, 1, NULL);
3584 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3586 assert(topop == OpSIBLING(cBINOPo->op_first));
3595 * my $lex = A.B.C...
3598 * The original padsv op is kept but nulled in case it's the
3599 * entry point for the optree (which it will be for
3602 private_flags |= OPpTARGET_MY;
3603 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3604 o->op_targ = targetop->op_targ;
3605 targetop->op_targ = 0;
3609 flags |= OPf_STACKED;
3611 else if (targmyop) {
3612 private_flags |= OPpTARGET_MY;
3613 if (o != targmyop) {
3614 o->op_targ = targmyop->op_targ;
3615 targmyop->op_targ = 0;
3619 /* detach the emaciated husk of the sprintf/concat optree and free it */
3621 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3627 /* and convert o into a multiconcat */
3629 o->op_flags = (flags|OPf_KIDS|stacked_last
3630 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3631 o->op_private = private_flags;
3632 o->op_type = OP_MULTICONCAT;
3633 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3634 cUNOP_AUXo->op_aux = aux;
3638 /* do all the final processing on an optree (e.g. running the peephole
3639 * optimiser on it), then attach it to cv (if cv is non-null)
3643 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3647 /* XXX for some reason, evals, require and main optrees are
3648 * never attached to their CV; instead they just hang off
3649 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3650 * and get manually freed when appropriate */
3652 startp = &CvSTART(cv);
3654 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3657 optree->op_private |= OPpREFCOUNTED;
3658 OpREFCNT_set(optree, 1);
3659 optimize_optree(optree);
3661 finalize_optree(optree);
3662 S_prune_chain_head(startp);
3665 /* now that optimizer has done its work, adjust pad values */
3666 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3667 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3673 =for apidoc optimize_optree
3675 This function applies some optimisations to the optree in top-down order.
3676 It is called before the peephole optimizer, which processes ops in
3677 execution order. Note that finalize_optree() also does a top-down scan,
3678 but is called *after* the peephole optimizer.
3684 Perl_optimize_optree(pTHX_ OP* o)
3686 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3689 SAVEVPTR(PL_curcop);
3697 /* helper for optimize_optree() which optimises one op then recurses
3698 * to optimise any children.
3702 S_optimize_op(pTHX_ OP* o)
3706 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3709 OP * next_kid = NULL;
3711 assert(o->op_type != OP_FREED);
3713 switch (o->op_type) {
3716 PL_curcop = ((COP*)o); /* for warnings */
3724 S_maybe_multiconcat(aTHX_ o);
3728 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3729 /* we can't assume that op_pmreplroot->op_sibparent == o
3730 * and that it is thus possible to walk back up the tree
3731 * past op_pmreplroot. So, although we try to avoid
3732 * recursing through op trees, do it here. After all,
3733 * there are unlikely to be many nested s///e's within
3734 * the replacement part of a s///e.
3736 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3744 if (o->op_flags & OPf_KIDS)
3745 next_kid = cUNOPo->op_first;
3747 /* if a kid hasn't been nominated to process, continue with the
3748 * next sibling, or if no siblings left, go back to the parent's
3749 * siblings and so on
3753 return; /* at top; no parents/siblings to try */
3754 if (OpHAS_SIBLING(o))
3755 next_kid = o->op_sibparent;
3757 o = o->op_sibparent; /*try parent's next sibling */
3760 /* this label not yet used. Goto here if any code above sets
3770 =for apidoc finalize_optree
3772 This function finalizes the optree. Should be called directly after
3773 the complete optree is built. It does some additional
3774 checking which can't be done in the normal C<ck_>xxx functions and makes
3775 the tree thread-safe.
3780 Perl_finalize_optree(pTHX_ OP* o)
3782 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3785 SAVEVPTR(PL_curcop);
3793 /* Relocate sv to the pad for thread safety.
3794 * Despite being a "constant", the SV is written to,
3795 * for reference counts, sv_upgrade() etc. */
3796 PERL_STATIC_INLINE void
3797 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3800 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3802 ix = pad_alloc(OP_CONST, SVf_READONLY);
3803 SvREFCNT_dec(PAD_SVl(ix));
3804 PAD_SETSV(ix, *svp);
3805 /* XXX I don't know how this isn't readonly already. */
3806 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3813 =for apidoc traverse_op_tree
3815 Return the next op in a depth-first traversal of the op tree,
3816 returning NULL when the traversal is complete.
3818 The initial call must supply the root of the tree as both top and o.
3820 For now it's static, but it may be exposed to the API in the future.
3826 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3829 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3831 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3832 return cUNOPo->op_first;
3834 else if ((sib = OpSIBLING(o))) {
3838 OP *parent = o->op_sibparent;
3839 assert(!(o->op_moresib));
3840 while (parent && parent != top) {
3841 OP *sib = OpSIBLING(parent);
3844 parent = parent->op_sibparent;
3852 S_finalize_op(pTHX_ OP* o)
3855 PERL_ARGS_ASSERT_FINALIZE_OP;
3858 assert(o->op_type != OP_FREED);
3860 switch (o->op_type) {
3863 PL_curcop = ((COP*)o); /* for warnings */
3866 if (OpHAS_SIBLING(o)) {
3867 OP *sib = OpSIBLING(o);
3868 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3869 && ckWARN(WARN_EXEC)
3870 && OpHAS_SIBLING(sib))
3872 const OPCODE type = OpSIBLING(sib)->op_type;
3873 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3874 const line_t oldline = CopLINE(PL_curcop);
3875 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3876 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3877 "Statement unlikely to be reached");
3878 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3879 "\t(Maybe you meant system() when you said exec()?)\n");
3880 CopLINE_set(PL_curcop, oldline);
3887 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3888 GV * const gv = cGVOPo_gv;
3889 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3890 /* XXX could check prototype here instead of just carping */
3891 SV * const sv = sv_newmortal();
3892 gv_efullname3(sv, gv, NULL);
3893 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3894 "%" SVf "() called too early to check prototype",
3901 if (cSVOPo->op_private & OPpCONST_STRICT)
3902 no_bareword_allowed(o);
3906 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3911 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3912 case OP_METHOD_NAMED:
3913 case OP_METHOD_SUPER:
3914 case OP_METHOD_REDIR:
3915 case OP_METHOD_REDIR_SUPER:
3916 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3925 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3928 rop = (UNOP*)((BINOP*)o)->op_first;
3933 S_scalar_slice_warning(aTHX_ o);
3937 kid = OpSIBLING(cLISTOPo->op_first);
3938 if (/* I bet there's always a pushmark... */
3939 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3940 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3945 key_op = (SVOP*)(kid->op_type == OP_CONST
3947 : OpSIBLING(kLISTOP->op_first));
3949 rop = (UNOP*)((LISTOP*)o)->op_last;
3952 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3954 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3958 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3962 S_scalar_slice_warning(aTHX_ o);
3966 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3967 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3975 if (o->op_flags & OPf_KIDS) {
3978 /* check that op_last points to the last sibling, and that
3979 * the last op_sibling/op_sibparent field points back to the
3980 * parent, and that the only ops with KIDS are those which are
3981 * entitled to them */
3982 U32 type = o->op_type;
3986 if (type == OP_NULL) {
3988 /* ck_glob creates a null UNOP with ex-type GLOB
3989 * (which is a list op. So pretend it wasn't a listop */
3990 if (type == OP_GLOB)
3993 family = PL_opargs[type] & OA_CLASS_MASK;
3995 has_last = ( family == OA_BINOP
3996 || family == OA_LISTOP
3997 || family == OA_PMOP
3998 || family == OA_LOOP
4000 assert( has_last /* has op_first and op_last, or ...
4001 ... has (or may have) op_first: */
4002 || family == OA_UNOP
4003 || family == OA_UNOP_AUX
4004 || family == OA_LOGOP
4005 || family == OA_BASEOP_OR_UNOP
4006 || family == OA_FILESTATOP
4007 || family == OA_LOOPEXOP
4008 || family == OA_METHOP
4009 || type == OP_CUSTOM
4010 || type == OP_NULL /* new_logop does this */
4013 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
4014 if (!OpHAS_SIBLING(kid)) {
4016 assert(kid == cLISTOPo->op_last);
4017 assert(kid->op_sibparent == o);
4022 } while (( o = traverse_op_tree(top, o)) != NULL);
4026 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
4029 PadnameLVALUE_on(pn);
4030 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
4032 /* RT #127786: cv can be NULL due to an eval within the DB package
4033 * called from an anon sub - anon subs don't have CvOUTSIDE() set
4034 * unless they contain an eval, but calling eval within DB
4035 * pretends the eval was done in the caller's scope.
4039 assert(CvPADLIST(cv));
4041 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
4042 assert(PadnameLEN(pn));
4043 PadnameLVALUE_on(pn);
4048 S_vivifies(const OPCODE type)
4051 case OP_RV2AV: case OP_ASLICE:
4052 case OP_RV2HV: case OP_KVASLICE:
4053 case OP_RV2SV: case OP_HSLICE:
4054 case OP_AELEMFAST: case OP_KVHSLICE:
4063 /* apply lvalue reference (aliasing) context to the optree o.
4066 * o would be the list ($x,$y) and type would be OP_AASSIGN.
4067 * It may descend and apply this to children too, for example in
4068 * \( $cond ? $x, $y) = (...)
4072 S_lvref(pTHX_ OP *o, I32 type)
4078 switch (o->op_type) {
4080 o = OpSIBLING(cUNOPo->op_first);
4087 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4088 o->op_flags |= OPf_STACKED;
4089 if (o->op_flags & OPf_PARENS) {
4090 if (o->op_private & OPpLVAL_INTRO) {
4091 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4092 "localized parenthesized array in list assignment"));
4096 OpTYPE_set(o, OP_LVAVREF);
4097 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4098 o->op_flags |= OPf_MOD|OPf_REF;
4101 o->op_private |= OPpLVREF_AV;
4105 kid = cUNOPo->op_first;
4106 if (kid->op_type == OP_NULL)
4107 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4109 o->op_private = OPpLVREF_CV;
4110 if (kid->op_type == OP_GV)
4111 o->op_flags |= OPf_STACKED;
4112 else if (kid->op_type == OP_PADCV) {
4113 o->op_targ = kid->op_targ;
4115 op_free(cUNOPo->op_first);
4116 cUNOPo->op_first = NULL;
4117 o->op_flags &=~ OPf_KIDS;
4123 if (o->op_flags & OPf_PARENS) {
4125 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4126 "parenthesized hash in list assignment"));
4129 o->op_private |= OPpLVREF_HV;
4133 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4134 o->op_flags |= OPf_STACKED;
4138 if (o->op_flags & OPf_PARENS) goto parenhash;
4139 o->op_private |= OPpLVREF_HV;
4142 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4146 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4147 if (o->op_flags & OPf_PARENS) goto slurpy;
4148 o->op_private |= OPpLVREF_AV;
4153 o->op_private |= OPpLVREF_ELEM;
4154 o->op_flags |= OPf_STACKED;
4159 OpTYPE_set(o, OP_LVREFSLICE);
4160 o->op_private &= OPpLVAL_INTRO;
4164 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4166 else if (!(o->op_flags & OPf_KIDS))
4169 /* the code formerly only recursed into the first child of
4170 * a non ex-list OP_NULL. if we ever encounter such a null op with
4171 * more than one child, need to decide whether its ok to process
4172 * *all* its kids or not */
4173 assert(o->op_targ == OP_LIST
4174 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4177 o = cLISTOPo->op_first;
4181 if (o->op_flags & OPf_PARENS)
4186 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4187 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4188 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4195 OpTYPE_set(o, OP_LVREF);
4197 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4198 if (type == OP_ENTERLOOP)
4199 o->op_private |= OPpLVREF_ITER;
4204 return; /* at top; no parents/siblings to try */
4205 if (OpHAS_SIBLING(o)) {
4206 o = o->op_sibparent;
4209 o = o->op_sibparent; /*try parent's next sibling */
4215 PERL_STATIC_INLINE bool
4216 S_potential_mod_type(I32 type)
4218 /* Types that only potentially result in modification. */
4219 return type == OP_GREPSTART || type == OP_ENTERSUB
4220 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4225 =for apidoc op_lvalue
4227 Propagate lvalue ("modifiable") context to an op and its children.
4228 C<type> represents the context type, roughly based on the type of op that
4229 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4230 because it has no op type of its own (it is signalled by a flag on
4233 This function detects things that can't be modified, such as C<$x+1>, and
4234 generates errors for them. For example, C<$x+1 = 2> would cause it to be
4235 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4237 It also flags things that need to behave specially in an lvalue context,
4238 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4242 Perl_op_lvalue_flags() is a non-API lower-level interface to
4243 op_lvalue(). The flags param has these bits:
4244 OP_LVALUE_NO_CROAK: return rather than croaking on error
4249 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4253 if (!o || (PL_parser && PL_parser->error_count))
4258 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4260 OP *next_kid = NULL;
4262 if ((o->op_private & OPpTARGET_MY)
4263 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4268 /* elements of a list might be in void context because the list is
4269 in scalar context or because they are attribute sub calls */
4270 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4273 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4275 switch (o->op_type) {
4281 if ((o->op_flags & OPf_PARENS))
4286 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4287 !(o->op_flags & OPf_STACKED)) {
4288 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4289 assert(cUNOPo->op_first->op_type == OP_NULL);
4290 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4293 else { /* lvalue subroutine call */
4294 o->op_private |= OPpLVAL_INTRO;
4295 PL_modcount = RETURN_UNLIMITED_NUMBER;
4296 if (S_potential_mod_type(type)) {
4297 o->op_private |= OPpENTERSUB_INARGS;
4300 else { /* Compile-time error message: */
4301 OP *kid = cUNOPo->op_first;
4306 if (kid->op_type != OP_PUSHMARK) {
4307 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4309 "panic: unexpected lvalue entersub "
4310 "args: type/targ %ld:%" UVuf,
4311 (long)kid->op_type, (UV)kid->op_targ);
4312 kid = kLISTOP->op_first;
4314 while (OpHAS_SIBLING(kid))
4315 kid = OpSIBLING(kid);
4316 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4317 break; /* Postpone until runtime */
4320 kid = kUNOP->op_first;
4321 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4322 kid = kUNOP->op_first;
4323 if (kid->op_type == OP_NULL)
4325 "Unexpected constant lvalue entersub "
4326 "entry via type/targ %ld:%" UVuf,
4327 (long)kid->op_type, (UV)kid->op_targ);
4328 if (kid->op_type != OP_GV) {
4335 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4336 ? MUTABLE_CV(SvRV(gv))
4342 if (flags & OP_LVALUE_NO_CROAK)
4345 namesv = cv_name(cv, NULL, 0);
4346 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4347 "subroutine call of &%" SVf " in %s",
4348 SVfARG(namesv), PL_op_desc[type]),
4356 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4357 /* grep, foreach, subcalls, refgen */
4358 if (S_potential_mod_type(type))
4360 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4361 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4364 type ? PL_op_desc[type] : "local"));
4377 case OP_RIGHT_SHIFT:
4386 if (!(o->op_flags & OPf_STACKED))
4392 if (o->op_flags & OPf_STACKED) {
4396 if (!(o->op_private & OPpREPEAT_DOLIST))
4399 const I32 mods = PL_modcount;
4400 /* we recurse rather than iterate here because we need to
4401 * calculate and use the delta applied to PL_modcount by the
4402 * first child. So in something like
4403 * ($x, ($y) x 3) = split;
4404 * split knows that 4 elements are wanted
4406 modkids(cBINOPo->op_first, type);
4407 if (type != OP_AASSIGN)
4409 kid = cBINOPo->op_last;
4410 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4411 const IV iv = SvIV(kSVOP_sv);
4412 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4414 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4417 PL_modcount = RETURN_UNLIMITED_NUMBER;
4423 next_kid = OpSIBLING(cUNOPo->op_first);
4428 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4429 PL_modcount = RETURN_UNLIMITED_NUMBER;
4430 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4431 fiable since some contexts need to know. */
4432 o->op_flags |= OPf_MOD;
4437 if (scalar_mod_type(o, type))
4439 ref(cUNOPo->op_first, o->op_type);
4446 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4447 if (type == OP_LEAVESUBLV && (
4448 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4449 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4451 o->op_private |= OPpMAYBE_LVSUB;
4455 PL_modcount = RETURN_UNLIMITED_NUMBER;
4461 if (type == OP_LEAVESUBLV)
4462 o->op_private |= OPpMAYBE_LVSUB;
4466 if (type == OP_LEAVESUBLV
4467 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4468 o->op_private |= OPpMAYBE_LVSUB;
4472 PL_hints |= HINT_BLOCK_SCOPE;
4473 if (type == OP_LEAVESUBLV)
4474 o->op_private |= OPpMAYBE_LVSUB;
4479 ref(cUNOPo->op_first, o->op_type);
4483 PL_hints |= HINT_BLOCK_SCOPE;
4493 case OP_AELEMFAST_LEX:
4500 PL_modcount = RETURN_UNLIMITED_NUMBER;
4501 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4503 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4504 fiable since some contexts need to know. */
4505 o->op_flags |= OPf_MOD;
4508 if (scalar_mod_type(o, type))
4510 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4511 && type == OP_LEAVESUBLV)
4512 o->op_private |= OPpMAYBE_LVSUB;
4516 if (!type) /* local() */
4517 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4518 PNfARG(PAD_COMPNAME(o->op_targ)));
4519 if (!(o->op_private & OPpLVAL_INTRO)
4520 || ( type != OP_SASSIGN && type != OP_AASSIGN
4521 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4522 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4530 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4534 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4540 if (type == OP_LEAVESUBLV)
4541 o->op_private |= OPpMAYBE_LVSUB;
4542 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4543 /* we recurse rather than iterate here because the child
4544 * needs to be processed with a different 'type' parameter */
4546 /* substr and vec */
4547 /* If this op is in merely potential (non-fatal) modifiable
4548 context, then apply OP_ENTERSUB context to
4549 the kid op (to avoid croaking). Other-
4550 wise pass this op’s own type so the correct op is mentioned
4551 in error messages. */
4552 op_lvalue(OpSIBLING(cBINOPo->op_first),
4553 S_potential_mod_type(type)
4561 ref(cBINOPo->op_first, o->op_type);
4562 if (type == OP_ENTERSUB &&
4563 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4564 o->op_private |= OPpLVAL_DEFER;
4565 if (type == OP_LEAVESUBLV)
4566 o->op_private |= OPpMAYBE_LVSUB;
4573 o->op_private |= OPpLVALUE;
4579 if (o->op_flags & OPf_KIDS)
4580 next_kid = cLISTOPo->op_last;
4585 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4587 else if (!(o->op_flags & OPf_KIDS))
4590 if (o->op_targ != OP_LIST) {
4591 OP *sib = OpSIBLING(cLISTOPo->op_first);
4592 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4599 * compared with things like OP_MATCH which have the argument
4605 * so handle specially to correctly get "Can't modify" croaks etc
4608 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4610 /* this should trigger a "Can't modify transliteration" err */
4611 op_lvalue(sib, type);
4613 next_kid = cBINOPo->op_first;
4614 /* we assume OP_NULLs which aren't ex-list have no more than 2
4615 * children. If this assumption is wrong, increase the scan
4617 assert( !OpHAS_SIBLING(next_kid)
4618 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4624 next_kid = cLISTOPo->op_first;
4632 if (type == OP_LEAVESUBLV
4633 || !S_vivifies(cLOGOPo->op_first->op_type))
4634 next_kid = cLOGOPo->op_first;
4635 else if (type == OP_LEAVESUBLV
4636 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4637 next_kid = OpSIBLING(cLOGOPo->op_first);
4641 if (type == OP_NULL) { /* local */
4643 if (!FEATURE_MYREF_IS_ENABLED)
4644 Perl_croak(aTHX_ "The experimental declared_refs "
4645 "feature is not enabled");
4646 Perl_ck_warner_d(aTHX_
4647 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4648 "Declaring references is experimental");
4649 next_kid = cUNOPo->op_first;
4652 if (type != OP_AASSIGN && type != OP_SASSIGN
4653 && type != OP_ENTERLOOP)
4655 /* Don’t bother applying lvalue context to the ex-list. */
4656 kid = cUNOPx(cUNOPo->op_first)->op_first;
4657 assert (!OpHAS_SIBLING(kid));
4660 if (type == OP_NULL) /* local */
4662 if (type != OP_AASSIGN) goto nomod;
4663 kid = cUNOPo->op_first;
4666 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4667 S_lvref(aTHX_ kid, type);
4668 if (!PL_parser || PL_parser->error_count == ec) {
4669 if (!FEATURE_REFALIASING_IS_ENABLED)
4671 "Experimental aliasing via reference not enabled");
4672 Perl_ck_warner_d(aTHX_
4673 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4674 "Aliasing via reference is experimental");
4677 if (o->op_type == OP_REFGEN)
4678 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4683 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4684 /* This is actually @array = split. */
4685 PL_modcount = RETURN_UNLIMITED_NUMBER;
4691 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4695 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4696 their argument is a filehandle; thus \stat(".") should not set
4698 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4701 if (type != OP_LEAVESUBLV)
4702 o->op_flags |= OPf_MOD;
4704 if (type == OP_AASSIGN || type == OP_SASSIGN)
4705 o->op_flags |= OPf_SPECIAL
4706 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4707 else if (!type) { /* local() */
4710 o->op_private |= OPpLVAL_INTRO;
4711 o->op_flags &= ~OPf_SPECIAL;
4712 PL_hints |= HINT_BLOCK_SCOPE;
4717 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4718 "Useless localization of %s", OP_DESC(o));
4721 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4722 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4723 o->op_flags |= OPf_REF;
4728 return top_op; /* at top; no parents/siblings to try */
4729 if (OpHAS_SIBLING(o)) {
4730 next_kid = o->op_sibparent;
4731 if (!OpHAS_SIBLING(next_kid)) {
4732 /* a few node types don't recurse into their second child */
4733 OP *parent = next_kid->op_sibparent;
4734 I32 ptype = parent->op_type;
4735 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
4736 || ( (ptype == OP_AND || ptype == OP_OR)
4737 && (type != OP_LEAVESUBLV
4738 && S_vivifies(next_kid->op_type))
4741 /*try parent's next sibling */
4748 o = o->op_sibparent; /*try parent's next sibling */
4759 S_scalar_mod_type(const OP *o, I32 type)
4764 if (o && o->op_type == OP_RV2GV)
4788 case OP_RIGHT_SHIFT:
4817 S_is_handle_constructor(const OP *o, I32 numargs)
4819 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4821 switch (o->op_type) {
4829 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4842 S_refkids(pTHX_ OP *o, I32 type)
4844 if (o && o->op_flags & OPf_KIDS) {
4846 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4853 /* Apply reference (autovivification) context to the subtree at o.
4855 * push @{expression}, ....;
4856 * o will be the head of 'expression' and type will be OP_RV2AV.
4857 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4859 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4860 * set_op_ref is true.
4862 * Also calls scalar(o).
4866 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4870 PERL_ARGS_ASSERT_DOREF;
4872 if (PL_parser && PL_parser->error_count)
4876 switch (o->op_type) {
4878 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4879 !(o->op_flags & OPf_STACKED)) {
4880 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4881 assert(cUNOPo->op_first->op_type == OP_NULL);
4882 /* disable pushmark */
4883 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4884 o->op_flags |= OPf_SPECIAL;
4886 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4887 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4888 : type == OP_RV2HV ? OPpDEREF_HV
4890 o->op_flags |= OPf_MOD;
4896 o = OpSIBLING(cUNOPo->op_first);
4900 if (type == OP_DEFINED)
4901 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4904 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4905 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4906 : type == OP_RV2HV ? OPpDEREF_HV
4908 o->op_flags |= OPf_MOD;
4910 if (o->op_flags & OPf_KIDS) {
4912 o = cUNOPo->op_first;
4920 o->op_flags |= OPf_REF;
4923 if (type == OP_DEFINED)
4924 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4926 o = cUNOPo->op_first;
4932 o->op_flags |= OPf_REF;
4937 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4939 o = cBINOPo->op_first;
4944 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4945 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4946 : type == OP_RV2HV ? OPpDEREF_HV
4948 o->op_flags |= OPf_MOD;
4951 o = cBINOPo->op_first;
4960 if (!(o->op_flags & OPf_KIDS))
4962 o = cLISTOPo->op_last;
4971 return scalar(top_op); /* at top; no parents/siblings to try */
4972 if (OpHAS_SIBLING(o)) {
4973 o = o->op_sibparent;
4974 /* Normally skip all siblings and go straight to the parent;
4975 * the only op that requires two children to be processed
4976 * is OP_COND_EXPR */
4977 if (!OpHAS_SIBLING(o)
4978 && o->op_sibparent->op_type == OP_COND_EXPR)
4982 o = o->op_sibparent; /*try parent's next sibling */
4989 S_dup_attrlist(pTHX_ OP *o)
4993 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4995 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4996 * where the first kid is OP_PUSHMARK and the remaining ones
4997 * are OP_CONST. We need to push the OP_CONST values.
4999 if (o->op_type == OP_CONST)
5000 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
5002 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5004 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
5005 if (o->op_type == OP_CONST)
5006 rop = op_append_elem(OP_LIST, rop,
5007 newSVOP(OP_CONST, o->op_flags,
5008 SvREFCNT_inc_NN(cSVOPo->op_sv)));
5015 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
5017 PERL_ARGS_ASSERT_APPLY_ATTRS;
5019 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
5021 /* fake up C<use attributes $pkg,$rv,@attrs> */
5023 #define ATTRSMODULE "attributes"
5024 #define ATTRSMODULE_PM "attributes.pm"
5027 aTHX_ PERL_LOADMOD_IMPORT_OPS,
5028 newSVpvs(ATTRSMODULE),
5030 op_prepend_elem(OP_LIST,
5031 newSVOP(OP_CONST, 0, stashsv),
5032 op_prepend_elem(OP_LIST,
5033 newSVOP(OP_CONST, 0,
5035 dup_attrlist(attrs))));
5040 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
5042 OP *pack, *imop, *arg;
5043 SV *meth, *stashsv, **svp;
5045 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
5050 assert(target->op_type == OP_PADSV ||
5051 target->op_type == OP_PADHV ||
5052 target->op_type == OP_PADAV);
5054 /* Ensure that attributes.pm is loaded. */
5055 /* Don't force the C<use> if we don't need it. */
5056 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
5057 if (svp && *svp != &PL_sv_undef)
5058 NOOP; /* already in %INC */
5060 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5061 newSVpvs(ATTRSMODULE), NULL);
5063 /* Need package name for method call. */
5064 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
5066 /* Build up the real arg-list. */
5067 stashsv = newSVhek(HvNAME_HEK(stash));
5069 arg = newOP(OP_PADSV, 0);
5070 arg->op_targ = target->op_targ;
5071 arg = op_prepend_elem(OP_LIST,
5072 newSVOP(OP_CONST, 0, stashsv),
5073 op_prepend_elem(OP_LIST,
5074 newUNOP(OP_REFGEN, 0,
5076 dup_attrlist(attrs)));
5078 /* Fake up a method call to import */
5079 meth = newSVpvs_share("import");
5080 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
5081 op_append_elem(OP_LIST,
5082 op_prepend_elem(OP_LIST, pack, arg),
5083 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5085 /* Combine the ops. */
5086 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
5090 =notfor apidoc apply_attrs_string
5092 Attempts to apply a list of attributes specified by the C<attrstr> and
5093 C<len> arguments to the subroutine identified by the C<cv> argument which
5094 is expected to be associated with the package identified by the C<stashpv>
5095 argument (see L<attributes>). It gets this wrong, though, in that it
5096 does not correctly identify the boundaries of the individual attribute
5097 specifications within C<attrstr>. This is not really intended for the
5098 public API, but has to be listed here for systems such as AIX which
5099 need an explicit export list for symbols. (It's called from XS code
5100 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
5101 to respect attribute syntax properly would be welcome.
5107 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
5108 const char *attrstr, STRLEN len)
5112 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
5115 len = strlen(attrstr);
5119 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
5121 const char * const sstr = attrstr;
5122 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
5123 attrs = op_append_elem(OP_LIST, attrs,
5124 newSVOP(OP_CONST, 0,
5125 newSVpvn(sstr, attrstr-sstr)));
5129 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5130 newSVpvs(ATTRSMODULE),
5131 NULL, op_prepend_elem(OP_LIST,
5132 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5133 op_prepend_elem(OP_LIST,
5134 newSVOP(OP_CONST, 0,
5135 newRV(MUTABLE_SV(cv))),
5140 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5143 OP *new_proto = NULL;
5148 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5154 if (o->op_type == OP_CONST) {
5155 pv = SvPV(cSVOPo_sv, pvlen);
5156 if (memBEGINs(pv, pvlen, "prototype(")) {
5157 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5158 SV ** const tmpo = cSVOPx_svp(o);
5159 SvREFCNT_dec(cSVOPo_sv);
5164 } else if (o->op_type == OP_LIST) {
5166 assert(o->op_flags & OPf_KIDS);
5167 lasto = cLISTOPo->op_first;
5168 assert(lasto->op_type == OP_PUSHMARK);
5169 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5170 if (o->op_type == OP_CONST) {
5171 pv = SvPV(cSVOPo_sv, pvlen);
5172 if (memBEGINs(pv, pvlen, "prototype(")) {
5173 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5174 SV ** const tmpo = cSVOPx_svp(o);
5175 SvREFCNT_dec(cSVOPo_sv);
5177 if (new_proto && ckWARN(WARN_MISC)) {
5179 const char * newp = SvPV(cSVOPo_sv, new_len);
5180 Perl_warner(aTHX_ packWARN(WARN_MISC),
5181 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5182 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5188 /* excise new_proto from the list */
5189 op_sibling_splice(*attrs, lasto, 1, NULL);
5196 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5197 would get pulled in with no real need */
5198 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5207 svname = sv_newmortal();
5208 gv_efullname3(svname, name, NULL);
5210 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5211 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5213 svname = (SV *)name;
5214 if (ckWARN(WARN_ILLEGALPROTO))
5215 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5217 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5218 STRLEN old_len, new_len;
5219 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5220 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5222 if (curstash && svname == (SV *)name
5223 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5224 svname = sv_2mortal(newSVsv(PL_curstname));
5225 sv_catpvs(svname, "::");
5226 sv_catsv(svname, (SV *)name);
5229 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5230 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5232 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5233 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5243 S_cant_declare(pTHX_ OP *o)
5245 if (o->op_type == OP_NULL
5246 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5247 o = cUNOPo->op_first;
5248 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5249 o->op_type == OP_NULL
5250 && o->op_flags & OPf_SPECIAL
5253 PL_parser->in_my == KEY_our ? "our" :
5254 PL_parser->in_my == KEY_state ? "state" :
5259 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5262 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5264 PERL_ARGS_ASSERT_MY_KID;
5266 if (!o || (PL_parser && PL_parser->error_count))
5271 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5273 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5274 my_kid(kid, attrs, imopsp);
5276 } else if (type == OP_UNDEF || type == OP_STUB) {
5278 } else if (type == OP_RV2SV || /* "our" declaration */
5281 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5282 S_cant_declare(aTHX_ o);
5284 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5286 PL_parser->in_my = FALSE;
5287 PL_parser->in_my_stash = NULL;
5288 apply_attrs(GvSTASH(gv),
5289 (type == OP_RV2SV ? GvSVn(gv) :
5290 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5291 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5294 o->op_private |= OPpOUR_INTRO;
5297 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5298 if (!FEATURE_MYREF_IS_ENABLED)
5299 Perl_croak(aTHX_ "The experimental declared_refs "
5300 "feature is not enabled");
5301 Perl_ck_warner_d(aTHX_
5302 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5303 "Declaring references is experimental");
5304 /* Kid is a nulled OP_LIST, handled above. */
5305 my_kid(cUNOPo->op_first, attrs, imopsp);
5308 else if (type != OP_PADSV &&
5311 type != OP_PUSHMARK)
5313 S_cant_declare(aTHX_ o);
5316 else if (attrs && type != OP_PUSHMARK) {
5320 PL_parser->in_my = FALSE;
5321 PL_parser->in_my_stash = NULL;
5323 /* check for C<my Dog $spot> when deciding package */
5324 stash = PAD_COMPNAME_TYPE(o->op_targ);
5326 stash = PL_curstash;
5327 apply_attrs_my(stash, o, attrs, imopsp);
5329 o->op_flags |= OPf_MOD;
5330 o->op_private |= OPpLVAL_INTRO;
5332 o->op_private |= OPpPAD_STATE;
5337 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5340 int maybe_scalar = 0;
5342 PERL_ARGS_ASSERT_MY_ATTRS;
5344 /* [perl #17376]: this appears to be premature, and results in code such as
5345 C< our(%x); > executing in list mode rather than void mode */
5347 if (o->op_flags & OPf_PARENS)
5357 o = my_kid(o, attrs, &rops);
5359 if (maybe_scalar && o->op_type == OP_PADSV) {
5360 o = scalar(op_append_list(OP_LIST, rops, o));
5361 o->op_private |= OPpLVAL_INTRO;
5364 /* The listop in rops might have a pushmark at the beginning,
5365 which will mess up list assignment. */
5366 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5367 if (rops->op_type == OP_LIST &&
5368 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5370 OP * const pushmark = lrops->op_first;
5371 /* excise pushmark */
5372 op_sibling_splice(rops, NULL, 1, NULL);
5375 o = op_append_list(OP_LIST, o, rops);
5378 PL_parser->in_my = FALSE;
5379 PL_parser->in_my_stash = NULL;
5384 Perl_sawparens(pTHX_ OP *o)
5386 PERL_UNUSED_CONTEXT;
5388 o->op_flags |= OPf_PARENS;
5393 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5397 const OPCODE ltype = left->op_type;
5398 const OPCODE rtype = right->op_type;
5400 PERL_ARGS_ASSERT_BIND_MATCH;
5402 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5403 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5405 const char * const desc
5407 rtype == OP_SUBST || rtype == OP_TRANS
5408 || rtype == OP_TRANSR
5410 ? (int)rtype : OP_MATCH];
5411 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5413 S_op_varname(aTHX_ left);
5415 Perl_warner(aTHX_ packWARN(WARN_MISC),
5416 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5417 desc, SVfARG(name), SVfARG(name));
5419 const char * const sample = (isary
5420 ? "@array" : "%hash");
5421 Perl_warner(aTHX_ packWARN(WARN_MISC),
5422 "Applying %s to %s will act on scalar(%s)",
5423 desc, sample, sample);
5427 if (rtype == OP_CONST &&
5428 cSVOPx(right)->op_private & OPpCONST_BARE &&
5429 cSVOPx(right)->op_private & OPpCONST_STRICT)
5431 no_bareword_allowed(right);
5434 /* !~ doesn't make sense with /r, so error on it for now */
5435 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5437 /* diag_listed_as: Using !~ with %s doesn't make sense */
5438 yyerror("Using !~ with s///r doesn't make sense");
5439 if (rtype == OP_TRANSR && type == OP_NOT)
5440 /* diag_listed_as: Using !~ with %s doesn't make sense */
5441 yyerror("Using !~ with tr///r doesn't make sense");
5443 ismatchop = (rtype == OP_MATCH ||
5444 rtype == OP_SUBST ||
5445 rtype == OP_TRANS || rtype == OP_TRANSR)
5446 && !(right->op_flags & OPf_SPECIAL);
5447 if (ismatchop && right->op_private & OPpTARGET_MY) {
5449 right->op_private &= ~OPpTARGET_MY;
5451 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5452 if (left->op_type == OP_PADSV
5453 && !(left->op_private & OPpLVAL_INTRO))
5455 right->op_targ = left->op_targ;
5460 right->op_flags |= OPf_STACKED;
5461 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5462 ! (rtype == OP_TRANS &&
5463 right->op_private & OPpTRANS_IDENTICAL) &&
5464 ! (rtype == OP_SUBST &&
5465 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5466 left = op_lvalue(left, rtype);
5467 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5468 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5470 o = op_prepend_elem(rtype, scalar(left), right);
5473 return newUNOP(OP_NOT, 0, scalar(o));
5477 return bind_match(type, left,
5478 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5482 Perl_invert(pTHX_ OP *o)
5486 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5490 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
5496 left = newOP(OP_NULL, 0);
5498 right = newOP(OP_NULL, 0);
5501 NewOp(0, bop, 1, BINOP);
5503 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5504 OpTYPE_set(op, type);
5505 cBINOPx(op)->op_flags = OPf_KIDS;
5506 cBINOPx(op)->op_private = 2;
5507 cBINOPx(op)->op_first = left;
5508 cBINOPx(op)->op_last = right;
5509 OpMORESIB_set(left, right);
5510 OpLASTSIB_set(right, op);
5515 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
5520 PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
5522 right = newOP(OP_NULL, 0);
5524 NewOp(0, bop, 1, BINOP);
5526 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5527 OpTYPE_set(op, type);
5528 if (ch->op_type != OP_NULL) {
5530 OP *nch, *cleft, *cright;
5531 NewOp(0, lch, 1, UNOP);
5533 OpTYPE_set(nch, OP_NULL);
5534 nch->op_flags = OPf_KIDS;
5535 cleft = cBINOPx(ch)->op_first;
5536 cright = cBINOPx(ch)->op_last;
5537 cBINOPx(ch)->op_first = NULL;
5538 cBINOPx(ch)->op_last = NULL;
5539 cBINOPx(ch)->op_private = 0;
5540 cBINOPx(ch)->op_flags = 0;
5541 cUNOPx(nch)->op_first = cright;
5542 OpMORESIB_set(cright, ch);
5543 OpMORESIB_set(ch, cleft);
5544 OpLASTSIB_set(cleft, nch);
5547 OpMORESIB_set(right, op);
5548 OpMORESIB_set(op, cUNOPx(ch)->op_first);
5549 cUNOPx(ch)->op_first = right;
5554 Perl_cmpchain_finish(pTHX_ OP *ch)
5557 PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
5558 if (ch->op_type != OP_NULL) {
5559 OPCODE cmpoptype = ch->op_type;
5560 ch = CHECKOP(cmpoptype, ch);
5561 if(!ch->op_next && ch->op_type == cmpoptype)
5562 ch = fold_constants(op_integerize(op_std_init(ch)));
5566 OP *rightarg = cUNOPx(ch)->op_first;
5567 cUNOPx(ch)->op_first = OpSIBLING(rightarg);
5568 OpLASTSIB_set(rightarg, NULL);
5570 OP *cmpop = cUNOPx(ch)->op_first;
5571 OP *leftarg = OpSIBLING(cmpop);
5572 OPCODE cmpoptype = cmpop->op_type;
5575 is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
5576 OpLASTSIB_set(cmpop, NULL);
5577 OpLASTSIB_set(leftarg, NULL);
5581 nextrightarg = NULL;
5583 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
5584 leftarg = newOP(OP_NULL, 0);
5586 cBINOPx(cmpop)->op_first = leftarg;
5587 cBINOPx(cmpop)->op_last = rightarg;
5588 OpMORESIB_set(leftarg, rightarg);
5589 OpLASTSIB_set(rightarg, cmpop);
5590 cmpop->op_flags = OPf_KIDS;
5591 cmpop->op_private = 2;
5592 cmpop = CHECKOP(cmpoptype, cmpop);
5593 if(!cmpop->op_next && cmpop->op_type == cmpoptype)
5594 cmpop = op_integerize(op_std_init(cmpop));
5595 condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
5599 rightarg = nextrightarg;
5605 =for apidoc op_scope
5607 Wraps up an op tree with some additional ops so that at runtime a dynamic
5608 scope will be created. The original ops run in the new dynamic scope,
5609 and then, provided that they exit normally, the scope will be unwound.
5610 The additional ops used to create and unwind the dynamic scope will
5611 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5612 instead if the ops are simple enough to not need the full dynamic scope
5619 Perl_op_scope(pTHX_ OP *o)
5622 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5623 o = op_prepend_elem(OP_LINESEQ,
5624 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
5625 OpTYPE_set(o, OP_LEAVE);
5627 else if (o->op_type == OP_LINESEQ) {
5629 OpTYPE_set(o, OP_SCOPE);
5630 kid = ((LISTOP*)o)->op_first;
5631 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5634 /* The following deals with things like 'do {1 for 1}' */
5635 kid = OpSIBLING(kid);
5637 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5642 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5648 Perl_op_unscope(pTHX_ OP *o)
5650 if (o && o->op_type == OP_LINESEQ) {
5651 OP *kid = cLISTOPo->op_first;
5652 for(; kid; kid = OpSIBLING(kid))
5653 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5660 =for apidoc block_start
5662 Handles compile-time scope entry.
5663 Arranges for hints to be restored on block
5664 exit and also handles pad sequence numbers to make lexical variables scope
5665 right. Returns a savestack index for use with C<block_end>.
5671 Perl_block_start(pTHX_ int full)
5673 const int retval = PL_savestack_ix;
5675 PL_compiling.cop_seq = PL_cop_seqmax;
5677 pad_block_start(full);
5679 PL_hints &= ~HINT_BLOCK_SCOPE;
5680 SAVECOMPILEWARNINGS();
5681 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5682 SAVEI32(PL_compiling.cop_seq);
5683 PL_compiling.cop_seq = 0;
5685 CALL_BLOCK_HOOKS(bhk_start, full);
5691 =for apidoc block_end
5693 Handles compile-time scope exit. C<floor>
5694 is the savestack index returned by
5695 C<block_start>, and C<seq> is the body of the block. Returns the block,
5702 Perl_block_end(pTHX_ I32 floor, OP *seq)
5704 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5705 OP* retval = scalarseq(seq);
5708 /* XXX Is the null PL_parser check necessary here? */
5709 assert(PL_parser); /* Let’s find out under debugging builds. */
5710 if (PL_parser && PL_parser->parsed_sub) {
5711 o = newSTATEOP(0, NULL, NULL);
5713 retval = op_append_elem(OP_LINESEQ, retval, o);
5716 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5720 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5724 /* pad_leavemy has created a sequence of introcv ops for all my
5725 subs declared in the block. We have to replicate that list with
5726 clonecv ops, to deal with this situation:
5731 sub s1 { state sub foo { \&s2 } }
5734 Originally, I was going to have introcv clone the CV and turn
5735 off the stale flag. Since &s1 is declared before &s2, the
5736 introcv op for &s1 is executed (on sub entry) before the one for
5737 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5738 cloned, since it is a state sub) closes over &s2 and expects
5739 to see it in its outer CV’s pad. If the introcv op clones &s1,
5740 then &s2 is still marked stale. Since &s1 is not active, and
5741 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5742 ble will not stay shared’ warning. Because it is the same stub
5743 that will be used when the introcv op for &s2 is executed, clos-
5744 ing over it is safe. Hence, we have to turn off the stale flag
5745 on all lexical subs in the block before we clone any of them.
5746 Hence, having introcv clone the sub cannot work. So we create a
5747 list of ops like this:
5771 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5772 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5773 for (;; kid = OpSIBLING(kid)) {
5774 OP *newkid = newOP(OP_CLONECV, 0);
5775 newkid->op_targ = kid->op_targ;
5776 o = op_append_elem(OP_LINESEQ, o, newkid);
5777 if (kid == last) break;
5779 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5782 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5788 =for apidoc_section $scope
5790 =for apidoc blockhook_register
5792 Register a set of hooks to be called when the Perl lexical scope changes
5793 at compile time. See L<perlguts/"Compile-time scope hooks">.
5799 Perl_blockhook_register(pTHX_ BHK *hk)
5801 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5803 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5807 Perl_newPROG(pTHX_ OP *o)
5811 PERL_ARGS_ASSERT_NEWPROG;
5818 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5819 ((PL_in_eval & EVAL_KEEPERR)
5820 ? OPf_SPECIAL : 0), o);
5823 assert(CxTYPE(cx) == CXt_EVAL);
5825 if ((cx->blk_gimme & G_WANT) == G_VOID)
5826 scalarvoid(PL_eval_root);
5827 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5830 scalar(PL_eval_root);
5832 start = op_linklist(PL_eval_root);
5833 PL_eval_root->op_next = 0;
5834 i = PL_savestack_ix;
5837 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5839 PL_savestack_ix = i;
5842 if (o->op_type == OP_STUB) {
5843 /* This block is entered if nothing is compiled for the main
5844 program. This will be the case for an genuinely empty main
5845 program, or one which only has BEGIN blocks etc, so already
5848 Historically (5.000) the guard above was !o. However, commit
5849 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5850 c71fccf11fde0068, changed perly.y so that newPROG() is now
5851 called with the output of block_end(), which returns a new
5852 OP_STUB for the case of an empty optree. ByteLoader (and
5853 maybe other things) also take this path, because they set up
5854 PL_main_start and PL_main_root directly, without generating an
5857 If the parsing the main program aborts (due to parse errors,
5858 or due to BEGIN or similar calling exit), then newPROG()
5859 isn't even called, and hence this code path and its cleanups
5860 are skipped. This shouldn't make a make a difference:
5861 * a non-zero return from perl_parse is a failure, and
5862 perl_destruct() should be called immediately.
5863 * however, if exit(0) is called during the parse, then
5864 perl_parse() returns 0, and perl_run() is called. As
5865 PL_main_start will be NULL, perl_run() will return
5866 promptly, and the exit code will remain 0.
5869 PL_comppad_name = 0;
5871 S_op_destroy(aTHX_ o);
5874 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5875 PL_curcop = &PL_compiling;
5876 start = LINKLIST(PL_main_root);
5877 PL_main_root->op_next = 0;
5878 S_process_optree(aTHX_ NULL, PL_main_root, start);
5879 if (!PL_parser->error_count)
5880 /* on error, leave CV slabbed so that ops left lying around
5881 * will eb cleaned up. Else unslab */
5882 cv_forget_slab(PL_compcv);
5885 /* Register with debugger */
5887 CV * const cv = get_cvs("DB::postponed", 0);
5891 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5893 call_sv(MUTABLE_SV(cv), G_DISCARD);
5900 Perl_localize(pTHX_ OP *o, I32 lex)
5902 PERL_ARGS_ASSERT_LOCALIZE;
5904 if (o->op_flags & OPf_PARENS)
5905 /* [perl #17376]: this appears to be premature, and results in code such as
5906 C< our(%x); > executing in list mode rather than void mode */
5913 if ( PL_parser->bufptr > PL_parser->oldbufptr
5914 && PL_parser->bufptr[-1] == ','
5915 && ckWARN(WARN_PARENTHESIS))
5917 char *s = PL_parser->bufptr;
5920 /* some heuristics to detect a potential error */
5921 while (*s && (memCHRs(", \t\n", *s)))
5925 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
5927 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5930 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5932 while (*s && (memCHRs(", \t\n", *s)))
5938 if (sigil && (*s == ';' || *s == '=')) {
5939 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5940 "Parentheses missing around \"%s\" list",
5942 ? (PL_parser->in_my == KEY_our
5944 : PL_parser->in_my == KEY_state
5954 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5955 PL_parser->in_my = FALSE;
5956 PL_parser->in_my_stash = NULL;
5961 Perl_jmaybe(pTHX_ OP *o)
5963 PERL_ARGS_ASSERT_JMAYBE;
5965 if (o->op_type == OP_LIST) {
5966 if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
5968 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5969 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5972 /* If the user disables this, then a warning might not be enough to alert
5973 them to a possible change of behaviour here, so throw an exception.
5975 yyerror("Multidimensional hash lookup is disabled");
5981 PERL_STATIC_INLINE OP *
5982 S_op_std_init(pTHX_ OP *o)
5984 I32 type = o->op_type;
5986 PERL_ARGS_ASSERT_OP_STD_INIT;
5988 if (PL_opargs[type] & OA_RETSCALAR)
5990 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5991 o->op_targ = pad_alloc(type, SVs_PADTMP);
5996 PERL_STATIC_INLINE OP *
5997 S_op_integerize(pTHX_ OP *o)
5999 I32 type = o->op_type;
6001 PERL_ARGS_ASSERT_OP_INTEGERIZE;
6003 /* integerize op. */
6004 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
6006 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
6009 if (type == OP_NEGATE)
6010 /* XXX might want a ck_negate() for this */
6011 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
6016 /* This function exists solely to provide a scope to limit
6017 setjmp/longjmp() messing with auto variables. It cannot be inlined because
6021 S_fold_constants_eval(pTHX) {
6037 S_fold_constants(pTHX_ OP *const o)
6041 I32 type = o->op_type;
6046 SV * const oldwarnhook = PL_warnhook;
6047 SV * const olddiehook = PL_diehook;
6049 U8 oldwarn = PL_dowarn;
6052 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
6054 if (!(PL_opargs[type] & OA_FOLDCONST))
6063 #ifdef USE_LOCALE_CTYPE
6064 if (IN_LC_COMPILETIME(LC_CTYPE))
6073 #ifdef USE_LOCALE_COLLATE
6074 if (IN_LC_COMPILETIME(LC_COLLATE))
6079 /* XXX what about the numeric ops? */
6080 #ifdef USE_LOCALE_NUMERIC
6081 if (IN_LC_COMPILETIME(LC_NUMERIC))
6086 if (!OpHAS_SIBLING(cLISTOPo->op_first)
6087 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
6090 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
6091 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
6093 const char *s = SvPVX_const(sv);
6094 while (s < SvEND(sv)) {
6095 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
6102 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
6105 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
6106 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
6110 if (PL_parser && PL_parser->error_count)
6111 goto nope; /* Don't try to run w/ errors */
6113 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
6114 switch (curop->op_type) {
6116 if ( (curop->op_private & OPpCONST_BARE)
6117 && (curop->op_private & OPpCONST_STRICT)) {
6118 no_bareword_allowed(curop);
6126 /* Foldable; move to next op in list */
6130 /* No other op types are considered foldable */
6135 curop = LINKLIST(o);
6136 old_next = o->op_next;
6140 old_cxix = cxstack_ix;
6141 create_eval_scope(NULL, G_FAKINGEVAL);
6143 /* Verify that we don't need to save it: */
6144 assert(PL_curcop == &PL_compiling);
6145 StructCopy(&PL_compiling, ¬_compiling, COP);
6146 PL_curcop = ¬_compiling;
6147 /* The above ensures that we run with all the correct hints of the
6148 currently compiling COP, but that IN_PERL_RUNTIME is true. */
6149 assert(IN_PERL_RUNTIME);
6150 PL_warnhook = PERL_WARNHOOK_FATAL;
6153 /* Effective $^W=1. */
6154 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6155 PL_dowarn |= G_WARN_ON;
6157 ret = S_fold_constants_eval(aTHX);
6161 sv = *(PL_stack_sp--);
6162 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
6163 pad_swipe(o->op_targ, FALSE);
6165 else if (SvTEMP(sv)) { /* grab mortal temp? */
6166 SvREFCNT_inc_simple_void(sv);
6169 else { assert(SvIMMORTAL(sv)); }
6172 /* Something tried to die. Abandon constant folding. */
6173 /* Pretend the error never happened. */
6175 o->op_next = old_next;
6178 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
6179 PL_warnhook = oldwarnhook;
6180 PL_diehook = olddiehook;
6181 /* XXX note that this croak may fail as we've already blown away
6182 * the stack - eg any nested evals */
6183 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6185 PL_dowarn = oldwarn;
6186 PL_warnhook = oldwarnhook;
6187 PL_diehook = olddiehook;
6188 PL_curcop = &PL_compiling;
6190 /* if we croaked, depending on how we croaked the eval scope
6191 * may or may not have already been popped */
6192 if (cxstack_ix > old_cxix) {
6193 assert(cxstack_ix == old_cxix + 1);
6194 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6195 delete_eval_scope();
6200 /* OP_STRINGIFY and constant folding are used to implement qq.
6201 Here the constant folding is an implementation detail that we
6202 want to hide. If the stringify op is itself already marked
6203 folded, however, then it is actually a folded join. */
6204 is_stringify = type == OP_STRINGIFY && !o->op_folded;
6209 else if (!SvIMMORTAL(sv)) {
6213 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6214 if (!is_stringify) newop->op_folded = 1;
6221 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6222 * the constant value being an AV holding the flattened range.
6226 S_gen_constant_list(pTHX_ OP *o)
6228 OP *curop, *old_next;
6229 SV * const oldwarnhook = PL_warnhook;
6230 SV * const olddiehook = PL_diehook;
6232 U8 oldwarn = PL_dowarn;
6242 if (PL_parser && PL_parser->error_count)
6243 return; /* Don't attempt to run with errors */
6245 curop = LINKLIST(o);
6246 old_next = o->op_next;
6248 op_was_null = o->op_type == OP_NULL;
6249 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6250 o->op_type = OP_CUSTOM;
6253 o->op_type = OP_NULL;
6254 S_prune_chain_head(&curop);
6257 old_cxix = cxstack_ix;
6258 create_eval_scope(NULL, G_FAKINGEVAL);
6260 old_curcop = PL_curcop;
6261 StructCopy(old_curcop, ¬_compiling, COP);
6262 PL_curcop = ¬_compiling;
6263 /* The above ensures that we run with all the correct hints of the
6264 current COP, but that IN_PERL_RUNTIME is true. */
6265 assert(IN_PERL_RUNTIME);
6266 PL_warnhook = PERL_WARNHOOK_FATAL;
6270 /* Effective $^W=1. */
6271 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6272 PL_dowarn |= G_WARN_ON;
6276 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6277 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6279 Perl_pp_pushmark(aTHX);
6282 assert (!(curop->op_flags & OPf_SPECIAL));
6283 assert(curop->op_type == OP_RANGE);
6284 Perl_pp_anonlist(aTHX);
6288 o->op_next = old_next;
6292 PL_warnhook = oldwarnhook;
6293 PL_diehook = olddiehook;
6294 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6299 PL_dowarn = oldwarn;
6300 PL_warnhook = oldwarnhook;
6301 PL_diehook = olddiehook;
6302 PL_curcop = old_curcop;
6304 if (cxstack_ix > old_cxix) {
6305 assert(cxstack_ix == old_cxix + 1);
6306 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6307 delete_eval_scope();
6312 OpTYPE_set(o, OP_RV2AV);
6313 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6314 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6315 o->op_opt = 0; /* needs to be revisited in rpeep() */
6316 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6318 /* replace subtree with an OP_CONST */
6319 curop = ((UNOP*)o)->op_first;
6320 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6323 if (AvFILLp(av) != -1)
6324 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6327 SvREADONLY_on(*svp);
6335 =for apidoc_section $optree_manipulation
6338 /* List constructors */
6341 =for apidoc op_append_elem
6343 Append an item to the list of ops contained directly within a list-type
6344 op, returning the lengthened list. C<first> is the list-type op,
6345 and C<last> is the op to append to the list. C<optype> specifies the
6346 intended opcode for the list. If C<first> is not already a list of the
6347 right type, it will be upgraded into one. If either C<first> or C<last>
6348 is null, the other is returned unchanged.
6354 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6362 if (first->op_type != (unsigned)type
6363 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6365 return newLISTOP(type, 0, first, last);
6368 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6369 first->op_flags |= OPf_KIDS;
6374 =for apidoc op_append_list
6376 Concatenate the lists of ops contained directly within two list-type ops,
6377 returning the combined list. C<first> and C<last> are the list-type ops
6378 to concatenate. C<optype> specifies the intended opcode for the list.
6379 If either C<first> or C<last> is not already a list of the right type,
6380 it will be upgraded into one. If either C<first> or C<last> is null,
6381 the other is returned unchanged.
6387 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6395 if (first->op_type != (unsigned)type)
6396 return op_prepend_elem(type, first, last);
6398 if (last->op_type != (unsigned)type)
6399 return op_append_elem(type, first, last);
6401 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6402 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6403 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6404 first->op_flags |= (last->op_flags & OPf_KIDS);
6406 S_op_destroy(aTHX_ last);
6412 =for apidoc op_prepend_elem
6414 Prepend an item to the list of ops contained directly within a list-type
6415 op, returning the lengthened list. C<first> is the op to prepend to the
6416 list, and C<last> is the list-type op. C<optype> specifies the intended
6417 opcode for the list. If C<last> is not already a list of the right type,
6418 it will be upgraded into one. If either C<first> or C<last> is null,
6419 the other is returned unchanged.
6425 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6433 if (last->op_type == (unsigned)type) {
6434 if (type == OP_LIST) { /* already a PUSHMARK there */
6435 /* insert 'first' after pushmark */
6436 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6437 if (!(first->op_flags & OPf_PARENS))
6438 last->op_flags &= ~OPf_PARENS;
6441 op_sibling_splice(last, NULL, 0, first);
6442 last->op_flags |= OPf_KIDS;
6446 return newLISTOP(type, 0, first, last);
6450 =for apidoc op_convert_list
6452 Converts C<o> into a list op if it is not one already, and then converts it
6453 into the specified C<type>, calling its check function, allocating a target if
6454 it needs one, and folding constants.
6456 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6457 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6458 C<op_convert_list> to make it the right type.
6464 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6466 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6467 if (!o || o->op_type != OP_LIST)
6468 o = force_list(o, 0);
6471 o->op_flags &= ~OPf_WANT;
6472 o->op_private &= ~OPpLVAL_INTRO;
6475 if (!(PL_opargs[type] & OA_MARK))
6476 op_null(cLISTOPo->op_first);
6478 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6479 if (kid2 && kid2->op_type == OP_COREARGS) {
6480 op_null(cLISTOPo->op_first);
6481 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6485 if (type != OP_SPLIT)
6486 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6487 * ck_split() create a real PMOP and leave the op's type as listop
6488 * for now. Otherwise op_free() etc will crash.
6490 OpTYPE_set(o, type);
6492 o->op_flags |= flags;
6493 if (flags & OPf_FOLDED)
6496 o = CHECKOP(type, o);
6497 if (o->op_type != (unsigned)type)
6500 return fold_constants(op_integerize(op_std_init(o)));
6507 =for apidoc_section $optree_construction
6509 =for apidoc newNULLLIST
6511 Constructs, checks, and returns a new C<stub> op, which represents an
6512 empty list expression.
6518 Perl_newNULLLIST(pTHX)
6520 return newOP(OP_STUB, 0);
6523 /* promote o and any siblings to be a list if its not already; i.e.
6531 * pushmark - o - A - B
6533 * If nullit it true, the list op is nulled.
6537 S_force_list(pTHX_ OP *o, bool nullit)
6539 if (!o || o->op_type != OP_LIST) {
6542 /* manually detach any siblings then add them back later */
6543 rest = OpSIBLING(o);
6544 OpLASTSIB_set(o, NULL);
6546 o = newLISTOP(OP_LIST, 0, o, NULL);
6548 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6556 =for apidoc newLISTOP
6558 Constructs, checks, and returns an op of any list type. C<type> is
6559 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6560 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6561 supply up to two ops to be direct children of the list op; they are
6562 consumed by this function and become part of the constructed op tree.
6564 For most list operators, the check function expects all the kid ops to be
6565 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6566 appropriate. What you want to do in that case is create an op of type
6567 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6568 See L</op_convert_list> for more information.
6575 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6578 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6579 * pushmark is banned. So do it now while existing ops are in a
6580 * consistent state, in case they suddenly get freed */
6581 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6583 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6584 || type == OP_CUSTOM);
6586 NewOp(1101, listop, 1, LISTOP);
6587 OpTYPE_set(listop, type);
6590 listop->op_flags = (U8)flags;
6594 else if (!first && last)
6597 OpMORESIB_set(first, last);
6598 listop->op_first = first;
6599 listop->op_last = last;
6602 OpMORESIB_set(pushop, first);
6603 listop->op_first = pushop;
6604 listop->op_flags |= OPf_KIDS;
6606 listop->op_last = pushop;
6608 if (listop->op_last)
6609 OpLASTSIB_set(listop->op_last, (OP*)listop);
6611 return CHECKOP(type, listop);
6617 Constructs, checks, and returns an op of any base type (any type that
6618 has no extra fields). C<type> is the opcode. C<flags> gives the
6619 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6626 Perl_newOP(pTHX_ I32 type, I32 flags)
6630 if (type == -OP_ENTEREVAL) {
6631 type = OP_ENTEREVAL;
6632 flags |= OPpEVAL_BYTES<<8;
6635 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6636 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6637 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6638 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6640 NewOp(1101, o, 1, OP);
6641 OpTYPE_set(o, type);
6642 o->op_flags = (U8)flags;
6645 o->op_private = (U8)(0 | (flags >> 8));
6646 if (PL_opargs[type] & OA_RETSCALAR)
6648 if (PL_opargs[type] & OA_TARGET)
6649 o->op_targ = pad_alloc(type, SVs_PADTMP);
6650 return CHECKOP(type, o);
6656 Constructs, checks, and returns an op of any unary type. C<type> is
6657 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6658 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6659 bits, the eight bits of C<op_private>, except that the bit with value 1
6660 is automatically set. C<first> supplies an optional op to be the direct
6661 child of the unary op; it is consumed by this function and become part
6662 of the constructed op tree.
6664 =for apidoc Amnh||OPf_KIDS
6670 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6674 if (type == -OP_ENTEREVAL) {
6675 type = OP_ENTEREVAL;
6676 flags |= OPpEVAL_BYTES<<8;
6679 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6680 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6681 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6682 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6683 || type == OP_SASSIGN
6684 || type == OP_ENTERTRY
6685 || type == OP_CUSTOM
6686 || type == OP_NULL );
6689 first = newOP(OP_STUB, 0);
6690 if (PL_opargs[type] & OA_MARK)
6691 first = force_list(first, 1);
6693 NewOp(1101, unop, 1, UNOP);
6694 OpTYPE_set(unop, type);
6695 unop->op_first = first;
6696 unop->op_flags = (U8)(flags | OPf_KIDS);
6697 unop->op_private = (U8)(1 | (flags >> 8));
6699 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6700 OpLASTSIB_set(first, (OP*)unop);
6702 unop = (UNOP*) CHECKOP(type, unop);
6706 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6710 =for apidoc newUNOP_AUX
6712 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6713 initialised to C<aux>
6719 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6723 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6724 || type == OP_CUSTOM);
6726 NewOp(1101, unop, 1, UNOP_AUX);
6727 unop->op_type = (OPCODE)type;
6728 unop->op_ppaddr = PL_ppaddr[type];
6729 unop->op_first = first;
6730 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6731 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6734 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6735 OpLASTSIB_set(first, (OP*)unop);
6737 unop = (UNOP_AUX*) CHECKOP(type, unop);
6739 return op_std_init((OP *) unop);
6743 =for apidoc newMETHOP
6745 Constructs, checks, and returns an op of method type with a method name
6746 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6747 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6748 and, shifted up eight bits, the eight bits of C<op_private>, except that
6749 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6750 op which evaluates method name; it is consumed by this function and
6751 become part of the constructed op tree.
6752 Supported optypes: C<OP_METHOD>.
6758 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6761 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6762 || type == OP_CUSTOM);
6764 NewOp(1101, methop, 1, METHOP);
6766 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6767 methop->op_flags = (U8)(flags | OPf_KIDS);
6768 methop->op_u.op_first = dynamic_meth;
6769 methop->op_private = (U8)(1 | (flags >> 8));
6771 if (!OpHAS_SIBLING(dynamic_meth))
6772 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6776 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6777 methop->op_u.op_meth_sv = const_meth;
6778 methop->op_private = (U8)(0 | (flags >> 8));
6779 methop->op_next = (OP*)methop;
6783 methop->op_rclass_targ = 0;
6785 methop->op_rclass_sv = NULL;
6788 OpTYPE_set(methop, type);
6789 return CHECKOP(type, methop);
6793 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6794 PERL_ARGS_ASSERT_NEWMETHOP;
6795 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6799 =for apidoc newMETHOP_named
6801 Constructs, checks, and returns an op of method type with a constant
6802 method name. C<type> is the opcode. C<flags> gives the eight bits of
6803 C<op_flags>, and, shifted up eight bits, the eight bits of
6804 C<op_private>. C<const_meth> supplies a constant method name;
6805 it must be a shared COW string.
6806 Supported optypes: C<OP_METHOD_NAMED>.
6812 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6813 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6814 return newMETHOP_internal(type, flags, NULL, const_meth);
6818 =for apidoc newBINOP
6820 Constructs, checks, and returns an op of any binary type. C<type>
6821 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6822 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6823 the eight bits of C<op_private>, except that the bit with value 1 or
6824 2 is automatically set as required. C<first> and C<last> supply up to
6825 two ops to be the direct children of the binary op; they are consumed
6826 by this function and become part of the constructed op tree.
6832 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6836 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6837 || type == OP_NULL || type == OP_CUSTOM);
6839 NewOp(1101, binop, 1, BINOP);
6842 first = newOP(OP_NULL, 0);
6844 OpTYPE_set(binop, type);
6845 binop->op_first = first;
6846 binop->op_flags = (U8)(flags | OPf_KIDS);
6849 binop->op_private = (U8)(1 | (flags >> 8));
6852 binop->op_private = (U8)(2 | (flags >> 8));
6853 OpMORESIB_set(first, last);
6856 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6857 OpLASTSIB_set(last, (OP*)binop);
6859 binop->op_last = OpSIBLING(binop->op_first);
6861 OpLASTSIB_set(binop->op_last, (OP*)binop);
6863 binop = (BINOP*)CHECKOP(type, binop);
6864 if (binop->op_next || binop->op_type != (OPCODE)type)
6867 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6871 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
6873 const char indent[] = " ";
6875 UV len = _invlist_len(invlist);
6876 UV * array = invlist_array(invlist);
6879 PERL_ARGS_ASSERT_INVMAP_DUMP;
6881 for (i = 0; i < len; i++) {
6882 UV start = array[i];
6883 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
6885 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
6886 if (end == IV_MAX) {
6887 PerlIO_printf(Perl_debug_log, " .. INFTY");
6889 else if (end != start) {
6890 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
6893 PerlIO_printf(Perl_debug_log, " ");
6896 PerlIO_printf(Perl_debug_log, "\t");
6898 if (map[i] == TR_UNLISTED) {
6899 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
6901 else if (map[i] == TR_SPECIAL_HANDLING) {
6902 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
6905 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
6910 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6911 * containing the search and replacement strings, assemble into
6912 * a translation table attached as o->op_pv.
6913 * Free expr and repl.
6914 * It expects the toker to have already set the
6915 * OPpTRANS_COMPLEMENT
6918 * flags as appropriate; this function may add
6920 * OPpTRANS_CAN_FORCE_UTF8
6921 * OPpTRANS_IDENTICAL
6927 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6929 /* This function compiles a tr///, from data gathered from toke.c, into a
6930 * form suitable for use by do_trans() in doop.c at runtime.
6932 * It first normalizes the data, while discarding extraneous inputs; then
6933 * writes out the compiled data. The normalization allows for complete
6934 * analysis, and avoids some false negatives and positives earlier versions
6937 * The normalization form is an inversion map (described below in detail).
6938 * This is essentially the compiled form for tr///'s that require UTF-8,
6939 * and its easy to use it to write the 257-byte table for tr///'s that
6940 * don't need UTF-8. That table is identical to what's been in use for
6941 * many perl versions, except that it doesn't handle some edge cases that
6942 * it used to, involving code points above 255. The UTF-8 form now handles
6943 * these. (This could be changed with extra coding should it shown to be
6946 * If the complement (/c) option is specified, the lhs string (tstr) is
6947 * parsed into an inversion list. Complementing these is trivial. Then a
6948 * complemented tstr is built from that, and used thenceforth. This hides
6949 * the fact that it was complemented from almost all successive code.
6951 * One of the important characteristics to know about the input is whether
6952 * the transliteration may be done in place, or does a temporary need to be
6953 * allocated, then copied. If the replacement for every character in every
6954 * possible string takes up no more bytes than the character it
6955 * replaces, then it can be edited in place. Otherwise the replacement
6956 * could overwrite a byte we are about to read, depending on the strings
6957 * being processed. The comments and variable names here refer to this as
6958 * "growing". Some inputs won't grow, and might even shrink under /d, but
6959 * some inputs could grow, so we have to assume any given one might grow.
6960 * On very long inputs, the temporary could eat up a lot of memory, so we
6961 * want to avoid it if possible. For non-UTF-8 inputs, everything is
6962 * single-byte, so can be edited in place, unless there is something in the
6963 * pattern that could force it into UTF-8. The inversion map makes it
6964 * feasible to determine this. Previous versions of this code pretty much
6965 * punted on determining if UTF-8 could be edited in place. Now, this code
6966 * is rigorous in making that determination.
6968 * Another characteristic we need to know is whether the lhs and rhs are
6969 * identical. If so, and no other flags are present, the only effect of
6970 * the tr/// is to count the characters present in the input that are
6971 * mentioned in the lhs string. The implementation of that is easier and
6972 * runs faster than the more general case. Normalizing here allows for
6973 * accurate determination of this. Previously there were false negatives
6976 * Instead of 'transliterated', the comments here use 'unmapped' for the
6977 * characters that are left unchanged by the operation; otherwise they are
6980 * The lhs of the tr/// is here referred to as the t side.
6981 * The rhs of the tr/// is here referred to as the r side.
6984 SV * const tstr = ((SVOP*)expr)->op_sv;
6985 SV * const rstr = ((SVOP*)repl)->op_sv;
6988 const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
6989 const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
6992 UV t_count = 0, r_count = 0; /* Number of characters in search and
6993 replacement lists */
6995 /* khw thinks some of the private flags for this op are quaintly named.
6996 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
6997 * character when represented in UTF-8 is longer than the original
6998 * character's UTF-8 representation */
6999 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
7000 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
7001 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
7003 /* Set to true if there is some character < 256 in the lhs that maps to
7004 * above 255. If so, a non-UTF-8 match string can be forced into being in
7005 * UTF-8 by a tr/// operation. */
7006 bool can_force_utf8 = FALSE;
7008 /* What is the maximum expansion factor in UTF-8 transliterations. If a
7009 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
7010 * expansion factor is 1.5. This number is used at runtime to calculate
7011 * how much space to allocate for non-inplace transliterations. Without
7012 * this number, the worst case is 14, which is extremely unlikely to happen
7013 * in real life, and could require significant memory overhead. */
7014 NV max_expansion = 1.;
7016 UV t_range_count, r_range_count, min_range_count;
7020 UV r_cp = 0, t_cp = 0;
7021 UV t_cp_end = (UV) -1;
7025 UV final_map = TR_UNLISTED; /* The final character in the replacement
7026 list, updated as we go along. Initialize
7027 to something illegal */
7029 bool rstr_utf8 = cBOOL(SvUTF8(rstr));
7030 bool tstr_utf8 = cBOOL(SvUTF8(tstr));
7032 const U8* tend = t + tlen;
7033 const U8* rend = r + rlen;
7035 SV * inverted_tstr = NULL;
7040 /* This routine implements detection of a transliteration having a longer
7041 * UTF-8 representation than its source, by partitioning all the possible
7042 * code points of the platform into equivalence classes of the same UTF-8
7043 * byte length in the first pass. As it constructs the mappings, it carves
7044 * these up into smaller chunks, but doesn't merge any together. This
7045 * makes it easy to find the instances it's looking for. A second pass is
7046 * done after this has been determined which merges things together to
7047 * shrink the table for runtime. The table below is used for both ASCII
7048 * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically
7049 * increasing for code points below 256. To correct for that, the macro
7050 * CP_ADJUST defined below converts those code points to ASCII in the first
7051 * pass, and we use the ASCII partition values. That works because the
7052 * growth factor will be unaffected, which is all that is calculated during
7053 * the first pass. */
7054 UV PL_partition_by_byte_length[] = {
7056 0x80, /* Below this is 1 byte representations */
7057 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */
7058 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */
7059 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */
7060 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */
7061 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */
7065 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */
7070 PERL_ARGS_ASSERT_PMTRANS;
7072 PL_hints |= HINT_BLOCK_SCOPE;
7074 /* If /c, the search list is sorted and complemented. This is now done by
7075 * creating an inversion list from it, and then trivially inverting that.
7076 * The previous implementation used qsort, but creating the list
7077 * automatically keeps it sorted as we go along */
7080 SV * inverted_tlist = _new_invlist(tlen);
7083 DEBUG_y(PerlIO_printf(Perl_debug_log,
7084 "%s: %d: tstr before inversion=\n%s\n",
7085 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7089 /* Non-utf8 strings don't have ranges, so each character is listed
7092 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
7095 else { /* But UTF-8 strings have been parsed in toke.c to have
7096 * ranges if appropriate. */
7100 /* Get the first character */
7101 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7104 /* If the next byte indicates that this wasn't the first
7105 * element of a range, the range is just this one */
7106 if (t >= tend || *t != RANGE_INDICATOR) {
7107 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
7109 else { /* Otherwise, ignore the indicator byte, and get the
7110 final element, and add the whole range */
7112 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
7115 inverted_tlist = _add_range_to_invlist(inverted_tlist,
7119 } /* End of parse through tstr */
7121 /* The inversion list is done; now invert it */
7122 _invlist_invert(inverted_tlist);
7124 /* Now go through the inverted list and create a new tstr for the rest
7125 * of the routine to use. Since the UTF-8 version can have ranges, and
7126 * can be much more compact than the non-UTF-8 version, we create the
7127 * string in UTF-8 even if not necessary. (This is just an intermediate
7128 * value that gets thrown away anyway.) */
7129 invlist_iterinit(inverted_tlist);
7130 inverted_tstr = newSVpvs("");
7131 while (invlist_iternext(inverted_tlist, &start, &end)) {
7132 U8 temp[UTF8_MAXBYTES];
7135 /* IV_MAX keeps things from going out of bounds */
7136 start = MIN(IV_MAX, start);
7137 end = MIN(IV_MAX, end);
7139 temp_end_pos = uvchr_to_utf8(temp, start);
7140 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7143 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
7144 temp_end_pos = uvchr_to_utf8(temp, end);
7145 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7149 /* Set up so the remainder of the routine uses this complement, instead
7150 * of the actual input */
7151 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
7152 tend = t0 + temp_len;
7155 SvREFCNT_dec_NN(inverted_tlist);
7158 /* For non-/d, an empty rhs means to use the lhs */
7159 if (rlen == 0 && ! del) {
7162 rstr_utf8 = tstr_utf8;
7165 t_invlist = _new_invlist(1);
7167 /* Initialize to a single range */
7168 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7170 /* For the first pass, the lhs is partitioned such that the
7171 * number of UTF-8 bytes required to represent a code point in each
7172 * partition is the same as the number for any other code point in
7173 * that partion. We copy the pre-compiled partion. */
7174 len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
7175 invlist_extend(t_invlist, len);
7176 t_array = invlist_array(t_invlist);
7177 Copy(PL_partition_by_byte_length, t_array, len, UV);
7178 invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
7179 Newx(r_map, len + 1, UV);
7181 /* Parse the (potentially adjusted) input, creating the inversion map.
7182 * This is done in two passes. The first pass is to determine if the
7183 * transliteration can be done in place. The inversion map it creates
7184 * could be used, but generally would be larger and slower to run than the
7185 * output of the second pass, which starts with a more compact table and
7186 * allows more ranges to be merged */
7187 for (pass2 = 0; pass2 < 2; pass2++) {
7189 /* Initialize to a single range */
7190 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7192 /* In the second pass, we just have the single range */
7194 t_array = invlist_array(t_invlist);
7197 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
7198 * so as to get the well-behaved length 1 vs length 2 boundary. Only code
7199 * points below 256 differ between the two character sets in this regard. For
7200 * these, we also can't have any ranges, as they have to be individually
7203 # define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x))
7204 # define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256))
7205 # define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
7207 # define CP_ADJUST(x) (x)
7208 # define FORCE_RANGE_LEN_1(x) 0
7209 # define CP_SKIP(x) UVCHR_SKIP(x)
7212 /* And the mapping of each of the ranges is initialized. Initially,
7213 * everything is TR_UNLISTED. */
7214 for (i = 0; i < len; i++) {
7215 r_map[i] = TR_UNLISTED;
7222 t_range_count = r_range_count = 0;
7224 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
7225 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7226 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
7227 _byte_dump_string(r, rend - r, 0)));
7228 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
7229 complement, squash, del));
7230 DEBUG_y(invmap_dump(t_invlist, r_map));
7232 /* Now go through the search list constructing an inversion map. The
7233 * input is not necessarily in any particular order. Making it an
7234 * inversion map orders it, potentially simplifying, and makes it easy
7235 * to deal with at run time. This is the only place in core that
7236 * generates an inversion map; if others were introduced, it might be
7237 * better to create general purpose routines to handle them.
7238 * (Inversion maps are created in perl in other places.)
7240 * An inversion map consists of two parallel arrays. One is
7241 * essentially an inversion list: an ordered list of code points such
7242 * that each element gives the first code point of a range of
7243 * consecutive code points that map to the element in the other array
7244 * that has the same index as this one (in other words, the
7245 * corresponding element). Thus the range extends up to (but not
7246 * including) the code point given by the next higher element. In a
7247 * true inversion map, the corresponding element in the other array
7248 * gives the mapping of the first code point in the range, with the
7249 * understanding that the next higher code point in the inversion
7250 * list's range will map to the next higher code point in the map.
7252 * So if at element [i], let's say we have:
7257 * This means that A => a, B => b, C => c.... Let's say that the
7258 * situation is such that:
7262 * This means the sequence that started at [i] stops at K => k. This
7263 * illustrates that you need to look at the next element to find where
7264 * a sequence stops. Except, the highest element in the inversion list
7265 * begins a range that is understood to extend to the platform's
7268 * This routine modifies traditional inversion maps to reserve two
7271 * TR_UNLISTED (or -1) indicates that no code point in the range
7272 * is listed in the tr/// searchlist. At runtime, these are
7273 * always passed through unchanged. In the inversion map, all
7274 * points in the range are mapped to -1, instead of increasing,
7275 * like the 'L' in the example above.
7277 * We start the parse with every code point mapped to this, and as
7278 * we parse and find ones that are listed in the search list, we
7279 * carve out ranges as we go along that override that.
7281 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
7282 * range needs special handling. Again, all code points in the
7283 * range are mapped to -2, instead of increasing.
7285 * Under /d this value means the code point should be deleted from
7286 * the transliteration when encountered.
7288 * Otherwise, it marks that every code point in the range is to
7289 * map to the final character in the replacement list. This
7290 * happens only when the replacement list is shorter than the
7291 * search one, so there are things in the search list that have no
7292 * correspondence in the replacement list. For example, in
7293 * tr/a-z/A/, 'A' is the final value, and the inversion map
7294 * generated for this would be like this:
7299 * 'A' appears once, then the remainder of the range maps to -2.
7300 * The use of -2 isn't strictly necessary, as an inversion map is
7301 * capable of representing this situation, but not nearly so
7302 * compactly, and this is actually quite commonly encountered.
7303 * Indeed, the original design of this code used a full inversion
7304 * map for this. But things like
7306 * generated huge data structures, slowly, and the execution was
7307 * also slow. So the current scheme was implemented.
7309 * So, if the next element in our example is:
7313 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next
7317 * [i+4] S TR_UNLISTED
7319 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is
7320 * the final element in the arrays, every code point from S to infinity
7321 * maps to TR_UNLISTED.
7324 /* Finish up range started in what otherwise would
7325 * have been the final iteration */
7326 while (t < tend || t_range_count > 0) {
7327 bool adjacent_to_range_above = FALSE;
7328 bool adjacent_to_range_below = FALSE;
7330 bool merge_with_range_above = FALSE;
7331 bool merge_with_range_below = FALSE;
7333 UV span, invmap_range_length_remaining;
7337 /* If we are in the middle of processing a range in the 'target'
7338 * side, the previous iteration has set us up. Otherwise, look at
7339 * the next character in the search list */
7340 if (t_range_count <= 0) {
7343 /* Here, not in the middle of a range, and not UTF-8. The
7344 * next code point is the single byte where we're at */
7345 t_cp = CP_ADJUST(*t);
7352 /* Here, not in the middle of a range, and is UTF-8. The
7353 * next code point is the next UTF-8 char in the input. We
7354 * know the input is valid, because the toker constructed
7356 t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
7359 /* UTF-8 strings (only) have been parsed in toke.c to have
7360 * ranges. See if the next byte indicates that this was
7361 * the first element of a range. If so, get the final
7362 * element and calculate the range size. If not, the range
7364 if ( t < tend && *t == RANGE_INDICATOR
7365 && ! FORCE_RANGE_LEN_1(t_cp))
7368 t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
7377 /* Count the total number of listed code points * */
7378 t_count += t_range_count;
7381 /* Similarly, get the next character in the replacement list */
7382 if (r_range_count <= 0) {
7385 /* But if we've exhausted the rhs, there is nothing to map
7386 * to, except the special handling one, and we make the
7387 * range the same size as the lhs one. */
7388 r_cp = TR_SPECIAL_HANDLING;
7389 r_range_count = t_range_count;
7392 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7393 "final_map =%" UVXf "\n", final_map));
7398 r_cp = CP_ADJUST(*r);
7405 r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
7407 if ( r < rend && *r == RANGE_INDICATOR
7408 && ! FORCE_RANGE_LEN_1(r_cp))
7411 r_range_count = valid_utf8_to_uvchr(r,
7412 &r_char_len) - r_cp + 1;
7420 if (r_cp == TR_SPECIAL_HANDLING) {
7421 r_range_count = t_range_count;
7424 /* This is the final character so far */
7425 final_map = r_cp + r_range_count - 1;
7427 r_count += r_range_count;
7431 /* Here, we have the next things ready in both sides. They are
7432 * potentially ranges. We try to process as big a chunk as
7433 * possible at once, but the lhs and rhs must be synchronized, so
7434 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
7436 min_range_count = MIN(t_range_count, r_range_count);
7438 /* Search the inversion list for the entry that contains the input
7439 * code point <cp>. The inversion map was initialized to cover the
7440 * entire range of possible inputs, so this should not fail. So
7441 * the return value is the index into the list's array of the range
7442 * that contains <cp>, that is, 'i' such that array[i] <= cp <
7444 j = _invlist_search(t_invlist, t_cp);
7448 /* Here, the data structure might look like:
7451 * [i-1] J j # J-L => j-l
7452 * [i] M -1 # M => default; as do N, O, P, Q
7453 * [i+1] R x # R => x, S => x+1, T => x+2
7454 * [i+2] U y # U => y, V => y+1, ...
7456 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7458 * where 'x' and 'y' above are not to be taken literally.
7460 * The maximum chunk we can handle in this loop iteration, is the
7461 * smallest of the three components: the lhs 't_', the rhs 'r_',
7462 * and the remainder of the range in element [i]. (In pass 1, that
7463 * range will have everything in it be of the same class; we can't
7464 * cross into another class.) 'min_range_count' already contains
7465 * the smallest of the first two values. The final one is
7466 * irrelevant if the map is to the special indicator */
7468 invmap_range_length_remaining = (i + 1 < len)
7469 ? t_array[i+1] - t_cp
7471 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
7473 /* The end point of this chunk is where we are, plus the span, but
7474 * never larger than the platform's infinity */
7475 t_cp_end = MIN(IV_MAX, t_cp + span - 1);
7477 if (r_cp == TR_SPECIAL_HANDLING) {
7479 /* If unmatched lhs code points map to the final map, use that
7480 * value. This being set to TR_SPECIAL_HANDLING indicates that
7481 * we don't have a final map: unmatched lhs code points are
7483 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
7486 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
7488 /* If something on the lhs is below 256, and something on the
7489 * rhs is above, there is a potential mapping here across that
7490 * boundary. Indeed the only way there isn't is if both sides
7491 * start at the same point. That means they both cross at the
7492 * same time. But otherwise one crosses before the other */
7493 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
7494 can_force_utf8 = TRUE;
7498 /* If a character appears in the search list more than once, the
7499 * 2nd and succeeding occurrences are ignored, so only do this
7500 * range if haven't already processed this character. (The range
7501 * has been set up so that all members in it will be of the same
7503 if (r_map[i] == TR_UNLISTED) {
7504 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7505 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
7506 t_cp, t_cp_end, r_cp, r_cp_end));
7508 /* This is the first definition for this chunk, hence is valid
7509 * and needs to be processed. Here and in the comments below,
7510 * we use the above sample data. The t_cp chunk must be any
7511 * contiguous subset of M, N, O, P, and/or Q.
7513 * In the first pass, calculate if there is any possible input
7514 * string that has a character whose transliteration will be
7515 * longer than it. If none, the transliteration may be done
7516 * in-place, as it can't write over a so-far unread byte.
7517 * Otherwise, a copy must first be made. This could be
7518 * expensive for long inputs.
7520 * In the first pass, the t_invlist has been partitioned so
7521 * that all elements in any single range have the same number
7522 * of bytes in their UTF-8 representations. And the r space is
7523 * either a single byte, or a range of strictly monotonically
7524 * increasing code points. So the final element in the range
7525 * will be represented by no fewer bytes than the initial one.
7526 * That means that if the final code point in the t range has
7527 * at least as many bytes as the final code point in the r,
7528 * then all code points in the t range have at least as many
7529 * bytes as their corresponding r range element. But if that's
7530 * not true, the transliteration of at least the final code
7531 * point grows in length. As an example, suppose we had
7532 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
7533 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
7534 * platforms. We have deliberately set up the data structure
7535 * so that any range in the lhs gets split into chunks for
7536 * processing, such that every code point in a chunk has the
7537 * same number of UTF-8 bytes. We only have to check the final
7538 * code point in the rhs against any code point in the lhs. */
7540 && r_cp_end != TR_SPECIAL_HANDLING
7541 && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
7543 /* Here, we will need to make a copy of the input string
7544 * before doing the transliteration. The worst possible
7545 * case is an expansion ratio of 14:1. This is rare, and
7546 * we'd rather allocate only the necessary amount of extra
7547 * memory for that copy. We can calculate the worst case
7548 * for this particular transliteration is by keeping track
7549 * of the expansion factor for each range.
7551 * Consider tr/\xCB/\X{E000}/. The maximum expansion
7552 * factor is 1 byte going to 3 if the target string is not
7553 * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We
7554 * could pass two different values so doop could choose
7555 * based on the UTF-8ness of the target. But khw thinks
7556 * (perhaps wrongly) that is overkill. It is used only to
7557 * make sure we malloc enough space.
7559 * If no target string can force the result to be UTF-8,
7560 * then we don't have to worry about the case of the target
7561 * string not being UTF-8 */
7562 NV t_size = (can_force_utf8 && t_cp < 256)
7564 : CP_SKIP(t_cp_end);
7565 NV ratio = CP_SKIP(r_cp_end) / t_size;
7567 o->op_private |= OPpTRANS_GROWS;
7569 /* Now that we know it grows, we can keep track of the
7571 if (ratio > max_expansion) {
7572 max_expansion = ratio;
7573 DEBUG_y(PerlIO_printf(Perl_debug_log,
7574 "New expansion factor: %" NVgf "\n",
7579 /* The very first range is marked as adjacent to the
7580 * non-existent range below it, as it causes things to "just
7583 * If the lowest code point in this chunk is M, it adjoins the
7585 if (t_cp == t_array[i]) {
7586 adjacent_to_range_below = TRUE;
7588 /* And if the map has the same offset from the beginning of
7589 * the range as does this new code point (or both are for
7590 * TR_SPECIAL_HANDLING), this chunk can be completely
7591 * merged with the range below. EXCEPT, in the first pass,
7592 * we don't merge ranges whose UTF-8 byte representations
7593 * have different lengths, so that we can more easily
7594 * detect if a replacement is longer than the source, that
7595 * is if it 'grows'. But in the 2nd pass, there's no
7596 * reason to not merge */
7597 if ( (i > 0 && ( pass2
7598 || CP_SKIP(t_array[i-1])
7600 && ( ( r_cp == TR_SPECIAL_HANDLING
7601 && r_map[i-1] == TR_SPECIAL_HANDLING)
7602 || ( r_cp != TR_SPECIAL_HANDLING
7603 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
7605 merge_with_range_below = TRUE;
7609 /* Similarly, if the highest code point in this chunk is 'Q',
7610 * it adjoins the range above, and if the map is suitable, can
7611 * be merged with it */
7612 if ( t_cp_end >= IV_MAX - 1
7614 && t_cp_end + 1 == t_array[i+1]))
7616 adjacent_to_range_above = TRUE;
7619 || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
7620 && ( ( r_cp == TR_SPECIAL_HANDLING
7621 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
7622 || ( r_cp != TR_SPECIAL_HANDLING
7623 && r_cp_end == r_map[i+1] - 1)))
7625 merge_with_range_above = TRUE;
7629 if (merge_with_range_below && merge_with_range_above) {
7631 /* Here the new chunk looks like M => m, ... Q => q; and
7632 * the range above is like R => r, .... Thus, the [i-1]
7633 * and [i+1] ranges should be seamlessly melded so the
7636 * [i-1] J j # J-T => j-t
7637 * [i] U y # U => y, V => y+1, ...
7639 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7641 Move(t_array + i + 2, t_array + i, len - i - 2, UV);
7642 Move(r_map + i + 2, r_map + i, len - i - 2, UV);
7644 invlist_set_len(t_invlist,
7646 *(get_invlist_offset_addr(t_invlist)));
7648 else if (merge_with_range_below) {
7650 /* Here the new chunk looks like M => m, .... But either
7651 * (or both) it doesn't extend all the way up through Q; or
7652 * the range above doesn't start with R => r. */
7653 if (! adjacent_to_range_above) {
7655 /* In the first case, let's say the new chunk extends
7656 * through O. We then want:
7658 * [i-1] J j # J-O => j-o
7659 * [i] P -1 # P => -1, Q => -1
7660 * [i+1] R x # R => x, S => x+1, T => x+2
7661 * [i+2] U y # U => y, V => y+1, ...
7663 * [-1] Z -1 # Z => default; as do Z+1, ...
7666 t_array[i] = t_cp_end + 1;
7667 r_map[i] = TR_UNLISTED;
7669 else { /* Adjoins the range above, but can't merge with it
7670 (because 'x' is not the next map after q) */
7672 * [i-1] J j # J-Q => j-q
7673 * [i] R x # R => x, S => x+1, T => x+2
7674 * [i+1] U y # U => y, V => y+1, ...
7676 * [-1] Z -1 # Z => default; as do Z+1, ...
7680 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7681 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7683 invlist_set_len(t_invlist, len,
7684 *(get_invlist_offset_addr(t_invlist)));
7687 else if (merge_with_range_above) {
7689 /* Here the new chunk ends with Q => q, and the range above
7690 * must start with R => r, so the two can be merged. But
7691 * either (or both) the new chunk doesn't extend all the
7692 * way down to M; or the mapping of the final code point
7693 * range below isn't m */
7694 if (! adjacent_to_range_below) {
7696 /* In the first case, let's assume the new chunk starts
7697 * with P => p. Then, because it's merge-able with the
7698 * range above, that range must be R => r. We want:
7700 * [i-1] J j # J-L => j-l
7701 * [i] M -1 # M => -1, N => -1
7702 * [i+1] P p # P-T => p-t
7703 * [i+2] U y # U => y, V => y+1, ...
7705 * [-1] Z -1 # Z => default; as do Z+1, ...
7708 t_array[i+1] = t_cp;
7711 else { /* Adjoins the range below, but can't merge with it
7714 * [i-1] J j # J-L => j-l
7715 * [i] M x # M-T => x-5 .. x+2
7716 * [i+1] U y # U => y, V => y+1, ...
7718 * [-1] Z -1 # Z => default; as do Z+1, ...
7721 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7722 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7726 invlist_set_len(t_invlist, len,
7727 *(get_invlist_offset_addr(t_invlist)));
7730 else if (adjacent_to_range_below && adjacent_to_range_above) {
7731 /* The new chunk completely fills the gap between the
7732 * ranges on either side, but can't merge with either of
7735 * [i-1] J j # J-L => j-l
7736 * [i] M z # M => z, N => z+1 ... Q => z+4
7737 * [i+1] R x # R => x, S => x+1, T => x+2
7738 * [i+2] U y # U => y, V => y+1, ...
7740 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7744 else if (adjacent_to_range_below) {
7745 /* The new chunk adjoins the range below, but not the range
7746 * above, and can't merge. Let's assume the chunk ends at
7749 * [i-1] J j # J-L => j-l
7750 * [i] M z # M => z, N => z+1, O => z+2
7751 * [i+1] P -1 # P => -1, Q => -1
7752 * [i+2] R x # R => x, S => x+1, T => x+2
7753 * [i+3] U y # U => y, V => y+1, ...
7755 * [-w] Z -1 # Z => default; as do Z+1, ... infinity
7757 invlist_extend(t_invlist, len + 1);
7758 t_array = invlist_array(t_invlist);
7759 Renew(r_map, len + 1, UV);
7761 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7762 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7764 t_array[i+1] = t_cp_end + 1;
7765 r_map[i+1] = TR_UNLISTED;
7767 invlist_set_len(t_invlist, len,
7768 *(get_invlist_offset_addr(t_invlist)));
7770 else if (adjacent_to_range_above) {
7771 /* The new chunk adjoins the range above, but not the range
7772 * below, and can't merge. Let's assume the new chunk
7775 * [i-1] J j # J-L => j-l
7776 * [i] M -1 # M => default, N => default
7777 * [i+1] O z # O => z, P => z+1, Q => z+2
7778 * [i+2] R x # R => x, S => x+1, T => x+2
7779 * [i+3] U y # U => y, V => y+1, ...
7781 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7783 invlist_extend(t_invlist, len + 1);
7784 t_array = invlist_array(t_invlist);
7785 Renew(r_map, len + 1, UV);
7787 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7788 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7789 t_array[i+1] = t_cp;
7792 invlist_set_len(t_invlist, len,
7793 *(get_invlist_offset_addr(t_invlist)));
7796 /* The new chunk adjoins neither the range above, nor the
7797 * range below. Lets assume it is N..P => n..p
7799 * [i-1] J j # J-L => j-l
7800 * [i] M -1 # M => default
7801 * [i+1] N n # N..P => n..p
7802 * [i+2] Q -1 # Q => default
7803 * [i+3] R x # R => x, S => x+1, T => x+2
7804 * [i+4] U y # U => y, V => y+1, ...
7806 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7809 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7810 "Before fixing up: len=%d, i=%d\n",
7811 (int) len, (int) i));
7812 DEBUG_yv(invmap_dump(t_invlist, r_map));
7814 invlist_extend(t_invlist, len + 2);
7815 t_array = invlist_array(t_invlist);
7816 Renew(r_map, len + 2, UV);
7818 Move(t_array + i + 1,
7819 t_array + i + 2 + 1, len - i - (2 - 1), UV);
7821 r_map + i + 2 + 1, len - i - (2 - 1), UV);
7824 invlist_set_len(t_invlist, len,
7825 *(get_invlist_offset_addr(t_invlist)));
7827 t_array[i+1] = t_cp;
7830 t_array[i+2] = t_cp_end + 1;
7831 r_map[i+2] = TR_UNLISTED;
7833 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7834 "After iteration: span=%" UVuf ", t_range_count=%"
7835 UVuf " r_range_count=%" UVuf "\n",
7836 span, t_range_count, r_range_count));
7837 DEBUG_yv(invmap_dump(t_invlist, r_map));
7838 } /* End of this chunk needs to be processed */
7840 /* Done with this chunk. */
7842 if (t_cp >= IV_MAX) {
7845 t_range_count -= span;
7846 if (r_cp != TR_SPECIAL_HANDLING) {
7848 r_range_count -= span;
7854 } /* End of loop through the search list */
7856 /* We don't need an exact count, but we do need to know if there is
7857 * anything left over in the replacement list. So, just assume it's
7858 * one byte per character */
7862 } /* End of passes */
7864 SvREFCNT_dec(inverted_tstr);
7866 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
7867 DEBUG_y(invmap_dump(t_invlist, r_map));
7869 /* We now have normalized the input into an inversion map.
7871 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op
7872 * except for the count, and streamlined runtime code can be used */
7873 if (!del && !squash) {
7875 /* They are identical if they point to same address, or if everything
7876 * maps to UNLISTED or to itself. This catches things that not looking
7877 * at the normalized inversion map doesn't catch, like tr/aa/ab/ or
7878 * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */
7880 for (i = 0; i < len; i++) {
7881 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
7882 goto done_identical_check;
7887 /* Here have gone through entire list, and didn't find any
7888 * non-identical mappings */
7889 o->op_private |= OPpTRANS_IDENTICAL;
7891 done_identical_check: ;
7894 t_array = invlist_array(t_invlist);
7896 /* If has components above 255, we generally need to use the inversion map
7900 && t_array[len-1] > 255
7901 /* If the final range is 0x100-INFINITY and is a special
7902 * mapping, the table implementation can handle it */
7903 && ! ( t_array[len-1] == 256
7904 && ( r_map[len-1] == TR_UNLISTED
7905 || r_map[len-1] == TR_SPECIAL_HANDLING))))
7909 /* A UTF-8 op is generated, indicated by this flag. This op is an
7911 o->op_private |= OPpTRANS_USE_SVOP;
7913 if (can_force_utf8) {
7914 o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
7917 /* The inversion map is pushed; first the list. */
7918 invmap = MUTABLE_AV(newAV());
7919 av_push(invmap, t_invlist);
7921 /* 2nd is the mapping */
7922 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
7923 av_push(invmap, r_map_sv);
7925 /* 3rd is the max possible expansion factor */
7926 av_push(invmap, newSVnv(max_expansion));
7928 /* Characters that are in the search list, but not in the replacement
7929 * list are mapped to the final character in the replacement list */
7930 if (! del && r_count < t_count) {
7931 av_push(invmap, newSVuv(final_map));
7935 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
7936 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
7937 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
7938 SvPADTMP_on(invmap);
7939 SvREADONLY_on(invmap);
7941 cSVOPo->op_sv = (SV *) invmap;
7949 /* The OPtrans_map struct already contains one slot; hence the -1. */
7950 SSize_t struct_size = sizeof(OPtrans_map)
7951 + (256 - 1 + 1)*sizeof(short);
7953 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
7954 * table. Entries with the value TR_UNMAPPED indicate chars not to be
7955 * translated, while TR_DELETE indicates a search char without a
7956 * corresponding replacement char under /d.
7958 * In addition, an extra slot at the end is used to store the final
7959 * repeating char, or TR_R_EMPTY under an empty replacement list, or
7960 * TR_DELETE under /d; which makes the runtime code easier.
7963 /* Indicate this is an op_pv */
7964 o->op_private &= ~OPpTRANS_USE_SVOP;
7966 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7968 cPVOPo->op_pv = (char*)tbl;
7970 for (i = 0; i < len; i++) {
7971 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7972 short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7973 short to = (short) r_map[i];
7975 bool do_increment = TRUE;
7977 /* Any code points above our limit should be irrelevant */
7978 if (t_array[i] >= tbl->size) break;
7980 /* Set up the map */
7981 if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7982 to = (short) final_map;
7983 do_increment = FALSE;
7986 do_increment = FALSE;
7989 /* Create a map for everything in this range. The value increases
7990 * except for the special cases */
7991 for (j = (short) t_array[i]; j < upper; j++) {
7993 if (do_increment) to++;
7997 tbl->map[tbl->size] = del
8001 : (short) TR_R_EMPTY;
8002 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
8003 for (i = 0; i < tbl->size; i++) {
8004 if (tbl->map[i] < 0) {
8005 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
8006 (unsigned) i, tbl->map[i]));
8009 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
8010 (unsigned) i, tbl->map[i]));
8012 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
8013 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
8016 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
8017 (unsigned) tbl->size, tbl->map[tbl->size]));
8019 SvREFCNT_dec(t_invlist);
8021 #if 0 /* code that added excess above-255 chars at the end of the table, in
8022 case we ever want to not use the inversion map implementation for
8029 /* More replacement chars than search chars:
8030 * store excess replacement chars at end of main table.
8033 struct_size += excess;
8034 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
8035 struct_size + excess * sizeof(short));
8036 tbl->size += excess;
8037 cPVOPo->op_pv = (char*)tbl;
8039 for (i = 0; i < excess; i++)
8040 tbl->map[i + 256] = r[j+i];
8043 /* no more replacement chars than search chars */
8049 DEBUG_y(PerlIO_printf(Perl_debug_log,
8050 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
8051 " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
8052 del, squash, complement,
8053 cBOOL(o->op_private & OPpTRANS_IDENTICAL),
8054 cBOOL(o->op_private & OPpTRANS_USE_SVOP),
8055 cBOOL(o->op_private & OPpTRANS_GROWS),
8056 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
8061 if(del && rlen != 0 && r_count == t_count) {
8062 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
8063 } else if(r_count > t_count) {
8064 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
8077 Constructs, checks, and returns an op of any pattern matching type.
8078 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
8079 and, shifted up eight bits, the eight bits of C<op_private>.
8085 Perl_newPMOP(pTHX_ I32 type, I32 flags)
8089 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
8090 || type == OP_CUSTOM);
8092 NewOp(1101, pmop, 1, PMOP);
8093 OpTYPE_set(pmop, type);
8094 pmop->op_flags = (U8)flags;
8095 pmop->op_private = (U8)(0 | (flags >> 8));
8096 if (PL_opargs[type] & OA_RETSCALAR)
8099 if (PL_hints & HINT_RE_TAINT)
8100 pmop->op_pmflags |= PMf_RETAINT;
8101 #ifdef USE_LOCALE_CTYPE
8102 if (IN_LC_COMPILETIME(LC_CTYPE)) {
8103 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
8108 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
8110 if (PL_hints & HINT_RE_FLAGS) {
8111 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8112 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
8114 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
8115 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8116 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
8118 if (reflags && SvOK(reflags)) {
8119 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
8125 assert(SvPOK(PL_regex_pad[0]));
8126 if (SvCUR(PL_regex_pad[0])) {
8127 /* Pop off the "packed" IV from the end. */
8128 SV *const repointer_list = PL_regex_pad[0];
8129 const char *p = SvEND(repointer_list) - sizeof(IV);
8130 const IV offset = *((IV*)p);
8132 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
8134 SvEND_set(repointer_list, p);
8136 pmop->op_pmoffset = offset;
8137 /* This slot should be free, so assert this: */
8138 assert(PL_regex_pad[offset] == &PL_sv_undef);
8140 SV * const repointer = &PL_sv_undef;
8141 av_push(PL_regex_padav, repointer);
8142 pmop->op_pmoffset = av_top_index(PL_regex_padav);
8143 PL_regex_pad = AvARRAY(PL_regex_padav);
8147 return CHECKOP(type, pmop);
8155 /* Any pad names in scope are potentially lvalues. */
8156 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
8157 PADNAME *pn = PAD_COMPNAME_SV(i);
8158 if (!pn || !PadnameLEN(pn))
8160 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
8161 S_mark_padname_lvalue(aTHX_ pn);
8165 /* Given some sort of match op o, and an expression expr containing a
8166 * pattern, either compile expr into a regex and attach it to o (if it's
8167 * constant), or convert expr into a runtime regcomp op sequence (if it's
8170 * Flags currently has 2 bits of meaning:
8171 * 1: isreg indicates that the pattern is part of a regex construct, eg
8172 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
8173 * split "pattern", which aren't. In the former case, expr will be a list
8174 * if the pattern contains more than one term (eg /a$b/).
8175 * 2: The pattern is for a split.
8177 * When the pattern has been compiled within a new anon CV (for
8178 * qr/(?{...})/ ), then floor indicates the savestack level just before
8179 * the new sub was created
8181 * tr/// is also handled.
8185 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
8189 I32 repl_has_vars = 0;
8190 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
8191 bool is_compiletime;
8193 bool isreg = cBOOL(flags & 1);
8194 bool is_split = cBOOL(flags & 2);
8196 PERL_ARGS_ASSERT_PMRUNTIME;
8199 return pmtrans(o, expr, repl);
8202 /* find whether we have any runtime or code elements;
8203 * at the same time, temporarily set the op_next of each DO block;
8204 * then when we LINKLIST, this will cause the DO blocks to be excluded
8205 * from the op_next chain (and from having LINKLIST recursively
8206 * applied to them). We fix up the DOs specially later */
8210 if (expr->op_type == OP_LIST) {
8212 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8213 if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
8215 assert(!child->op_next);
8216 if (UNLIKELY(!OpHAS_SIBLING(child))) {
8217 assert(PL_parser && PL_parser->error_count);
8218 /* This can happen with qr/ (?{(^{})/. Just fake up
8219 the op we were expecting to see, to avoid crashing
8221 op_sibling_splice(expr, child, 0,
8222 newSVOP(OP_CONST, 0, &PL_sv_no));
8224 child->op_next = OpSIBLING(child);
8226 else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
8230 else if (expr->op_type != OP_CONST)
8235 /* fix up DO blocks; treat each one as a separate little sub;
8236 * also, mark any arrays as LIST/REF */
8238 if (expr->op_type == OP_LIST) {
8240 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8242 if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
8243 assert( !(child->op_flags & OPf_WANT));
8244 /* push the array rather than its contents. The regex
8245 * engine will retrieve and join the elements later */
8246 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
8250 if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
8252 child->op_next = NULL; /* undo temporary hack from above */
8255 if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
8256 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
8258 assert(leaveop->op_first->op_type == OP_ENTER);
8259 assert(OpHAS_SIBLING(leaveop->op_first));
8260 child->op_next = OpSIBLING(leaveop->op_first);
8262 assert(leaveop->op_flags & OPf_KIDS);
8263 assert(leaveop->op_last->op_next == (OP*)leaveop);
8264 leaveop->op_next = NULL; /* stop on last op */
8265 op_null((OP*)leaveop);
8269 OP *scope = cLISTOPx(child)->op_first;
8270 assert(scope->op_type == OP_SCOPE);
8271 assert(scope->op_flags & OPf_KIDS);
8272 scope->op_next = NULL; /* stop on last op */
8276 /* XXX optimize_optree() must be called on o before
8277 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
8278 * currently cope with a peephole-optimised optree.
8279 * Calling optimize_optree() here ensures that condition
8280 * is met, but may mean optimize_optree() is applied
8281 * to the same optree later (where hopefully it won't do any
8282 * harm as it can't convert an op to multiconcat if it's
8283 * already been converted */
8284 optimize_optree(child);
8286 /* have to peep the DOs individually as we've removed it from
8287 * the op_next chain */
8289 S_prune_chain_head(&(child->op_next));
8291 /* runtime finalizes as part of finalizing whole tree */
8292 finalize_optree(child);
8295 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
8296 assert( !(expr->op_flags & OPf_WANT));
8297 /* push the array rather than its contents. The regex
8298 * engine will retrieve and join the elements later */
8299 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
8302 PL_hints |= HINT_BLOCK_SCOPE;
8304 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
8306 if (is_compiletime) {
8307 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
8308 regexp_engine const *eng = current_re_engine();
8311 /* make engine handle split ' ' specially */
8312 pm->op_pmflags |= PMf_SPLIT;
8313 rx_flags |= RXf_SPLIT;
8316 if (!has_code || !eng->op_comp) {
8317 /* compile-time simple constant pattern */
8319 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
8320 /* whoops! we guessed that a qr// had a code block, but we
8321 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
8322 * that isn't required now. Note that we have to be pretty
8323 * confident that nothing used that CV's pad while the
8324 * regex was parsed, except maybe op targets for \Q etc.
8325 * If there were any op targets, though, they should have
8326 * been stolen by constant folding.
8330 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
8331 while (++i <= AvFILLp(PL_comppad)) {
8332 # ifdef USE_PAD_RESET
8333 /* under USE_PAD_RESET, pad swipe replaces a swiped
8334 * folded constant with a fresh padtmp */
8335 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
8337 assert(!PL_curpad[i]);
8341 /* This LEAVE_SCOPE will restore PL_compcv to point to the
8342 * outer CV (the one whose slab holds the pm op). The
8343 * inner CV (which holds expr) will be freed later, once
8344 * all the entries on the parse stack have been popped on
8345 * return from this function. Which is why its safe to
8346 * call op_free(expr) below.
8349 pm->op_pmflags &= ~PMf_HAS_CV;
8352 /* Skip compiling if parser found an error for this pattern */
8353 if (pm->op_pmflags & PMf_HAS_ERROR) {
8359 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8360 rx_flags, pm->op_pmflags)
8361 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8362 rx_flags, pm->op_pmflags)
8367 /* compile-time pattern that includes literal code blocks */
8371 /* Skip compiling if parser found an error for this pattern */
8372 if (pm->op_pmflags & PMf_HAS_ERROR) {
8376 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8379 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
8382 if (pm->op_pmflags & PMf_HAS_CV) {
8384 /* this QR op (and the anon sub we embed it in) is never
8385 * actually executed. It's just a placeholder where we can
8386 * squirrel away expr in op_code_list without the peephole
8387 * optimiser etc processing it for a second time */
8388 OP *qr = newPMOP(OP_QR, 0);
8389 ((PMOP*)qr)->op_code_list = expr;
8391 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
8392 SvREFCNT_inc_simple_void(PL_compcv);
8393 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8394 ReANY(re)->qr_anoncv = cv;
8396 /* attach the anon CV to the pad so that
8397 * pad_fixup_inner_anons() can find it */
8398 (void)pad_add_anon(cv, o->op_type);
8399 SvREFCNT_inc_simple_void(cv);
8402 pm->op_code_list = expr;
8407 /* runtime pattern: build chain of regcomp etc ops */
8409 PADOFFSET cv_targ = 0;
8411 reglist = isreg && expr->op_type == OP_LIST;
8416 pm->op_code_list = expr;
8417 /* don't free op_code_list; its ops are embedded elsewhere too */
8418 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
8422 /* make engine handle split ' ' specially */
8423 pm->op_pmflags |= PMf_SPLIT;
8425 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
8426 * to allow its op_next to be pointed past the regcomp and
8427 * preceding stacking ops;
8428 * OP_REGCRESET is there to reset taint before executing the
8430 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
8431 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
8433 if (pm->op_pmflags & PMf_HAS_CV) {
8434 /* we have a runtime qr with literal code. This means
8435 * that the qr// has been wrapped in a new CV, which
8436 * means that runtime consts, vars etc will have been compiled
8437 * against a new pad. So... we need to execute those ops
8438 * within the environment of the new CV. So wrap them in a call
8439 * to a new anon sub. i.e. for
8443 * we build an anon sub that looks like
8445 * sub { "a", $b, '(?{...})' }
8447 * and call it, passing the returned list to regcomp.
8448 * Or to put it another way, the list of ops that get executed
8452 * ------ -------------------
8453 * pushmark (for regcomp)
8454 * pushmark (for entersub)
8458 * regcreset regcreset
8460 * const("a") const("a")
8462 * const("(?{...})") const("(?{...})")
8467 SvREFCNT_inc_simple_void(PL_compcv);
8468 CvLVALUE_on(PL_compcv);
8469 /* these lines are just an unrolled newANONATTRSUB */
8470 expr = newSVOP(OP_ANONCODE, 0,
8471 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
8472 cv_targ = expr->op_targ;
8473 expr = newUNOP(OP_REFGEN, 0, expr);
8475 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
8478 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
8479 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
8480 | (reglist ? OPf_STACKED : 0);
8481 rcop->op_targ = cv_targ;
8483 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
8484 if (PL_hints & HINT_RE_EVAL)
8485 S_set_haseval(aTHX);
8487 /* establish postfix order */
8488 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
8490 rcop->op_next = expr;
8491 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
8494 rcop->op_next = LINKLIST(expr);
8495 expr->op_next = (OP*)rcop;
8498 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
8504 /* If we are looking at s//.../e with a single statement, get past
8505 the implicit do{}. */
8506 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
8507 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
8508 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
8511 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
8512 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
8513 && !OpHAS_SIBLING(sib))
8516 if (curop->op_type == OP_CONST)
8518 else if (( (curop->op_type == OP_RV2SV ||
8519 curop->op_type == OP_RV2AV ||
8520 curop->op_type == OP_RV2HV ||
8521 curop->op_type == OP_RV2GV)
8522 && cUNOPx(curop)->op_first
8523 && cUNOPx(curop)->op_first->op_type == OP_GV )
8524 || curop->op_type == OP_PADSV
8525 || curop->op_type == OP_PADAV
8526 || curop->op_type == OP_PADHV
8527 || curop->op_type == OP_PADANY) {
8535 || !RX_PRELEN(PM_GETRE(pm))
8536 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
8538 pm->op_pmflags |= PMf_CONST; /* const for long enough */
8539 op_prepend_elem(o->op_type, scalar(repl), o);
8542 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
8543 rcop->op_private = 1;
8545 /* establish postfix order */
8546 rcop->op_next = LINKLIST(repl);
8547 repl->op_next = (OP*)rcop;
8549 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
8550 assert(!(pm->op_pmflags & PMf_ONCE));
8551 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
8562 Constructs, checks, and returns an op of any type that involves an
8563 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
8564 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
8565 takes ownership of one reference to it.
8571 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
8575 PERL_ARGS_ASSERT_NEWSVOP;
8577 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8578 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8579 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8580 || type == OP_CUSTOM);
8582 NewOp(1101, svop, 1, SVOP);
8583 OpTYPE_set(svop, type);
8585 svop->op_next = (OP*)svop;
8586 svop->op_flags = (U8)flags;
8587 svop->op_private = (U8)(0 | (flags >> 8));
8588 if (PL_opargs[type] & OA_RETSCALAR)
8590 if (PL_opargs[type] & OA_TARGET)
8591 svop->op_targ = pad_alloc(type, SVs_PADTMP);
8592 return CHECKOP(type, svop);
8596 =for apidoc newDEFSVOP
8598 Constructs and returns an op to access C<$_>.
8604 Perl_newDEFSVOP(pTHX)
8606 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
8612 =for apidoc newPADOP
8614 Constructs, checks, and returns an op of any type that involves a
8615 reference to a pad element. C<type> is the opcode. C<flags> gives the
8616 eight bits of C<op_flags>. A pad slot is automatically allocated, and
8617 is populated with C<sv>; this function takes ownership of one reference
8620 This function only exists if Perl has been compiled to use ithreads.
8626 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
8630 PERL_ARGS_ASSERT_NEWPADOP;
8632 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8633 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8634 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8635 || type == OP_CUSTOM);
8637 NewOp(1101, padop, 1, PADOP);
8638 OpTYPE_set(padop, type);
8640 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
8641 SvREFCNT_dec(PAD_SVl(padop->op_padix));
8642 PAD_SETSV(padop->op_padix, sv);
8644 padop->op_next = (OP*)padop;
8645 padop->op_flags = (U8)flags;
8646 if (PL_opargs[type] & OA_RETSCALAR)
8648 if (PL_opargs[type] & OA_TARGET)
8649 padop->op_targ = pad_alloc(type, SVs_PADTMP);
8650 return CHECKOP(type, padop);
8653 #endif /* USE_ITHREADS */
8658 Constructs, checks, and returns an op of any type that involves an
8659 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
8660 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
8661 reference; calling this function does not transfer ownership of any
8668 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
8670 PERL_ARGS_ASSERT_NEWGVOP;
8673 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8675 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8682 Constructs, checks, and returns an op of any type that involves an
8683 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
8684 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
8685 Depending on the op type, the memory referenced by C<pv> may be freed
8686 when the op is destroyed. If the op is of a freeing type, C<pv> must
8687 have been allocated using C<PerlMemShared_malloc>.
8693 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
8695 const bool utf8 = cBOOL(flags & SVf_UTF8);
8700 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8701 || type == OP_RUNCV || type == OP_CUSTOM
8702 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
8704 NewOp(1101, pvop, 1, PVOP);
8705 OpTYPE_set(pvop, type);
8707 pvop->op_next = (OP*)pvop;
8708 pvop->op_flags = (U8)flags;
8709 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
8710 if (PL_opargs[type] & OA_RETSCALAR)
8712 if (PL_opargs[type] & OA_TARGET)
8713 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
8714 return CHECKOP(type, pvop);
8718 Perl_package(pTHX_ OP *o)
8720 SV *const sv = cSVOPo->op_sv;
8722 PERL_ARGS_ASSERT_PACKAGE;
8724 SAVEGENERICSV(PL_curstash);
8725 save_item(PL_curstname);
8727 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
8729 sv_setsv(PL_curstname, sv);
8731 PL_hints |= HINT_BLOCK_SCOPE;
8732 PL_parser->copline = NOLINE;
8738 Perl_package_version( pTHX_ OP *v )
8740 U32 savehints = PL_hints;
8741 PERL_ARGS_ASSERT_PACKAGE_VERSION;
8742 PL_hints &= ~HINT_STRICT_VARS;
8743 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
8744 PL_hints = savehints;
8749 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
8754 SV *use_version = NULL;
8756 PERL_ARGS_ASSERT_UTILIZE;
8758 if (idop->op_type != OP_CONST)
8759 Perl_croak(aTHX_ "Module name must be constant");
8764 SV * const vesv = ((SVOP*)version)->op_sv;
8766 if (!arg && !SvNIOKp(vesv)) {
8773 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
8774 Perl_croak(aTHX_ "Version number must be a constant number");
8776 /* Make copy of idop so we don't free it twice */
8777 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8779 /* Fake up a method call to VERSION */
8780 meth = newSVpvs_share("VERSION");
8781 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8782 op_append_elem(OP_LIST,
8783 op_prepend_elem(OP_LIST, pack, version),
8784 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
8788 /* Fake up an import/unimport */
8789 if (arg && arg->op_type == OP_STUB) {
8790 imop = arg; /* no import on explicit () */
8792 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
8793 imop = NULL; /* use 5.0; */
8795 use_version = ((SVOP*)idop)->op_sv;
8797 idop->op_private |= OPpCONST_NOVER;
8802 /* Make copy of idop so we don't free it twice */
8803 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8805 /* Fake up a method call to import/unimport */
8807 ? newSVpvs_share("import") : newSVpvs_share("unimport");
8808 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8809 op_append_elem(OP_LIST,
8810 op_prepend_elem(OP_LIST, pack, arg),
8811 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
8815 /* Fake up the BEGIN {}, which does its thing immediately. */
8817 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
8820 op_append_elem(OP_LINESEQ,
8821 op_append_elem(OP_LINESEQ,
8822 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
8823 newSTATEOP(0, NULL, veop)),
8824 newSTATEOP(0, NULL, imop) ));
8828 * feature bundle that corresponds to the required version. */
8829 use_version = sv_2mortal(new_version(use_version));
8830 S_enable_feature_bundle(aTHX_ use_version);
8832 /* If a version >= 5.11.0 is requested, strictures are on by default! */
8833 if (vcmp(use_version,
8834 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
8835 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8836 PL_hints |= HINT_STRICT_REFS;
8837 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8838 PL_hints |= HINT_STRICT_SUBS;
8839 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8840 PL_hints |= HINT_STRICT_VARS;
8842 /* otherwise they are off */
8844 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8845 PL_hints &= ~HINT_STRICT_REFS;
8846 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8847 PL_hints &= ~HINT_STRICT_SUBS;
8848 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8849 PL_hints &= ~HINT_STRICT_VARS;
8853 /* The "did you use incorrect case?" warning used to be here.
8854 * The problem is that on case-insensitive filesystems one
8855 * might get false positives for "use" (and "require"):
8856 * "use Strict" or "require CARP" will work. This causes
8857 * portability problems for the script: in case-strict
8858 * filesystems the script will stop working.
8860 * The "incorrect case" warning checked whether "use Foo"
8861 * imported "Foo" to your namespace, but that is wrong, too:
8862 * there is no requirement nor promise in the language that
8863 * a Foo.pm should or would contain anything in package "Foo".
8865 * There is very little Configure-wise that can be done, either:
8866 * the case-sensitivity of the build filesystem of Perl does not
8867 * help in guessing the case-sensitivity of the runtime environment.
8870 PL_hints |= HINT_BLOCK_SCOPE;
8871 PL_parser->copline = NOLINE;
8872 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
8876 =for apidoc_section $embedding
8878 =for apidoc load_module
8880 Loads the module whose name is pointed to by the string part of C<name>.
8881 Note that the actual module name, not its filename, should be given.
8882 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
8883 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
8884 trailing arguments can be used to specify arguments to the module's C<import()>
8885 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
8886 on the flags. The flags argument is a bitwise-ORed collection of any of
8887 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
8888 (or 0 for no flags).
8890 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
8891 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
8892 the trailing optional arguments may be omitted entirely. Otherwise, if
8893 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
8894 exactly one C<OP*>, containing the op tree that produces the relevant import
8895 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
8896 will be used as import arguments; and the list must be terminated with C<(SV*)
8897 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
8898 set, the trailing C<NULL> pointer is needed even if no import arguments are
8899 desired. The reference count for each specified C<SV*> argument is
8900 decremented. In addition, the C<name> argument is modified.
8902 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
8905 =for apidoc Amnh||PERL_LOADMOD_DENY
8906 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
8907 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
8909 =for apidoc vload_module
8910 Like C<L</load_module>> but the arguments are an encapsulated argument list.
8912 =for apidoc load_module_nocontext
8913 Like C<L</load_module>> but does not take a thread context (C<aTHX>) parameter,
8914 so is used in situations where the caller doesn't already have the thread
8920 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
8924 PERL_ARGS_ASSERT_LOAD_MODULE;
8926 va_start(args, ver);
8927 vload_module(flags, name, ver, &args);
8931 #ifdef PERL_IMPLICIT_CONTEXT
8933 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8937 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8938 va_start(args, ver);
8939 vload_module(flags, name, ver, &args);
8945 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8951 PERL_ARGS_ASSERT_VLOAD_MODULE;
8953 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8954 * that it has a PL_parser to play with while doing that, and also
8955 * that it doesn't mess with any existing parser, by creating a tmp
8956 * new parser with lex_start(). This won't actually be used for much,
8957 * since pp_require() will create another parser for the real work.
8958 * The ENTER/LEAVE pair protect callers from any side effects of use.
8960 * start_subparse() creates a new PL_compcv. This means that any ops
8961 * allocated below will be allocated from that CV's op slab, and so
8962 * will be automatically freed if the utilise() fails
8966 SAVEVPTR(PL_curcop);
8967 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8968 floor = start_subparse(FALSE, 0);
8970 modname = newSVOP(OP_CONST, 0, name);
8971 modname->op_private |= OPpCONST_BARE;
8973 veop = newSVOP(OP_CONST, 0, ver);
8977 if (flags & PERL_LOADMOD_NOIMPORT) {
8978 imop = sawparens(newNULLLIST());
8980 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8981 imop = va_arg(*args, OP*);
8986 sv = va_arg(*args, SV*);
8988 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8989 sv = va_arg(*args, SV*);
8993 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
8997 PERL_STATIC_INLINE OP *
8998 S_new_entersubop(pTHX_ GV *gv, OP *arg)
9000 return newUNOP(OP_ENTERSUB, OPf_STACKED,
9001 newLISTOP(OP_LIST, 0, arg,
9002 newUNOP(OP_RV2CV, 0,
9003 newGVOP(OP_GV, 0, gv))));
9007 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
9012 PERL_ARGS_ASSERT_DOFILE;
9014 if (!force_builtin && (gv = gv_override("do", 2))) {
9015 doop = S_new_entersubop(aTHX_ gv, term);
9018 doop = newUNOP(OP_DOFILE, 0, scalar(term));
9024 =for apidoc_section $optree_construction
9026 =for apidoc newSLICEOP
9028 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
9029 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
9030 be set automatically, and, shifted up eight bits, the eight bits of
9031 C<op_private>, except that the bit with value 1 or 2 is automatically
9032 set as required. C<listval> and C<subscript> supply the parameters of
9033 the slice; they are consumed by this function and become part of the
9034 constructed op tree.
9040 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
9042 return newBINOP(OP_LSLICE, flags,
9043 list(force_list(subscript, 1)),
9044 list(force_list(listval, 1)) );
9047 #define ASSIGN_SCALAR 0
9048 #define ASSIGN_LIST 1
9049 #define ASSIGN_REF 2
9051 /* given the optree o on the LHS of an assignment, determine whether its:
9052 * ASSIGN_SCALAR $x = ...
9053 * ASSIGN_LIST ($x) = ...
9054 * ASSIGN_REF \$x = ...
9058 S_assignment_type(pTHX_ const OP *o)
9067 if (o->op_type == OP_SREFGEN)
9069 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
9070 type = kid->op_type;
9071 flags = o->op_flags | kid->op_flags;
9072 if (!(flags & OPf_PARENS)
9073 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
9074 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
9078 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
9079 o = cUNOPo->op_first;
9080 flags = o->op_flags;
9082 ret = ASSIGN_SCALAR;
9085 if (type == OP_COND_EXPR) {
9086 OP * const sib = OpSIBLING(cLOGOPo->op_first);
9087 const I32 t = assignment_type(sib);
9088 const I32 f = assignment_type(OpSIBLING(sib));
9090 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
9092 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
9093 yyerror("Assignment to both a list and a scalar");
9094 return ASSIGN_SCALAR;
9097 if (type == OP_LIST &&
9098 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
9099 o->op_private & OPpLVAL_INTRO)
9102 if (type == OP_LIST || flags & OPf_PARENS ||
9103 type == OP_RV2AV || type == OP_RV2HV ||
9104 type == OP_ASLICE || type == OP_HSLICE ||
9105 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
9108 if (type == OP_PADAV || type == OP_PADHV)
9111 if (type == OP_RV2SV)
9118 S_newONCEOP(pTHX_ OP *initop, OP *padop)
9120 const PADOFFSET target = padop->op_targ;
9121 OP *const other = newOP(OP_PADSV,
9123 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
9124 OP *const first = newOP(OP_NULL, 0);
9125 OP *const nullop = newCONDOP(0, first, initop, other);
9126 /* XXX targlex disabled for now; see ticket #124160
9127 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
9129 OP *const condop = first->op_next;
9131 OpTYPE_set(condop, OP_ONCE);
9132 other->op_targ = target;
9133 nullop->op_flags |= OPf_WANT_SCALAR;
9135 /* Store the initializedness of state vars in a separate
9138 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
9139 /* hijacking PADSTALE for uninitialized state variables */
9140 SvPADSTALE_on(PAD_SVl(condop->op_targ));
9146 =for apidoc newASSIGNOP
9148 Constructs, checks, and returns an assignment op. C<left> and C<right>
9149 supply the parameters of the assignment; they are consumed by this
9150 function and become part of the constructed op tree.
9152 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
9153 a suitable conditional optree is constructed. If C<optype> is the opcode
9154 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
9155 performs the binary operation and assigns the result to the left argument.
9156 Either way, if C<optype> is non-zero then C<flags> has no effect.
9158 If C<optype> is zero, then a plain scalar or list assignment is
9159 constructed. Which type of assignment it is is automatically determined.
9160 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9161 will be set automatically, and, shifted up eight bits, the eight bits
9162 of C<op_private>, except that the bit with value 1 or 2 is automatically
9169 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
9175 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
9176 right = scalar(right);
9177 return newLOGOP(optype, 0,
9178 op_lvalue(scalar(left), optype),
9179 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
9182 return newBINOP(optype, OPf_STACKED,
9183 op_lvalue(scalar(left), optype), scalar(right));
9187 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
9188 OP *state_var_op = NULL;
9189 static const char no_list_state[] = "Initialization of state variables"
9190 " in list currently forbidden";
9193 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
9194 left->op_private &= ~ OPpSLICEWARNING;
9197 left = op_lvalue(left, OP_AASSIGN);
9198 curop = list(force_list(left, 1));
9199 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
9200 o->op_private = (U8)(0 | (flags >> 8));
9202 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
9204 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
9205 if (!(left->op_flags & OPf_PARENS) &&
9206 lop->op_type == OP_PUSHMARK &&
9207 (vop = OpSIBLING(lop)) &&
9208 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
9209 !(vop->op_flags & OPf_PARENS) &&
9210 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
9211 (OPpLVAL_INTRO|OPpPAD_STATE) &&
9212 (eop = OpSIBLING(vop)) &&
9213 eop->op_type == OP_ENTERSUB &&
9214 !OpHAS_SIBLING(eop)) {
9218 if ((lop->op_type == OP_PADSV ||
9219 lop->op_type == OP_PADAV ||
9220 lop->op_type == OP_PADHV ||
9221 lop->op_type == OP_PADANY)
9222 && (lop->op_private & OPpPAD_STATE)
9224 yyerror(no_list_state);
9225 lop = OpSIBLING(lop);
9229 else if ( (left->op_private & OPpLVAL_INTRO)
9230 && (left->op_private & OPpPAD_STATE)
9231 && ( left->op_type == OP_PADSV
9232 || left->op_type == OP_PADAV
9233 || left->op_type == OP_PADHV
9234 || left->op_type == OP_PADANY)
9236 /* All single variable list context state assignments, hence
9246 if (left->op_flags & OPf_PARENS)
9247 yyerror(no_list_state);
9249 state_var_op = left;
9252 /* optimise @a = split(...) into:
9253 * @{expr}: split(..., @{expr}) (where @a is not flattened)
9254 * @a, my @a, local @a: split(...) (where @a is attached to
9255 * the split op itself)
9259 && right->op_type == OP_SPLIT
9260 /* don't do twice, e.g. @b = (@a = split) */
9261 && !(right->op_private & OPpSPLIT_ASSIGN))
9265 if ( ( left->op_type == OP_RV2AV
9266 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
9267 || left->op_type == OP_PADAV)
9269 /* @pkg or @lex or local @pkg' or 'my @lex' */
9273 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
9274 = cPADOPx(gvop)->op_padix;
9275 cPADOPx(gvop)->op_padix = 0; /* steal it */
9277 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
9278 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
9279 cSVOPx(gvop)->op_sv = NULL; /* steal it */
9281 right->op_private |=
9282 left->op_private & OPpOUR_INTRO;
9285 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
9286 left->op_targ = 0; /* steal it */
9287 right->op_private |= OPpSPLIT_LEX;
9289 right->op_private |= left->op_private & OPpLVAL_INTRO;
9292 tmpop = cUNOPo->op_first; /* to list (nulled) */
9293 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
9294 assert(OpSIBLING(tmpop) == right);
9295 assert(!OpHAS_SIBLING(right));
9296 /* detach the split subtreee from the o tree,
9297 * then free the residual o tree */
9298 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
9299 op_free(o); /* blow off assign */
9300 right->op_private |= OPpSPLIT_ASSIGN;
9301 right->op_flags &= ~OPf_WANT;
9302 /* "I don't know and I don't care." */
9305 else if (left->op_type == OP_RV2AV) {
9308 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
9309 assert(OpSIBLING(pushop) == left);
9310 /* Detach the array ... */
9311 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
9312 /* ... and attach it to the split. */
9313 op_sibling_splice(right, cLISTOPx(right)->op_last,
9315 right->op_flags |= OPf_STACKED;
9316 /* Detach split and expunge aassign as above. */
9319 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
9320 ((LISTOP*)right)->op_last->op_type == OP_CONST)
9322 /* convert split(...,0) to split(..., PL_modcount+1) */
9324 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
9325 SV * const sv = *svp;
9326 if (SvIOK(sv) && SvIVX(sv) == 0)
9328 if (right->op_private & OPpSPLIT_IMPLIM) {
9329 /* our own SV, created in ck_split */
9331 sv_setiv(sv, PL_modcount+1);
9334 /* SV may belong to someone else */
9336 *svp = newSViv(PL_modcount+1);
9343 o = S_newONCEOP(aTHX_ o, state_var_op);
9346 if (assign_type == ASSIGN_REF)
9347 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
9349 right = newOP(OP_UNDEF, 0);
9350 if (right->op_type == OP_READLINE) {
9351 right->op_flags |= OPf_STACKED;
9352 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
9356 o = newBINOP(OP_SASSIGN, flags,
9357 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
9363 =for apidoc newSTATEOP
9365 Constructs a state op (COP). The state op is normally a C<nextstate> op,
9366 but will be a C<dbstate> op if debugging is enabled for currently-compiled
9367 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
9368 If C<label> is non-null, it supplies the name of a label to attach to
9369 the state op; this function takes ownership of the memory pointed at by
9370 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
9373 If C<o> is null, the state op is returned. Otherwise the state op is
9374 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
9375 is consumed by this function and becomes part of the returned op tree.
9381 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
9383 const U32 seq = intro_my();
9384 const U32 utf8 = flags & SVf_UTF8;
9387 PL_parser->parsed_sub = 0;
9391 NewOp(1101, cop, 1, COP);
9392 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
9393 OpTYPE_set(cop, OP_DBSTATE);
9396 OpTYPE_set(cop, OP_NEXTSTATE);
9398 cop->op_flags = (U8)flags;
9399 CopHINTS_set(cop, PL_hints);
9401 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
9403 cop->op_next = (OP*)cop;
9406 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9407 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
9409 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
9411 PL_hints |= HINT_BLOCK_SCOPE;
9412 /* It seems that we need to defer freeing this pointer, as other parts
9413 of the grammar end up wanting to copy it after this op has been
9418 if (PL_parser->preambling != NOLINE) {
9419 CopLINE_set(cop, PL_parser->preambling);
9420 PL_parser->copline = NOLINE;
9422 else if (PL_parser->copline == NOLINE)
9423 CopLINE_set(cop, CopLINE(PL_curcop));
9425 CopLINE_set(cop, PL_parser->copline);
9426 PL_parser->copline = NOLINE;
9429 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
9431 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
9433 CopSTASH_set(cop, PL_curstash);
9435 if (cop->op_type == OP_DBSTATE) {
9436 /* this line can have a breakpoint - store the cop in IV */
9437 AV *av = CopFILEAVx(PL_curcop);
9439 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
9440 if (svp && *svp != &PL_sv_undef ) {
9441 (void)SvIOK_on(*svp);
9442 SvIV_set(*svp, PTR2IV(cop));
9447 if (flags & OPf_SPECIAL)
9449 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
9453 =for apidoc newLOGOP
9455 Constructs, checks, and returns a logical (flow control) op. C<type>
9456 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
9457 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
9458 the eight bits of C<op_private>, except that the bit with value 1 is
9459 automatically set. C<first> supplies the expression controlling the
9460 flow, and C<other> supplies the side (alternate) chain of ops; they are
9461 consumed by this function and become part of the constructed op tree.
9467 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
9469 PERL_ARGS_ASSERT_NEWLOGOP;
9471 return new_logop(type, flags, &first, &other);
9475 /* See if the optree o contains a single OP_CONST (plus possibly
9476 * surrounding enter/nextstate/null etc). If so, return it, else return
9481 S_search_const(pTHX_ OP *o)
9483 PERL_ARGS_ASSERT_SEARCH_CONST;
9486 switch (o->op_type) {
9490 if (o->op_flags & OPf_KIDS) {
9491 o = cUNOPo->op_first;
9500 if (!(o->op_flags & OPf_KIDS))
9502 kid = cLISTOPo->op_first;
9505 switch (kid->op_type) {
9509 kid = OpSIBLING(kid);
9512 if (kid != cLISTOPo->op_last)
9519 kid = cLISTOPo->op_last;
9531 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
9538 int prepend_not = 0;
9540 PERL_ARGS_ASSERT_NEW_LOGOP;
9545 /* [perl #59802]: Warn about things like "return $a or $b", which
9546 is parsed as "(return $a) or $b" rather than "return ($a or
9547 $b)". NB: This also applies to xor, which is why we do it
9550 switch (first->op_type) {
9554 /* XXX: Perhaps we should emit a stronger warning for these.
9555 Even with the high-precedence operator they don't seem to do
9558 But until we do, fall through here.
9564 /* XXX: Currently we allow people to "shoot themselves in the
9565 foot" by explicitly writing "(return $a) or $b".
9567 Warn unless we are looking at the result from folding or if
9568 the programmer explicitly grouped the operators like this.
9569 The former can occur with e.g.
9571 use constant FEATURE => ( $] >= ... );
9572 sub { not FEATURE and return or do_stuff(); }
9574 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
9575 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9576 "Possible precedence issue with control flow operator");
9577 /* XXX: Should we optimze this to "return $a;" (i.e. remove
9583 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
9584 return newBINOP(type, flags, scalar(first), scalar(other));
9586 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
9587 || type == OP_CUSTOM);
9589 scalarboolean(first);
9591 /* search for a constant op that could let us fold the test */
9592 if ((cstop = search_const(first))) {
9593 if (cstop->op_private & OPpCONST_STRICT)
9594 no_bareword_allowed(cstop);
9595 else if ((cstop->op_private & OPpCONST_BARE))
9596 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
9597 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
9598 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
9599 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
9600 /* Elide the (constant) lhs, since it can't affect the outcome */
9602 if (other->op_type == OP_CONST)
9603 other->op_private |= OPpCONST_SHORTCIRCUIT;
9605 if (other->op_type == OP_LEAVE)
9606 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
9607 else if (other->op_type == OP_MATCH
9608 || other->op_type == OP_SUBST
9609 || other->op_type == OP_TRANSR
9610 || other->op_type == OP_TRANS)
9611 /* Mark the op as being unbindable with =~ */
9612 other->op_flags |= OPf_SPECIAL;
9614 other->op_folded = 1;
9618 /* Elide the rhs, since the outcome is entirely determined by
9619 * the (constant) lhs */
9621 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
9622 const OP *o2 = other;
9623 if ( ! (o2->op_type == OP_LIST
9624 && (( o2 = cUNOPx(o2)->op_first))
9625 && o2->op_type == OP_PUSHMARK
9626 && (( o2 = OpSIBLING(o2))) )
9629 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
9630 || o2->op_type == OP_PADHV)
9631 && o2->op_private & OPpLVAL_INTRO
9632 && !(o2->op_private & OPpPAD_STATE))
9634 Perl_croak(aTHX_ "This use of my() in false conditional is "
9635 "no longer allowed");
9639 if (cstop->op_type == OP_CONST)
9640 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
9645 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
9646 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
9648 const OP * const k1 = ((UNOP*)first)->op_first;
9649 const OP * const k2 = OpSIBLING(k1);
9651 switch (first->op_type)
9654 if (k2 && k2->op_type == OP_READLINE
9655 && (k2->op_flags & OPf_STACKED)
9656 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9658 warnop = k2->op_type;
9663 if (k1->op_type == OP_READDIR
9664 || k1->op_type == OP_GLOB
9665 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9666 || k1->op_type == OP_EACH
9667 || k1->op_type == OP_AEACH)
9669 warnop = ((k1->op_type == OP_NULL)
9670 ? (OPCODE)k1->op_targ : k1->op_type);
9675 const line_t oldline = CopLINE(PL_curcop);
9676 /* This ensures that warnings are reported at the first line
9677 of the construction, not the last. */
9678 CopLINE_set(PL_curcop, PL_parser->copline);
9679 Perl_warner(aTHX_ packWARN(WARN_MISC),
9680 "Value of %s%s can be \"0\"; test with defined()",
9682 ((warnop == OP_READLINE || warnop == OP_GLOB)
9683 ? " construct" : "() operator"));
9684 CopLINE_set(PL_curcop, oldline);
9688 /* optimize AND and OR ops that have NOTs as children */
9689 if (first->op_type == OP_NOT
9690 && (first->op_flags & OPf_KIDS)
9691 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
9692 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
9694 if (type == OP_AND || type == OP_OR) {
9700 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
9702 prepend_not = 1; /* prepend a NOT op later */
9707 logop = alloc_LOGOP(type, first, LINKLIST(other));
9708 logop->op_flags |= (U8)flags;
9709 logop->op_private = (U8)(1 | (flags >> 8));
9711 /* establish postfix order */
9712 logop->op_next = LINKLIST(first);
9713 first->op_next = (OP*)logop;
9714 assert(!OpHAS_SIBLING(first));
9715 op_sibling_splice((OP*)logop, first, 0, other);
9717 CHECKOP(type,logop);
9719 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
9720 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
9728 =for apidoc newCONDOP
9730 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
9731 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9732 will be set automatically, and, shifted up eight bits, the eight bits of
9733 C<op_private>, except that the bit with value 1 is automatically set.
9734 C<first> supplies the expression selecting between the two branches,
9735 and C<trueop> and C<falseop> supply the branches; they are consumed by
9736 this function and become part of the constructed op tree.
9742 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
9749 PERL_ARGS_ASSERT_NEWCONDOP;
9752 return newLOGOP(OP_AND, 0, first, trueop);
9754 return newLOGOP(OP_OR, 0, first, falseop);
9756 scalarboolean(first);
9757 if ((cstop = search_const(first))) {
9758 /* Left or right arm of the conditional? */
9759 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
9760 OP *live = left ? trueop : falseop;
9761 OP *const dead = left ? falseop : trueop;
9762 if (cstop->op_private & OPpCONST_BARE &&
9763 cstop->op_private & OPpCONST_STRICT) {
9764 no_bareword_allowed(cstop);
9768 if (live->op_type == OP_LEAVE)
9769 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
9770 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
9771 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
9772 /* Mark the op as being unbindable with =~ */
9773 live->op_flags |= OPf_SPECIAL;
9774 live->op_folded = 1;
9777 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
9778 logop->op_flags |= (U8)flags;
9779 logop->op_private = (U8)(1 | (flags >> 8));
9780 logop->op_next = LINKLIST(falseop);
9782 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
9785 /* establish postfix order */
9786 start = LINKLIST(first);
9787 first->op_next = (OP*)logop;
9789 /* make first, trueop, falseop siblings */
9790 op_sibling_splice((OP*)logop, first, 0, trueop);
9791 op_sibling_splice((OP*)logop, trueop, 0, falseop);
9793 o = newUNOP(OP_NULL, 0, (OP*)logop);
9795 trueop->op_next = falseop->op_next = o;
9802 =for apidoc newRANGE
9804 Constructs and returns a C<range> op, with subordinate C<flip> and
9805 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
9806 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
9807 for both the C<flip> and C<range> ops, except that the bit with value
9808 1 is automatically set. C<left> and C<right> supply the expressions
9809 controlling the endpoints of the range; they are consumed by this function
9810 and become part of the constructed op tree.
9816 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
9824 PERL_ARGS_ASSERT_NEWRANGE;
9826 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
9827 range->op_flags = OPf_KIDS;
9828 leftstart = LINKLIST(left);
9829 range->op_private = (U8)(1 | (flags >> 8));
9831 /* make left and right siblings */
9832 op_sibling_splice((OP*)range, left, 0, right);
9834 range->op_next = (OP*)range;
9835 flip = newUNOP(OP_FLIP, flags, (OP*)range);
9836 flop = newUNOP(OP_FLOP, 0, flip);
9837 o = newUNOP(OP_NULL, 0, flop);
9839 range->op_next = leftstart;
9841 left->op_next = flip;
9842 right->op_next = flop;
9845 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9846 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9848 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9849 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9850 SvPADTMP_on(PAD_SV(flip->op_targ));
9852 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9853 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9855 /* check barewords before they might be optimized aways */
9856 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9857 no_bareword_allowed(left);
9858 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9859 no_bareword_allowed(right);
9862 if (!flip->op_private || !flop->op_private)
9863 LINKLIST(o); /* blow off optimizer unless constant */
9869 =for apidoc newLOOPOP
9871 Constructs, checks, and returns an op tree expressing a loop. This is
9872 only a loop in the control flow through the op tree; it does not have
9873 the heavyweight loop structure that allows exiting the loop by C<last>
9874 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
9875 top-level op, except that some bits will be set automatically as required.
9876 C<expr> supplies the expression controlling loop iteration, and C<block>
9877 supplies the body of the loop; they are consumed by this function and
9878 become part of the constructed op tree. C<debuggable> is currently
9879 unused and should always be 1.
9885 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9889 const bool once = block && block->op_flags & OPf_SPECIAL &&
9890 block->op_type == OP_NULL;
9892 PERL_UNUSED_ARG(debuggable);
9896 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
9897 || ( expr->op_type == OP_NOT
9898 && cUNOPx(expr)->op_first->op_type == OP_CONST
9899 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9902 /* Return the block now, so that S_new_logop does not try to
9906 return block; /* do {} while 0 does once */
9909 if (expr->op_type == OP_READLINE
9910 || expr->op_type == OP_READDIR
9911 || expr->op_type == OP_GLOB
9912 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9913 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9914 expr = newUNOP(OP_DEFINED, 0,
9915 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9916 } else if (expr->op_flags & OPf_KIDS) {
9917 const OP * const k1 = ((UNOP*)expr)->op_first;
9918 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9919 switch (expr->op_type) {
9921 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9922 && (k2->op_flags & OPf_STACKED)
9923 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9924 expr = newUNOP(OP_DEFINED, 0, expr);
9928 if (k1 && (k1->op_type == OP_READDIR
9929 || k1->op_type == OP_GLOB
9930 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9931 || k1->op_type == OP_EACH
9932 || k1->op_type == OP_AEACH))
9933 expr = newUNOP(OP_DEFINED, 0, expr);
9939 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9940 * op, in listop. This is wrong. [perl #27024] */
9942 block = newOP(OP_NULL, 0);
9943 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9944 o = new_logop(OP_AND, 0, &expr, &listop);
9951 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
9953 if (once && o != listop)
9955 assert(cUNOPo->op_first->op_type == OP_AND
9956 || cUNOPo->op_first->op_type == OP_OR);
9957 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
9961 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
9963 o->op_flags |= flags;
9965 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9970 =for apidoc newWHILEOP
9972 Constructs, checks, and returns an op tree expressing a C<while> loop.
9973 This is a heavyweight loop, with structure that allows exiting the loop
9974 by C<last> and suchlike.
9976 C<loop> is an optional preconstructed C<enterloop> op to use in the
9977 loop; if it is null then a suitable op will be constructed automatically.
9978 C<expr> supplies the loop's controlling expression. C<block> supplies the
9979 main body of the loop, and C<cont> optionally supplies a C<continue> block
9980 that operates as a second half of the body. All of these optree inputs
9981 are consumed by this function and become part of the constructed op tree.
9983 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9984 op and, shifted up eight bits, the eight bits of C<op_private> for
9985 the C<leaveloop> op, except that (in both cases) some bits will be set
9986 automatically. C<debuggable> is currently unused and should always be 1.
9987 C<has_my> can be supplied as true to force the
9988 loop body to be enclosed in its own scope.
9994 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9995 OP *expr, OP *block, OP *cont, I32 has_my)
10003 PERL_UNUSED_ARG(debuggable);
10006 if (expr->op_type == OP_READLINE
10007 || expr->op_type == OP_READDIR
10008 || expr->op_type == OP_GLOB
10009 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
10010 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
10011 expr = newUNOP(OP_DEFINED, 0,
10012 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
10013 } else if (expr->op_flags & OPf_KIDS) {
10014 const OP * const k1 = ((UNOP*)expr)->op_first;
10015 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
10016 switch (expr->op_type) {
10018 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
10019 && (k2->op_flags & OPf_STACKED)
10020 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
10021 expr = newUNOP(OP_DEFINED, 0, expr);
10025 if (k1 && (k1->op_type == OP_READDIR
10026 || k1->op_type == OP_GLOB
10027 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
10028 || k1->op_type == OP_EACH
10029 || k1->op_type == OP_AEACH))
10030 expr = newUNOP(OP_DEFINED, 0, expr);
10037 block = newOP(OP_NULL, 0);
10038 else if (cont || has_my) {
10039 block = op_scope(block);
10043 next = LINKLIST(cont);
10046 OP * const unstack = newOP(OP_UNSTACK, 0);
10049 cont = op_append_elem(OP_LINESEQ, cont, unstack);
10053 listop = op_append_list(OP_LINESEQ, block, cont);
10055 redo = LINKLIST(listop);
10059 o = new_logop(OP_AND, 0, &expr, &listop);
10060 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
10061 op_free((OP*)loop);
10062 return expr; /* listop already freed by new_logop */
10065 ((LISTOP*)listop)->op_last->op_next =
10066 (o == listop ? redo : LINKLIST(o));
10072 NewOp(1101,loop,1,LOOP);
10073 OpTYPE_set(loop, OP_ENTERLOOP);
10074 loop->op_private = 0;
10075 loop->op_next = (OP*)loop;
10078 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
10080 loop->op_redoop = redo;
10081 loop->op_lastop = o;
10082 o->op_private |= loopflags;
10085 loop->op_nextop = next;
10087 loop->op_nextop = o;
10089 o->op_flags |= flags;
10090 o->op_private |= (flags >> 8);
10095 =for apidoc newFOROP
10097 Constructs, checks, and returns an op tree expressing a C<foreach>
10098 loop (iteration through a list of values). This is a heavyweight loop,
10099 with structure that allows exiting the loop by C<last> and suchlike.
10101 C<sv> optionally supplies the variable that will be aliased to each
10102 item in turn; if null, it defaults to C<$_>.
10103 C<expr> supplies the list of values to iterate over. C<block> supplies
10104 the main body of the loop, and C<cont> optionally supplies a C<continue>
10105 block that operates as a second half of the body. All of these optree
10106 inputs are consumed by this function and become part of the constructed
10109 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10110 op and, shifted up eight bits, the eight bits of C<op_private> for
10111 the C<leaveloop> op, except that (in both cases) some bits will be set
10118 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
10122 PADOFFSET padoff = 0;
10124 I32 iterpflags = 0;
10126 PERL_ARGS_ASSERT_NEWFOROP;
10129 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
10130 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
10131 OpTYPE_set(sv, OP_RV2GV);
10133 /* The op_type check is needed to prevent a possible segfault
10134 * if the loop variable is undeclared and 'strict vars' is in
10135 * effect. This is illegal but is nonetheless parsed, so we
10136 * may reach this point with an OP_CONST where we're expecting
10139 if (cUNOPx(sv)->op_first->op_type == OP_GV
10140 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
10141 iterpflags |= OPpITER_DEF;
10143 else if (sv->op_type == OP_PADSV) { /* private variable */
10144 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
10145 padoff = sv->op_targ;
10149 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
10151 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
10154 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
10156 PADNAME * const pn = PAD_COMPNAME(padoff);
10157 const char * const name = PadnamePV(pn);
10159 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
10160 iterpflags |= OPpITER_DEF;
10164 sv = newGVOP(OP_GV, 0, PL_defgv);
10165 iterpflags |= OPpITER_DEF;
10168 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
10169 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
10170 iterflags |= OPf_STACKED;
10172 else if (expr->op_type == OP_NULL &&
10173 (expr->op_flags & OPf_KIDS) &&
10174 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
10176 /* Basically turn for($x..$y) into the same as for($x,$y), but we
10177 * set the STACKED flag to indicate that these values are to be
10178 * treated as min/max values by 'pp_enteriter'.
10180 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
10181 LOGOP* const range = (LOGOP*) flip->op_first;
10182 OP* const left = range->op_first;
10183 OP* const right = OpSIBLING(left);
10186 range->op_flags &= ~OPf_KIDS;
10187 /* detach range's children */
10188 op_sibling_splice((OP*)range, NULL, -1, NULL);
10190 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
10191 listop->op_first->op_next = range->op_next;
10192 left->op_next = range->op_other;
10193 right->op_next = (OP*)listop;
10194 listop->op_next = listop->op_first;
10197 expr = (OP*)(listop);
10199 iterflags |= OPf_STACKED;
10202 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
10205 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
10206 op_append_elem(OP_LIST, list(expr),
10208 assert(!loop->op_next);
10209 /* for my $x () sets OPpLVAL_INTRO;
10210 * for our $x () sets OPpOUR_INTRO */
10211 loop->op_private = (U8)iterpflags;
10213 /* upgrade loop from a LISTOP to a LOOPOP;
10214 * keep it in-place if there's space */
10215 if (loop->op_slabbed
10216 && OpSLOT(loop)->opslot_size
10217 < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
10219 /* no space; allocate new op */
10221 NewOp(1234,tmp,1,LOOP);
10222 Copy(loop,tmp,1,LISTOP);
10223 assert(loop->op_last->op_sibparent == (OP*)loop);
10224 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
10225 S_op_destroy(aTHX_ (OP*)loop);
10228 else if (!loop->op_slabbed)
10230 /* loop was malloc()ed */
10231 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
10232 OpLASTSIB_set(loop->op_last, (OP*)loop);
10234 loop->op_targ = padoff;
10235 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
10240 =for apidoc newLOOPEX
10242 Constructs, checks, and returns a loop-exiting op (such as C<goto>
10243 or C<last>). C<type> is the opcode. C<label> supplies the parameter
10244 determining the target of the op; it is consumed by this function and
10245 becomes part of the constructed op tree.
10251 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
10255 PERL_ARGS_ASSERT_NEWLOOPEX;
10257 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
10258 || type == OP_CUSTOM);
10260 if (type != OP_GOTO) {
10261 /* "last()" means "last" */
10262 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
10263 o = newOP(type, OPf_SPECIAL);
10267 /* Check whether it's going to be a goto &function */
10268 if (label->op_type == OP_ENTERSUB
10269 && !(label->op_flags & OPf_STACKED))
10270 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
10273 /* Check for a constant argument */
10274 if (label->op_type == OP_CONST) {
10275 SV * const sv = ((SVOP *)label)->op_sv;
10277 const char *s = SvPV_const(sv,l);
10278 if (l == strlen(s)) {
10280 SvUTF8(((SVOP*)label)->op_sv),
10282 SvPV_nolen_const(((SVOP*)label)->op_sv)));
10286 /* If we have already created an op, we do not need the label. */
10289 else o = newUNOP(type, OPf_STACKED, label);
10291 PL_hints |= HINT_BLOCK_SCOPE;
10295 /* if the condition is a literal array or hash
10296 (or @{ ... } etc), make a reference to it.
10299 S_ref_array_or_hash(pTHX_ OP *cond)
10302 && (cond->op_type == OP_RV2AV
10303 || cond->op_type == OP_PADAV
10304 || cond->op_type == OP_RV2HV
10305 || cond->op_type == OP_PADHV))
10307 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
10310 && (cond->op_type == OP_ASLICE
10311 || cond->op_type == OP_KVASLICE
10312 || cond->op_type == OP_HSLICE
10313 || cond->op_type == OP_KVHSLICE)) {
10315 /* anonlist now needs a list from this op, was previously used in
10316 * scalar context */
10317 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
10318 cond->op_flags |= OPf_WANT_LIST;
10320 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
10327 /* These construct the optree fragments representing given()
10330 entergiven and enterwhen are LOGOPs; the op_other pointer
10331 points up to the associated leave op. We need this so we
10332 can put it in the context and make break/continue work.
10333 (Also, of course, pp_enterwhen will jump straight to
10334 op_other if the match fails.)
10338 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
10339 I32 enter_opcode, I32 leave_opcode,
10340 PADOFFSET entertarg)
10345 PERL_ARGS_ASSERT_NEWGIVWHENOP;
10346 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
10348 enterop = alloc_LOGOP(enter_opcode, block, NULL);
10349 enterop->op_targ = 0;
10350 enterop->op_private = 0;
10352 o = newUNOP(leave_opcode, 0, (OP *) enterop);
10355 /* prepend cond if we have one */
10356 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
10358 o->op_next = LINKLIST(cond);
10359 cond->op_next = (OP *) enterop;
10362 /* This is a default {} block */
10363 enterop->op_flags |= OPf_SPECIAL;
10364 o ->op_flags |= OPf_SPECIAL;
10366 o->op_next = (OP *) enterop;
10369 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
10370 entergiven and enterwhen both
10373 enterop->op_next = LINKLIST(block);
10374 block->op_next = enterop->op_other = o;
10380 /* For the purposes of 'when(implied_smartmatch)'
10381 * versus 'when(boolean_expression)',
10382 * does this look like a boolean operation? For these purposes
10383 a boolean operation is:
10384 - a subroutine call [*]
10385 - a logical connective
10386 - a comparison operator
10387 - a filetest operator, with the exception of -s -M -A -C
10388 - defined(), exists() or eof()
10389 - /$re/ or $foo =~ /$re/
10391 [*] possibly surprising
10394 S_looks_like_bool(pTHX_ const OP *o)
10396 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
10398 switch(o->op_type) {
10401 return looks_like_bool(cLOGOPo->op_first);
10405 OP* sibl = OpSIBLING(cLOGOPo->op_first);
10408 looks_like_bool(cLOGOPo->op_first)
10409 && looks_like_bool(sibl));
10415 o->op_flags & OPf_KIDS
10416 && looks_like_bool(cUNOPo->op_first));
10420 case OP_NOT: case OP_XOR:
10422 case OP_EQ: case OP_NE: case OP_LT:
10423 case OP_GT: case OP_LE: case OP_GE:
10425 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
10426 case OP_I_GT: case OP_I_LE: case OP_I_GE:
10428 case OP_SEQ: case OP_SNE: case OP_SLT:
10429 case OP_SGT: case OP_SLE: case OP_SGE:
10431 case OP_SMARTMATCH:
10433 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
10434 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
10435 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
10436 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
10437 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
10438 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
10439 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
10440 case OP_FTTEXT: case OP_FTBINARY:
10442 case OP_DEFINED: case OP_EXISTS:
10443 case OP_MATCH: case OP_EOF:
10451 /* optimised-away (index() != -1) or similar comparison */
10452 if (o->op_private & OPpTRUEBOOL)
10457 /* Detect comparisons that have been optimized away */
10458 if (cSVOPo->op_sv == &PL_sv_yes
10459 || cSVOPo->op_sv == &PL_sv_no)
10472 =for apidoc newGIVENOP
10474 Constructs, checks, and returns an op tree expressing a C<given> block.
10475 C<cond> supplies the expression to whose value C<$_> will be locally
10476 aliased, and C<block> supplies the body of the C<given> construct; they
10477 are consumed by this function and become part of the constructed op tree.
10478 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
10484 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
10486 PERL_ARGS_ASSERT_NEWGIVENOP;
10487 PERL_UNUSED_ARG(defsv_off);
10489 assert(!defsv_off);
10490 return newGIVWHENOP(
10491 ref_array_or_hash(cond),
10493 OP_ENTERGIVEN, OP_LEAVEGIVEN,
10498 =for apidoc newWHENOP
10500 Constructs, checks, and returns an op tree expressing a C<when> block.
10501 C<cond> supplies the test expression, and C<block> supplies the block
10502 that will be executed if the test evaluates to true; they are consumed
10503 by this function and become part of the constructed op tree. C<cond>
10504 will be interpreted DWIMically, often as a comparison against C<$_>,
10505 and may be null to generate a C<default> block.
10511 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
10513 const bool cond_llb = (!cond || looks_like_bool(cond));
10516 PERL_ARGS_ASSERT_NEWWHENOP;
10521 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
10523 scalar(ref_array_or_hash(cond)));
10526 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
10529 /* must not conflict with SVf_UTF8 */
10530 #define CV_CKPROTO_CURSTASH 0x1
10533 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
10534 const STRLEN len, const U32 flags)
10536 SV *name = NULL, *msg;
10537 const char * cvp = SvROK(cv)
10538 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
10539 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
10542 STRLEN clen = CvPROTOLEN(cv), plen = len;
10544 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
10546 if (p == NULL && cvp == NULL)
10549 if (!ckWARN_d(WARN_PROTOTYPE))
10553 p = S_strip_spaces(aTHX_ p, &plen);
10554 cvp = S_strip_spaces(aTHX_ cvp, &clen);
10555 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
10556 if (plen == clen && memEQ(cvp, p, plen))
10559 if (flags & SVf_UTF8) {
10560 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
10564 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
10570 msg = sv_newmortal();
10575 gv_efullname3(name = sv_newmortal(), gv, NULL);
10576 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
10577 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
10578 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
10579 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
10580 sv_catpvs(name, "::");
10582 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
10583 assert (CvNAMED(SvRV_const(gv)));
10584 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
10586 else sv_catsv(name, (SV *)gv);
10588 else name = (SV *)gv;
10590 sv_setpvs(msg, "Prototype mismatch:");
10592 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
10594 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
10595 UTF8fARG(SvUTF8(cv),clen,cvp)
10598 sv_catpvs(msg, ": none");
10599 sv_catpvs(msg, " vs ");
10601 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
10603 sv_catpvs(msg, "none");
10604 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
10607 static void const_sv_xsub(pTHX_ CV* cv);
10608 static void const_av_xsub(pTHX_ CV* cv);
10612 =for apidoc_section $optree_manipulation
10614 =for apidoc cv_const_sv
10616 If C<cv> is a constant sub eligible for inlining, returns the constant
10617 value returned by the sub. Otherwise, returns C<NULL>.
10619 Constant subs can be created with C<newCONSTSUB> or as described in
10620 L<perlsub/"Constant Functions">.
10625 Perl_cv_const_sv(const CV *const cv)
10630 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
10632 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10633 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
10638 Perl_cv_const_sv_or_av(const CV * const cv)
10642 if (SvROK(cv)) return SvRV((SV *)cv);
10643 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
10644 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10647 /* op_const_sv: examine an optree to determine whether it's in-lineable.
10648 * Can be called in 2 ways:
10651 * look for a single OP_CONST with attached value: return the value
10653 * allow_lex && !CvCONST(cv);
10655 * examine the clone prototype, and if contains only a single
10656 * OP_CONST, return the value; or if it contains a single PADSV ref-
10657 * erencing an outer lexical, turn on CvCONST to indicate the CV is
10658 * a candidate for "constizing" at clone time, and return NULL.
10662 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
10665 bool padsv = FALSE;
10670 for (; o; o = o->op_next) {
10671 const OPCODE type = o->op_type;
10673 if (type == OP_NEXTSTATE || type == OP_LINESEQ
10675 || type == OP_PUSHMARK)
10677 if (type == OP_DBSTATE)
10679 if (type == OP_LEAVESUB)
10683 if (type == OP_CONST && cSVOPo->op_sv)
10684 sv = cSVOPo->op_sv;
10685 else if (type == OP_UNDEF && !o->op_private) {
10689 else if (allow_lex && type == OP_PADSV) {
10690 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
10692 sv = &PL_sv_undef; /* an arbitrary non-null value */
10710 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10711 PADNAME * const name, SV ** const const_svp)
10714 assert (o || name);
10715 assert (const_svp);
10717 if (CvFLAGS(PL_compcv)) {
10718 /* might have had built-in attrs applied */
10719 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10720 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10721 && ckWARN(WARN_MISC))
10723 /* protect against fatal warnings leaking compcv */
10724 SAVEFREESV(PL_compcv);
10725 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10726 SvREFCNT_inc_simple_void_NN(PL_compcv);
10729 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10730 & ~(CVf_LVALUE * pureperl));
10735 /* redundant check for speed: */
10736 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10737 const line_t oldline = CopLINE(PL_curcop);
10740 : sv_2mortal(newSVpvn_utf8(
10741 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
10743 if (PL_parser && PL_parser->copline != NOLINE)
10744 /* This ensures that warnings are reported at the first
10745 line of a redefinition, not the last. */
10746 CopLINE_set(PL_curcop, PL_parser->copline);
10747 /* protect against fatal warnings leaking compcv */
10748 SAVEFREESV(PL_compcv);
10749 report_redefined_cv(namesv, cv, const_svp);
10750 SvREFCNT_inc_simple_void_NN(PL_compcv);
10751 CopLINE_set(PL_curcop, oldline);
10758 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10763 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10766 CV *compcv = PL_compcv;
10769 PADOFFSET pax = o->op_targ;
10770 CV *outcv = CvOUTSIDE(PL_compcv);
10773 bool reusable = FALSE;
10775 #ifdef PERL_DEBUG_READONLY_OPS
10776 OPSLAB *slab = NULL;
10779 PERL_ARGS_ASSERT_NEWMYSUB;
10781 PL_hints |= HINT_BLOCK_SCOPE;
10783 /* Find the pad slot for storing the new sub.
10784 We cannot use PL_comppad, as it is the pad owned by the new sub. We
10785 need to look in CvOUTSIDE and find the pad belonging to the enclos-
10786 ing sub. And then we need to dig deeper if this is a lexical from
10788 my sub foo; sub { sub foo { } }
10791 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10792 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10793 pax = PARENT_PAD_INDEX(name);
10794 outcv = CvOUTSIDE(outcv);
10799 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10800 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10801 spot = (CV **)svspot;
10803 if (!(PL_parser && PL_parser->error_count))
10804 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10807 assert(proto->op_type == OP_CONST);
10808 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10809 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10819 if (PL_parser && PL_parser->error_count) {
10821 SvREFCNT_dec(PL_compcv);
10826 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10828 svspot = (SV **)(spot = &clonee);
10830 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10833 assert (SvTYPE(*spot) == SVt_PVCV);
10834 if (CvNAMED(*spot))
10835 hek = CvNAME_HEK(*spot);
10838 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10839 CvNAME_HEK_set(*spot, hek =
10842 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10846 CvLEXICAL_on(*spot);
10848 cv = PadnamePROTOCV(name);
10849 svspot = (SV **)(spot = &PadnamePROTOCV(name));
10853 /* This makes sub {}; work as expected. */
10854 if (block->op_type == OP_STUB) {
10855 const line_t l = PL_parser->copline;
10857 block = newSTATEOP(0, NULL, 0);
10858 PL_parser->copline = l;
10860 block = CvLVALUE(compcv)
10861 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10862 ? newUNOP(OP_LEAVESUBLV, 0,
10863 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10864 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10865 start = LINKLIST(block);
10866 block->op_next = 0;
10867 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10868 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10876 const bool exists = CvROOT(cv) || CvXSUB(cv);
10878 /* if the subroutine doesn't exist and wasn't pre-declared
10879 * with a prototype, assume it will be AUTOLOADed,
10880 * skipping the prototype check
10882 if (exists || SvPOK(cv))
10883 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10885 /* already defined? */
10887 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10893 /* just a "sub foo;" when &foo is already defined */
10894 SAVEFREESV(compcv);
10898 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10905 SvREFCNT_inc_simple_void_NN(const_sv);
10906 SvFLAGS(const_sv) |= SVs_PADTMP;
10908 assert(!CvROOT(cv) && !CvCONST(cv));
10909 cv_forget_slab(cv);
10912 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10913 CvFILE_set_from_cop(cv, PL_curcop);
10914 CvSTASH_set(cv, PL_curstash);
10917 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10918 CvXSUBANY(cv).any_ptr = const_sv;
10919 CvXSUB(cv) = const_sv_xsub;
10923 CvFLAGS(cv) |= CvMETHOD(compcv);
10925 SvREFCNT_dec(compcv);
10930 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10931 determine whether this sub definition is in the same scope as its
10932 declaration. If this sub definition is inside an inner named pack-
10933 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10934 the package sub. So check PadnameOUTER(name) too.
10936 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10937 assert(!CvWEAKOUTSIDE(compcv));
10938 SvREFCNT_dec(CvOUTSIDE(compcv));
10939 CvWEAKOUTSIDE_on(compcv);
10941 /* XXX else do we have a circular reference? */
10943 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
10944 /* transfer PL_compcv to cv */
10946 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10947 cv_flags_t preserved_flags =
10948 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10949 PADLIST *const temp_padl = CvPADLIST(cv);
10950 CV *const temp_cv = CvOUTSIDE(cv);
10951 const cv_flags_t other_flags =
10952 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10953 OP * const cvstart = CvSTART(cv);
10957 CvFLAGS(compcv) | preserved_flags;
10958 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10959 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10960 CvPADLIST_set(cv, CvPADLIST(compcv));
10961 CvOUTSIDE(compcv) = temp_cv;
10962 CvPADLIST_set(compcv, temp_padl);
10963 CvSTART(cv) = CvSTART(compcv);
10964 CvSTART(compcv) = cvstart;
10965 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10966 CvFLAGS(compcv) |= other_flags;
10969 Safefree(CvFILE(cv));
10973 /* inner references to compcv must be fixed up ... */
10974 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10975 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10976 ++PL_sub_generation;
10979 /* Might have had built-in attributes applied -- propagate them. */
10980 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10982 /* ... before we throw it away */
10983 SvREFCNT_dec(compcv);
10984 PL_compcv = compcv = cv;
10993 if (!CvNAME_HEK(cv)) {
10994 if (hek) (void)share_hek_hek(hek);
10997 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10998 hek = share_hek(PadnamePV(name)+1,
10999 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
11002 CvNAME_HEK_set(cv, hek);
11008 if (CvFILE(cv) && CvDYNFILE(cv))
11009 Safefree(CvFILE(cv));
11010 CvFILE_set_from_cop(cv, PL_curcop);
11011 CvSTASH_set(cv, PL_curstash);
11014 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11016 SvUTF8_on(MUTABLE_SV(cv));
11020 /* If we assign an optree to a PVCV, then we've defined a
11021 * subroutine that the debugger could be able to set a breakpoint
11022 * in, so signal to pp_entereval that it should not throw away any
11023 * saved lines at scope exit. */
11025 PL_breakable_sub_gen++;
11026 CvROOT(cv) = block;
11027 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11028 itself has a refcount. */
11030 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11031 #ifdef PERL_DEBUG_READONLY_OPS
11032 slab = (OPSLAB *)CvSTART(cv);
11034 S_process_optree(aTHX_ cv, block, start);
11039 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11040 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
11044 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11045 SV * const tmpstr = sv_newmortal();
11046 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11047 GV_ADDMULTI, SVt_PVHV);
11049 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11050 CopFILE(PL_curcop),
11052 (long)CopLINE(PL_curcop));
11053 if (HvNAME_HEK(PL_curstash)) {
11054 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
11055 sv_catpvs(tmpstr, "::");
11058 sv_setpvs(tmpstr, "__ANON__::");
11060 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
11061 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
11062 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11063 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11064 hv = GvHVn(db_postponed);
11065 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11066 CV * const pcv = GvCV(db_postponed);
11072 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11080 assert(CvDEPTH(outcv));
11082 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
11084 cv_clone_into(clonee, *spot);
11085 else *spot = cv_clone(clonee);
11086 SvREFCNT_dec_NN(clonee);
11090 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
11091 PADOFFSET depth = CvDEPTH(outcv);
11094 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
11096 *svspot = SvREFCNT_inc_simple_NN(cv);
11097 SvREFCNT_dec(oldcv);
11103 PL_parser->copline = NOLINE;
11104 LEAVE_SCOPE(floor);
11105 #ifdef PERL_DEBUG_READONLY_OPS
11114 =for apidoc newATTRSUB_x
11116 Construct a Perl subroutine, also performing some surrounding jobs.
11118 This function is expected to be called in a Perl compilation context,
11119 and some aspects of the subroutine are taken from global variables
11120 associated with compilation. In particular, C<PL_compcv> represents
11121 the subroutine that is currently being compiled. It must be non-null
11122 when this function is called, and some aspects of the subroutine being
11123 constructed are taken from it. The constructed subroutine may actually
11124 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
11126 If C<block> is null then the subroutine will have no body, and for the
11127 time being it will be an error to call it. This represents a forward
11128 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
11129 non-null then it provides the Perl code of the subroutine body, which
11130 will be executed when the subroutine is called. This body includes
11131 any argument unwrapping code resulting from a subroutine signature or
11132 similar. The pad use of the code must correspond to the pad attached
11133 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
11134 C<leavesublv> op; this function will add such an op. C<block> is consumed
11135 by this function and will become part of the constructed subroutine.
11137 C<proto> specifies the subroutine's prototype, unless one is supplied
11138 as an attribute (see below). If C<proto> is null, then the subroutine
11139 will not have a prototype. If C<proto> is non-null, it must point to a
11140 C<const> op whose value is a string, and the subroutine will have that
11141 string as its prototype. If a prototype is supplied as an attribute, the
11142 attribute takes precedence over C<proto>, but in that case C<proto> should
11143 preferably be null. In any case, C<proto> is consumed by this function.
11145 C<attrs> supplies attributes to be applied the subroutine. A handful of
11146 attributes take effect by built-in means, being applied to C<PL_compcv>
11147 immediately when seen. Other attributes are collected up and attached
11148 to the subroutine by this route. C<attrs> may be null to supply no
11149 attributes, or point to a C<const> op for a single attribute, or point
11150 to a C<list> op whose children apart from the C<pushmark> are C<const>
11151 ops for one or more attributes. Each C<const> op must be a string,
11152 giving the attribute name optionally followed by parenthesised arguments,
11153 in the manner in which attributes appear in Perl source. The attributes
11154 will be applied to the sub by this function. C<attrs> is consumed by
11157 If C<o_is_gv> is false and C<o> is null, then the subroutine will
11158 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
11159 must point to a C<const> OP, which will be consumed by this function,
11160 and its string value supplies a name for the subroutine. The name may
11161 be qualified or unqualified, and if it is unqualified then a default
11162 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
11163 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
11164 by which the subroutine will be named.
11166 If there is already a subroutine of the specified name, then the new
11167 sub will either replace the existing one in the glob or be merged with
11168 the existing one. A warning may be generated about redefinition.
11170 If the subroutine has one of a few special names, such as C<BEGIN> or
11171 C<END>, then it will be claimed by the appropriate queue for automatic
11172 running of phase-related subroutines. In this case the relevant glob will
11173 be left not containing any subroutine, even if it did contain one before.
11174 In the case of C<BEGIN>, the subroutine will be executed and the reference
11175 to it disposed of before this function returns.
11177 The function returns a pointer to the constructed subroutine. If the sub
11178 is anonymous then ownership of one counted reference to the subroutine
11179 is transferred to the caller. If the sub is named then the caller does
11180 not get ownership of a reference. In most such cases, where the sub
11181 has a non-phase name, the sub will be alive at the point it is returned
11182 by virtue of being contained in the glob that names it. A phase-named
11183 subroutine will usually be alive by virtue of the reference owned by the
11184 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11185 been executed, will quite likely have been destroyed already by the
11186 time this function returns, making it erroneous for the caller to make
11187 any use of the returned pointer. It is the caller's responsibility to
11188 ensure that it knows which of these situations applies.
11190 =for apidoc newATTRSUB
11191 Construct a Perl subroutine, also performing some surrounding jobs.
11193 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter set to
11194 FALSE. This means that if C<o> is null, the new sub will be anonymous; otherwise
11195 the name will be derived from C<o> in the way described (as with all other
11196 details) in L<perlintern/C<newATTRSUB_x>>.
11199 Like C<L</newATTRSUB>>, but without attributes.
11204 /* _x = extended */
11206 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
11207 OP *block, bool o_is_gv)
11211 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11213 CV *cv = NULL; /* the previous CV with this name, if any */
11215 const bool ec = PL_parser && PL_parser->error_count;
11216 /* If the subroutine has no body, no attributes, and no builtin attributes
11217 then it's just a sub declaration, and we may be able to get away with
11218 storing with a placeholder scalar in the symbol table, rather than a
11219 full CV. If anything is present then it will take a full CV to
11221 const I32 gv_fetch_flags
11222 = ec ? GV_NOADD_NOINIT :
11223 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
11224 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
11226 const char * const name =
11227 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
11229 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
11230 bool evanescent = FALSE;
11232 #ifdef PERL_DEBUG_READONLY_OPS
11233 OPSLAB *slab = NULL;
11241 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
11242 hek and CvSTASH pointer together can imply the GV. If the name
11243 contains a package name, then GvSTASH(CvGV(cv)) may differ from
11244 CvSTASH, so forego the optimisation if we find any.
11245 Also, we may be called from load_module at run time, so
11246 PL_curstash (which sets CvSTASH) may not point to the stash the
11247 sub is stored in. */
11248 /* XXX This optimization is currently disabled for packages other
11249 than main, since there was too much CPAN breakage. */
11251 ec ? GV_NOADD_NOINIT
11252 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
11253 || PL_curstash != PL_defstash
11254 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
11256 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
11257 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
11259 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
11260 SV * const sv = sv_newmortal();
11261 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
11262 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11263 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11264 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
11266 } else if (PL_curstash) {
11267 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
11270 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
11276 move_proto_attr(&proto, &attrs, gv, 0);
11279 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
11284 assert(proto->op_type == OP_CONST);
11285 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11286 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11302 SvREFCNT_dec(PL_compcv);
11307 if (name && block) {
11308 const char *s = (char *) my_memrchr(name, ':', namlen);
11309 s = s ? s+1 : name;
11310 if (strEQ(s, "BEGIN")) {
11311 if (PL_in_eval & EVAL_KEEPERR)
11312 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
11314 SV * const errsv = ERRSV;
11315 /* force display of errors found but not reported */
11316 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
11317 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
11324 if (!block && SvTYPE(gv) != SVt_PVGV) {
11325 /* If we are not defining a new sub and the existing one is not a
11327 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
11328 /* We are applying attributes to an existing sub, so we need it
11329 upgraded if it is a constant. */
11330 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
11331 gv_init_pvn(gv, PL_curstash, name, namlen,
11332 SVf_UTF8 * name_is_utf8);
11334 else { /* Maybe prototype now, and had at maximum
11335 a prototype or const/sub ref before. */
11336 if (SvTYPE(gv) > SVt_NULL) {
11337 cv_ckproto_len_flags((const CV *)gv,
11338 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11344 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
11346 SvUTF8_on(MUTABLE_SV(gv));
11349 sv_setiv(MUTABLE_SV(gv), -1);
11352 SvREFCNT_dec(PL_compcv);
11353 cv = PL_compcv = NULL;
11358 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
11362 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
11368 /* This makes sub {}; work as expected. */
11369 if (block->op_type == OP_STUB) {
11370 const line_t l = PL_parser->copline;
11372 block = newSTATEOP(0, NULL, 0);
11373 PL_parser->copline = l;
11375 block = CvLVALUE(PL_compcv)
11376 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
11377 && (!isGV(gv) || !GvASSUMECV(gv)))
11378 ? newUNOP(OP_LEAVESUBLV, 0,
11379 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
11380 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
11381 start = LINKLIST(block);
11382 block->op_next = 0;
11383 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
11385 S_op_const_sv(aTHX_ start, PL_compcv,
11386 cBOOL(CvCLONE(PL_compcv)));
11393 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
11394 cv_ckproto_len_flags((const CV *)gv,
11395 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11396 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
11398 /* All the other code for sub redefinition warnings expects the
11399 clobbered sub to be a CV. Instead of making all those code
11400 paths more complex, just inline the RV version here. */
11401 const line_t oldline = CopLINE(PL_curcop);
11402 assert(IN_PERL_COMPILETIME);
11403 if (PL_parser && PL_parser->copline != NOLINE)
11404 /* This ensures that warnings are reported at the first
11405 line of a redefinition, not the last. */
11406 CopLINE_set(PL_curcop, PL_parser->copline);
11407 /* protect against fatal warnings leaking compcv */
11408 SAVEFREESV(PL_compcv);
11410 if (ckWARN(WARN_REDEFINE)
11411 || ( ckWARN_d(WARN_REDEFINE)
11412 && ( !const_sv || SvRV(gv) == const_sv
11413 || sv_cmp(SvRV(gv), const_sv) ))) {
11415 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11416 "Constant subroutine %" SVf " redefined",
11417 SVfARG(cSVOPo->op_sv));
11420 SvREFCNT_inc_simple_void_NN(PL_compcv);
11421 CopLINE_set(PL_curcop, oldline);
11422 SvREFCNT_dec(SvRV(gv));
11427 const bool exists = CvROOT(cv) || CvXSUB(cv);
11429 /* if the subroutine doesn't exist and wasn't pre-declared
11430 * with a prototype, assume it will be AUTOLOADed,
11431 * skipping the prototype check
11433 if (exists || SvPOK(cv))
11434 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
11435 /* already defined (or promised)? */
11436 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
11437 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
11443 /* just a "sub foo;" when &foo is already defined */
11444 SAVEFREESV(PL_compcv);
11451 SvREFCNT_inc_simple_void_NN(const_sv);
11452 SvFLAGS(const_sv) |= SVs_PADTMP;
11454 assert(!CvROOT(cv) && !CvCONST(cv));
11455 cv_forget_slab(cv);
11456 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
11457 CvXSUBANY(cv).any_ptr = const_sv;
11458 CvXSUB(cv) = const_sv_xsub;
11462 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11465 if (isGV(gv) || CvMETHOD(PL_compcv)) {
11466 if (name && isGV(gv))
11467 GvCV_set(gv, NULL);
11468 cv = newCONSTSUB_flags(
11469 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
11473 assert(SvREFCNT((SV*)cv) != 0);
11474 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11478 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11479 prepare_SV_for_RV((SV *)gv);
11480 SvOK_off((SV *)gv);
11483 SvRV_set(gv, const_sv);
11487 SvREFCNT_dec(PL_compcv);
11492 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
11493 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
11496 if (cv) { /* must reuse cv if autoloaded */
11497 /* transfer PL_compcv to cv */
11499 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11500 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
11501 PADLIST *const temp_av = CvPADLIST(cv);
11502 CV *const temp_cv = CvOUTSIDE(cv);
11503 const cv_flags_t other_flags =
11504 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11505 OP * const cvstart = CvSTART(cv);
11509 assert(!CvCVGV_RC(cv));
11510 assert(CvGV(cv) == gv);
11514 PERL_HASH(hash, name, namlen);
11524 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
11526 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
11527 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
11528 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
11529 CvOUTSIDE(PL_compcv) = temp_cv;
11530 CvPADLIST_set(PL_compcv, temp_av);
11531 CvSTART(cv) = CvSTART(PL_compcv);
11532 CvSTART(PL_compcv) = cvstart;
11533 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11534 CvFLAGS(PL_compcv) |= other_flags;
11537 Safefree(CvFILE(cv));
11539 CvFILE_set_from_cop(cv, PL_curcop);
11540 CvSTASH_set(cv, PL_curstash);
11542 /* inner references to PL_compcv must be fixed up ... */
11543 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
11544 if (PERLDB_INTER)/* Advice debugger on the new sub. */
11545 ++PL_sub_generation;
11548 /* Might have had built-in attributes applied -- propagate them. */
11549 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
11551 /* ... before we throw it away */
11552 SvREFCNT_dec(PL_compcv);
11557 if (name && isGV(gv)) {
11560 if (HvENAME_HEK(GvSTASH(gv)))
11561 /* sub Foo::bar { (shift)+1 } */
11562 gv_method_changed(gv);
11566 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11567 prepare_SV_for_RV((SV *)gv);
11568 SvOK_off((SV *)gv);
11571 SvRV_set(gv, (SV *)cv);
11572 if (HvENAME_HEK(PL_curstash))
11573 mro_method_changed_in(PL_curstash);
11577 assert(SvREFCNT((SV*)cv) != 0);
11579 if (!CvHASGV(cv)) {
11584 PERL_HASH(hash, name, namlen);
11585 CvNAME_HEK_set(cv, share_hek(name,
11591 CvFILE_set_from_cop(cv, PL_curcop);
11592 CvSTASH_set(cv, PL_curstash);
11596 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11598 SvUTF8_on(MUTABLE_SV(cv));
11602 /* If we assign an optree to a PVCV, then we've defined a
11603 * subroutine that the debugger could be able to set a breakpoint
11604 * in, so signal to pp_entereval that it should not throw away any
11605 * saved lines at scope exit. */
11607 PL_breakable_sub_gen++;
11608 CvROOT(cv) = block;
11609 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11610 itself has a refcount. */
11612 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11613 #ifdef PERL_DEBUG_READONLY_OPS
11614 slab = (OPSLAB *)CvSTART(cv);
11616 S_process_optree(aTHX_ cv, block, start);
11621 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11622 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
11623 ? GvSTASH(CvGV(cv))
11627 apply_attrs(stash, MUTABLE_SV(cv), attrs);
11629 SvREFCNT_inc_simple_void_NN(cv);
11632 if (block && has_name) {
11633 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11634 SV * const tmpstr = cv_name(cv,NULL,0);
11635 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11636 GV_ADDMULTI, SVt_PVHV);
11638 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11639 CopFILE(PL_curcop),
11641 (long)CopLINE(PL_curcop));
11642 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11643 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11644 hv = GvHVn(db_postponed);
11645 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11646 CV * const pcv = GvCV(db_postponed);
11652 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11658 if (PL_parser && PL_parser->error_count)
11659 clear_special_blocks(name, gv, cv);
11662 process_special_blocks(floor, name, gv, cv);
11668 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11670 PL_parser->copline = NOLINE;
11671 LEAVE_SCOPE(floor);
11673 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11675 #ifdef PERL_DEBUG_READONLY_OPS
11679 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11680 pad_add_weakref(cv);
11686 S_clear_special_blocks(pTHX_ const char *const fullname,
11687 GV *const gv, CV *const cv) {
11691 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11693 colon = strrchr(fullname,':');
11694 name = colon ? colon + 1 : fullname;
11696 if ((*name == 'B' && strEQ(name, "BEGIN"))
11697 || (*name == 'E' && strEQ(name, "END"))
11698 || (*name == 'U' && strEQ(name, "UNITCHECK"))
11699 || (*name == 'C' && strEQ(name, "CHECK"))
11700 || (*name == 'I' && strEQ(name, "INIT"))) {
11705 GvCV_set(gv, NULL);
11706 SvREFCNT_dec_NN(MUTABLE_SV(cv));
11710 /* Returns true if the sub has been freed. */
11712 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11716 const char *const colon = strrchr(fullname,':');
11717 const char *const name = colon ? colon + 1 : fullname;
11719 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11721 if (*name == 'B') {
11722 if (strEQ(name, "BEGIN")) {
11723 const I32 oldscope = PL_scopestack_ix;
11726 if (floor) LEAVE_SCOPE(floor);
11728 PUSHSTACKi(PERLSI_REQUIRE);
11729 SAVECOPFILE(&PL_compiling);
11730 SAVECOPLINE(&PL_compiling);
11731 SAVEVPTR(PL_curcop);
11733 DEBUG_x( dump_sub(gv) );
11734 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11735 GvCV_set(gv,0); /* cv has been hijacked */
11736 call_list(oldscope, PL_beginav);
11740 return !PL_savebegin;
11745 if (*name == 'E') {
11746 if (strEQ(name, "END")) {
11747 DEBUG_x( dump_sub(gv) );
11748 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11751 } else if (*name == 'U') {
11752 if (strEQ(name, "UNITCHECK")) {
11753 /* It's never too late to run a unitcheck block */
11754 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11758 } else if (*name == 'C') {
11759 if (strEQ(name, "CHECK")) {
11761 /* diag_listed_as: Too late to run %s block */
11762 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11763 "Too late to run CHECK block");
11764 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11768 } else if (*name == 'I') {
11769 if (strEQ(name, "INIT")) {
11771 /* diag_listed_as: Too late to run %s block */
11772 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11773 "Too late to run INIT block");
11774 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11780 DEBUG_x( dump_sub(gv) );
11782 GvCV_set(gv,0); /* cv has been hijacked */
11788 =for apidoc newCONSTSUB
11790 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11791 rather than of counted length, and no flags are set. (This means that
11792 C<name> is always interpreted as Latin-1.)
11798 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11800 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11804 =for apidoc newCONSTSUB_flags
11806 Construct a constant subroutine, also performing some surrounding
11807 jobs. A scalar constant-valued subroutine is eligible for inlining
11808 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11809 123 }>>. Other kinds of constant subroutine have other treatment.
11811 The subroutine will have an empty prototype and will ignore any arguments
11812 when called. Its constant behaviour is determined by C<sv>. If C<sv>
11813 is null, the subroutine will yield an empty list. If C<sv> points to a
11814 scalar, the subroutine will always yield that scalar. If C<sv> points
11815 to an array, the subroutine will always yield a list of the elements of
11816 that array in list context, or the number of elements in the array in
11817 scalar context. This function takes ownership of one counted reference
11818 to the scalar or array, and will arrange for the object to live as long
11819 as the subroutine does. If C<sv> points to a scalar then the inlining
11820 assumes that the value of the scalar will never change, so the caller
11821 must ensure that the scalar is not subsequently written to. If C<sv>
11822 points to an array then no such assumption is made, so it is ostensibly
11823 safe to mutate the array or its elements, but whether this is really
11824 supported has not been determined.
11826 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11827 Other aspects of the subroutine will be left in their default state.
11828 The caller is free to mutate the subroutine beyond its initial state
11829 after this function has returned.
11831 If C<name> is null then the subroutine will be anonymous, with its
11832 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11833 subroutine will be named accordingly, referenced by the appropriate glob.
11834 C<name> is a string of length C<len> bytes giving a sigilless symbol
11835 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11836 otherwise. The name may be either qualified or unqualified. If the
11837 name is unqualified then it defaults to being in the stash specified by
11838 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11839 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11842 C<flags> should not have bits set other than C<SVf_UTF8>.
11844 If there is already a subroutine of the specified name, then the new sub
11845 will replace the existing one in the glob. A warning may be generated
11846 about the redefinition.
11848 If the subroutine has one of a few special names, such as C<BEGIN> or
11849 C<END>, then it will be claimed by the appropriate queue for automatic
11850 running of phase-related subroutines. In this case the relevant glob will
11851 be left not containing any subroutine, even if it did contain one before.
11852 Execution of the subroutine will likely be a no-op, unless C<sv> was
11853 a tied array or the caller modified the subroutine in some interesting
11854 way before it was executed. In the case of C<BEGIN>, the treatment is
11855 buggy: the sub will be executed when only half built, and may be deleted
11856 prematurely, possibly causing a crash.
11858 The function returns a pointer to the constructed subroutine. If the sub
11859 is anonymous then ownership of one counted reference to the subroutine
11860 is transferred to the caller. If the sub is named then the caller does
11861 not get ownership of a reference. In most such cases, where the sub
11862 has a non-phase name, the sub will be alive at the point it is returned
11863 by virtue of being contained in the glob that names it. A phase-named
11864 subroutine will usually be alive by virtue of the reference owned by
11865 the phase's automatic run queue. A C<BEGIN> subroutine may have been
11866 destroyed already by the time this function returns, but currently bugs
11867 occur in that case before the caller gets control. It is the caller's
11868 responsibility to ensure that it knows which of these situations applies.
11874 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11878 const char *const file = CopFILE(PL_curcop);
11882 if (IN_PERL_RUNTIME) {
11883 /* at runtime, it's not safe to manipulate PL_curcop: it may be
11884 * an op shared between threads. Use a non-shared COP for our
11886 SAVEVPTR(PL_curcop);
11887 SAVECOMPILEWARNINGS();
11888 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11889 PL_curcop = &PL_compiling;
11891 SAVECOPLINE(PL_curcop);
11892 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11895 PL_hints &= ~HINT_BLOCK_SCOPE;
11898 SAVEGENERICSV(PL_curstash);
11899 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11902 /* Protect sv against leakage caused by fatal warnings. */
11903 if (sv) SAVEFREESV(sv);
11905 /* file becomes the CvFILE. For an XS, it's usually static storage,
11906 and so doesn't get free()d. (It's expected to be from the C pre-
11907 processor __FILE__ directive). But we need a dynamically allocated one,
11908 and we need it to get freed. */
11909 cv = newXS_len_flags(name, len,
11910 sv && SvTYPE(sv) == SVt_PVAV
11913 file ? file : "", "",
11914 &sv, XS_DYNAMIC_FILENAME | flags);
11916 assert(SvREFCNT((SV*)cv) != 0);
11917 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11928 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
11929 static storage, as it is used directly as CvFILE(), without a copy being made.
11935 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11937 PERL_ARGS_ASSERT_NEWXS;
11938 return newXS_len_flags(
11939 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11944 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11945 const char *const filename, const char *const proto,
11948 PERL_ARGS_ASSERT_NEWXS_FLAGS;
11949 return newXS_len_flags(
11950 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11955 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11957 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11958 return newXS_len_flags(
11959 name, strlen(name), subaddr, NULL, NULL, NULL, 0
11964 =for apidoc newXS_len_flags
11966 Construct an XS subroutine, also performing some surrounding jobs.
11968 The subroutine will have the entry point C<subaddr>. It will have
11969 the prototype specified by the nul-terminated string C<proto>, or
11970 no prototype if C<proto> is null. The prototype string is copied;
11971 the caller can mutate the supplied string afterwards. If C<filename>
11972 is non-null, it must be a nul-terminated filename, and the subroutine
11973 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
11974 point directly to the supplied string, which must be static. If C<flags>
11975 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11978 Other aspects of the subroutine will be left in their default state.
11979 If anything else needs to be done to the subroutine for it to function
11980 correctly, it is the caller's responsibility to do that after this
11981 function has constructed it. However, beware of the subroutine
11982 potentially being destroyed before this function returns, as described
11985 If C<name> is null then the subroutine will be anonymous, with its
11986 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11987 subroutine will be named accordingly, referenced by the appropriate glob.
11988 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11989 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11990 The name may be either qualified or unqualified, with the stash defaulting
11991 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
11992 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11993 they have there, such as C<GV_ADDWARN>. The symbol is always added to
11994 the stash if necessary, with C<GV_ADDMULTI> semantics.
11996 If there is already a subroutine of the specified name, then the new sub
11997 will replace the existing one in the glob. A warning may be generated
11998 about the redefinition. If the old subroutine was C<CvCONST> then the
11999 decision about whether to warn is influenced by an expectation about
12000 whether the new subroutine will become a constant of similar value.
12001 That expectation is determined by C<const_svp>. (Note that the call to
12002 this function doesn't make the new subroutine C<CvCONST> in any case;
12003 that is left to the caller.) If C<const_svp> is null then it indicates
12004 that the new subroutine will not become a constant. If C<const_svp>
12005 is non-null then it indicates that the new subroutine will become a
12006 constant, and it points to an C<SV*> that provides the constant value
12007 that the subroutine will have.
12009 If the subroutine has one of a few special names, such as C<BEGIN> or
12010 C<END>, then it will be claimed by the appropriate queue for automatic
12011 running of phase-related subroutines. In this case the relevant glob will
12012 be left not containing any subroutine, even if it did contain one before.
12013 In the case of C<BEGIN>, the subroutine will be executed and the reference
12014 to it disposed of before this function returns, and also before its
12015 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
12016 constructed by this function to be ready for execution then the caller
12017 must prevent this happening by giving the subroutine a different name.
12019 The function returns a pointer to the constructed subroutine. If the sub
12020 is anonymous then ownership of one counted reference to the subroutine
12021 is transferred to the caller. If the sub is named then the caller does
12022 not get ownership of a reference. In most such cases, where the sub
12023 has a non-phase name, the sub will be alive at the point it is returned
12024 by virtue of being contained in the glob that names it. A phase-named
12025 subroutine will usually be alive by virtue of the reference owned by the
12026 phase's automatic run queue. But a C<BEGIN> subroutine, having already
12027 been executed, will quite likely have been destroyed already by the
12028 time this function returns, making it erroneous for the caller to make
12029 any use of the returned pointer. It is the caller's responsibility to
12030 ensure that it knows which of these situations applies.
12036 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
12037 XSUBADDR_t subaddr, const char *const filename,
12038 const char *const proto, SV **const_svp,
12042 bool interleave = FALSE;
12043 bool evanescent = FALSE;
12045 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
12048 GV * const gv = gv_fetchpvn(
12049 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
12050 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
12051 sizeof("__ANON__::__ANON__") - 1,
12052 GV_ADDMULTI | flags, SVt_PVCV);
12054 if ((cv = (name ? GvCV(gv) : NULL))) {
12056 /* just a cached method */
12060 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
12061 /* already defined (or promised) */
12062 /* Redundant check that allows us to avoid creating an SV
12063 most of the time: */
12064 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
12065 report_redefined_cv(newSVpvn_flags(
12066 name,len,(flags&SVf_UTF8)|SVs_TEMP
12077 if (cv) /* must reuse cv if autoloaded */
12080 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12084 if (HvENAME_HEK(GvSTASH(gv)))
12085 gv_method_changed(gv); /* newXS */
12089 assert(SvREFCNT((SV*)cv) != 0);
12093 /* XSUBs can't be perl lang/perl5db.pl debugged
12094 if (PERLDB_LINE_OR_SAVESRC)
12095 (void)gv_fetchfile(filename); */
12096 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
12097 if (flags & XS_DYNAMIC_FILENAME) {
12099 CvFILE(cv) = savepv(filename);
12101 /* NOTE: not copied, as it is expected to be an external constant string */
12102 CvFILE(cv) = (char *)filename;
12105 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
12106 CvFILE(cv) = (char*)PL_xsubfilename;
12109 CvXSUB(cv) = subaddr;
12110 #ifndef PERL_IMPLICIT_CONTEXT
12111 CvHSCXT(cv) = &PL_stack_sp;
12117 evanescent = process_special_blocks(0, name, gv, cv);
12120 } /* <- not a conditional branch */
12123 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12125 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
12126 if (interleave) LEAVE;
12127 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12131 /* Add a stub CV to a typeglob.
12132 * This is the implementation of a forward declaration, 'sub foo';'
12136 Perl_newSTUB(pTHX_ GV *gv, bool fake)
12138 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12140 PERL_ARGS_ASSERT_NEWSTUB;
12141 assert(!GvCVu(gv));
12144 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
12145 gv_method_changed(gv);
12147 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
12151 CvGV_set(cv, cvgv);
12152 CvFILE_set_from_cop(cv, PL_curcop);
12153 CvSTASH_set(cv, PL_curstash);
12159 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
12166 if (PL_parser && PL_parser->error_count) {
12172 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
12173 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
12176 if ((cv = GvFORM(gv))) {
12177 if (ckWARN(WARN_REDEFINE)) {
12178 const line_t oldline = CopLINE(PL_curcop);
12179 if (PL_parser && PL_parser->copline != NOLINE)
12180 CopLINE_set(PL_curcop, PL_parser->copline);
12182 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12183 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
12185 /* diag_listed_as: Format %s redefined */
12186 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12187 "Format STDOUT redefined");
12189 CopLINE_set(PL_curcop, oldline);
12194 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
12196 CvFILE_set_from_cop(cv, PL_curcop);
12199 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
12201 start = LINKLIST(root);
12203 S_process_optree(aTHX_ cv, root, start);
12204 cv_forget_slab(cv);
12209 PL_parser->copline = NOLINE;
12210 LEAVE_SCOPE(floor);
12211 PL_compiling.cop_seq = 0;
12215 Perl_newANONLIST(pTHX_ OP *o)
12217 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
12221 Perl_newANONHASH(pTHX_ OP *o)
12223 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
12227 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
12229 return newANONATTRSUB(floor, proto, NULL, block);
12233 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
12235 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
12237 newSVOP(OP_ANONCODE, 0,
12239 if (CvANONCONST(cv))
12240 anoncode = newUNOP(OP_ANONCONST, 0,
12241 op_convert_list(OP_ENTERSUB,
12242 OPf_STACKED|OPf_WANT_SCALAR,
12244 return newUNOP(OP_REFGEN, 0, anoncode);
12248 Perl_oopsAV(pTHX_ OP *o)
12251 PERL_ARGS_ASSERT_OOPSAV;
12253 switch (o->op_type) {
12256 OpTYPE_set(o, OP_PADAV);
12257 return ref(o, OP_RV2AV);
12261 OpTYPE_set(o, OP_RV2AV);
12266 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
12273 Perl_oopsHV(pTHX_ OP *o)
12276 PERL_ARGS_ASSERT_OOPSHV;
12278 switch (o->op_type) {
12281 OpTYPE_set(o, OP_PADHV);
12282 return ref(o, OP_RV2HV);
12286 OpTYPE_set(o, OP_RV2HV);
12287 /* rv2hv steals the bottom bit for its own uses */
12288 o->op_private &= ~OPpARG1_MASK;
12293 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
12300 Perl_newAVREF(pTHX_ OP *o)
12303 PERL_ARGS_ASSERT_NEWAVREF;
12305 if (o->op_type == OP_PADANY) {
12306 OpTYPE_set(o, OP_PADAV);
12309 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
12310 Perl_croak(aTHX_ "Can't use an array as a reference");
12312 return newUNOP(OP_RV2AV, 0, scalar(o));
12316 Perl_newGVREF(pTHX_ I32 type, OP *o)
12318 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
12319 return newUNOP(OP_NULL, 0, o);
12320 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
12324 Perl_newHVREF(pTHX_ OP *o)
12327 PERL_ARGS_ASSERT_NEWHVREF;
12329 if (o->op_type == OP_PADANY) {
12330 OpTYPE_set(o, OP_PADHV);
12333 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12334 Perl_croak(aTHX_ "Can't use a hash as a reference");
12336 return newUNOP(OP_RV2HV, 0, scalar(o));
12340 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12342 if (o->op_type == OP_PADANY) {
12343 OpTYPE_set(o, OP_PADCV);
12345 return newUNOP(OP_RV2CV, flags, scalar(o));
12349 Perl_newSVREF(pTHX_ OP *o)
12352 PERL_ARGS_ASSERT_NEWSVREF;
12354 if (o->op_type == OP_PADANY) {
12355 OpTYPE_set(o, OP_PADSV);
12359 return newUNOP(OP_RV2SV, 0, scalar(o));
12362 /* Check routines. See the comments at the top of this file for details
12363 * on when these are called */
12366 Perl_ck_anoncode(pTHX_ OP *o)
12368 PERL_ARGS_ASSERT_CK_ANONCODE;
12370 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12371 cSVOPo->op_sv = NULL;
12376 S_io_hints(pTHX_ OP *o)
12378 #if O_BINARY != 0 || O_TEXT != 0
12380 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12382 SV **svp = hv_fetchs(table, "open_IN", FALSE);
12385 const char *d = SvPV_const(*svp, len);
12386 const I32 mode = mode_from_discipline(d, len);
12387 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12389 if (mode & O_BINARY)
12390 o->op_private |= OPpOPEN_IN_RAW;
12394 o->op_private |= OPpOPEN_IN_CRLF;
12398 svp = hv_fetchs(table, "open_OUT", FALSE);
12401 const char *d = SvPV_const(*svp, len);
12402 const I32 mode = mode_from_discipline(d, len);
12403 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12405 if (mode & O_BINARY)
12406 o->op_private |= OPpOPEN_OUT_RAW;
12410 o->op_private |= OPpOPEN_OUT_CRLF;
12415 PERL_UNUSED_CONTEXT;
12416 PERL_UNUSED_ARG(o);
12421 Perl_ck_backtick(pTHX_ OP *o)
12426 PERL_ARGS_ASSERT_CK_BACKTICK;
12428 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12429 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12430 && (gv = gv_override("readpipe",8)))
12432 /* detach rest of siblings from o and its first child */
12433 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12434 newop = S_new_entersubop(aTHX_ gv, sibl);
12436 else if (!(o->op_flags & OPf_KIDS))
12437 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12442 S_io_hints(aTHX_ o);
12447 Perl_ck_bitop(pTHX_ OP *o)
12449 PERL_ARGS_ASSERT_CK_BITOP;
12451 o->op_private = (U8)(PL_hints & HINT_INTEGER);
12453 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12454 && OP_IS_INFIX_BIT(o->op_type))
12456 const OP * const left = cBINOPo->op_first;
12457 const OP * const right = OpSIBLING(left);
12458 if ((OP_IS_NUMCOMPARE(left->op_type) &&
12459 (left->op_flags & OPf_PARENS) == 0) ||
12460 (OP_IS_NUMCOMPARE(right->op_type) &&
12461 (right->op_flags & OPf_PARENS) == 0))
12462 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12463 "Possible precedence problem on bitwise %s operator",
12464 o->op_type == OP_BIT_OR
12465 ||o->op_type == OP_NBIT_OR ? "|"
12466 : o->op_type == OP_BIT_AND
12467 ||o->op_type == OP_NBIT_AND ? "&"
12468 : o->op_type == OP_BIT_XOR
12469 ||o->op_type == OP_NBIT_XOR ? "^"
12470 : o->op_type == OP_SBIT_OR ? "|."
12471 : o->op_type == OP_SBIT_AND ? "&." : "^."
12477 PERL_STATIC_INLINE bool
12478 is_dollar_bracket(pTHX_ const OP * const o)
12481 PERL_UNUSED_CONTEXT;
12482 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12483 && (kid = cUNOPx(o)->op_first)
12484 && kid->op_type == OP_GV
12485 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12488 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12491 Perl_ck_cmp(pTHX_ OP *o)
12497 OP *indexop, *constop, *start;
12501 PERL_ARGS_ASSERT_CK_CMP;
12503 is_eq = ( o->op_type == OP_EQ
12504 || o->op_type == OP_NE
12505 || o->op_type == OP_I_EQ
12506 || o->op_type == OP_I_NE);
12508 if (!is_eq && ckWARN(WARN_SYNTAX)) {
12509 const OP *kid = cUNOPo->op_first;
12512 ( is_dollar_bracket(aTHX_ kid)
12513 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12515 || ( kid->op_type == OP_CONST
12516 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12520 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12521 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12524 /* convert (index(...) == -1) and variations into
12525 * (r)index/BOOL(,NEG)
12530 indexop = cUNOPo->op_first;
12531 constop = OpSIBLING(indexop);
12533 if (indexop->op_type == OP_CONST) {
12535 indexop = OpSIBLING(constop);
12540 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12543 /* ($lex = index(....)) == -1 */
12544 if (indexop->op_private & OPpTARGET_MY)
12547 if (constop->op_type != OP_CONST)
12550 sv = cSVOPx_sv(constop);
12551 if (!(sv && SvIOK_notUV(sv)))
12555 if (iv != -1 && iv != 0)
12559 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12560 if (!(iv0 ^ reverse))
12564 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12569 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12570 if (!(iv0 ^ reverse))
12574 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12579 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12585 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12591 indexop->op_flags &= ~OPf_PARENS;
12592 indexop->op_flags |= (o->op_flags & OPf_PARENS);
12593 indexop->op_private |= OPpTRUEBOOL;
12595 indexop->op_private |= OPpINDEX_BOOLNEG;
12596 /* cut out the index op and free the eq,const ops */
12597 (void)op_sibling_splice(o, start, 1, NULL);
12605 Perl_ck_concat(pTHX_ OP *o)
12607 const OP * const kid = cUNOPo->op_first;
12609 PERL_ARGS_ASSERT_CK_CONCAT;
12610 PERL_UNUSED_CONTEXT;
12612 /* reuse the padtmp returned by the concat child */
12613 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12614 !(kUNOP->op_first->op_flags & OPf_MOD))
12616 o->op_flags |= OPf_STACKED;
12617 o->op_private |= OPpCONCAT_NESTED;
12623 Perl_ck_spair(pTHX_ OP *o)
12626 PERL_ARGS_ASSERT_CK_SPAIR;
12628 if (o->op_flags & OPf_KIDS) {
12632 const OPCODE type = o->op_type;
12633 o = modkids(ck_fun(o), type);
12634 kid = cUNOPo->op_first;
12635 kidkid = kUNOP->op_first;
12636 newop = OpSIBLING(kidkid);
12638 const OPCODE type = newop->op_type;
12639 if (OpHAS_SIBLING(newop))
12641 if (o->op_type == OP_REFGEN
12642 && ( type == OP_RV2CV
12643 || ( !(newop->op_flags & OPf_PARENS)
12644 && ( type == OP_RV2AV || type == OP_PADAV
12645 || type == OP_RV2HV || type == OP_PADHV))))
12646 NOOP; /* OK (allow srefgen for \@a and \%h) */
12647 else if (OP_GIMME(newop,0) != G_SCALAR)
12650 /* excise first sibling */
12651 op_sibling_splice(kid, NULL, 1, NULL);
12654 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12655 * and OP_CHOMP into OP_SCHOMP */
12656 o->op_ppaddr = PL_ppaddr[++o->op_type];
12661 Perl_ck_delete(pTHX_ OP *o)
12663 PERL_ARGS_ASSERT_CK_DELETE;
12667 if (o->op_flags & OPf_KIDS) {
12668 OP * const kid = cUNOPo->op_first;
12669 switch (kid->op_type) {
12671 o->op_flags |= OPf_SPECIAL;
12674 o->op_private |= OPpSLICE;
12677 o->op_flags |= OPf_SPECIAL;
12682 o->op_flags |= OPf_SPECIAL;
12685 o->op_private |= OPpKVSLICE;
12688 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12689 "element or slice");
12691 if (kid->op_private & OPpLVAL_INTRO)
12692 o->op_private |= OPpLVAL_INTRO;
12699 Perl_ck_eof(pTHX_ OP *o)
12701 PERL_ARGS_ASSERT_CK_EOF;
12703 if (o->op_flags & OPf_KIDS) {
12705 if (cLISTOPo->op_first->op_type == OP_STUB) {
12707 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12712 kid = cLISTOPo->op_first;
12713 if (kid->op_type == OP_RV2GV)
12714 kid->op_private |= OPpALLOW_FAKE;
12721 Perl_ck_eval(pTHX_ OP *o)
12724 PERL_ARGS_ASSERT_CK_EVAL;
12726 PL_hints |= HINT_BLOCK_SCOPE;
12727 if (o->op_flags & OPf_KIDS) {
12728 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12731 if (o->op_type == OP_ENTERTRY) {
12734 /* cut whole sibling chain free from o */
12735 op_sibling_splice(o, NULL, -1, NULL);
12738 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12740 /* establish postfix order */
12741 enter->op_next = (OP*)enter;
12743 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12744 OpTYPE_set(o, OP_LEAVETRY);
12745 enter->op_other = o;
12750 S_set_haseval(aTHX);
12754 const U8 priv = o->op_private;
12756 /* the newUNOP will recursively call ck_eval(), which will handle
12757 * all the stuff at the end of this function, like adding
12760 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12762 o->op_targ = (PADOFFSET)PL_hints;
12763 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12764 if ((PL_hints & HINT_LOCALIZE_HH) != 0
12765 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12766 /* Store a copy of %^H that pp_entereval can pick up. */
12767 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12769 STOREFEATUREBITSHH(hh);
12770 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12771 /* append hhop to only child */
12772 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12774 o->op_private |= OPpEVAL_HAS_HH;
12776 if (!(o->op_private & OPpEVAL_BYTES)
12777 && FEATURE_UNIEVAL_IS_ENABLED)
12778 o->op_private |= OPpEVAL_UNICODE;
12783 Perl_ck_exec(pTHX_ OP *o)
12785 PERL_ARGS_ASSERT_CK_EXEC;
12787 if (o->op_flags & OPf_STACKED) {
12790 kid = OpSIBLING(cUNOPo->op_first);
12791 if (kid->op_type == OP_RV2GV)
12800 Perl_ck_exists(pTHX_ OP *o)
12802 PERL_ARGS_ASSERT_CK_EXISTS;
12805 if (o->op_flags & OPf_KIDS) {
12806 OP * const kid = cUNOPo->op_first;
12807 if (kid->op_type == OP_ENTERSUB) {
12808 (void) ref(kid, o->op_type);
12809 if (kid->op_type != OP_RV2CV
12810 && !(PL_parser && PL_parser->error_count))
12812 "exists argument is not a subroutine name");
12813 o->op_private |= OPpEXISTS_SUB;
12815 else if (kid->op_type == OP_AELEM)
12816 o->op_flags |= OPf_SPECIAL;
12817 else if (kid->op_type != OP_HELEM)
12818 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12819 "element or a subroutine");
12826 Perl_ck_rvconst(pTHX_ OP *o)
12828 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12830 PERL_ARGS_ASSERT_CK_RVCONST;
12832 if (o->op_type == OP_RV2HV)
12833 /* rv2hv steals the bottom bit for its own uses */
12834 o->op_private &= ~OPpARG1_MASK;
12836 o->op_private |= (PL_hints & HINT_STRICT_REFS);
12838 if (kid->op_type == OP_CONST) {
12841 SV * const kidsv = kid->op_sv;
12843 /* Is it a constant from cv_const_sv()? */
12844 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12847 if (SvTYPE(kidsv) == SVt_PVAV) return o;
12848 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12849 const char *badthing;
12850 switch (o->op_type) {
12852 badthing = "a SCALAR";
12855 badthing = "an ARRAY";
12858 badthing = "a HASH";
12866 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12867 SVfARG(kidsv), badthing);
12870 * This is a little tricky. We only want to add the symbol if we
12871 * didn't add it in the lexer. Otherwise we get duplicate strict
12872 * warnings. But if we didn't add it in the lexer, we must at
12873 * least pretend like we wanted to add it even if it existed before,
12874 * or we get possible typo warnings. OPpCONST_ENTERED says
12875 * whether the lexer already added THIS instance of this symbol.
12877 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12878 gv = gv_fetchsv(kidsv,
12879 o->op_type == OP_RV2CV
12880 && o->op_private & OPpMAY_RETURN_CONSTANT
12882 : iscv | !(kid->op_private & OPpCONST_ENTERED),
12885 : o->op_type == OP_RV2SV
12887 : o->op_type == OP_RV2AV
12889 : o->op_type == OP_RV2HV
12896 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12897 && SvTYPE(SvRV(gv)) != SVt_PVCV)
12898 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12900 OpTYPE_set(kid, OP_GV);
12901 SvREFCNT_dec(kid->op_sv);
12902 #ifdef USE_ITHREADS
12903 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12904 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12905 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12906 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12907 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12909 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12911 kid->op_private = 0;
12912 /* FAKE globs in the symbol table cause weird bugs (#77810) */
12920 Perl_ck_ftst(pTHX_ OP *o)
12922 const I32 type = o->op_type;
12924 PERL_ARGS_ASSERT_CK_FTST;
12926 if (o->op_flags & OPf_REF) {
12929 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12930 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12931 const OPCODE kidtype = kid->op_type;
12933 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12934 && !kid->op_folded) {
12935 OP * const newop = newGVOP(type, OPf_REF,
12936 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12941 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12942 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12944 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12945 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12946 array_passed_to_stat, name);
12949 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12950 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12953 scalar((OP *) kid);
12954 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12955 o->op_private |= OPpFT_ACCESS;
12956 if (OP_IS_FILETEST(type)
12957 && OP_IS_FILETEST(kidtype)
12959 o->op_private |= OPpFT_STACKED;
12960 kid->op_private |= OPpFT_STACKING;
12961 if (kidtype == OP_FTTTY && (
12962 !(kid->op_private & OPpFT_STACKED)
12963 || kid->op_private & OPpFT_AFTER_t
12965 o->op_private |= OPpFT_AFTER_t;
12970 if (type == OP_FTTTY)
12971 o = newGVOP(type, OPf_REF, PL_stdingv);
12973 o = newUNOP(type, 0, newDEFSVOP());
12979 Perl_ck_fun(pTHX_ OP *o)
12981 const int type = o->op_type;
12982 I32 oa = PL_opargs[type] >> OASHIFT;
12984 PERL_ARGS_ASSERT_CK_FUN;
12986 if (o->op_flags & OPf_STACKED) {
12987 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12988 oa &= ~OA_OPTIONAL;
12990 return no_fh_allowed(o);
12993 if (o->op_flags & OPf_KIDS) {
12994 OP *prev_kid = NULL;
12995 OP *kid = cLISTOPo->op_first;
12997 bool seen_optional = FALSE;
12999 if (kid->op_type == OP_PUSHMARK ||
13000 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
13003 kid = OpSIBLING(kid);
13005 if (kid && kid->op_type == OP_COREARGS) {
13006 bool optional = FALSE;
13009 if (oa & OA_OPTIONAL) optional = TRUE;
13012 if (optional) o->op_private |= numargs;
13017 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
13018 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
13019 kid = newDEFSVOP();
13020 /* append kid to chain */
13021 op_sibling_splice(o, prev_kid, 0, kid);
13023 seen_optional = TRUE;
13030 /* list seen where single (scalar) arg expected? */
13031 if (numargs == 1 && !(oa >> 4)
13032 && kid->op_type == OP_LIST && type != OP_SCALAR)
13034 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13036 if (type != OP_DELETE) scalar(kid);
13047 if ((type == OP_PUSH || type == OP_UNSHIFT)
13048 && !OpHAS_SIBLING(kid))
13049 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
13050 "Useless use of %s with no values",
13053 if (kid->op_type == OP_CONST
13054 && ( !SvROK(cSVOPx_sv(kid))
13055 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
13057 bad_type_pv(numargs, "array", o, kid);
13058 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
13059 || kid->op_type == OP_RV2GV) {
13060 bad_type_pv(1, "array", o, kid);
13062 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
13063 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
13064 PL_op_desc[type]), 0);
13067 op_lvalue(kid, type);
13071 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
13072 bad_type_pv(numargs, "hash", o, kid);
13073 op_lvalue(kid, type);
13077 /* replace kid with newop in chain */
13079 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
13080 newop->op_next = newop;
13085 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
13086 if (kid->op_type == OP_CONST &&
13087 (kid->op_private & OPpCONST_BARE))
13089 OP * const newop = newGVOP(OP_GV, 0,
13090 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
13091 /* replace kid with newop in chain */
13092 op_sibling_splice(o, prev_kid, 1, newop);
13096 else if (kid->op_type == OP_READLINE) {
13097 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
13098 bad_type_pv(numargs, "HANDLE", o, kid);
13101 I32 flags = OPf_SPECIAL;
13103 PADOFFSET targ = 0;
13105 /* is this op a FH constructor? */
13106 if (is_handle_constructor(o,numargs)) {
13107 const char *name = NULL;
13110 bool want_dollar = TRUE;
13113 /* Set a flag to tell rv2gv to vivify
13114 * need to "prove" flag does not mean something
13115 * else already - NI-S 1999/05/07
13118 if (kid->op_type == OP_PADSV) {
13120 = PAD_COMPNAME_SV(kid->op_targ);
13121 name = PadnamePV (pn);
13122 len = PadnameLEN(pn);
13123 name_utf8 = PadnameUTF8(pn);
13125 else if (kid->op_type == OP_RV2SV
13126 && kUNOP->op_first->op_type == OP_GV)
13128 GV * const gv = cGVOPx_gv(kUNOP->op_first);
13130 len = GvNAMELEN(gv);
13131 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
13133 else if (kid->op_type == OP_AELEM
13134 || kid->op_type == OP_HELEM)
13137 OP *op = ((BINOP*)kid)->op_first;
13141 const char * const a =
13142 kid->op_type == OP_AELEM ?
13144 if (((op->op_type == OP_RV2AV) ||
13145 (op->op_type == OP_RV2HV)) &&
13146 (firstop = ((UNOP*)op)->op_first) &&
13147 (firstop->op_type == OP_GV)) {
13148 /* packagevar $a[] or $h{} */
13149 GV * const gv = cGVOPx_gv(firstop);
13152 Perl_newSVpvf(aTHX_
13157 else if (op->op_type == OP_PADAV
13158 || op->op_type == OP_PADHV) {
13159 /* lexicalvar $a[] or $h{} */
13160 const char * const padname =
13161 PAD_COMPNAME_PV(op->op_targ);
13164 Perl_newSVpvf(aTHX_
13170 name = SvPV_const(tmpstr, len);
13171 name_utf8 = SvUTF8(tmpstr);
13172 sv_2mortal(tmpstr);
13176 name = "__ANONIO__";
13178 want_dollar = FALSE;
13180 op_lvalue(kid, type);
13184 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
13185 namesv = PAD_SVl(targ);
13186 if (want_dollar && *name != '$')
13187 sv_setpvs(namesv, "$");
13190 sv_catpvn(namesv, name, len);
13191 if ( name_utf8 ) SvUTF8_on(namesv);
13195 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
13197 kid->op_targ = targ;
13198 kid->op_private |= priv;
13204 if ((type == OP_UNDEF || type == OP_POS)
13205 && numargs == 1 && !(oa >> 4)
13206 && kid->op_type == OP_LIST)
13207 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13208 op_lvalue(scalar(kid), type);
13213 kid = OpSIBLING(kid);
13215 /* FIXME - should the numargs or-ing move after the too many
13216 * arguments check? */
13217 o->op_private |= numargs;
13219 return too_many_arguments_pv(o,OP_DESC(o), 0);
13222 else if (PL_opargs[type] & OA_DEFGV) {
13223 /* Ordering of these two is important to keep f_map.t passing. */
13225 return newUNOP(type, 0, newDEFSVOP());
13229 while (oa & OA_OPTIONAL)
13231 if (oa && oa != OA_LIST)
13232 return too_few_arguments_pv(o,OP_DESC(o), 0);
13238 Perl_ck_glob(pTHX_ OP *o)
13242 PERL_ARGS_ASSERT_CK_GLOB;
13245 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13246 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13248 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13252 * \ null - const(wildcard)
13257 * \ mark - glob - rv2cv
13258 * | \ gv(CORE::GLOBAL::glob)
13260 * \ null - const(wildcard)
13262 o->op_flags |= OPf_SPECIAL;
13263 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13264 o = S_new_entersubop(aTHX_ gv, o);
13265 o = newUNOP(OP_NULL, 0, o);
13266 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13269 else o->op_flags &= ~OPf_SPECIAL;
13270 #if !defined(PERL_EXTERNAL_GLOB)
13271 if (!PL_globhook) {
13273 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13274 newSVpvs("File::Glob"), NULL, NULL, NULL);
13277 #endif /* !PERL_EXTERNAL_GLOB */
13278 gv = (GV *)newSV(0);
13279 gv_init(gv, 0, "", 0, 0);
13281 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13282 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13288 Perl_ck_grep(pTHX_ OP *o)
13292 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13294 PERL_ARGS_ASSERT_CK_GREP;
13296 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13298 if (o->op_flags & OPf_STACKED) {
13299 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13300 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13301 return no_fh_allowed(o);
13302 o->op_flags &= ~OPf_STACKED;
13304 kid = OpSIBLING(cLISTOPo->op_first);
13305 if (type == OP_MAPWHILE)
13310 if (PL_parser && PL_parser->error_count)
13312 kid = OpSIBLING(cLISTOPo->op_first);
13313 if (kid->op_type != OP_NULL)
13314 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13315 kid = kUNOP->op_first;
13317 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13318 kid->op_next = (OP*)gwop;
13319 o->op_private = gwop->op_private = 0;
13320 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13322 kid = OpSIBLING(cLISTOPo->op_first);
13323 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13324 op_lvalue(kid, OP_GREPSTART);
13330 Perl_ck_index(pTHX_ OP *o)
13332 PERL_ARGS_ASSERT_CK_INDEX;
13334 if (o->op_flags & OPf_KIDS) {
13335 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13337 kid = OpSIBLING(kid); /* get past "big" */
13338 if (kid && kid->op_type == OP_CONST) {
13339 const bool save_taint = TAINT_get;
13340 SV *sv = kSVOP->op_sv;
13341 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13342 && SvOK(sv) && !SvROK(sv))
13345 sv_copypv(sv, kSVOP->op_sv);
13346 SvREFCNT_dec_NN(kSVOP->op_sv);
13349 if (SvOK(sv)) fbm_compile(sv, 0);
13350 TAINT_set(save_taint);
13351 #ifdef NO_TAINT_SUPPORT
13352 PERL_UNUSED_VAR(save_taint);
13360 Perl_ck_lfun(pTHX_ OP *o)
13362 const OPCODE type = o->op_type;
13364 PERL_ARGS_ASSERT_CK_LFUN;
13366 return modkids(ck_fun(o), type);
13370 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
13372 PERL_ARGS_ASSERT_CK_DEFINED;
13374 if ((o->op_flags & OPf_KIDS)) {
13375 switch (cUNOPo->op_first->op_type) {
13378 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13379 " (Maybe you should just omit the defined()?)");
13380 NOT_REACHED; /* NOTREACHED */
13384 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13385 " (Maybe you should just omit the defined()?)");
13386 NOT_REACHED; /* NOTREACHED */
13397 Perl_ck_readline(pTHX_ OP *o)
13399 PERL_ARGS_ASSERT_CK_READLINE;
13401 if (o->op_flags & OPf_KIDS) {
13402 OP *kid = cLISTOPo->op_first;
13403 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13408 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13416 Perl_ck_rfun(pTHX_ OP *o)
13418 const OPCODE type = o->op_type;
13420 PERL_ARGS_ASSERT_CK_RFUN;
13422 return refkids(ck_fun(o), type);
13426 Perl_ck_listiob(pTHX_ OP *o)
13430 PERL_ARGS_ASSERT_CK_LISTIOB;
13432 kid = cLISTOPo->op_first;
13434 o = force_list(o, 1);
13435 kid = cLISTOPo->op_first;
13437 if (kid->op_type == OP_PUSHMARK)
13438 kid = OpSIBLING(kid);
13439 if (kid && o->op_flags & OPf_STACKED)
13440 kid = OpSIBLING(kid);
13441 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
13442 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13443 && !kid->op_folded) {
13444 o->op_flags |= OPf_STACKED; /* make it a filehandle */
13446 /* replace old const op with new OP_RV2GV parent */
13447 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13448 OP_RV2GV, OPf_REF);
13449 kid = OpSIBLING(kid);
13454 op_append_elem(o->op_type, o, newDEFSVOP());
13456 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13457 return listkids(o);
13461 Perl_ck_smartmatch(pTHX_ OP *o)
13463 PERL_ARGS_ASSERT_CK_SMARTMATCH;
13464 if (0 == (o->op_flags & OPf_SPECIAL)) {
13465 OP *first = cBINOPo->op_first;
13466 OP *second = OpSIBLING(first);
13468 /* Implicitly take a reference to an array or hash */
13470 /* remove the original two siblings, then add back the
13471 * (possibly different) first and second sibs.
13473 op_sibling_splice(o, NULL, 1, NULL);
13474 op_sibling_splice(o, NULL, 1, NULL);
13475 first = ref_array_or_hash(first);
13476 second = ref_array_or_hash(second);
13477 op_sibling_splice(o, NULL, 0, second);
13478 op_sibling_splice(o, NULL, 0, first);
13480 /* Implicitly take a reference to a regular expression */
13481 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13482 OpTYPE_set(first, OP_QR);
13484 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13485 OpTYPE_set(second, OP_QR);
13494 S_maybe_targlex(pTHX_ OP *o)
13496 OP * const kid = cLISTOPo->op_first;
13497 /* has a disposable target? */
13498 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13499 && !(kid->op_flags & OPf_STACKED)
13500 /* Cannot steal the second time! */
13501 && !(kid->op_private & OPpTARGET_MY)
13504 OP * const kkid = OpSIBLING(kid);
13506 /* Can just relocate the target. */
13507 if (kkid && kkid->op_type == OP_PADSV
13508 && (!(kkid->op_private & OPpLVAL_INTRO)
13509 || kkid->op_private & OPpPAD_STATE))
13511 kid->op_targ = kkid->op_targ;
13513 /* Now we do not need PADSV and SASSIGN.
13514 * Detach kid and free the rest. */
13515 op_sibling_splice(o, NULL, 1, NULL);
13517 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
13525 Perl_ck_sassign(pTHX_ OP *o)
13527 OP * const kid = cBINOPo->op_first;
13529 PERL_ARGS_ASSERT_CK_SASSIGN;
13531 if (OpHAS_SIBLING(kid)) {
13532 OP *kkid = OpSIBLING(kid);
13533 /* For state variable assignment with attributes, kkid is a list op
13534 whose op_last is a padsv. */
13535 if ((kkid->op_type == OP_PADSV ||
13536 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13537 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13540 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13541 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13542 return S_newONCEOP(aTHX_ o, kkid);
13545 return S_maybe_targlex(aTHX_ o);
13550 Perl_ck_match(pTHX_ OP *o)
13552 PERL_UNUSED_CONTEXT;
13553 PERL_ARGS_ASSERT_CK_MATCH;
13559 Perl_ck_method(pTHX_ OP *o)
13561 SV *sv, *methsv, *rclass;
13562 const char* method;
13565 STRLEN len, nsplit = 0, i;
13567 OP * const kid = cUNOPo->op_first;
13569 PERL_ARGS_ASSERT_CK_METHOD;
13570 if (kid->op_type != OP_CONST) return o;
13574 /* replace ' with :: */
13575 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13576 SvEND(sv) - SvPVX(sv) )))
13579 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13582 method = SvPVX_const(sv);
13584 utf8 = SvUTF8(sv) ? -1 : 1;
13586 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13591 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13593 if (!nsplit) { /* $proto->method() */
13595 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13598 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13600 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13603 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13604 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13605 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13606 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13608 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13609 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13611 #ifdef USE_ITHREADS
13612 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13614 cMETHOPx(new_op)->op_rclass_sv = rclass;
13621 Perl_ck_null(pTHX_ OP *o)
13623 PERL_ARGS_ASSERT_CK_NULL;
13624 PERL_UNUSED_CONTEXT;
13629 Perl_ck_open(pTHX_ OP *o)
13631 PERL_ARGS_ASSERT_CK_OPEN;
13633 S_io_hints(aTHX_ o);
13635 /* In case of three-arg dup open remove strictness
13636 * from the last arg if it is a bareword. */
13637 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13638 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
13642 if ((last->op_type == OP_CONST) && /* The bareword. */
13643 (last->op_private & OPpCONST_BARE) &&
13644 (last->op_private & OPpCONST_STRICT) &&
13645 (oa = OpSIBLING(first)) && /* The fh. */
13646 (oa = OpSIBLING(oa)) && /* The mode. */
13647 (oa->op_type == OP_CONST) &&
13648 SvPOK(((SVOP*)oa)->op_sv) &&
13649 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
13650 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
13651 (last == OpSIBLING(oa))) /* The bareword. */
13652 last->op_private &= ~OPpCONST_STRICT;
13658 Perl_ck_prototype(pTHX_ OP *o)
13660 PERL_ARGS_ASSERT_CK_PROTOTYPE;
13661 if (!(o->op_flags & OPf_KIDS)) {
13663 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13669 Perl_ck_refassign(pTHX_ OP *o)
13671 OP * const right = cLISTOPo->op_first;
13672 OP * const left = OpSIBLING(right);
13673 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13676 PERL_ARGS_ASSERT_CK_REFASSIGN;
13678 assert (left->op_type == OP_SREFGEN);
13681 /* we use OPpPAD_STATE in refassign to mean either of those things,
13682 * and the code assumes the two flags occupy the same bit position
13683 * in the various ops below */
13684 assert(OPpPAD_STATE == OPpOUR_INTRO);
13686 switch (varop->op_type) {
13688 o->op_private |= OPpLVREF_AV;
13691 o->op_private |= OPpLVREF_HV;
13695 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13696 o->op_targ = varop->op_targ;
13697 varop->op_targ = 0;
13698 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13702 o->op_private |= OPpLVREF_AV;
13704 NOT_REACHED; /* NOTREACHED */
13706 o->op_private |= OPpLVREF_HV;
13710 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13711 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13713 /* Point varop to its GV kid, detached. */
13714 varop = op_sibling_splice(varop, NULL, -1, NULL);
13718 OP * const kidparent =
13719 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13720 OP * const kid = cUNOPx(kidparent)->op_first;
13721 o->op_private |= OPpLVREF_CV;
13722 if (kid->op_type == OP_GV) {
13723 SV *sv = (SV*)cGVOPx_gv(kid);
13725 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13726 /* a CVREF here confuses pp_refassign, so make sure
13728 CV *const cv = (CV*)SvRV(sv);
13729 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
13730 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13731 assert(SvTYPE(sv) == SVt_PVGV);
13733 goto detach_and_stack;
13735 if (kid->op_type != OP_PADCV) goto bad;
13736 o->op_targ = kid->op_targ;
13742 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13743 o->op_private |= OPpLVREF_ELEM;
13746 /* Detach varop. */
13747 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13751 /* diag_listed_as: Can't modify reference to %s in %s assignment */
13752 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13757 if (!FEATURE_REFALIASING_IS_ENABLED)
13759 "Experimental aliasing via reference not enabled");
13760 Perl_ck_warner_d(aTHX_
13761 packWARN(WARN_EXPERIMENTAL__REFALIASING),
13762 "Aliasing via reference is experimental");
13764 o->op_flags |= OPf_STACKED;
13765 op_sibling_splice(o, right, 1, varop);
13768 o->op_flags &=~ OPf_STACKED;
13769 op_sibling_splice(o, right, 1, NULL);
13776 Perl_ck_repeat(pTHX_ OP *o)
13778 PERL_ARGS_ASSERT_CK_REPEAT;
13780 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13782 o->op_private |= OPpREPEAT_DOLIST;
13783 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13784 kids = force_list(kids, 1); /* promote it to a list */
13785 op_sibling_splice(o, NULL, 0, kids); /* and add back */
13793 Perl_ck_require(pTHX_ OP *o)
13797 PERL_ARGS_ASSERT_CK_REQUIRE;
13799 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
13800 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13804 if (kid->op_type == OP_CONST) {
13805 SV * const sv = kid->op_sv;
13806 U32 const was_readonly = SvREADONLY(sv);
13807 if (kid->op_private & OPpCONST_BARE) {
13811 if (was_readonly) {
13812 SvREADONLY_off(sv);
13815 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13820 /* treat ::foo::bar as foo::bar */
13821 if (len >= 2 && s[0] == ':' && s[1] == ':')
13822 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13824 DIE(aTHX_ "Bareword in require maps to empty filename");
13826 for (; s < end; s++) {
13827 if (*s == ':' && s[1] == ':') {
13829 Move(s+2, s+1, end - s - 1, char);
13833 SvEND_set(sv, end);
13834 sv_catpvs(sv, ".pm");
13835 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13836 hek = share_hek(SvPVX(sv),
13837 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13839 sv_sethek(sv, hek);
13841 SvFLAGS(sv) |= was_readonly;
13843 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13846 if (SvREFCNT(sv) > 1) {
13847 kid->op_sv = newSVpvn_share(
13848 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13849 SvREFCNT_dec_NN(sv);
13853 if (was_readonly) SvREADONLY_off(sv);
13854 PERL_HASH(hash, s, len);
13856 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13858 sv_sethek(sv, hek);
13860 SvFLAGS(sv) |= was_readonly;
13866 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13867 /* handle override, if any */
13868 && (gv = gv_override("require", 7))) {
13870 if (o->op_flags & OPf_KIDS) {
13871 kid = cUNOPo->op_first;
13872 op_sibling_splice(o, NULL, -1, NULL);
13875 kid = newDEFSVOP();
13878 newop = S_new_entersubop(aTHX_ gv, kid);
13886 Perl_ck_return(pTHX_ OP *o)
13890 PERL_ARGS_ASSERT_CK_RETURN;
13892 kid = OpSIBLING(cLISTOPo->op_first);
13893 if (PL_compcv && CvLVALUE(PL_compcv)) {
13894 for (; kid; kid = OpSIBLING(kid))
13895 op_lvalue(kid, OP_LEAVESUBLV);
13902 Perl_ck_select(pTHX_ OP *o)
13906 PERL_ARGS_ASSERT_CK_SELECT;
13908 if (o->op_flags & OPf_KIDS) {
13909 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13910 if (kid && OpHAS_SIBLING(kid)) {
13911 OpTYPE_set(o, OP_SSELECT);
13913 return fold_constants(op_integerize(op_std_init(o)));
13917 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13918 if (kid && kid->op_type == OP_RV2GV)
13919 kid->op_private &= ~HINT_STRICT_REFS;
13924 Perl_ck_shift(pTHX_ OP *o)
13926 const I32 type = o->op_type;
13928 PERL_ARGS_ASSERT_CK_SHIFT;
13930 if (!(o->op_flags & OPf_KIDS)) {
13933 if (!CvUNIQUE(PL_compcv)) {
13934 o->op_flags |= OPf_SPECIAL;
13938 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13940 return newUNOP(type, 0, scalar(argop));
13942 return scalar(ck_fun(o));
13946 Perl_ck_sort(pTHX_ OP *o)
13950 HV * const hinthv =
13951 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
13954 PERL_ARGS_ASSERT_CK_SORT;
13957 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
13959 const I32 sorthints = (I32)SvIV(*svp);
13960 if ((sorthints & HINT_SORT_STABLE) != 0)
13961 o->op_private |= OPpSORT_STABLE;
13962 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
13963 o->op_private |= OPpSORT_UNSTABLE;
13967 if (o->op_flags & OPf_STACKED)
13969 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13971 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
13972 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
13974 /* if the first arg is a code block, process it and mark sort as
13976 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13978 if (kid->op_type == OP_LEAVE)
13979 op_null(kid); /* wipe out leave */
13980 /* Prevent execution from escaping out of the sort block. */
13983 /* provide scalar context for comparison function/block */
13984 kid = scalar(firstkid);
13985 kid->op_next = kid;
13986 o->op_flags |= OPf_SPECIAL;
13988 else if (kid->op_type == OP_CONST
13989 && kid->op_private & OPpCONST_BARE) {
13993 const char * const name = SvPV(kSVOP_sv, len);
13995 assert (len < 256);
13996 Copy(name, tmpbuf+1, len, char);
13997 off = pad_findmy_pvn(tmpbuf, len+1, 0);
13998 if (off != NOT_IN_PAD) {
13999 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
14001 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
14002 sv_catpvs(fq, "::");
14003 sv_catsv(fq, kSVOP_sv);
14004 SvREFCNT_dec_NN(kSVOP_sv);
14008 OP * const padop = newOP(OP_PADCV, 0);
14009 padop->op_targ = off;
14010 /* replace the const op with the pad op */
14011 op_sibling_splice(firstkid, NULL, 1, padop);
14017 firstkid = OpSIBLING(firstkid);
14020 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
14021 /* provide list context for arguments */
14024 op_lvalue(kid, OP_GREPSTART);
14030 /* for sort { X } ..., where X is one of
14031 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
14032 * elide the second child of the sort (the one containing X),
14033 * and set these flags as appropriate
14037 * Also, check and warn on lexical $a, $b.
14041 S_simplify_sort(pTHX_ OP *o)
14043 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14047 const char *gvname;
14050 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
14052 kid = kUNOP->op_first; /* get past null */
14053 if (!(have_scopeop = kid->op_type == OP_SCOPE)
14054 && kid->op_type != OP_LEAVE)
14056 kid = kLISTOP->op_last; /* get past scope */
14057 switch(kid->op_type) {
14061 if (!have_scopeop) goto padkids;
14066 k = kid; /* remember this node*/
14067 if (kBINOP->op_first->op_type != OP_RV2SV
14068 || kBINOP->op_last ->op_type != OP_RV2SV)
14071 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
14072 then used in a comparison. This catches most, but not
14073 all cases. For instance, it catches
14074 sort { my($a); $a <=> $b }
14076 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
14077 (although why you'd do that is anyone's guess).
14081 if (!ckWARN(WARN_SYNTAX)) return;
14082 kid = kBINOP->op_first;
14084 if (kid->op_type == OP_PADSV) {
14085 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
14086 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
14087 && ( PadnamePV(name)[1] == 'a'
14088 || PadnamePV(name)[1] == 'b' ))
14089 /* diag_listed_as: "my %s" used in sort comparison */
14090 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14091 "\"%s %s\" used in sort comparison",
14092 PadnameIsSTATE(name)
14097 } while ((kid = OpSIBLING(kid)));
14100 kid = kBINOP->op_first; /* get past cmp */
14101 if (kUNOP->op_first->op_type != OP_GV)
14103 kid = kUNOP->op_first; /* get past rv2sv */
14105 if (GvSTASH(gv) != PL_curstash)
14107 gvname = GvNAME(gv);
14108 if (*gvname == 'a' && gvname[1] == '\0')
14110 else if (*gvname == 'b' && gvname[1] == '\0')
14115 kid = k; /* back to cmp */
14116 /* already checked above that it is rv2sv */
14117 kid = kBINOP->op_last; /* down to 2nd arg */
14118 if (kUNOP->op_first->op_type != OP_GV)
14120 kid = kUNOP->op_first; /* get past rv2sv */
14122 if (GvSTASH(gv) != PL_curstash)
14124 gvname = GvNAME(gv);
14126 ? !(*gvname == 'a' && gvname[1] == '\0')
14127 : !(*gvname == 'b' && gvname[1] == '\0'))
14129 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
14131 o->op_private |= OPpSORT_DESCEND;
14132 if (k->op_type == OP_NCMP)
14133 o->op_private |= OPpSORT_NUMERIC;
14134 if (k->op_type == OP_I_NCMP)
14135 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
14136 kid = OpSIBLING(cLISTOPo->op_first);
14137 /* cut out and delete old block (second sibling) */
14138 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
14143 Perl_ck_split(pTHX_ OP *o)
14148 PERL_ARGS_ASSERT_CK_SPLIT;
14150 assert(o->op_type == OP_LIST);
14152 if (o->op_flags & OPf_STACKED)
14153 return no_fh_allowed(o);
14155 kid = cLISTOPo->op_first;
14156 /* delete leading NULL node, then add a CONST if no other nodes */
14157 assert(kid->op_type == OP_NULL);
14158 op_sibling_splice(o, NULL, 1,
14159 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
14161 kid = cLISTOPo->op_first;
14163 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
14164 /* remove match expression, and replace with new optree with
14165 * a match op at its head */
14166 op_sibling_splice(o, NULL, 1, NULL);
14167 /* pmruntime will handle split " " behavior with flag==2 */
14168 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
14169 op_sibling_splice(o, NULL, 0, kid);
14172 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
14174 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
14175 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
14176 "Use of /g modifier is meaningless in split");
14179 /* eliminate the split op, and move the match op (plus any children)
14180 * into its place, then convert the match op into a split op. i.e.
14182 * SPLIT MATCH SPLIT(ex-MATCH)
14184 * MATCH - A - B - C => R - A - B - C => R - A - B - C
14190 * (R, if it exists, will be a regcomp op)
14193 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14194 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14195 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14196 OpTYPE_set(kid, OP_SPLIT);
14197 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
14198 kid->op_private = o->op_private;
14201 kid = sibs; /* kid is now the string arg of the split */
14204 kid = newDEFSVOP();
14205 op_append_elem(OP_SPLIT, o, kid);
14209 kid = OpSIBLING(kid);
14211 kid = newSVOP(OP_CONST, 0, newSViv(0));
14212 op_append_elem(OP_SPLIT, o, kid);
14213 o->op_private |= OPpSPLIT_IMPLIM;
14217 if (OpHAS_SIBLING(kid))
14218 return too_many_arguments_pv(o,OP_DESC(o), 0);
14224 Perl_ck_stringify(pTHX_ OP *o)
14226 OP * const kid = OpSIBLING(cUNOPo->op_first);
14227 PERL_ARGS_ASSERT_CK_STRINGIFY;
14228 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14229 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
14230 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
14231 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14233 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14241 Perl_ck_join(pTHX_ OP *o)
14243 OP * const kid = OpSIBLING(cLISTOPo->op_first);
14245 PERL_ARGS_ASSERT_CK_JOIN;
14247 if (kid && kid->op_type == OP_MATCH) {
14248 if (ckWARN(WARN_SYNTAX)) {
14249 const REGEXP *re = PM_GETRE(kPMOP);
14251 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14252 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14253 : newSVpvs_flags( "STRING", SVs_TEMP );
14254 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14255 "/%" SVf "/ should probably be written as \"%" SVf "\"",
14256 SVfARG(msg), SVfARG(msg));
14260 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14261 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14262 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14263 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14265 const OP * const bairn = OpSIBLING(kid); /* the list */
14266 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14267 && OP_GIMME(bairn,0) == G_SCALAR)
14269 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14270 op_sibling_splice(o, kid, 1, NULL));
14280 =for apidoc rv2cv_op_cv
14282 Examines an op, which is expected to identify a subroutine at runtime,
14283 and attempts to determine at compile time which subroutine it identifies.
14284 This is normally used during Perl compilation to determine whether
14285 a prototype can be applied to a function call. C<cvop> is the op
14286 being considered, normally an C<rv2cv> op. A pointer to the identified
14287 subroutine is returned, if it could be determined statically, and a null
14288 pointer is returned if it was not possible to determine statically.
14290 Currently, the subroutine can be identified statically if the RV that the
14291 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14292 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
14293 suitable if the constant value must be an RV pointing to a CV. Details of
14294 this process may change in future versions of Perl. If the C<rv2cv> op
14295 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14296 the subroutine statically: this flag is used to suppress compile-time
14297 magic on a subroutine call, forcing it to use default runtime behaviour.
14299 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14300 of a GV reference is modified. If a GV was examined and its CV slot was
14301 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14302 If the op is not optimised away, and the CV slot is later populated with
14303 a subroutine having a prototype, that flag eventually triggers the warning
14304 "called too early to check prototype".
14306 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14307 of returning a pointer to the subroutine it returns a pointer to the
14308 GV giving the most appropriate name for the subroutine in this context.
14309 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14310 (C<CvANON>) subroutine that is referenced through a GV it will be the
14311 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
14312 A null pointer is returned as usual if there is no statically-determinable
14315 =for apidoc Amnh||OPpEARLY_CV
14316 =for apidoc Amnh||OPpENTERSUB_AMPER
14317 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14318 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14323 /* shared by toke.c:yylex */
14325 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14327 PADNAME *name = PAD_COMPNAME(off);
14328 CV *compcv = PL_compcv;
14329 while (PadnameOUTER(name)) {
14330 assert(PARENT_PAD_INDEX(name));
14331 compcv = CvOUTSIDE(compcv);
14332 name = PadlistNAMESARRAY(CvPADLIST(compcv))
14333 [off = PARENT_PAD_INDEX(name)];
14335 assert(!PadnameIsOUR(name));
14336 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14337 return PadnamePROTOCV(name);
14339 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14343 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14348 PERL_ARGS_ASSERT_RV2CV_OP_CV;
14349 if (flags & ~RV2CVOPCV_FLAG_MASK)
14350 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14351 if (cvop->op_type != OP_RV2CV)
14353 if (cvop->op_private & OPpENTERSUB_AMPER)
14355 if (!(cvop->op_flags & OPf_KIDS))
14357 rvop = cUNOPx(cvop)->op_first;
14358 switch (rvop->op_type) {
14360 gv = cGVOPx_gv(rvop);
14362 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14363 cv = MUTABLE_CV(SvRV(gv));
14367 if (flags & RV2CVOPCV_RETURN_STUB)
14373 if (flags & RV2CVOPCV_MARK_EARLY)
14374 rvop->op_private |= OPpEARLY_CV;
14379 SV *rv = cSVOPx_sv(rvop);
14382 cv = (CV*)SvRV(rv);
14386 cv = find_lexical_cv(rvop->op_targ);
14391 } NOT_REACHED; /* NOTREACHED */
14393 if (SvTYPE((SV*)cv) != SVt_PVCV)
14395 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14396 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14400 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14401 if (CvLEXICAL(cv) || CvNAMED(cv))
14403 if (!CvANON(cv) || !gv)
14413 =for apidoc ck_entersub_args_list
14415 Performs the default fixup of the arguments part of an C<entersub>
14416 op tree. This consists of applying list context to each of the
14417 argument ops. This is the standard treatment used on a call marked
14418 with C<&>, or a method call, or a call through a subroutine reference,
14419 or any other call where the callee can't be identified at compile time,
14420 or a call where the callee has no prototype.
14426 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14430 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14432 aop = cUNOPx(entersubop)->op_first;
14433 if (!OpHAS_SIBLING(aop))
14434 aop = cUNOPx(aop)->op_first;
14435 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14436 /* skip the extra attributes->import() call implicitly added in
14437 * something like foo(my $x : bar)
14439 if ( aop->op_type == OP_ENTERSUB
14440 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14444 op_lvalue(aop, OP_ENTERSUB);
14450 =for apidoc ck_entersub_args_proto
14452 Performs the fixup of the arguments part of an C<entersub> op tree
14453 based on a subroutine prototype. This makes various modifications to
14454 the argument ops, from applying context up to inserting C<refgen> ops,
14455 and checking the number and syntactic types of arguments, as directed by
14456 the prototype. This is the standard treatment used on a subroutine call,
14457 not marked with C<&>, where the callee can be identified at compile time
14458 and has a prototype.
14460 C<protosv> supplies the subroutine prototype to be applied to the call.
14461 It may be a normal defined scalar, of which the string value will be used.
14462 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14463 that has been cast to C<SV*>) which has a prototype. The prototype
14464 supplied, in whichever form, does not need to match the actual callee
14465 referenced by the op tree.
14467 If the argument ops disagree with the prototype, for example by having
14468 an unacceptable number of arguments, a valid op tree is returned anyway.
14469 The error is reflected in the parser state, normally resulting in a single
14470 exception at the top level of parsing which covers all the compilation
14471 errors that occurred. In the error message, the callee is referred to
14472 by the name defined by the C<namegv> parameter.
14478 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14481 const char *proto, *proto_end;
14482 OP *aop, *prev, *cvop, *parent;
14485 I32 contextclass = 0;
14486 const char *e = NULL;
14487 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14488 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14489 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14490 "flags=%lx", (unsigned long) SvFLAGS(protosv));
14491 if (SvTYPE(protosv) == SVt_PVCV)
14492 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14493 else proto = SvPV(protosv, proto_len);
14494 proto = S_strip_spaces(aTHX_ proto, &proto_len);
14495 proto_end = proto + proto_len;
14496 parent = entersubop;
14497 aop = cUNOPx(entersubop)->op_first;
14498 if (!OpHAS_SIBLING(aop)) {
14500 aop = cUNOPx(aop)->op_first;
14503 aop = OpSIBLING(aop);
14504 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14505 while (aop != cvop) {
14508 if (proto >= proto_end)
14510 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14511 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14512 SVfARG(namesv)), SvUTF8(namesv));
14522 /* _ must be at the end */
14523 if (proto[1] && !memCHRs(";@%", proto[1]))
14539 if ( o3->op_type != OP_UNDEF
14540 && (o3->op_type != OP_SREFGEN
14541 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14543 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14545 bad_type_gv(arg, namegv, o3,
14546 arg == 1 ? "block or sub {}" : "sub {}");
14549 /* '*' allows any scalar type, including bareword */
14552 if (o3->op_type == OP_RV2GV)
14553 goto wrapref; /* autoconvert GLOB -> GLOBref */
14554 else if (o3->op_type == OP_CONST)
14555 o3->op_private &= ~OPpCONST_STRICT;
14561 if (o3->op_type == OP_RV2AV ||
14562 o3->op_type == OP_PADAV ||
14563 o3->op_type == OP_RV2HV ||
14564 o3->op_type == OP_PADHV
14570 case '[': case ']':
14577 switch (*proto++) {
14579 if (contextclass++ == 0) {
14580 e = (char *) memchr(proto, ']', proto_end - proto);
14581 if (!e || e == proto)
14589 if (contextclass) {
14590 const char *p = proto;
14591 const char *const end = proto;
14593 while (*--p != '[')
14594 /* \[$] accepts any scalar lvalue */
14596 && Perl_op_lvalue_flags(aTHX_
14598 OP_READ, /* not entersub */
14601 bad_type_gv(arg, namegv, o3,
14602 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14607 if (o3->op_type == OP_RV2GV)
14610 bad_type_gv(arg, namegv, o3, "symbol");
14613 if (o3->op_type == OP_ENTERSUB
14614 && !(o3->op_flags & OPf_STACKED))
14617 bad_type_gv(arg, namegv, o3, "subroutine");
14620 if (o3->op_type == OP_RV2SV ||
14621 o3->op_type == OP_PADSV ||
14622 o3->op_type == OP_HELEM ||
14623 o3->op_type == OP_AELEM)
14625 if (!contextclass) {
14626 /* \$ accepts any scalar lvalue */
14627 if (Perl_op_lvalue_flags(aTHX_
14629 OP_READ, /* not entersub */
14632 bad_type_gv(arg, namegv, o3, "scalar");
14636 if (o3->op_type == OP_RV2AV ||
14637 o3->op_type == OP_PADAV)
14639 o3->op_flags &=~ OPf_PARENS;
14643 bad_type_gv(arg, namegv, o3, "array");
14646 if (o3->op_type == OP_RV2HV ||
14647 o3->op_type == OP_PADHV)
14649 o3->op_flags &=~ OPf_PARENS;
14653 bad_type_gv(arg, namegv, o3, "hash");
14656 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14658 if (contextclass && e) {
14663 default: goto oops;
14673 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14674 SVfARG(cv_name((CV *)namegv, NULL, 0)),
14679 op_lvalue(aop, OP_ENTERSUB);
14681 aop = OpSIBLING(aop);
14683 if (aop == cvop && *proto == '_') {
14684 /* generate an access to $_ */
14685 op_sibling_splice(parent, prev, 0, newDEFSVOP());
14687 if (!optional && proto_end > proto &&
14688 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14690 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14691 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14692 SVfARG(namesv)), SvUTF8(namesv));
14698 =for apidoc ck_entersub_args_proto_or_list
14700 Performs the fixup of the arguments part of an C<entersub> op tree either
14701 based on a subroutine prototype or using default list-context processing.
14702 This is the standard treatment used on a subroutine call, not marked
14703 with C<&>, where the callee can be identified at compile time.
14705 C<protosv> supplies the subroutine prototype to be applied to the call,
14706 or indicates that there is no prototype. It may be a normal scalar,
14707 in which case if it is defined then the string value will be used
14708 as a prototype, and if it is undefined then there is no prototype.
14709 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14710 that has been cast to C<SV*>), of which the prototype will be used if it
14711 has one. The prototype (or lack thereof) supplied, in whichever form,
14712 does not need to match the actual callee referenced by the op tree.
14714 If the argument ops disagree with the prototype, for example by having
14715 an unacceptable number of arguments, a valid op tree is returned anyway.
14716 The error is reflected in the parser state, normally resulting in a single
14717 exception at the top level of parsing which covers all the compilation
14718 errors that occurred. In the error message, the callee is referred to
14719 by the name defined by the C<namegv> parameter.
14725 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14726 GV *namegv, SV *protosv)
14728 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14729 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14730 return ck_entersub_args_proto(entersubop, namegv, protosv);
14732 return ck_entersub_args_list(entersubop);
14736 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14738 IV cvflags = SvIVX(protosv);
14739 int opnum = cvflags & 0xffff;
14740 OP *aop = cUNOPx(entersubop)->op_first;
14742 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14746 if (!OpHAS_SIBLING(aop))
14747 aop = cUNOPx(aop)->op_first;
14748 aop = OpSIBLING(aop);
14749 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14751 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14752 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14753 SVfARG(namesv)), SvUTF8(namesv));
14756 op_free(entersubop);
14757 switch(cvflags >> 16) {
14758 case 'F': return newSVOP(OP_CONST, 0,
14759 newSVpv(CopFILE(PL_curcop),0));
14760 case 'L': return newSVOP(
14762 Perl_newSVpvf(aTHX_
14763 "%" IVdf, (IV)CopLINE(PL_curcop)
14766 case 'P': return newSVOP(OP_CONST, 0,
14768 ? newSVhek(HvNAME_HEK(PL_curstash))
14773 NOT_REACHED; /* NOTREACHED */
14776 OP *prev, *cvop, *first, *parent;
14779 parent = entersubop;
14780 if (!OpHAS_SIBLING(aop)) {
14782 aop = cUNOPx(aop)->op_first;
14785 first = prev = aop;
14786 aop = OpSIBLING(aop);
14787 /* find last sibling */
14789 OpHAS_SIBLING(cvop);
14790 prev = cvop, cvop = OpSIBLING(cvop))
14792 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14793 /* Usually, OPf_SPECIAL on an op with no args means that it had
14794 * parens, but these have their own meaning for that flag: */
14795 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14796 && opnum != OP_DELETE && opnum != OP_EXISTS)
14797 flags |= OPf_SPECIAL;
14798 /* excise cvop from end of sibling chain */
14799 op_sibling_splice(parent, prev, 1, NULL);
14801 if (aop == cvop) aop = NULL;
14803 /* detach remaining siblings from the first sibling, then
14804 * dispose of original optree */
14807 op_sibling_splice(parent, first, -1, NULL);
14808 op_free(entersubop);
14810 if (cvflags == (OP_ENTEREVAL | (1<<16)))
14811 flags |= OPpEVAL_BYTES <<8;
14813 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14815 case OA_BASEOP_OR_UNOP:
14816 case OA_FILESTATOP:
14818 return newOP(opnum,flags); /* zero args */
14820 return newUNOP(opnum,flags,aop); /* one arg */
14821 /* too many args */
14828 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14829 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14830 SVfARG(namesv)), SvUTF8(namesv));
14832 nextop = OpSIBLING(aop);
14838 return opnum == OP_RUNCV
14839 ? newPVOP(OP_RUNCV,0,NULL)
14842 return op_convert_list(opnum,0,aop);
14845 NOT_REACHED; /* NOTREACHED */
14850 =for apidoc cv_get_call_checker_flags
14852 Retrieves the function that will be used to fix up a call to C<cv>.
14853 Specifically, the function is applied to an C<entersub> op tree for a
14854 subroutine call, not marked with C<&>, where the callee can be identified
14855 at compile time as C<cv>.
14857 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14858 for it is returned in C<*ckobj_p>, and control flags are returned in
14859 C<*ckflags_p>. The function is intended to be called in this manner:
14861 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14863 In this call, C<entersubop> is a pointer to the C<entersub> op,
14864 which may be replaced by the check function, and C<namegv> supplies
14865 the name that should be used by the check function to refer
14866 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14867 It is permitted to apply the check function in non-standard situations,
14868 such as to a call to a different subroutine or to a method call.
14870 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
14871 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14872 instead, anything that can be used as the first argument to L</cv_name>.
14873 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14874 check function requires C<namegv> to be a genuine GV.
14876 By default, the check function is
14877 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14878 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14879 flag is clear. This implements standard prototype processing. It can
14880 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14882 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14883 indicates that the caller only knows about the genuine GV version of
14884 C<namegv>, and accordingly the corresponding bit will always be set in
14885 C<*ckflags_p>, regardless of the check function's recorded requirements.
14886 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14887 indicates the caller knows about the possibility of passing something
14888 other than a GV as C<namegv>, and accordingly the corresponding bit may
14889 be either set or clear in C<*ckflags_p>, indicating the check function's
14890 recorded requirements.
14892 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14893 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14894 (for which see above). All other bits should be clear.
14896 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14898 =for apidoc cv_get_call_checker
14900 The original form of L</cv_get_call_checker_flags>, which does not return
14901 checker flags. When using a checker function returned by this function,
14902 it is only safe to call it with a genuine GV as its C<namegv> argument.
14908 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14909 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14912 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14913 PERL_UNUSED_CONTEXT;
14914 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14916 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14917 *ckobj_p = callmg->mg_obj;
14918 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14920 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14921 *ckobj_p = (SV*)cv;
14922 *ckflags_p = gflags & MGf_REQUIRE_GV;
14927 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14930 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14931 PERL_UNUSED_CONTEXT;
14932 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14937 =for apidoc cv_set_call_checker_flags
14939 Sets the function that will be used to fix up a call to C<cv>.
14940 Specifically, the function is applied to an C<entersub> op tree for a
14941 subroutine call, not marked with C<&>, where the callee can be identified
14942 at compile time as C<cv>.
14944 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14945 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14946 The function should be defined like this:
14948 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14950 It is intended to be called in this manner:
14952 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14954 In this call, C<entersubop> is a pointer to the C<entersub> op,
14955 which may be replaced by the check function, and C<namegv> supplies
14956 the name that should be used by the check function to refer
14957 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14958 It is permitted to apply the check function in non-standard situations,
14959 such as to a call to a different subroutine or to a method call.
14961 C<namegv> may not actually be a GV. For efficiency, perl may pass a
14962 CV or other SV instead. Whatever is passed can be used as the first
14963 argument to L</cv_name>. You can force perl to pass a GV by including
14964 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14966 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14967 bit currently has a defined meaning (for which see above). All other
14968 bits should be clear.
14970 The current setting for a particular CV can be retrieved by
14971 L</cv_get_call_checker_flags>.
14973 =for apidoc cv_set_call_checker
14975 The original form of L</cv_set_call_checker_flags>, which passes it the
14976 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
14977 of that flag setting is that the check function is guaranteed to get a
14978 genuine GV as its C<namegv> argument.
14984 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14986 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14987 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14991 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14992 SV *ckobj, U32 ckflags)
14994 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14995 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
14996 if (SvMAGICAL((SV*)cv))
14997 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
15000 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
15001 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
15003 if (callmg->mg_flags & MGf_REFCOUNTED) {
15004 SvREFCNT_dec(callmg->mg_obj);
15005 callmg->mg_flags &= ~MGf_REFCOUNTED;
15007 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
15008 callmg->mg_obj = ckobj;
15009 if (ckobj != (SV*)cv) {
15010 SvREFCNT_inc_simple_void_NN(ckobj);
15011 callmg->mg_flags |= MGf_REFCOUNTED;
15013 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
15014 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
15019 S_entersub_alloc_targ(pTHX_ OP * const o)
15021 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
15022 o->op_private |= OPpENTERSUB_HASTARG;
15026 Perl_ck_subr(pTHX_ OP *o)
15031 SV **const_class = NULL;
15033 PERL_ARGS_ASSERT_CK_SUBR;
15035 aop = cUNOPx(o)->op_first;
15036 if (!OpHAS_SIBLING(aop))
15037 aop = cUNOPx(aop)->op_first;
15038 aop = OpSIBLING(aop);
15039 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
15040 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
15041 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
15043 o->op_private &= ~1;
15044 o->op_private |= (PL_hints & HINT_STRICT_REFS);
15045 if (PERLDB_SUB && PL_curstash != PL_debstash)
15046 o->op_private |= OPpENTERSUB_DB;
15047 switch (cvop->op_type) {
15049 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
15053 case OP_METHOD_NAMED:
15054 case OP_METHOD_SUPER:
15055 case OP_METHOD_REDIR:
15056 case OP_METHOD_REDIR_SUPER:
15057 o->op_flags |= OPf_REF;
15058 if (aop->op_type == OP_CONST) {
15059 aop->op_private &= ~OPpCONST_STRICT;
15060 const_class = &cSVOPx(aop)->op_sv;
15062 else if (aop->op_type == OP_LIST) {
15063 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
15064 if (sib && sib->op_type == OP_CONST) {
15065 sib->op_private &= ~OPpCONST_STRICT;
15066 const_class = &cSVOPx(sib)->op_sv;
15069 /* make class name a shared cow string to speedup method calls */
15070 /* constant string might be replaced with object, f.e. bigint */
15071 if (const_class && SvPOK(*const_class)) {
15073 const char* str = SvPV(*const_class, len);
15075 SV* const shared = newSVpvn_share(
15076 str, SvUTF8(*const_class)
15077 ? -(SSize_t)len : (SSize_t)len,
15080 if (SvREADONLY(*const_class))
15081 SvREADONLY_on(shared);
15082 SvREFCNT_dec(*const_class);
15083 *const_class = shared;
15090 S_entersub_alloc_targ(aTHX_ o);
15091 return ck_entersub_args_list(o);
15093 Perl_call_checker ckfun;
15096 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
15097 if (CvISXSUB(cv) || !CvROOT(cv))
15098 S_entersub_alloc_targ(aTHX_ o);
15100 /* The original call checker API guarantees that a GV will
15101 be provided with the right name. So, if the old API was
15102 used (or the REQUIRE_GV flag was passed), we have to reify
15103 the CV’s GV, unless this is an anonymous sub. This is not
15104 ideal for lexical subs, as its stringification will include
15105 the package. But it is the best we can do. */
15106 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
15107 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
15110 else namegv = MUTABLE_GV(cv);
15111 /* After a syntax error in a lexical sub, the cv that
15112 rv2cv_op_cv returns may be a nameless stub. */
15113 if (!namegv) return ck_entersub_args_list(o);
15116 return ckfun(aTHX_ o, namegv, ckobj);
15121 Perl_ck_svconst(pTHX_ OP *o)
15123 SV * const sv = cSVOPo->op_sv;
15124 PERL_ARGS_ASSERT_CK_SVCONST;
15125 PERL_UNUSED_CONTEXT;
15126 #ifdef PERL_COPY_ON_WRITE
15127 /* Since the read-only flag may be used to protect a string buffer, we
15128 cannot do copy-on-write with existing read-only scalars that are not
15129 already copy-on-write scalars. To allow $_ = "hello" to do COW with
15130 that constant, mark the constant as COWable here, if it is not
15131 already read-only. */
15132 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
15135 # ifdef PERL_DEBUG_READONLY_COW
15145 Perl_ck_trunc(pTHX_ OP *o)
15147 PERL_ARGS_ASSERT_CK_TRUNC;
15149 if (o->op_flags & OPf_KIDS) {
15150 SVOP *kid = (SVOP*)cUNOPo->op_first;
15152 if (kid->op_type == OP_NULL)
15153 kid = (SVOP*)OpSIBLING(kid);
15154 if (kid && kid->op_type == OP_CONST &&
15155 (kid->op_private & OPpCONST_BARE) &&
15158 o->op_flags |= OPf_SPECIAL;
15159 kid->op_private &= ~OPpCONST_STRICT;
15166 Perl_ck_substr(pTHX_ OP *o)
15168 PERL_ARGS_ASSERT_CK_SUBSTR;
15171 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15172 OP *kid = cLISTOPo->op_first;
15174 if (kid->op_type == OP_NULL)
15175 kid = OpSIBLING(kid);
15177 /* Historically, substr(delete $foo{bar},...) has been allowed
15178 with 4-arg substr. Keep it working by applying entersub
15180 op_lvalue(kid, OP_ENTERSUB);
15187 Perl_ck_tell(pTHX_ OP *o)
15189 PERL_ARGS_ASSERT_CK_TELL;
15191 if (o->op_flags & OPf_KIDS) {
15192 OP *kid = cLISTOPo->op_first;
15193 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15194 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15200 Perl_ck_each(pTHX_ OP *o)
15202 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15203 const unsigned orig_type = o->op_type;
15205 PERL_ARGS_ASSERT_CK_EACH;
15208 switch (kid->op_type) {
15214 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15215 : orig_type == OP_KEYS ? OP_AKEYS
15219 if (kid->op_private == OPpCONST_BARE
15220 || !SvROK(cSVOPx_sv(kid))
15221 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15222 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
15227 qerror(Perl_mess(aTHX_
15228 "Experimental %s on scalar is now forbidden",
15229 PL_op_desc[orig_type]));
15231 bad_type_pv(1, "hash or array", o, kid);
15239 Perl_ck_length(pTHX_ OP *o)
15241 PERL_ARGS_ASSERT_CK_LENGTH;
15245 if (ckWARN(WARN_SYNTAX)) {
15246 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15250 const bool hash = kid->op_type == OP_PADHV
15251 || kid->op_type == OP_RV2HV;
15252 switch (kid->op_type) {
15257 name = S_op_varname(aTHX_ kid);
15263 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15264 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15266 SVfARG(name), hash ? "keys " : "", SVfARG(name)
15269 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15270 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15271 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15273 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15274 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15275 "length() used on @array (did you mean \"scalar(@array)\"?)");
15284 Perl_ck_isa(pTHX_ OP *o)
15286 OP *classop = cBINOPo->op_last;
15288 PERL_ARGS_ASSERT_CK_ISA;
15290 /* Convert barename into PV */
15291 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15292 /* TODO: Optionally convert package to raw HV here */
15293 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15301 ---------------------------------------------------------
15303 Common vars in list assignment
15305 There now follows some enums and static functions for detecting
15306 common variables in list assignments. Here is a little essay I wrote
15307 for myself when trying to get my head around this. DAPM.
15311 First some random observations:
15313 * If a lexical var is an alias of something else, e.g.
15314 for my $x ($lex, $pkg, $a[0]) {...}
15315 then the act of aliasing will increase the reference count of the SV
15317 * If a package var is an alias of something else, it may still have a
15318 reference count of 1, depending on how the alias was created, e.g.
15319 in *a = *b, $a may have a refcount of 1 since the GP is shared
15320 with a single GvSV pointer to the SV. So If it's an alias of another
15321 package var, then RC may be 1; if it's an alias of another scalar, e.g.
15322 a lexical var or an array element, then it will have RC > 1.
15324 * There are many ways to create a package alias; ultimately, XS code
15325 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
15326 run-time tracing mechanisms are unlikely to be able to catch all cases.
15328 * When the LHS is all my declarations, the same vars can't appear directly
15329 on the RHS, but they can indirectly via closures, aliasing and lvalue
15330 subs. But those techniques all involve an increase in the lexical
15331 scalar's ref count.
15333 * When the LHS is all lexical vars (but not necessarily my declarations),
15334 it is possible for the same lexicals to appear directly on the RHS, and
15335 without an increased ref count, since the stack isn't refcounted.
15336 This case can be detected at compile time by scanning for common lex
15337 vars with PL_generation.
15339 * lvalue subs defeat common var detection, but they do at least
15340 return vars with a temporary ref count increment. Also, you can't
15341 tell at compile time whether a sub call is lvalue.
15346 A: There are a few circumstances where there definitely can't be any
15349 LHS empty: () = (...);
15350 RHS empty: (....) = ();
15351 RHS contains only constants or other 'can't possibly be shared'
15352 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
15353 i.e. they only contain ops not marked as dangerous, whose children
15354 are also not dangerous;
15356 LHS contains a single scalar element: e.g. ($x) = (....); because
15357 after $x has been modified, it won't be used again on the RHS;
15358 RHS contains a single element with no aggregate on LHS: e.g.
15359 ($a,$b,$c) = ($x); again, once $a has been modified, its value
15360 won't be used again.
15362 B: If LHS are all 'my' lexical var declarations (or safe ops, which
15365 my ($a, $b, @c) = ...;
15367 Due to closure and goto tricks, these vars may already have content.
15368 For the same reason, an element on the RHS may be a lexical or package
15369 alias of one of the vars on the left, or share common elements, for
15372 my ($x,$y) = f(); # $x and $y on both sides
15373 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
15378 my @a = @$ra; # elements of @a on both sides
15379 sub f { @a = 1..4; \@a }
15382 First, just consider scalar vars on LHS:
15384 RHS is safe only if (A), or in addition,
15385 * contains only lexical *scalar* vars, where neither side's
15386 lexicals have been flagged as aliases
15388 If RHS is not safe, then it's always legal to check LHS vars for
15389 RC==1, since the only RHS aliases will always be associated
15392 Note that in particular, RHS is not safe if:
15394 * it contains package scalar vars; e.g.:
15397 my ($x, $y) = (2, $x_alias);
15398 sub f { $x = 1; *x_alias = \$x; }
15400 * It contains other general elements, such as flattened or
15401 * spliced or single array or hash elements, e.g.
15404 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
15408 use feature 'refaliasing';
15409 \($a[0], $a[1]) = \($y,$x);
15412 It doesn't matter if the array/hash is lexical or package.
15414 * it contains a function call that happens to be an lvalue
15415 sub which returns one or more of the above, e.g.
15426 (so a sub call on the RHS should be treated the same
15427 as having a package var on the RHS).
15429 * any other "dangerous" thing, such an op or built-in that
15430 returns one of the above, e.g. pp_preinc
15433 If RHS is not safe, what we can do however is at compile time flag
15434 that the LHS are all my declarations, and at run time check whether
15435 all the LHS have RC == 1, and if so skip the full scan.
15437 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
15439 Here the issue is whether there can be elements of @a on the RHS
15440 which will get prematurely freed when @a is cleared prior to
15441 assignment. This is only a problem if the aliasing mechanism
15442 is one which doesn't increase the refcount - only if RC == 1
15443 will the RHS element be prematurely freed.
15445 Because the array/hash is being INTROed, it or its elements
15446 can't directly appear on the RHS:
15448 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
15450 but can indirectly, e.g.:
15454 sub f { @a = 1..3; \@a }
15456 So if the RHS isn't safe as defined by (A), we must always
15457 mortalise and bump the ref count of any remaining RHS elements
15458 when assigning to a non-empty LHS aggregate.
15460 Lexical scalars on the RHS aren't safe if they've been involved in
15463 use feature 'refaliasing';
15466 \(my $lex) = \$pkg;
15467 my @a = ($lex,3); # equivalent to ($a[0],3)
15474 Similarly with lexical arrays and hashes on the RHS:
15488 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
15489 my $a; ($a, my $b) = (....);
15491 The difference between (B) and (C) is that it is now physically
15492 possible for the LHS vars to appear on the RHS too, where they
15493 are not reference counted; but in this case, the compile-time
15494 PL_generation sweep will detect such common vars.
15496 So the rules for (C) differ from (B) in that if common vars are
15497 detected, the runtime "test RC==1" optimisation can no longer be used,
15498 and a full mark and sweep is required
15500 D: As (C), but in addition the LHS may contain package vars.
15502 Since package vars can be aliased without a corresponding refcount
15503 increase, all bets are off. It's only safe if (A). E.g.
15505 my ($x, $y) = (1,2);
15507 for $x_alias ($x) {
15508 ($x_alias, $y) = (3, $x); # whoops
15511 Ditto for LHS aggregate package vars.
15513 E: Any other dangerous ops on LHS, e.g.
15514 (f(), $a[0], @$r) = (...);
15516 this is similar to (E) in that all bets are off. In addition, it's
15517 impossible to determine at compile time whether the LHS
15518 contains a scalar or an aggregate, e.g.
15520 sub f : lvalue { @a }
15523 * ---------------------------------------------------------
15527 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
15528 * that at least one of the things flagged was seen.
15532 AAS_MY_SCALAR = 0x001, /* my $scalar */
15533 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
15534 AAS_LEX_SCALAR = 0x004, /* $lexical */
15535 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
15536 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
15537 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
15538 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
15539 AAS_DANGEROUS = 0x080, /* an op (other than the above)
15540 that's flagged OA_DANGEROUS */
15541 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
15542 not in any of the categories above */
15543 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
15548 /* helper function for S_aassign_scan().
15549 * check a PAD-related op for commonality and/or set its generation number.
15550 * Returns a boolean indicating whether its shared */
15553 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
15555 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
15556 /* lexical used in aliasing */
15560 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
15562 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
15569 Helper function for OPpASSIGN_COMMON* detection in rpeep().
15570 It scans the left or right hand subtree of the aassign op, and returns a
15571 set of flags indicating what sorts of things it found there.
15572 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
15573 set PL_generation on lexical vars; if the latter, we see if
15574 PL_generation matches.
15575 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
15576 This fn will increment it by the number seen. It's not intended to
15577 be an accurate count (especially as many ops can push a variable
15578 number of SVs onto the stack); rather it's used as to test whether there
15579 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
15583 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
15586 OP *effective_top_op = o;
15590 bool top = o == effective_top_op;
15592 OP* next_kid = NULL;
15594 /* first, look for a solitary @_ on the RHS */
15597 && (o->op_flags & OPf_KIDS)
15598 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
15600 OP *kid = cUNOPo->op_first;
15601 if ( ( kid->op_type == OP_PUSHMARK
15602 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
15603 && ((kid = OpSIBLING(kid)))
15604 && !OpHAS_SIBLING(kid)
15605 && kid->op_type == OP_RV2AV
15606 && !(kid->op_flags & OPf_REF)
15607 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15608 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
15609 && ((kid = cUNOPx(kid)->op_first))
15610 && kid->op_type == OP_GV
15611 && cGVOPx_gv(kid) == PL_defgv
15616 switch (o->op_type) {
15619 all_flags |= AAS_PKG_SCALAR;
15625 /* if !top, could be e.g. @a[0,1] */
15626 all_flags |= (top && (o->op_flags & OPf_REF))
15627 ? ((o->op_private & OPpLVAL_INTRO)
15628 ? AAS_MY_AGG : AAS_LEX_AGG)
15634 int comm = S_aassign_padcheck(aTHX_ o, rhs)
15635 ? AAS_LEX_SCALAR_COMM : 0;
15637 all_flags |= (o->op_private & OPpLVAL_INTRO)
15638 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
15646 if (cUNOPx(o)->op_first->op_type != OP_GV)
15647 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
15649 /* if !top, could be e.g. @a[0,1] */
15650 else if (top && (o->op_flags & OPf_REF))
15651 all_flags |= AAS_PKG_AGG;
15653 all_flags |= AAS_DANGEROUS;
15658 if (cUNOPx(o)->op_first->op_type != OP_GV) {
15660 all_flags |= AAS_DANGEROUS; /* ${expr} */
15663 all_flags |= AAS_PKG_SCALAR; /* $pkg */
15667 if (o->op_private & OPpSPLIT_ASSIGN) {
15668 /* the assign in @a = split() has been optimised away
15669 * and the @a attached directly to the split op
15670 * Treat the array as appearing on the RHS, i.e.
15671 * ... = (@a = split)
15676 if (o->op_flags & OPf_STACKED) {
15677 /* @{expr} = split() - the array expression is tacked
15678 * on as an extra child to split - process kid */
15679 next_kid = cLISTOPo->op_last;
15683 /* ... else array is directly attached to split op */
15685 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
15686 ? ((o->op_private & OPpLVAL_INTRO)
15687 ? AAS_MY_AGG : AAS_LEX_AGG)
15692 /* other args of split can't be returned */
15693 all_flags |= AAS_SAFE_SCALAR;
15697 /* undef on LHS following a var is significant, e.g.
15699 * @a = (($x, undef) = (2 => $x));
15700 * # @a shoul be (2,1) not (2,2)
15702 * undef on RHS counts as a scalar:
15703 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
15705 if ((!rhs && *scalars_p) || rhs)
15707 flags = AAS_SAFE_SCALAR;
15712 /* these are all no-ops; they don't push a potentially common SV
15713 * onto the stack, so they are neither AAS_DANGEROUS nor
15714 * AAS_SAFE_SCALAR */
15717 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
15722 /* these do nothing, but may have children */
15726 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
15728 flags = AAS_DANGEROUS;
15732 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
15733 && (o->op_private & OPpTARGET_MY))
15736 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
15737 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
15741 /* if its an unrecognised, non-dangerous op, assume that it
15742 * is the cause of at least one safe scalar */
15744 flags = AAS_SAFE_SCALAR;
15748 all_flags |= flags;
15750 /* by default, process all kids next
15751 * XXX this assumes that all other ops are "transparent" - i.e. that
15752 * they can return some of their children. While this true for e.g.
15753 * sort and grep, it's not true for e.g. map. We really need a
15754 * 'transparent' flag added to regen/opcodes
15756 if (o->op_flags & OPf_KIDS) {
15757 next_kid = cUNOPo->op_first;
15758 /* these ops do nothing but may have children; but their
15759 * children should also be treated as top-level */
15760 if ( o == effective_top_op
15761 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
15763 effective_top_op = next_kid;
15767 /* If next_kid is set, someone in the code above wanted us to process
15768 * that kid and all its remaining siblings. Otherwise, work our way
15769 * back up the tree */
15771 while (!next_kid) {
15773 return all_flags; /* at top; no parents/siblings to try */
15774 if (OpHAS_SIBLING(o)) {
15775 next_kid = o->op_sibparent;
15776 if (o == effective_top_op)
15777 effective_top_op = next_kid;
15780 if (o == effective_top_op)
15781 effective_top_op = o->op_sibparent;
15782 o = o->op_sibparent; /* try parent's next sibling */
15791 /* Check for in place reverse and sort assignments like "@a = reverse @a"
15792 and modify the optree to make them work inplace */
15795 S_inplace_aassign(pTHX_ OP *o) {
15797 OP *modop, *modop_pushmark;
15799 OP *oleft, *oleft_pushmark;
15801 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
15803 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
15805 assert(cUNOPo->op_first->op_type == OP_NULL);
15806 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
15807 assert(modop_pushmark->op_type == OP_PUSHMARK);
15808 modop = OpSIBLING(modop_pushmark);
15810 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
15813 /* no other operation except sort/reverse */
15814 if (OpHAS_SIBLING(modop))
15817 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
15818 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
15820 if (modop->op_flags & OPf_STACKED) {
15821 /* skip sort subroutine/block */
15822 assert(oright->op_type == OP_NULL);
15823 oright = OpSIBLING(oright);
15826 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
15827 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
15828 assert(oleft_pushmark->op_type == OP_PUSHMARK);
15829 oleft = OpSIBLING(oleft_pushmark);
15831 /* Check the lhs is an array */
15833 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
15834 || OpHAS_SIBLING(oleft)
15835 || (oleft->op_private & OPpLVAL_INTRO)
15839 /* Only one thing on the rhs */
15840 if (OpHAS_SIBLING(oright))
15843 /* check the array is the same on both sides */
15844 if (oleft->op_type == OP_RV2AV) {
15845 if (oright->op_type != OP_RV2AV
15846 || !cUNOPx(oright)->op_first
15847 || cUNOPx(oright)->op_first->op_type != OP_GV
15848 || cUNOPx(oleft )->op_first->op_type != OP_GV
15849 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15850 cGVOPx_gv(cUNOPx(oright)->op_first)
15854 else if (oright->op_type != OP_PADAV
15855 || oright->op_targ != oleft->op_targ
15859 /* This actually is an inplace assignment */
15861 modop->op_private |= OPpSORT_INPLACE;
15863 /* transfer MODishness etc from LHS arg to RHS arg */
15864 oright->op_flags = oleft->op_flags;
15866 /* remove the aassign op and the lhs */
15868 op_null(oleft_pushmark);
15869 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15870 op_null(cUNOPx(oleft)->op_first);
15876 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
15877 * that potentially represent a series of one or more aggregate derefs
15878 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
15879 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
15880 * additional ops left in too).
15882 * The caller will have already verified that the first few ops in the
15883 * chain following 'start' indicate a multideref candidate, and will have
15884 * set 'orig_o' to the point further on in the chain where the first index
15885 * expression (if any) begins. 'orig_action' specifies what type of
15886 * beginning has already been determined by the ops between start..orig_o
15887 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
15889 * 'hints' contains any hints flags that need adding (currently just
15890 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
15894 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
15897 UNOP_AUX_item *arg_buf = NULL;
15898 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
15899 int index_skip = -1; /* don't output index arg on this action */
15901 /* similar to regex compiling, do two passes; the first pass
15902 * determines whether the op chain is convertible and calculates the
15903 * buffer size; the second pass populates the buffer and makes any
15904 * changes necessary to ops (such as moving consts to the pad on
15905 * threaded builds).
15907 * NB: for things like Coverity, note that both passes take the same
15908 * path through the logic tree (except for 'if (pass)' bits), since
15909 * both passes are following the same op_next chain; and in
15910 * particular, if it would return early on the second pass, it would
15911 * already have returned early on the first pass.
15913 for (pass = 0; pass < 2; pass++) {
15915 UV action = orig_action;
15916 OP *first_elem_op = NULL; /* first seen aelem/helem */
15917 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
15918 int action_count = 0; /* number of actions seen so far */
15919 int action_ix = 0; /* action_count % (actions per IV) */
15920 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
15921 bool is_last = FALSE; /* no more derefs to follow */
15922 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
15923 UV action_word = 0; /* all actions so far */
15924 UNOP_AUX_item *arg = arg_buf;
15925 UNOP_AUX_item *action_ptr = arg_buf;
15927 arg++; /* reserve slot for first action word */
15930 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
15931 case MDEREF_HV_gvhv_helem:
15932 next_is_hash = TRUE;
15934 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
15935 case MDEREF_AV_gvav_aelem:
15937 #ifdef USE_ITHREADS
15938 arg->pad_offset = cPADOPx(start)->op_padix;
15939 /* stop it being swiped when nulled */
15940 cPADOPx(start)->op_padix = 0;
15942 arg->sv = cSVOPx(start)->op_sv;
15943 cSVOPx(start)->op_sv = NULL;
15949 case MDEREF_HV_padhv_helem:
15950 case MDEREF_HV_padsv_vivify_rv2hv_helem:
15951 next_is_hash = TRUE;
15953 case MDEREF_AV_padav_aelem:
15954 case MDEREF_AV_padsv_vivify_rv2av_aelem:
15956 arg->pad_offset = start->op_targ;
15957 /* we skip setting op_targ = 0 for now, since the intact
15958 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
15959 reset_start_targ = TRUE;
15964 case MDEREF_HV_pop_rv2hv_helem:
15965 next_is_hash = TRUE;
15967 case MDEREF_AV_pop_rv2av_aelem:
15971 NOT_REACHED; /* NOTREACHED */
15976 /* look for another (rv2av/hv; get index;
15977 * aelem/helem/exists/delele) sequence */
15982 UV index_type = MDEREF_INDEX_none;
15984 if (action_count) {
15985 /* if this is not the first lookup, consume the rv2av/hv */
15987 /* for N levels of aggregate lookup, we normally expect
15988 * that the first N-1 [ah]elem ops will be flagged as
15989 * /DEREF (so they autovivifiy if necessary), and the last
15990 * lookup op not to be.
15991 * For other things (like @{$h{k1}{k2}}) extra scope or
15992 * leave ops can appear, so abandon the effort in that
15994 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
15997 /* rv2av or rv2hv sKR/1 */
15999 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16000 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16001 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16004 /* at this point, we wouldn't expect any of these
16005 * possible private flags:
16006 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
16007 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
16009 ASSUME(!(o->op_private &
16010 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
16012 hints = (o->op_private & OPpHINT_STRICT_REFS);
16014 /* make sure the type of the previous /DEREF matches the
16015 * type of the next lookup */
16016 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
16019 action = next_is_hash
16020 ? MDEREF_HV_vivify_rv2hv_helem
16021 : MDEREF_AV_vivify_rv2av_aelem;
16025 /* if this is the second pass, and we're at the depth where
16026 * previously we encountered a non-simple index expression,
16027 * stop processing the index at this point */
16028 if (action_count != index_skip) {
16030 /* look for one or more simple ops that return an array
16031 * index or hash key */
16033 switch (o->op_type) {
16035 /* it may be a lexical var index */
16036 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
16037 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16038 ASSUME(!(o->op_private &
16039 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16041 if ( OP_GIMME(o,0) == G_SCALAR
16042 && !(o->op_flags & (OPf_REF|OPf_MOD))
16043 && o->op_private == 0)
16046 arg->pad_offset = o->op_targ;
16048 index_type = MDEREF_INDEX_padsv;
16054 if (next_is_hash) {
16055 /* it's a constant hash index */
16056 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
16057 /* "use constant foo => FOO; $h{+foo}" for
16058 * some weird FOO, can leave you with constants
16059 * that aren't simple strings. It's not worth
16060 * the extra hassle for those edge cases */
16065 OP * helem_op = o->op_next;
16067 ASSUME( helem_op->op_type == OP_HELEM
16068 || helem_op->op_type == OP_NULL
16070 if (helem_op->op_type == OP_HELEM) {
16071 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
16072 if ( helem_op->op_private & OPpLVAL_INTRO
16073 || rop->op_type != OP_RV2HV
16077 /* on first pass just check; on second pass
16079 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
16084 #ifdef USE_ITHREADS
16085 /* Relocate sv to the pad for thread safety */
16086 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
16087 arg->pad_offset = o->op_targ;
16090 arg->sv = cSVOPx_sv(o);
16095 /* it's a constant array index */
16097 SV *ix_sv = cSVOPo->op_sv;
16102 if ( action_count == 0
16105 && ( action == MDEREF_AV_padav_aelem
16106 || action == MDEREF_AV_gvav_aelem)
16108 maybe_aelemfast = TRUE;
16112 SvREFCNT_dec_NN(cSVOPo->op_sv);
16116 /* we've taken ownership of the SV */
16117 cSVOPo->op_sv = NULL;
16119 index_type = MDEREF_INDEX_const;
16124 /* it may be a package var index */
16126 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
16127 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
16128 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
16129 || o->op_private != 0
16134 if (kid->op_type != OP_RV2SV)
16137 ASSUME(!(kid->op_flags &
16138 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
16139 |OPf_SPECIAL|OPf_PARENS)));
16140 ASSUME(!(kid->op_private &
16142 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
16143 |OPpDEREF|OPpLVAL_INTRO)));
16144 if( (kid->op_flags &~ OPf_PARENS)
16145 != (OPf_WANT_SCALAR|OPf_KIDS)
16146 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
16151 #ifdef USE_ITHREADS
16152 arg->pad_offset = cPADOPx(o)->op_padix;
16153 /* stop it being swiped when nulled */
16154 cPADOPx(o)->op_padix = 0;
16156 arg->sv = cSVOPx(o)->op_sv;
16157 cSVOPo->op_sv = NULL;
16161 index_type = MDEREF_INDEX_gvsv;
16166 } /* action_count != index_skip */
16168 action |= index_type;
16171 /* at this point we have either:
16172 * * detected what looks like a simple index expression,
16173 * and expect the next op to be an [ah]elem, or
16174 * an nulled [ah]elem followed by a delete or exists;
16175 * * found a more complex expression, so something other
16176 * than the above follows.
16179 /* possibly an optimised away [ah]elem (where op_next is
16180 * exists or delete) */
16181 if (o->op_type == OP_NULL)
16184 /* at this point we're looking for an OP_AELEM, OP_HELEM,
16185 * OP_EXISTS or OP_DELETE */
16187 /* if a custom array/hash access checker is in scope,
16188 * abandon optimisation attempt */
16189 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16190 && PL_check[o->op_type] != Perl_ck_null)
16192 /* similarly for customised exists and delete */
16193 if ( (o->op_type == OP_EXISTS)
16194 && PL_check[o->op_type] != Perl_ck_exists)
16196 if ( (o->op_type == OP_DELETE)
16197 && PL_check[o->op_type] != Perl_ck_delete)
16200 if ( o->op_type != OP_AELEM
16201 || (o->op_private &
16202 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
16204 maybe_aelemfast = FALSE;
16206 /* look for aelem/helem/exists/delete. If it's not the last elem
16207 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
16208 * flags; if it's the last, then it mustn't have
16209 * OPpDEREF_AV/HV, but may have lots of other flags, like
16210 * OPpLVAL_INTRO etc
16213 if ( index_type == MDEREF_INDEX_none
16214 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
16215 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
16219 /* we have aelem/helem/exists/delete with valid simple index */
16221 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16222 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
16223 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
16225 /* This doesn't make much sense but is legal:
16226 * @{ local $x[0][0] } = 1
16227 * Since scope exit will undo the autovivification,
16228 * don't bother in the first place. The OP_LEAVE
16229 * assertion is in case there are other cases of both
16230 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
16231 * exit that would undo the local - in which case this
16232 * block of code would need rethinking.
16234 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
16236 OP *n = o->op_next;
16237 while (n && ( n->op_type == OP_NULL
16238 || n->op_type == OP_LIST
16239 || n->op_type == OP_SCALAR))
16241 assert(n && n->op_type == OP_LEAVE);
16243 o->op_private &= ~OPpDEREF;
16248 ASSUME(!(o->op_flags &
16249 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
16250 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
16252 ok = (o->op_flags &~ OPf_PARENS)
16253 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
16254 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
16256 else if (o->op_type == OP_EXISTS) {
16257 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16258 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16259 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
16260 ok = !(o->op_private & ~OPpARG1_MASK);
16262 else if (o->op_type == OP_DELETE) {
16263 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16264 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16265 ASSUME(!(o->op_private &
16266 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
16267 /* don't handle slices or 'local delete'; the latter
16268 * is fairly rare, and has a complex runtime */
16269 ok = !(o->op_private & ~OPpARG1_MASK);
16270 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
16271 /* skip handling run-tome error */
16272 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
16275 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
16276 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
16277 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
16278 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
16279 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
16280 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
16285 if (!first_elem_op)
16289 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
16294 action |= MDEREF_FLAG_last;
16298 /* at this point we have something that started
16299 * promisingly enough (with rv2av or whatever), but failed
16300 * to find a simple index followed by an
16301 * aelem/helem/exists/delete. If this is the first action,
16302 * give up; but if we've already seen at least one
16303 * aelem/helem, then keep them and add a new action with
16304 * MDEREF_INDEX_none, which causes it to do the vivify
16305 * from the end of the previous lookup, and do the deref,
16306 * but stop at that point. So $a[0][expr] will do one
16307 * av_fetch, vivify and deref, then continue executing at
16312 index_skip = action_count;
16313 action |= MDEREF_FLAG_last;
16314 if (index_type != MDEREF_INDEX_none)
16318 action_word |= (action << (action_ix * MDEREF_SHIFT));
16321 /* if there's no space for the next action, reserve a new slot
16322 * for it *before* we start adding args for that action */
16323 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
16325 action_ptr->uv = action_word;
16331 } /* while !is_last */
16336 /* slot reserved for next action word not now needed */
16339 action_ptr->uv = action_word;
16345 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
16346 if (index_skip == -1) {
16347 mderef->op_flags = o->op_flags
16348 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
16349 if (o->op_type == OP_EXISTS)
16350 mderef->op_private = OPpMULTIDEREF_EXISTS;
16351 else if (o->op_type == OP_DELETE)
16352 mderef->op_private = OPpMULTIDEREF_DELETE;
16354 mderef->op_private = o->op_private
16355 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
16357 /* accumulate strictness from every level (although I don't think
16358 * they can actually vary) */
16359 mderef->op_private |= hints;
16361 /* integrate the new multideref op into the optree and the
16364 * In general an op like aelem or helem has two child
16365 * sub-trees: the aggregate expression (a_expr) and the
16366 * index expression (i_expr):
16372 * The a_expr returns an AV or HV, while the i-expr returns an
16373 * index. In general a multideref replaces most or all of a
16374 * multi-level tree, e.g.
16390 * With multideref, all the i_exprs will be simple vars or
16391 * constants, except that i_expr1 may be arbitrary in the case
16392 * of MDEREF_INDEX_none.
16394 * The bottom-most a_expr will be either:
16395 * 1) a simple var (so padXv or gv+rv2Xv);
16396 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
16397 * so a simple var with an extra rv2Xv;
16398 * 3) or an arbitrary expression.
16400 * 'start', the first op in the execution chain, will point to
16401 * 1),2): the padXv or gv op;
16402 * 3): the rv2Xv which forms the last op in the a_expr
16403 * execution chain, and the top-most op in the a_expr
16406 * For all cases, the 'start' node is no longer required,
16407 * but we can't free it since one or more external nodes
16408 * may point to it. E.g. consider
16409 * $h{foo} = $a ? $b : $c
16410 * Here, both the op_next and op_other branches of the
16411 * cond_expr point to the gv[*h] of the hash expression, so
16412 * we can't free the 'start' op.
16414 * For expr->[...], we need to save the subtree containing the
16415 * expression; for the other cases, we just need to save the
16417 * So in all cases, we null the start op and keep it around by
16418 * making it the child of the multideref op; for the expr->
16419 * case, the expr will be a subtree of the start node.
16421 * So in the simple 1,2 case the optree above changes to
16427 * ex-gv (or ex-padxv)
16429 * with the op_next chain being
16431 * -> ex-gv -> multideref -> op-following-ex-exists ->
16433 * In the 3 case, we have
16446 * -> rest-of-a_expr subtree ->
16447 * ex-rv2xv -> multideref -> op-following-ex-exists ->
16450 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
16451 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
16452 * multideref attached as the child, e.g.
16458 * ex-rv2av - i_expr1
16466 /* if we free this op, don't free the pad entry */
16467 if (reset_start_targ)
16468 start->op_targ = 0;
16471 /* Cut the bit we need to save out of the tree and attach to
16472 * the multideref op, then free the rest of the tree */
16474 /* find parent of node to be detached (for use by splice) */
16476 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
16477 || orig_action == MDEREF_HV_pop_rv2hv_helem)
16479 /* there is an arbitrary expression preceding us, e.g.
16480 * expr->[..]? so we need to save the 'expr' subtree */
16481 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
16482 p = cUNOPx(p)->op_first;
16483 ASSUME( start->op_type == OP_RV2AV
16484 || start->op_type == OP_RV2HV);
16487 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
16488 * above for exists/delete. */
16489 while ( (p->op_flags & OPf_KIDS)
16490 && cUNOPx(p)->op_first != start
16492 p = cUNOPx(p)->op_first;
16494 ASSUME(cUNOPx(p)->op_first == start);
16496 /* detach from main tree, and re-attach under the multideref */
16497 op_sibling_splice(mderef, NULL, 0,
16498 op_sibling_splice(p, NULL, 1, NULL));
16501 start->op_next = mderef;
16503 mderef->op_next = index_skip == -1 ? o->op_next : o;
16505 /* excise and free the original tree, and replace with
16506 * the multideref op */
16507 p = op_sibling_splice(top_op, NULL, -1, mderef);
16516 Size_t size = arg - arg_buf;
16518 if (maybe_aelemfast && action_count == 1)
16521 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
16522 sizeof(UNOP_AUX_item) * (size + 1));
16523 /* for dumping etc: store the length in a hidden first slot;
16524 * we set the op_aux pointer to the second slot */
16525 arg_buf->uv = size;
16528 } /* for (pass = ...) */
16531 /* See if the ops following o are such that o will always be executed in
16532 * boolean context: that is, the SV which o pushes onto the stack will
16533 * only ever be consumed by later ops via SvTRUE(sv) or similar.
16534 * If so, set a suitable private flag on o. Normally this will be
16535 * bool_flag; but see below why maybe_flag is needed too.
16537 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
16538 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
16539 * already be taken, so you'll have to give that op two different flags.
16541 * More explanation of 'maybe_flag' and 'safe_and' parameters.
16542 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
16543 * those underlying ops) short-circuit, which means that rather than
16544 * necessarily returning a truth value, they may return the LH argument,
16545 * which may not be boolean. For example in $x = (keys %h || -1), keys
16546 * should return a key count rather than a boolean, even though its
16547 * sort-of being used in boolean context.
16549 * So we only consider such logical ops to provide boolean context to
16550 * their LH argument if they themselves are in void or boolean context.
16551 * However, sometimes the context isn't known until run-time. In this
16552 * case the op is marked with the maybe_flag flag it.
16554 * Consider the following.
16556 * sub f { ....; if (%h) { .... } }
16558 * This is actually compiled as
16560 * sub f { ....; %h && do { .... } }
16562 * Here we won't know until runtime whether the final statement (and hence
16563 * the &&) is in void context and so is safe to return a boolean value.
16564 * So mark o with maybe_flag rather than the bool_flag.
16565 * Note that there is cost associated with determining context at runtime
16566 * (e.g. a call to block_gimme()), so it may not be worth setting (at
16567 * compile time) and testing (at runtime) maybe_flag if the scalar verses
16568 * boolean costs savings are marginal.
16570 * However, we can do slightly better with && (compared to || and //):
16571 * this op only returns its LH argument when that argument is false. In
16572 * this case, as long as the op promises to return a false value which is
16573 * valid in both boolean and scalar contexts, we can mark an op consumed
16574 * by && with bool_flag rather than maybe_flag.
16575 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
16576 * than &PL_sv_no for a false result in boolean context, then it's safe. An
16577 * op which promises to handle this case is indicated by setting safe_and
16582 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
16587 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
16589 /* OPpTARGET_MY and boolean context probably don't mix well.
16590 * If someone finds a valid use case, maybe add an extra flag to this
16591 * function which indicates its safe to do so for this op? */
16592 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
16593 && (o->op_private & OPpTARGET_MY)));
16598 switch (lop->op_type) {
16603 /* these two consume the stack argument in the scalar case,
16604 * and treat it as a boolean in the non linenumber case */
16607 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
16608 || (lop->op_private & OPpFLIP_LINENUM))
16614 /* these never leave the original value on the stack */
16623 /* OR DOR and AND evaluate their arg as a boolean, but then may
16624 * leave the original scalar value on the stack when following the
16625 * op_next route. If not in void context, we need to ensure
16626 * that whatever follows consumes the arg only in boolean context
16638 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
16642 else if (!(lop->op_flags & OPf_WANT)) {
16643 /* unknown context - decide at runtime */
16655 lop = lop->op_next;
16658 o->op_private |= flag;
16663 /* mechanism for deferring recursion in rpeep() */
16665 #define MAX_DEFERRED 4
16669 if (defer_ix == (MAX_DEFERRED-1)) { \
16670 OP **defer = defer_queue[defer_base]; \
16671 CALL_RPEEP(*defer); \
16672 S_prune_chain_head(defer); \
16673 defer_base = (defer_base + 1) % MAX_DEFERRED; \
16676 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
16679 #define IS_AND_OP(o) (o->op_type == OP_AND)
16680 #define IS_OR_OP(o) (o->op_type == OP_OR)
16683 /* A peephole optimizer. We visit the ops in the order they're to execute.
16684 * See the comments at the top of this file for more details about when
16685 * peep() is called */
16688 Perl_rpeep(pTHX_ OP *o)
16691 OP* oldoldop = NULL;
16692 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
16693 int defer_base = 0;
16696 if (!o || o->op_opt)
16699 assert(o->op_type != OP_FREED);
16703 SAVEVPTR(PL_curcop);
16704 for (;; o = o->op_next) {
16705 if (o && o->op_opt)
16708 while (defer_ix >= 0) {
16710 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
16711 CALL_RPEEP(*defer);
16712 S_prune_chain_head(defer);
16719 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
16720 assert(!oldoldop || oldoldop->op_next == oldop);
16721 assert(!oldop || oldop->op_next == o);
16723 /* By default, this op has now been optimised. A couple of cases below
16724 clear this again. */
16728 /* look for a series of 1 or more aggregate derefs, e.g.
16729 * $a[1]{foo}[$i]{$k}
16730 * and replace with a single OP_MULTIDEREF op.
16731 * Each index must be either a const, or a simple variable,
16733 * First, look for likely combinations of starting ops,
16734 * corresponding to (global and lexical variants of)
16736 * $r->[...] $r->{...}
16737 * (preceding expression)->[...]
16738 * (preceding expression)->{...}
16739 * and if so, call maybe_multideref() to do a full inspection
16740 * of the op chain and if appropriate, replace with an
16748 switch (o2->op_type) {
16750 /* $pkg[..] : gv[*pkg]
16751 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
16753 /* Fail if there are new op flag combinations that we're
16754 * not aware of, rather than:
16755 * * silently failing to optimise, or
16756 * * silently optimising the flag away.
16757 * If this ASSUME starts failing, examine what new flag
16758 * has been added to the op, and decide whether the
16759 * optimisation should still occur with that flag, then
16760 * update the code accordingly. This applies to all the
16761 * other ASSUMEs in the block of code too.
16763 ASSUME(!(o2->op_flags &
16764 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
16765 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
16769 if (o2->op_type == OP_RV2AV) {
16770 action = MDEREF_AV_gvav_aelem;
16774 if (o2->op_type == OP_RV2HV) {
16775 action = MDEREF_HV_gvhv_helem;
16779 if (o2->op_type != OP_RV2SV)
16782 /* at this point we've seen gv,rv2sv, so the only valid
16783 * construct left is $pkg->[] or $pkg->{} */
16785 ASSUME(!(o2->op_flags & OPf_STACKED));
16786 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16787 != (OPf_WANT_SCALAR|OPf_MOD))
16790 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
16791 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
16792 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
16794 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
16795 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
16799 if (o2->op_type == OP_RV2AV) {
16800 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
16803 if (o2->op_type == OP_RV2HV) {
16804 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
16810 /* $lex->[...]: padsv[$lex] sM/DREFAV */
16812 ASSUME(!(o2->op_flags &
16813 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
16814 if ((o2->op_flags &
16815 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16816 != (OPf_WANT_SCALAR|OPf_MOD))
16819 ASSUME(!(o2->op_private &
16820 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16821 /* skip if state or intro, or not a deref */
16822 if ( o2->op_private != OPpDEREF_AV
16823 && o2->op_private != OPpDEREF_HV)
16827 if (o2->op_type == OP_RV2AV) {
16828 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
16831 if (o2->op_type == OP_RV2HV) {
16832 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
16839 /* $lex[..]: padav[@lex:1,2] sR *
16840 * or $lex{..}: padhv[%lex:1,2] sR */
16841 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
16842 OPf_REF|OPf_SPECIAL)));
16843 if ((o2->op_flags &
16844 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16845 != (OPf_WANT_SCALAR|OPf_REF))
16847 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
16849 /* OPf_PARENS isn't currently used in this case;
16850 * if that changes, let us know! */
16851 ASSUME(!(o2->op_flags & OPf_PARENS));
16853 /* at this point, we wouldn't expect any of the remaining
16854 * possible private flags:
16855 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
16856 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
16858 * OPpSLICEWARNING shouldn't affect runtime
16860 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
16862 action = o2->op_type == OP_PADAV
16863 ? MDEREF_AV_padav_aelem
16864 : MDEREF_HV_padhv_helem;
16866 S_maybe_multideref(aTHX_ o, o2, action, 0);
16872 action = o2->op_type == OP_RV2AV
16873 ? MDEREF_AV_pop_rv2av_aelem
16874 : MDEREF_HV_pop_rv2hv_helem;
16877 /* (expr)->[...]: rv2av sKR/1;
16878 * (expr)->{...}: rv2hv sKR/1; */
16880 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
16882 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16883 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
16884 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16887 /* at this point, we wouldn't expect any of these
16888 * possible private flags:
16889 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
16890 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
16892 ASSUME(!(o2->op_private &
16893 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
16895 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
16899 S_maybe_multideref(aTHX_ o, o2, action, hints);
16908 switch (o->op_type) {
16910 PL_curcop = ((COP*)o); /* for warnings */
16913 PL_curcop = ((COP*)o); /* for warnings */
16915 /* Optimise a "return ..." at the end of a sub to just be "...".
16916 * This saves 2 ops. Before:
16917 * 1 <;> nextstate(main 1 -e:1) v ->2
16918 * 4 <@> return K ->5
16919 * 2 <0> pushmark s ->3
16920 * - <1> ex-rv2sv sK/1 ->4
16921 * 3 <#> gvsv[*cat] s ->4
16924 * - <@> return K ->-
16925 * - <0> pushmark s ->2
16926 * - <1> ex-rv2sv sK/1 ->-
16927 * 2 <$> gvsv(*cat) s ->3
16930 OP *next = o->op_next;
16931 OP *sibling = OpSIBLING(o);
16932 if ( OP_TYPE_IS(next, OP_PUSHMARK)
16933 && OP_TYPE_IS(sibling, OP_RETURN)
16934 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
16935 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
16936 ||OP_TYPE_IS(sibling->op_next->op_next,
16938 && cUNOPx(sibling)->op_first == next
16939 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
16942 /* Look through the PUSHMARK's siblings for one that
16943 * points to the RETURN */
16944 OP *top = OpSIBLING(next);
16945 while (top && top->op_next) {
16946 if (top->op_next == sibling) {
16947 top->op_next = sibling->op_next;
16948 o->op_next = next->op_next;
16951 top = OpSIBLING(top);
16956 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
16958 * This latter form is then suitable for conversion into padrange
16959 * later on. Convert:
16961 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
16965 * nextstate1 -> listop -> nextstate3
16967 * pushmark -> padop1 -> padop2
16969 if (o->op_next && (
16970 o->op_next->op_type == OP_PADSV
16971 || o->op_next->op_type == OP_PADAV
16972 || o->op_next->op_type == OP_PADHV
16974 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
16975 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
16976 && o->op_next->op_next->op_next && (
16977 o->op_next->op_next->op_next->op_type == OP_PADSV
16978 || o->op_next->op_next->op_next->op_type == OP_PADAV
16979 || o->op_next->op_next->op_next->op_type == OP_PADHV
16981 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
16982 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
16983 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
16984 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
16986 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
16989 ns2 = pad1->op_next;
16990 pad2 = ns2->op_next;
16991 ns3 = pad2->op_next;
16993 /* we assume here that the op_next chain is the same as
16994 * the op_sibling chain */
16995 assert(OpSIBLING(o) == pad1);
16996 assert(OpSIBLING(pad1) == ns2);
16997 assert(OpSIBLING(ns2) == pad2);
16998 assert(OpSIBLING(pad2) == ns3);
17000 /* excise and delete ns2 */
17001 op_sibling_splice(NULL, pad1, 1, NULL);
17004 /* excise pad1 and pad2 */
17005 op_sibling_splice(NULL, o, 2, NULL);
17007 /* create new listop, with children consisting of:
17008 * a new pushmark, pad1, pad2. */
17009 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
17010 newop->op_flags |= OPf_PARENS;
17011 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17013 /* insert newop between o and ns3 */
17014 op_sibling_splice(NULL, o, 0, newop);
17016 /*fixup op_next chain */
17017 newpm = cUNOPx(newop)->op_first; /* pushmark */
17018 o ->op_next = newpm;
17019 newpm->op_next = pad1;
17020 pad1 ->op_next = pad2;
17021 pad2 ->op_next = newop; /* listop */
17022 newop->op_next = ns3;
17024 /* Ensure pushmark has this flag if padops do */
17025 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
17026 newpm->op_flags |= OPf_MOD;
17032 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
17033 to carry two labels. For now, take the easier option, and skip
17034 this optimisation if the first NEXTSTATE has a label. */
17035 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
17036 OP *nextop = o->op_next;
17038 switch (nextop->op_type) {
17043 nextop = nextop->op_next;
17049 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
17052 oldop->op_next = nextop;
17054 /* Skip (old)oldop assignment since the current oldop's
17055 op_next already points to the next op. */
17062 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
17063 if (o->op_next->op_private & OPpTARGET_MY) {
17064 if (o->op_flags & OPf_STACKED) /* chained concats */
17065 break; /* ignore_optimization */
17067 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
17068 o->op_targ = o->op_next->op_targ;
17069 o->op_next->op_targ = 0;
17070 o->op_private |= OPpTARGET_MY;
17073 op_null(o->op_next);
17077 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
17078 break; /* Scalar stub must produce undef. List stub is noop */
17082 if (o->op_targ == OP_NEXTSTATE
17083 || o->op_targ == OP_DBSTATE)
17085 PL_curcop = ((COP*)o);
17087 /* XXX: We avoid setting op_seq here to prevent later calls
17088 to rpeep() from mistakenly concluding that optimisation
17089 has already occurred. This doesn't fix the real problem,
17090 though (See 20010220.007 (#5874)). AMS 20010719 */
17091 /* op_seq functionality is now replaced by op_opt */
17099 oldop->op_next = o->op_next;
17113 convert repeat into a stub with no kids.
17115 if (o->op_next->op_type == OP_CONST
17116 || ( o->op_next->op_type == OP_PADSV
17117 && !(o->op_next->op_private & OPpLVAL_INTRO))
17118 || ( o->op_next->op_type == OP_GV
17119 && o->op_next->op_next->op_type == OP_RV2SV
17120 && !(o->op_next->op_next->op_private
17121 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
17123 const OP *kid = o->op_next->op_next;
17124 if (o->op_next->op_type == OP_GV)
17125 kid = kid->op_next;
17126 /* kid is now the ex-list. */
17127 if (kid->op_type == OP_NULL
17128 && (kid = kid->op_next)->op_type == OP_CONST
17129 /* kid is now the repeat count. */
17130 && kid->op_next->op_type == OP_REPEAT
17131 && kid->op_next->op_private & OPpREPEAT_DOLIST
17132 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
17133 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
17136 o = kid->op_next; /* repeat */
17137 oldop->op_next = o;
17138 op_free(cBINOPo->op_first);
17139 op_free(cBINOPo->op_last );
17140 o->op_flags &=~ OPf_KIDS;
17141 /* stub is a baseop; repeat is a binop */
17142 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
17143 OpTYPE_set(o, OP_STUB);
17149 /* Convert a series of PAD ops for my vars plus support into a
17150 * single padrange op. Basically
17152 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
17154 * becomes, depending on circumstances, one of
17156 * padrange ----------------------------------> (list) -> rest
17157 * padrange --------------------------------------------> rest
17159 * where all the pad indexes are sequential and of the same type
17161 * We convert the pushmark into a padrange op, then skip
17162 * any other pad ops, and possibly some trailing ops.
17163 * Note that we don't null() the skipped ops, to make it
17164 * easier for Deparse to undo this optimisation (and none of
17165 * the skipped ops are holding any resourses). It also makes
17166 * it easier for find_uninit_var(), as it can just ignore
17167 * padrange, and examine the original pad ops.
17171 OP *followop = NULL; /* the op that will follow the padrange op */
17174 PADOFFSET base = 0; /* init only to stop compiler whining */
17175 bool gvoid = 0; /* init only to stop compiler whining */
17176 bool defav = 0; /* seen (...) = @_ */
17177 bool reuse = 0; /* reuse an existing padrange op */
17179 /* look for a pushmark -> gv[_] -> rv2av */
17184 if ( p->op_type == OP_GV
17185 && cGVOPx_gv(p) == PL_defgv
17186 && (rv2av = p->op_next)
17187 && rv2av->op_type == OP_RV2AV
17188 && !(rv2av->op_flags & OPf_REF)
17189 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
17190 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
17192 q = rv2av->op_next;
17193 if (q->op_type == OP_NULL)
17195 if (q->op_type == OP_PUSHMARK) {
17205 /* scan for PAD ops */
17207 for (p = p->op_next; p; p = p->op_next) {
17208 if (p->op_type == OP_NULL)
17211 if (( p->op_type != OP_PADSV
17212 && p->op_type != OP_PADAV
17213 && p->op_type != OP_PADHV
17215 /* any private flag other than INTRO? e.g. STATE */
17216 || (p->op_private & ~OPpLVAL_INTRO)
17220 /* let $a[N] potentially be optimised into AELEMFAST_LEX
17222 if ( p->op_type == OP_PADAV
17224 && p->op_next->op_type == OP_CONST
17225 && p->op_next->op_next
17226 && p->op_next->op_next->op_type == OP_AELEM
17230 /* for 1st padop, note what type it is and the range
17231 * start; for the others, check that it's the same type
17232 * and that the targs are contiguous */
17234 intro = (p->op_private & OPpLVAL_INTRO);
17236 gvoid = OP_GIMME(p,0) == G_VOID;
17239 if ((p->op_private & OPpLVAL_INTRO) != intro)
17241 /* Note that you'd normally expect targs to be
17242 * contiguous in my($a,$b,$c), but that's not the case
17243 * when external modules start doing things, e.g.
17244 * Function::Parameters */
17245 if (p->op_targ != base + count)
17247 assert(p->op_targ == base + count);
17248 /* Either all the padops or none of the padops should
17249 be in void context. Since we only do the optimisa-
17250 tion for av/hv when the aggregate itself is pushed
17251 on to the stack (one item), there is no need to dis-
17252 tinguish list from scalar context. */
17253 if (gvoid != (OP_GIMME(p,0) == G_VOID))
17257 /* for AV, HV, only when we're not flattening */
17258 if ( p->op_type != OP_PADSV
17260 && !(p->op_flags & OPf_REF)
17264 if (count >= OPpPADRANGE_COUNTMASK)
17267 /* there's a biggest base we can fit into a
17268 * SAVEt_CLEARPADRANGE in pp_padrange.
17269 * (The sizeof() stuff will be constant-folded, and is
17270 * intended to avoid getting "comparison is always false"
17271 * compiler warnings. See the comments above
17272 * MEM_WRAP_CHECK for more explanation on why we do this
17273 * in a weird way to avoid compiler warnings.)
17276 && (8*sizeof(base) >
17277 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
17279 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17281 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17285 /* Success! We've got another valid pad op to optimise away */
17287 followop = p->op_next;
17290 if (count < 1 || (count == 1 && !defav))
17293 /* pp_padrange in specifically compile-time void context
17294 * skips pushing a mark and lexicals; in all other contexts
17295 * (including unknown till runtime) it pushes a mark and the
17296 * lexicals. We must be very careful then, that the ops we
17297 * optimise away would have exactly the same effect as the
17299 * In particular in void context, we can only optimise to
17300 * a padrange if we see the complete sequence
17301 * pushmark, pad*v, ...., list
17302 * which has the net effect of leaving the markstack as it
17303 * was. Not pushing onto the stack (whereas padsv does touch
17304 * the stack) makes no difference in void context.
17308 if (followop->op_type == OP_LIST
17309 && OP_GIMME(followop,0) == G_VOID
17312 followop = followop->op_next; /* skip OP_LIST */
17314 /* consolidate two successive my(...);'s */
17317 && oldoldop->op_type == OP_PADRANGE
17318 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
17319 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
17320 && !(oldoldop->op_flags & OPf_SPECIAL)
17323 assert(oldoldop->op_next == oldop);
17324 assert( oldop->op_type == OP_NEXTSTATE
17325 || oldop->op_type == OP_DBSTATE);
17326 assert(oldop->op_next == o);
17329 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
17331 /* Do not assume pad offsets for $c and $d are con-
17336 if ( oldoldop->op_targ + old_count == base
17337 && old_count < OPpPADRANGE_COUNTMASK - count) {
17338 base = oldoldop->op_targ;
17339 count += old_count;
17344 /* if there's any immediately following singleton
17345 * my var's; then swallow them and the associated
17347 * my ($a,$b); my $c; my $d;
17349 * my ($a,$b,$c,$d);
17352 while ( ((p = followop->op_next))
17353 && ( p->op_type == OP_PADSV
17354 || p->op_type == OP_PADAV
17355 || p->op_type == OP_PADHV)
17356 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
17357 && (p->op_private & OPpLVAL_INTRO) == intro
17358 && !(p->op_private & ~OPpLVAL_INTRO)
17360 && ( p->op_next->op_type == OP_NEXTSTATE
17361 || p->op_next->op_type == OP_DBSTATE)
17362 && count < OPpPADRANGE_COUNTMASK
17363 && base + count == p->op_targ
17366 followop = p->op_next;
17374 assert(oldoldop->op_type == OP_PADRANGE);
17375 oldoldop->op_next = followop;
17376 oldoldop->op_private = (intro | count);
17382 /* Convert the pushmark into a padrange.
17383 * To make Deparse easier, we guarantee that a padrange was
17384 * *always* formerly a pushmark */
17385 assert(o->op_type == OP_PUSHMARK);
17386 o->op_next = followop;
17387 OpTYPE_set(o, OP_PADRANGE);
17389 /* bit 7: INTRO; bit 6..0: count */
17390 o->op_private = (intro | count);
17391 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
17392 | gvoid * OPf_WANT_VOID
17393 | (defav ? OPf_SPECIAL : 0));
17399 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17400 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17405 /*'keys %h' in void or scalar context: skip the OP_KEYS
17406 * and perform the functionality directly in the RV2HV/PADHV
17409 if (o->op_flags & OPf_REF) {
17410 OP *k = o->op_next;
17411 U8 want = (k->op_flags & OPf_WANT);
17413 && k->op_type == OP_KEYS
17414 && ( want == OPf_WANT_VOID
17415 || want == OPf_WANT_SCALAR)
17416 && !(k->op_private & OPpMAYBE_LVSUB)
17417 && !(k->op_flags & OPf_MOD)
17419 o->op_next = k->op_next;
17420 o->op_flags &= ~(OPf_REF|OPf_WANT);
17421 o->op_flags |= want;
17422 o->op_private |= (o->op_type == OP_PADHV ?
17423 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
17424 /* for keys(%lex), hold onto the OP_KEYS's targ
17425 * since padhv doesn't have its own targ to return
17427 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
17432 /* see if %h is used in boolean context */
17433 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17434 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17437 if (o->op_type != OP_PADHV)
17441 if ( o->op_type == OP_PADAV
17442 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17444 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17447 /* Skip over state($x) in void context. */
17448 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
17449 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
17451 oldop->op_next = o->op_next;
17452 goto redo_nextstate;
17454 if (o->op_type != OP_PADAV)
17458 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
17459 OP* const pop = (o->op_type == OP_PADAV) ?
17460 o->op_next : o->op_next->op_next;
17462 if (pop && pop->op_type == OP_CONST &&
17463 ((PL_op = pop->op_next)) &&
17464 pop->op_next->op_type == OP_AELEM &&
17465 !(pop->op_next->op_private &
17466 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
17467 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
17470 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
17471 no_bareword_allowed(pop);
17472 if (o->op_type == OP_GV)
17473 op_null(o->op_next);
17474 op_null(pop->op_next);
17476 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
17477 o->op_next = pop->op_next->op_next;
17478 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
17479 o->op_private = (U8)i;
17480 if (o->op_type == OP_GV) {
17483 o->op_type = OP_AELEMFAST;
17486 o->op_type = OP_AELEMFAST_LEX;
17488 if (o->op_type != OP_GV)
17492 /* Remove $foo from the op_next chain in void context. */
17494 && ( o->op_next->op_type == OP_RV2SV
17495 || o->op_next->op_type == OP_RV2AV
17496 || o->op_next->op_type == OP_RV2HV )
17497 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17498 && !(o->op_next->op_private & OPpLVAL_INTRO))
17500 oldop->op_next = o->op_next->op_next;
17501 /* Reprocess the previous op if it is a nextstate, to
17502 allow double-nextstate optimisation. */
17504 if (oldop->op_type == OP_NEXTSTATE) {
17511 o = oldop->op_next;
17514 else if (o->op_next->op_type == OP_RV2SV) {
17515 if (!(o->op_next->op_private & OPpDEREF)) {
17516 op_null(o->op_next);
17517 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
17519 o->op_next = o->op_next->op_next;
17520 OpTYPE_set(o, OP_GVSV);
17523 else if (o->op_next->op_type == OP_READLINE
17524 && o->op_next->op_next->op_type == OP_CONCAT
17525 && (o->op_next->op_next->op_flags & OPf_STACKED))
17527 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
17528 OpTYPE_set(o, OP_RCATLINE);
17529 o->op_flags |= OPf_STACKED;
17530 op_null(o->op_next->op_next);
17531 op_null(o->op_next);
17542 case OP_CMPCHAIN_AND:
17543 while (cLOGOP->op_other->op_type == OP_NULL)
17544 cLOGOP->op_other = cLOGOP->op_other->op_next;
17545 while (o->op_next && ( o->op_type == o->op_next->op_type
17546 || o->op_next->op_type == OP_NULL))
17547 o->op_next = o->op_next->op_next;
17549 /* If we're an OR and our next is an AND in void context, we'll
17550 follow its op_other on short circuit, same for reverse.
17551 We can't do this with OP_DOR since if it's true, its return
17552 value is the underlying value which must be evaluated
17556 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
17557 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
17559 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17561 o->op_next = ((LOGOP*)o->op_next)->op_other;
17563 DEFER(cLOGOP->op_other);
17568 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17569 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17578 case OP_ARGDEFELEM:
17579 while (cLOGOP->op_other->op_type == OP_NULL)
17580 cLOGOP->op_other = cLOGOP->op_other->op_next;
17581 DEFER(cLOGOP->op_other);
17586 while (cLOOP->op_redoop->op_type == OP_NULL)
17587 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
17588 while (cLOOP->op_nextop->op_type == OP_NULL)
17589 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
17590 while (cLOOP->op_lastop->op_type == OP_NULL)
17591 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
17592 /* a while(1) loop doesn't have an op_next that escapes the
17593 * loop, so we have to explicitly follow the op_lastop to
17594 * process the rest of the code */
17595 DEFER(cLOOP->op_lastop);
17599 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
17600 DEFER(cLOGOPo->op_other);
17604 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17605 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17606 assert(!(cPMOP->op_pmflags & PMf_ONCE));
17607 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
17608 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
17609 cPMOP->op_pmstashstartu.op_pmreplstart
17610 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
17611 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
17617 if (o->op_flags & OPf_SPECIAL) {
17618 /* first arg is a code block */
17619 OP * const nullop = OpSIBLING(cLISTOP->op_first);
17620 OP * kid = cUNOPx(nullop)->op_first;
17622 assert(nullop->op_type == OP_NULL);
17623 assert(kid->op_type == OP_SCOPE
17624 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
17625 /* since OP_SORT doesn't have a handy op_other-style
17626 * field that can point directly to the start of the code
17627 * block, store it in the otherwise-unused op_next field
17628 * of the top-level OP_NULL. This will be quicker at
17629 * run-time, and it will also allow us to remove leading
17630 * OP_NULLs by just messing with op_nexts without
17631 * altering the basic op_first/op_sibling layout. */
17632 kid = kLISTOP->op_first;
17634 (kid->op_type == OP_NULL
17635 && ( kid->op_targ == OP_NEXTSTATE
17636 || kid->op_targ == OP_DBSTATE ))
17637 || kid->op_type == OP_STUB
17638 || kid->op_type == OP_ENTER
17639 || (PL_parser && PL_parser->error_count));
17640 nullop->op_next = kid->op_next;
17641 DEFER(nullop->op_next);
17644 /* check that RHS of sort is a single plain array */
17645 oright = cUNOPo->op_first;
17646 if (!oright || oright->op_type != OP_PUSHMARK)
17649 if (o->op_private & OPpSORT_INPLACE)
17652 /* reverse sort ... can be optimised. */
17653 if (!OpHAS_SIBLING(cUNOPo)) {
17654 /* Nothing follows us on the list. */
17655 OP * const reverse = o->op_next;
17657 if (reverse->op_type == OP_REVERSE &&
17658 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
17659 OP * const pushmark = cUNOPx(reverse)->op_first;
17660 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
17661 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
17662 /* reverse -> pushmark -> sort */
17663 o->op_private |= OPpSORT_REVERSE;
17665 pushmark->op_next = oright->op_next;
17675 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
17677 LISTOP *enter, *exlist;
17679 if (o->op_private & OPpSORT_INPLACE)
17682 enter = (LISTOP *) o->op_next;
17685 if (enter->op_type == OP_NULL) {
17686 enter = (LISTOP *) enter->op_next;
17690 /* for $a (...) will have OP_GV then OP_RV2GV here.
17691 for (...) just has an OP_GV. */
17692 if (enter->op_type == OP_GV) {
17693 gvop = (OP *) enter;
17694 enter = (LISTOP *) enter->op_next;
17697 if (enter->op_type == OP_RV2GV) {
17698 enter = (LISTOP *) enter->op_next;
17704 if (enter->op_type != OP_ENTERITER)
17707 iter = enter->op_next;
17708 if (!iter || iter->op_type != OP_ITER)
17711 expushmark = enter->op_first;
17712 if (!expushmark || expushmark->op_type != OP_NULL
17713 || expushmark->op_targ != OP_PUSHMARK)
17716 exlist = (LISTOP *) OpSIBLING(expushmark);
17717 if (!exlist || exlist->op_type != OP_NULL
17718 || exlist->op_targ != OP_LIST)
17721 if (exlist->op_last != o) {
17722 /* Mmm. Was expecting to point back to this op. */
17725 theirmark = exlist->op_first;
17726 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
17729 if (OpSIBLING(theirmark) != o) {
17730 /* There's something between the mark and the reverse, eg
17731 for (1, reverse (...))
17736 ourmark = ((LISTOP *)o)->op_first;
17737 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
17740 ourlast = ((LISTOP *)o)->op_last;
17741 if (!ourlast || ourlast->op_next != o)
17744 rv2av = OpSIBLING(ourmark);
17745 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
17746 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
17747 /* We're just reversing a single array. */
17748 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
17749 enter->op_flags |= OPf_STACKED;
17752 /* We don't have control over who points to theirmark, so sacrifice
17754 theirmark->op_next = ourmark->op_next;
17755 theirmark->op_flags = ourmark->op_flags;
17756 ourlast->op_next = gvop ? gvop : (OP *) enter;
17759 enter->op_private |= OPpITER_REVERSED;
17760 iter->op_private |= OPpITER_REVERSED;
17764 o = oldop->op_next;
17766 NOT_REACHED; /* NOTREACHED */
17772 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
17773 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
17778 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
17779 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
17782 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
17784 sv = newRV((SV *)PL_compcv);
17788 OpTYPE_set(o, OP_CONST);
17789 o->op_flags |= OPf_SPECIAL;
17790 cSVOPo->op_sv = sv;
17795 if (OP_GIMME(o,0) == G_VOID
17796 || ( o->op_next->op_type == OP_LINESEQ
17797 && ( o->op_next->op_next->op_type == OP_LEAVESUB
17798 || ( o->op_next->op_next->op_type == OP_RETURN
17799 && !CvLVALUE(PL_compcv)))))
17801 OP *right = cBINOP->op_first;
17820 OP *left = OpSIBLING(right);
17821 if (left->op_type == OP_SUBSTR
17822 && (left->op_private & 7) < 4) {
17824 /* cut out right */
17825 op_sibling_splice(o, NULL, 1, NULL);
17826 /* and insert it as second child of OP_SUBSTR */
17827 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
17829 left->op_private |= OPpSUBSTR_REPL_FIRST;
17831 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17838 int l, r, lr, lscalars, rscalars;
17840 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
17841 Note that we do this now rather than in newASSIGNOP(),
17842 since only by now are aliased lexicals flagged as such
17844 See the essay "Common vars in list assignment" above for
17845 the full details of the rationale behind all the conditions
17848 PL_generation sorcery:
17849 To detect whether there are common vars, the global var
17850 PL_generation is incremented for each assign op we scan.
17851 Then we run through all the lexical variables on the LHS,
17852 of the assignment, setting a spare slot in each of them to
17853 PL_generation. Then we scan the RHS, and if any lexicals
17854 already have that value, we know we've got commonality.
17855 Also, if the generation number is already set to
17856 PERL_INT_MAX, then the variable is involved in aliasing, so
17857 we also have potential commonality in that case.
17863 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
17866 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
17870 /* After looking for things which are *always* safe, this main
17871 * if/else chain selects primarily based on the type of the
17872 * LHS, gradually working its way down from the more dangerous
17873 * to the more restrictive and thus safer cases */
17875 if ( !l /* () = ....; */
17876 || !r /* .... = (); */
17877 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
17878 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
17879 || (lscalars < 2) /* ($x, undef) = ... */
17881 NOOP; /* always safe */
17883 else if (l & AAS_DANGEROUS) {
17884 /* always dangerous */
17885 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17886 o->op_private |= OPpASSIGN_COMMON_AGG;
17888 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
17889 /* package vars are always dangerous - too many
17890 * aliasing possibilities */
17891 if (l & AAS_PKG_SCALAR)
17892 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17893 if (l & AAS_PKG_AGG)
17894 o->op_private |= OPpASSIGN_COMMON_AGG;
17896 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
17897 |AAS_LEX_SCALAR|AAS_LEX_AGG))
17899 /* LHS contains only lexicals and safe ops */
17901 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
17902 o->op_private |= OPpASSIGN_COMMON_AGG;
17904 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
17905 if (lr & AAS_LEX_SCALAR_COMM)
17906 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17907 else if ( !(l & AAS_LEX_SCALAR)
17908 && (r & AAS_DEFAV))
17912 * as scalar-safe for performance reasons.
17913 * (it will still have been marked _AGG if necessary */
17916 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
17917 /* if there are only lexicals on the LHS and no
17918 * common ones on the RHS, then we assume that the
17919 * only way those lexicals could also get
17920 * on the RHS is via some sort of dereffing or
17923 * ($lex, $x) = (1, $$r)
17924 * and in this case we assume the var must have
17925 * a bumped ref count. So if its ref count is 1,
17926 * it must only be on the LHS.
17928 o->op_private |= OPpASSIGN_COMMON_RC1;
17933 * may have to handle aggregate on LHS, but we can't
17934 * have common scalars. */
17937 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
17939 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17940 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
17945 /* see if ref() is used in boolean context */
17946 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17947 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17951 /* see if the op is used in known boolean context,
17952 * but not if OA_TARGLEX optimisation is enabled */
17953 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17954 && !(o->op_private & OPpTARGET_MY)
17956 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17960 /* see if the op is used in known boolean context */
17961 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17962 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17966 Perl_cpeep_t cpeep =
17967 XopENTRYCUSTOM(o, xop_peep);
17969 cpeep(aTHX_ o, oldop);
17974 /* did we just null the current op? If so, re-process it to handle
17975 * eliding "empty" ops from the chain */
17976 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
17989 Perl_peep(pTHX_ OP *o)
17995 =for apidoc_section $custom
17997 =for apidoc Perl_custom_op_xop
17998 Return the XOP structure for a given custom op. This macro should be
17999 considered internal to C<OP_NAME> and the other access macros: use them instead.
18000 This macro does call a function. Prior
18001 to 5.19.6, this was implemented as a
18008 /* use PERL_MAGIC_ext to call a function to free the xop structure when
18009 * freeing PL_custom_ops */
18012 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
18016 PERL_UNUSED_ARG(mg);
18017 xop = INT2PTR(XOP *, SvIV(sv));
18018 Safefree(xop->xop_name);
18019 Safefree(xop->xop_desc);
18025 static const MGVTBL custom_op_register_vtbl = {
18030 custom_op_register_free, /* free */
18040 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
18046 static const XOP xop_null = { 0, 0, 0, 0, 0 };
18048 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
18049 assert(o->op_type == OP_CUSTOM);
18051 /* This is wrong. It assumes a function pointer can be cast to IV,
18052 * which isn't guaranteed, but this is what the old custom OP code
18053 * did. In principle it should be safer to Copy the bytes of the
18054 * pointer into a PV: since the new interface is hidden behind
18055 * functions, this can be changed later if necessary. */
18056 /* Change custom_op_xop if this ever happens */
18057 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
18060 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18062 /* See if the op isn't registered, but its name *is* registered.
18063 * That implies someone is using the pre-5.14 API,where only name and
18064 * description could be registered. If so, fake up a real
18066 * We only check for an existing name, and assume no one will have
18067 * just registered a desc */
18068 if (!he && PL_custom_op_names &&
18069 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
18074 /* XXX does all this need to be shared mem? */
18075 Newxz(xop, 1, XOP);
18076 pv = SvPV(HeVAL(he), l);
18077 XopENTRY_set(xop, xop_name, savepvn(pv, l));
18078 if (PL_custom_op_descs &&
18079 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
18081 pv = SvPV(HeVAL(he), l);
18082 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
18084 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
18085 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18086 /* add magic to the SV so that the xop struct (pointed to by
18087 * SvIV(sv)) is freed. Normally a static xop is registered, but
18088 * for this backcompat hack, we've alloced one */
18089 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
18090 &custom_op_register_vtbl, NULL, 0);
18095 xop = (XOP *)&xop_null;
18097 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
18102 if(field == XOPe_xop_ptr) {
18105 const U32 flags = XopFLAGS(xop);
18106 if(flags & field) {
18108 case XOPe_xop_name:
18109 any.xop_name = xop->xop_name;
18111 case XOPe_xop_desc:
18112 any.xop_desc = xop->xop_desc;
18114 case XOPe_xop_class:
18115 any.xop_class = xop->xop_class;
18117 case XOPe_xop_peep:
18118 any.xop_peep = xop->xop_peep;
18123 "panic: custom_op_get_field(): invalid field %d\n",
18129 case XOPe_xop_name:
18130 any.xop_name = XOPd_xop_name;
18132 case XOPe_xop_desc:
18133 any.xop_desc = XOPd_xop_desc;
18135 case XOPe_xop_class:
18136 any.xop_class = XOPd_xop_class;
18138 case XOPe_xop_peep:
18139 any.xop_peep = XOPd_xop_peep;
18152 =for apidoc custom_op_register
18153 Register a custom op. See L<perlguts/"Custom Operators">.
18159 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
18163 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
18165 /* see the comment in custom_op_xop */
18166 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
18168 if (!PL_custom_ops)
18169 PL_custom_ops = newHV();
18171 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
18172 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
18177 =for apidoc core_prototype
18179 This function assigns the prototype of the named core function to C<sv>, or
18180 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
18181 C<NULL> if the core function has no prototype. C<code> is a code as returned
18182 by C<keyword()>. It must not be equal to 0.
18188 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
18191 int i = 0, n = 0, seen_question = 0, defgv = 0;
18193 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
18194 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
18195 bool nullret = FALSE;
18197 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
18201 if (!sv) sv = sv_newmortal();
18203 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
18205 switch (code < 0 ? -code : code) {
18206 case KEY_and : case KEY_chop: case KEY_chomp:
18207 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
18208 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
18209 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
18210 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
18211 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
18212 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
18213 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
18214 case KEY_x : case KEY_xor :
18215 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
18216 case KEY_glob: retsetpvs("_;", OP_GLOB);
18217 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
18218 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
18219 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
18220 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
18221 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
18223 case KEY_evalbytes:
18224 name = "entereval"; break;
18232 while (i < MAXO) { /* The slow way. */
18233 if (strEQ(name, PL_op_name[i])
18234 || strEQ(name, PL_op_desc[i]))
18236 if (nullret) { assert(opnum); *opnum = i; return NULL; }
18243 defgv = PL_opargs[i] & OA_DEFGV;
18244 oa = PL_opargs[i] >> OASHIFT;
18246 if (oa & OA_OPTIONAL && !seen_question && (
18247 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
18252 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
18253 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
18254 /* But globs are already references (kinda) */
18255 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
18259 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
18260 && !scalar_mod_type(NULL, i)) {
18265 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
18269 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
18270 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
18271 str[n-1] = '_'; defgv = 0;
18275 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
18277 sv_setpvn(sv, str, n - 1);
18278 if (opnum) *opnum = i;
18283 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
18286 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
18287 newSVOP(OP_COREARGS,0,coreargssv);
18290 PERL_ARGS_ASSERT_CORESUB_OP;
18294 return op_append_elem(OP_LINESEQ,
18297 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
18304 o = newUNOP(OP_AVHVSWITCH,0,argop);
18305 o->op_private = opnum-OP_EACH;
18307 case OP_SELECT: /* which represents OP_SSELECT as well */
18312 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
18313 newSVOP(OP_CONST, 0, newSVuv(1))
18315 coresub_op(newSVuv((UV)OP_SSELECT), 0,
18317 coresub_op(coreargssv, 0, OP_SELECT)
18321 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
18323 return op_append_elem(
18326 opnum == OP_WANTARRAY || opnum == OP_RUNCV
18327 ? OPpOFFBYONE << 8 : 0)
18329 case OA_BASEOP_OR_UNOP:
18330 if (opnum == OP_ENTEREVAL) {
18331 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
18332 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
18334 else o = newUNOP(opnum,0,argop);
18335 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
18338 if (is_handle_constructor(o, 1))
18339 argop->op_private |= OPpCOREARGS_DEREF1;
18340 if (scalar_mod_type(NULL, opnum))
18341 argop->op_private |= OPpCOREARGS_SCALARMOD;
18345 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
18346 if (is_handle_constructor(o, 2))
18347 argop->op_private |= OPpCOREARGS_DEREF2;
18348 if (opnum == OP_SUBSTR) {
18349 o->op_private |= OPpMAYBE_LVSUB;
18358 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
18359 SV * const *new_const_svp)
18361 const char *hvname;
18362 bool is_const = !!CvCONST(old_cv);
18363 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
18365 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
18367 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
18369 /* They are 2 constant subroutines generated from
18370 the same constant. This probably means that
18371 they are really the "same" proxy subroutine
18372 instantiated in 2 places. Most likely this is
18373 when a constant is exported twice. Don't warn.
18376 (ckWARN(WARN_REDEFINE)
18378 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
18379 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
18380 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
18381 strEQ(hvname, "autouse"))
18385 && ckWARN_d(WARN_REDEFINE)
18386 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
18389 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
18391 ? "Constant subroutine %" SVf " redefined"
18392 : "Subroutine %" SVf " redefined",
18397 =for apidoc_section $hook
18399 These functions provide convenient and thread-safe means of manipulating
18406 =for apidoc wrap_op_checker
18408 Puts a C function into the chain of check functions for a specified op
18409 type. This is the preferred way to manipulate the L</PL_check> array.
18410 C<opcode> specifies which type of op is to be affected. C<new_checker>
18411 is a pointer to the C function that is to be added to that opcode's
18412 check chain, and C<old_checker_p> points to the storage location where a
18413 pointer to the next function in the chain will be stored. The value of
18414 C<new_checker> is written into the L</PL_check> array, while the value
18415 previously stored there is written to C<*old_checker_p>.
18417 L</PL_check> is global to an entire process, and a module wishing to
18418 hook op checking may find itself invoked more than once per process,
18419 typically in different threads. To handle that situation, this function
18420 is idempotent. The location C<*old_checker_p> must initially (once
18421 per process) contain a null pointer. A C variable of static duration
18422 (declared at file scope, typically also marked C<static> to give
18423 it internal linkage) will be implicitly initialised appropriately,
18424 if it does not have an explicit initialiser. This function will only
18425 actually modify the check chain if it finds C<*old_checker_p> to be null.
18426 This function is also thread safe on the small scale. It uses appropriate
18427 locking to avoid race conditions in accessing L</PL_check>.
18429 When this function is called, the function referenced by C<new_checker>
18430 must be ready to be called, except for C<*old_checker_p> being unfilled.
18431 In a threading situation, C<new_checker> may be called immediately,
18432 even before this function has returned. C<*old_checker_p> will always
18433 be appropriately set before C<new_checker> is called. If C<new_checker>
18434 decides not to do anything special with an op that it is given (which
18435 is the usual case for most uses of op check hooking), it must chain the
18436 check function referenced by C<*old_checker_p>.
18438 Taken all together, XS code to hook an op checker should typically look
18439 something like this:
18441 static Perl_check_t nxck_frob;
18442 static OP *myck_frob(pTHX_ OP *op) {
18444 op = nxck_frob(aTHX_ op);
18449 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
18451 If you want to influence compilation of calls to a specific subroutine,
18452 then use L</cv_set_call_checker_flags> rather than hooking checking of
18453 all C<entersub> ops.
18459 Perl_wrap_op_checker(pTHX_ Optype opcode,
18460 Perl_check_t new_checker, Perl_check_t *old_checker_p)
18463 PERL_UNUSED_CONTEXT;
18464 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
18465 if (*old_checker_p) return;
18466 OP_CHECK_MUTEX_LOCK;
18467 if (!*old_checker_p) {
18468 *old_checker_p = PL_check[opcode];
18469 PL_check[opcode] = new_checker;
18471 OP_CHECK_MUTEX_UNLOCK;
18476 /* Efficient sub that returns a constant scalar value. */
18478 const_sv_xsub(pTHX_ CV* cv)
18481 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
18482 PERL_UNUSED_ARG(items);
18492 const_av_xsub(pTHX_ CV* cv)
18495 AV * const av = MUTABLE_AV(XSANY.any_ptr);
18503 if (SvRMAGICAL(av))
18504 Perl_croak(aTHX_ "Magical list constants are not supported");
18505 if (GIMME_V != G_ARRAY) {
18507 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
18510 EXTEND(SP, AvFILLp(av)+1);
18511 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
18512 XSRETURN(AvFILLp(av)+1);
18515 /* Copy an existing cop->cop_warnings field.
18516 * If it's one of the standard addresses, just re-use the address.
18517 * This is the e implementation for the DUP_WARNINGS() macro
18521 Perl_dup_warnings(pTHX_ STRLEN* warnings)
18524 STRLEN *new_warnings;
18526 if (warnings == NULL || specialWARN(warnings))
18529 size = sizeof(*warnings) + *warnings;
18531 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
18532 Copy(warnings, new_warnings, size, char);
18533 return new_warnings;
18537 * ex: set ts=8 sts=4 sw=4 et: