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 Functions
794 =for apidoc alloccopstash
796 Available only under threaded builds, this function allocates an entry in
797 C<PL_stashpad> for the stash passed to it.
804 Perl_alloccopstash(pTHX_ HV *hv)
806 PADOFFSET off = 0, o = 1;
807 bool found_slot = FALSE;
809 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
811 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
813 for (; o < PL_stashpadmax; ++o) {
814 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
815 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
816 found_slot = TRUE, off = o;
819 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
820 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
821 off = PL_stashpadmax;
822 PL_stashpadmax += 10;
825 PL_stashpad[PL_stashpadix = off] = hv;
830 /* free the body of an op without examining its contents.
831 * Always use this rather than FreeOp directly */
834 S_op_destroy(pTHX_ OP *o)
844 Free an op and its children. Only use this when an op is no longer linked
851 Perl_op_free(pTHX_ OP *o)
856 bool went_up = FALSE; /* whether we reached the current node by
857 following the parent pointer from a child, and
858 so have already seen this node */
860 if (!o || o->op_type == OP_FREED)
863 if (o->op_private & OPpREFCOUNTED) {
864 /* if base of tree is refcounted, just decrement */
865 switch (o->op_type) {
875 refcnt = OpREFCNT_dec(o);
878 /* Need to find and remove any pattern match ops from
879 * the list we maintain for reset(). */
880 find_and_forget_pmops(o);
893 /* free child ops before ourself, (then free ourself "on the
896 if (!went_up && o->op_flags & OPf_KIDS) {
897 next_op = cUNOPo->op_first;
901 /* find the next node to visit, *then* free the current node
902 * (can't rely on o->op_* fields being valid after o has been
905 /* The next node to visit will be either the sibling, or the
906 * parent if no siblings left, or NULL if we've worked our way
907 * back up to the top node in the tree */
908 next_op = (o == top_op) ? NULL : o->op_sibparent;
909 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
911 /* Now process the current node */
913 /* Though ops may be freed twice, freeing the op after its slab is a
915 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
916 /* During the forced freeing of ops after compilation failure, kidops
917 may be freed before their parents. */
918 if (!o || o->op_type == OP_FREED)
923 /* an op should only ever acquire op_private flags that we know about.
924 * If this fails, you may need to fix something in regen/op_private.
925 * Don't bother testing if:
926 * * the op_ppaddr doesn't match the op; someone may have
927 * overridden the op and be doing strange things with it;
928 * * we've errored, as op flags are often left in an
929 * inconsistent state then. Note that an error when
930 * compiling the main program leaves PL_parser NULL, so
931 * we can't spot faults in the main code, only
932 * evaled/required code */
934 if ( o->op_ppaddr == PL_ppaddr[type]
936 && !PL_parser->error_count)
938 assert(!(o->op_private & ~PL_op_private_valid[type]));
943 /* Call the op_free hook if it has been set. Do it now so that it's called
944 * at the right time for refcounted ops, but still before all of the kids
949 type = (OPCODE)o->op_targ;
952 Slab_to_rw(OpSLAB(o));
954 /* COP* is not cleared by op_clear() so that we may track line
955 * numbers etc even after null() */
956 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
968 /* S_op_clear_gv(): free a GV attached to an OP */
972 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
974 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
978 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
979 || o->op_type == OP_MULTIDEREF)
982 ? ((GV*)PAD_SVl(*ixp)) : NULL;
984 ? (GV*)(*svp) : NULL;
986 /* It's possible during global destruction that the GV is freed
987 before the optree. Whilst the SvREFCNT_inc is happy to bump from
988 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
989 will trigger an assertion failure, because the entry to sv_clear
990 checks that the scalar is not already freed. A check of for
991 !SvIS_FREED(gv) turns out to be invalid, because during global
992 destruction the reference count can be forced down to zero
993 (with SVf_BREAK set). In which case raising to 1 and then
994 dropping to 0 triggers cleanup before it should happen. I
995 *think* that this might actually be a general, systematic,
996 weakness of the whole idea of SVf_BREAK, in that code *is*
997 allowed to raise and lower references during global destruction,
998 so any *valid* code that happens to do this during global
999 destruction might well trigger premature cleanup. */
1000 bool still_valid = gv && SvREFCNT(gv);
1003 SvREFCNT_inc_simple_void(gv);
1006 pad_swipe(*ixp, TRUE);
1014 int try_downgrade = SvREFCNT(gv) == 2;
1015 SvREFCNT_dec_NN(gv);
1017 gv_try_downgrade(gv);
1023 Perl_op_clear(pTHX_ OP *o)
1027 PERL_ARGS_ASSERT_OP_CLEAR;
1029 switch (o->op_type) {
1030 case OP_NULL: /* Was holding old type, if any. */
1033 case OP_ENTEREVAL: /* Was holding hints. */
1034 case OP_ARGDEFELEM: /* Was holding signature index. */
1038 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1045 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1047 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1050 case OP_METHOD_REDIR:
1051 case OP_METHOD_REDIR_SUPER:
1053 if (cMETHOPx(o)->op_rclass_targ) {
1054 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1055 cMETHOPx(o)->op_rclass_targ = 0;
1058 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1059 cMETHOPx(o)->op_rclass_sv = NULL;
1062 case OP_METHOD_NAMED:
1063 case OP_METHOD_SUPER:
1064 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1065 cMETHOPx(o)->op_u.op_meth_sv = NULL;
1068 pad_swipe(o->op_targ, 1);
1075 SvREFCNT_dec(cSVOPo->op_sv);
1076 cSVOPo->op_sv = NULL;
1079 Even if op_clear does a pad_free for the target of the op,
1080 pad_free doesn't actually remove the sv that exists in the pad;
1081 instead it lives on. This results in that it could be reused as
1082 a target later on when the pad was reallocated.
1085 pad_swipe(o->op_targ,1);
1095 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1100 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1101 && (o->op_private & OPpTRANS_USE_SVOP))
1104 if (cPADOPo->op_padix > 0) {
1105 pad_swipe(cPADOPo->op_padix, TRUE);
1106 cPADOPo->op_padix = 0;
1109 SvREFCNT_dec(cSVOPo->op_sv);
1110 cSVOPo->op_sv = NULL;
1114 PerlMemShared_free(cPVOPo->op_pv);
1115 cPVOPo->op_pv = NULL;
1119 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1123 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1124 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1126 if (o->op_private & OPpSPLIT_LEX)
1127 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1130 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1132 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1139 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1140 op_free(cPMOPo->op_code_list);
1141 cPMOPo->op_code_list = NULL;
1142 forget_pmop(cPMOPo);
1143 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1144 /* we use the same protection as the "SAFE" version of the PM_ macros
1145 * here since sv_clean_all might release some PMOPs
1146 * after PL_regex_padav has been cleared
1147 * and the clearing of PL_regex_padav needs to
1148 * happen before sv_clean_all
1151 if(PL_regex_pad) { /* We could be in destruction */
1152 const IV offset = (cPMOPo)->op_pmoffset;
1153 ReREFCNT_dec(PM_GETRE(cPMOPo));
1154 PL_regex_pad[offset] = &PL_sv_undef;
1155 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1159 ReREFCNT_dec(PM_GETRE(cPMOPo));
1160 PM_SETRE(cPMOPo, NULL);
1166 PerlMemShared_free(cUNOP_AUXo->op_aux);
1169 case OP_MULTICONCAT:
1171 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1172 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1173 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1174 * utf8 shared strings */
1175 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1176 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1178 PerlMemShared_free(p1);
1180 PerlMemShared_free(p2);
1181 PerlMemShared_free(aux);
1187 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1188 UV actions = items->uv;
1190 bool is_hash = FALSE;
1193 switch (actions & MDEREF_ACTION_MASK) {
1196 actions = (++items)->uv;
1199 case MDEREF_HV_padhv_helem:
1202 case MDEREF_AV_padav_aelem:
1203 pad_free((++items)->pad_offset);
1206 case MDEREF_HV_gvhv_helem:
1209 case MDEREF_AV_gvav_aelem:
1211 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1213 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1217 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1220 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1222 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1224 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1226 goto do_vivify_rv2xv_elem;
1228 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1231 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1232 pad_free((++items)->pad_offset);
1233 goto do_vivify_rv2xv_elem;
1235 case MDEREF_HV_pop_rv2hv_helem:
1236 case MDEREF_HV_vivify_rv2hv_helem:
1239 do_vivify_rv2xv_elem:
1240 case MDEREF_AV_pop_rv2av_aelem:
1241 case MDEREF_AV_vivify_rv2av_aelem:
1243 switch (actions & MDEREF_INDEX_MASK) {
1244 case MDEREF_INDEX_none:
1247 case MDEREF_INDEX_const:
1251 pad_swipe((++items)->pad_offset, 1);
1253 SvREFCNT_dec((++items)->sv);
1259 case MDEREF_INDEX_padsv:
1260 pad_free((++items)->pad_offset);
1262 case MDEREF_INDEX_gvsv:
1264 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1266 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1271 if (actions & MDEREF_FLAG_last)
1284 actions >>= MDEREF_SHIFT;
1287 /* start of malloc is at op_aux[-1], where the length is
1289 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1294 if (o->op_targ > 0) {
1295 pad_free(o->op_targ);
1301 S_cop_free(pTHX_ COP* cop)
1303 PERL_ARGS_ASSERT_COP_FREE;
1306 if (! specialWARN(cop->cop_warnings))
1307 PerlMemShared_free(cop->cop_warnings);
1308 cophh_free(CopHINTHASH_get(cop));
1309 if (PL_curcop == cop)
1314 S_forget_pmop(pTHX_ PMOP *const o)
1316 HV * const pmstash = PmopSTASH(o);
1318 PERL_ARGS_ASSERT_FORGET_PMOP;
1320 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1321 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1323 PMOP **const array = (PMOP**) mg->mg_ptr;
1324 U32 count = mg->mg_len / sizeof(PMOP**);
1328 if (array[i] == o) {
1329 /* Found it. Move the entry at the end to overwrite it. */
1330 array[i] = array[--count];
1331 mg->mg_len = count * sizeof(PMOP**);
1332 /* Could realloc smaller at this point always, but probably
1333 not worth it. Probably worth free()ing if we're the
1336 Safefree(mg->mg_ptr);
1350 S_find_and_forget_pmops(pTHX_ OP *o)
1354 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1357 switch (o->op_type) {
1362 forget_pmop((PMOP*)o);
1365 if (o->op_flags & OPf_KIDS) {
1366 o = cUNOPo->op_first;
1372 return; /* at top; no parents/siblings to try */
1373 if (OpHAS_SIBLING(o)) {
1374 o = o->op_sibparent; /* process next sibling */
1377 o = o->op_sibparent; /*try parent's next sibling */
1386 Neutralizes an op when it is no longer needed, but is still linked to from
1393 Perl_op_null(pTHX_ OP *o)
1396 PERL_ARGS_ASSERT_OP_NULL;
1398 if (o->op_type == OP_NULL)
1401 o->op_targ = o->op_type;
1402 OpTYPE_set(o, OP_NULL);
1406 Perl_op_refcnt_lock(pTHX)
1407 PERL_TSA_ACQUIRE(PL_op_mutex)
1411 PERL_UNUSED_CONTEXT;
1416 Perl_op_refcnt_unlock(pTHX)
1417 PERL_TSA_RELEASE(PL_op_mutex)
1421 PERL_UNUSED_CONTEXT;
1427 =for apidoc op_sibling_splice
1429 A general function for editing the structure of an existing chain of
1430 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1431 you to delete zero or more sequential nodes, replacing them with zero or
1432 more different nodes. Performs the necessary op_first/op_last
1433 housekeeping on the parent node and op_sibling manipulation on the
1434 children. The last deleted node will be marked as the last node by
1435 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1437 Note that op_next is not manipulated, and nodes are not freed; that is the
1438 responsibility of the caller. It also won't create a new list op for an
1439 empty list etc; use higher-level functions like op_append_elem() for that.
1441 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1442 the splicing doesn't affect the first or last op in the chain.
1444 C<start> is the node preceding the first node to be spliced. Node(s)
1445 following it will be deleted, and ops will be inserted after it. If it is
1446 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1449 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1450 If -1 or greater than or equal to the number of remaining kids, all
1451 remaining kids are deleted.
1453 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1454 If C<NULL>, no nodes are inserted.
1456 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1461 action before after returns
1462 ------ ----- ----- -------
1465 splice(P, A, 2, X-Y-Z) | | B-C
1469 splice(P, NULL, 1, X-Y) | | A
1473 splice(P, NULL, 3, NULL) | | A-B-C
1477 splice(P, B, 0, X-Y) | | NULL
1481 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1482 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1488 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1492 OP *last_del = NULL;
1493 OP *last_ins = NULL;
1496 first = OpSIBLING(start);
1500 first = cLISTOPx(parent)->op_first;
1502 assert(del_count >= -1);
1504 if (del_count && first) {
1506 while (--del_count && OpHAS_SIBLING(last_del))
1507 last_del = OpSIBLING(last_del);
1508 rest = OpSIBLING(last_del);
1509 OpLASTSIB_set(last_del, NULL);
1516 while (OpHAS_SIBLING(last_ins))
1517 last_ins = OpSIBLING(last_ins);
1518 OpMAYBESIB_set(last_ins, rest, NULL);
1524 OpMAYBESIB_set(start, insert, NULL);
1528 cLISTOPx(parent)->op_first = insert;
1530 parent->op_flags |= OPf_KIDS;
1532 parent->op_flags &= ~OPf_KIDS;
1536 /* update op_last etc */
1543 /* ought to use OP_CLASS(parent) here, but that can't handle
1544 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1546 type = parent->op_type;
1547 if (type == OP_CUSTOM) {
1549 type = XopENTRYCUSTOM(parent, xop_class);
1552 if (type == OP_NULL)
1553 type = parent->op_targ;
1554 type = PL_opargs[type] & OA_CLASS_MASK;
1557 lastop = last_ins ? last_ins : start ? start : NULL;
1558 if ( type == OA_BINOP
1559 || type == OA_LISTOP
1563 cLISTOPx(parent)->op_last = lastop;
1566 OpLASTSIB_set(lastop, parent);
1568 return last_del ? first : NULL;
1571 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1575 =for apidoc op_parent
1577 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1583 Perl_op_parent(OP *o)
1585 PERL_ARGS_ASSERT_OP_PARENT;
1586 while (OpHAS_SIBLING(o))
1588 return o->op_sibparent;
1591 /* replace the sibling following start with a new UNOP, which becomes
1592 * the parent of the original sibling; e.g.
1594 * op_sibling_newUNOP(P, A, unop-args...)
1602 * where U is the new UNOP.
1604 * parent and start args are the same as for op_sibling_splice();
1605 * type and flags args are as newUNOP().
1607 * Returns the new UNOP.
1611 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1615 kid = op_sibling_splice(parent, start, 1, NULL);
1616 newop = newUNOP(type, flags, kid);
1617 op_sibling_splice(parent, start, 0, newop);
1622 /* lowest-level newLOGOP-style function - just allocates and populates
1623 * the struct. Higher-level stuff should be done by S_new_logop() /
1624 * newLOGOP(). This function exists mainly to avoid op_first assignment
1625 * being spread throughout this file.
1629 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1633 NewOp(1101, logop, 1, LOGOP);
1634 OpTYPE_set(logop, type);
1635 logop->op_first = first;
1636 logop->op_other = other;
1638 logop->op_flags = OPf_KIDS;
1639 while (kid && OpHAS_SIBLING(kid))
1640 kid = OpSIBLING(kid);
1642 OpLASTSIB_set(kid, (OP*)logop);
1647 /* Contextualizers */
1650 =for apidoc op_contextualize
1652 Applies a syntactic context to an op tree representing an expression.
1653 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1654 or C<G_VOID> to specify the context to apply. The modified op tree
1661 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1663 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1665 case G_SCALAR: return scalar(o);
1666 case G_ARRAY: return list(o);
1667 case G_VOID: return scalarvoid(o);
1669 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1676 =for apidoc op_linklist
1677 This function is the implementation of the L</LINKLIST> macro. It should
1678 not be called directly.
1685 Perl_op_linklist(pTHX_ OP *o)
1692 PERL_ARGS_ASSERT_OP_LINKLIST;
1695 /* Descend down the tree looking for any unprocessed subtrees to
1698 if (o->op_flags & OPf_KIDS) {
1699 o = cUNOPo->op_first;
1702 o->op_next = o; /* leaf node; link to self initially */
1705 /* if we're at the top level, there either weren't any children
1706 * to process, or we've worked our way back to the top. */
1710 /* o is now processed. Next, process any sibling subtrees */
1712 if (OpHAS_SIBLING(o)) {
1717 /* Done all the subtrees at this level. Go back up a level and
1718 * link the parent in with all its (processed) children.
1721 o = o->op_sibparent;
1722 assert(!o->op_next);
1723 prevp = &(o->op_next);
1724 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1726 *prevp = kid->op_next;
1727 prevp = &(kid->op_next);
1728 kid = OpSIBLING(kid);
1736 S_scalarkids(pTHX_ OP *o)
1738 if (o && o->op_flags & OPf_KIDS) {
1740 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1747 S_scalarboolean(pTHX_ OP *o)
1749 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1751 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1752 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1753 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1754 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1755 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1756 if (ckWARN(WARN_SYNTAX)) {
1757 const line_t oldline = CopLINE(PL_curcop);
1759 if (PL_parser && PL_parser->copline != NOLINE) {
1760 /* This ensures that warnings are reported at the first line
1761 of the conditional, not the last. */
1762 CopLINE_set(PL_curcop, PL_parser->copline);
1764 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1765 CopLINE_set(PL_curcop, oldline);
1772 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1775 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1776 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1778 const char funny = o->op_type == OP_PADAV
1779 || o->op_type == OP_RV2AV ? '@' : '%';
1780 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1782 if (cUNOPo->op_first->op_type != OP_GV
1783 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1785 return varname(gv, funny, 0, NULL, 0, subscript_type);
1788 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1793 S_op_varname(pTHX_ const OP *o)
1795 return S_op_varname_subscript(aTHX_ o, 1);
1799 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1800 { /* or not so pretty :-) */
1801 if (o->op_type == OP_CONST) {
1803 if (SvPOK(*retsv)) {
1805 *retsv = sv_newmortal();
1806 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1807 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1809 else if (!SvOK(*retsv))
1812 else *retpv = "...";
1816 S_scalar_slice_warning(pTHX_ const OP *o)
1819 const bool h = o->op_type == OP_HSLICE
1820 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1826 SV *keysv = NULL; /* just to silence compiler warnings */
1827 const char *key = NULL;
1829 if (!(o->op_private & OPpSLICEWARNING))
1831 if (PL_parser && PL_parser->error_count)
1832 /* This warning can be nonsensical when there is a syntax error. */
1835 kid = cLISTOPo->op_first;
1836 kid = OpSIBLING(kid); /* get past pushmark */
1837 /* weed out false positives: any ops that can return lists */
1838 switch (kid->op_type) {
1864 /* Don't warn if we have a nulled list either. */
1865 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1868 assert(OpSIBLING(kid));
1869 name = S_op_varname(aTHX_ OpSIBLING(kid));
1870 if (!name) /* XS module fiddling with the op tree */
1872 S_op_pretty(aTHX_ kid, &keysv, &key);
1873 assert(SvPOK(name));
1874 sv_chop(name,SvPVX(name)+1);
1876 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1877 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1878 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1880 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1881 lbrack, key, rbrack);
1883 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1884 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1885 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1887 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1888 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1893 /* apply scalar context to the o subtree */
1896 Perl_scalar(pTHX_ OP *o)
1901 OP *next_kid = NULL; /* what op (if any) to process next */
1904 /* assumes no premature commitment */
1905 if (!o || (PL_parser && PL_parser->error_count)
1906 || (o->op_flags & OPf_WANT)
1907 || o->op_type == OP_RETURN)
1912 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1914 switch (o->op_type) {
1916 scalar(cBINOPo->op_first);
1917 /* convert what initially looked like a list repeat into a
1918 * scalar repeat, e.g. $s = (1) x $n
1920 if (o->op_private & OPpREPEAT_DOLIST) {
1921 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1922 assert(kid->op_type == OP_PUSHMARK);
1923 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1924 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1925 o->op_private &=~ OPpREPEAT_DOLIST;
1933 /* impose scalar context on everything except the condition */
1934 next_kid = OpSIBLING(cUNOPo->op_first);
1938 if (o->op_flags & OPf_KIDS)
1939 next_kid = cUNOPo->op_first; /* do all kids */
1942 /* the children of these ops are usually a list of statements,
1943 * except the leaves, whose first child is a corresponding enter
1948 kid = cLISTOPo->op_first;
1952 kid = cLISTOPo->op_first;
1954 kid = OpSIBLING(kid);
1957 OP *sib = OpSIBLING(kid);
1958 /* Apply void context to all kids except the last, which
1959 * is scalar (ignoring a trailing ex-nextstate in determining
1960 * if it's the last kid). E.g.
1961 * $scalar = do { void; void; scalar }
1962 * Except that 'when's are always scalar, e.g.
1963 * $scalar = do { given(..) {
1964 * when (..) { scalar }
1965 * when (..) { scalar }
1970 || ( !OpHAS_SIBLING(sib)
1971 && sib->op_type == OP_NULL
1972 && ( sib->op_targ == OP_NEXTSTATE
1973 || sib->op_targ == OP_DBSTATE )
1977 /* tail call optimise calling scalar() on the last kid */
1981 else if (kid->op_type == OP_LEAVEWHEN)
1987 NOT_REACHED; /* NOTREACHED */
1991 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1997 /* Warn about scalar context */
1998 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1999 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
2002 const char *key = NULL;
2004 /* This warning can be nonsensical when there is a syntax error. */
2005 if (PL_parser && PL_parser->error_count)
2008 if (!ckWARN(WARN_SYNTAX)) break;
2010 kid = cLISTOPo->op_first;
2011 kid = OpSIBLING(kid); /* get past pushmark */
2012 assert(OpSIBLING(kid));
2013 name = S_op_varname(aTHX_ OpSIBLING(kid));
2014 if (!name) /* XS module fiddling with the op tree */
2016 S_op_pretty(aTHX_ kid, &keysv, &key);
2017 assert(SvPOK(name));
2018 sv_chop(name,SvPVX(name)+1);
2020 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2021 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2022 "%%%" SVf "%c%s%c in scalar context better written "
2023 "as $%" SVf "%c%s%c",
2024 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
2025 lbrack, key, rbrack);
2027 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2028 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2029 "%%%" SVf "%c%" SVf "%c in scalar context better "
2030 "written as $%" SVf "%c%" SVf "%c",
2031 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
2032 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2036 /* If next_kid is set, someone in the code above wanted us to process
2037 * that kid and all its remaining siblings. Otherwise, work our way
2038 * back up the tree */
2042 return top_op; /* at top; no parents/siblings to try */
2043 if (OpHAS_SIBLING(o))
2044 next_kid = o->op_sibparent;
2046 o = o->op_sibparent; /*try parent's next sibling */
2047 switch (o->op_type) {
2053 /* should really restore PL_curcop to its old value, but
2054 * setting it to PL_compiling is better than do nothing */
2055 PL_curcop = &PL_compiling;
2064 /* apply void context to the optree arg */
2067 Perl_scalarvoid(pTHX_ OP *arg)
2073 PERL_ARGS_ASSERT_SCALARVOID;
2077 SV *useless_sv = NULL;
2078 const char* useless = NULL;
2079 OP * next_kid = NULL;
2081 if (o->op_type == OP_NEXTSTATE
2082 || o->op_type == OP_DBSTATE
2083 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2084 || o->op_targ == OP_DBSTATE)))
2085 PL_curcop = (COP*)o; /* for warning below */
2087 /* assumes no premature commitment */
2088 want = o->op_flags & OPf_WANT;
2089 if ((want && want != OPf_WANT_SCALAR)
2090 || (PL_parser && PL_parser->error_count)
2091 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2096 if ((o->op_private & OPpTARGET_MY)
2097 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2099 /* newASSIGNOP has already applied scalar context, which we
2100 leave, as if this op is inside SASSIGN. */
2104 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2106 switch (o->op_type) {
2108 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2112 if (o->op_flags & OPf_STACKED)
2114 if (o->op_type == OP_REPEAT)
2115 scalar(cBINOPo->op_first);
2118 if ((o->op_flags & OPf_STACKED) &&
2119 !(o->op_private & OPpCONCAT_NESTED))
2123 if (o->op_private == 4)
2158 case OP_GETSOCKNAME:
2159 case OP_GETPEERNAME:
2164 case OP_GETPRIORITY:
2189 useless = OP_DESC(o);
2199 case OP_AELEMFAST_LEX:
2203 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2204 /* Otherwise it's "Useless use of grep iterator" */
2205 useless = OP_DESC(o);
2209 if (!(o->op_private & OPpSPLIT_ASSIGN))
2210 useless = OP_DESC(o);
2214 kid = cUNOPo->op_first;
2215 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2216 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2219 useless = "negative pattern binding (!~)";
2223 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2224 useless = "non-destructive substitution (s///r)";
2228 useless = "non-destructive transliteration (tr///r)";
2235 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2236 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2237 useless = "a variable";
2242 if (cSVOPo->op_private & OPpCONST_STRICT)
2243 no_bareword_allowed(o);
2245 if (ckWARN(WARN_VOID)) {
2247 /* don't warn on optimised away booleans, eg
2248 * use constant Foo, 5; Foo || print; */
2249 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2251 /* the constants 0 and 1 are permitted as they are
2252 conventionally used as dummies in constructs like
2253 1 while some_condition_with_side_effects; */
2254 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2256 else if (SvPOK(sv)) {
2257 SV * const dsv = newSVpvs("");
2259 = Perl_newSVpvf(aTHX_
2261 pv_pretty(dsv, SvPVX_const(sv),
2262 SvCUR(sv), 32, NULL, NULL,
2264 | PERL_PV_ESCAPE_NOCLEAR
2265 | PERL_PV_ESCAPE_UNI_DETECT));
2266 SvREFCNT_dec_NN(dsv);
2268 else if (SvOK(sv)) {
2269 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2272 useless = "a constant (undef)";
2275 op_null(o); /* don't execute or even remember it */
2279 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2283 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2287 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2291 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2296 UNOP *refgen, *rv2cv;
2299 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2302 rv2gv = ((BINOP *)o)->op_last;
2303 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2306 refgen = (UNOP *)((BINOP *)o)->op_first;
2308 if (!refgen || (refgen->op_type != OP_REFGEN
2309 && refgen->op_type != OP_SREFGEN))
2312 exlist = (LISTOP *)refgen->op_first;
2313 if (!exlist || exlist->op_type != OP_NULL
2314 || exlist->op_targ != OP_LIST)
2317 if (exlist->op_first->op_type != OP_PUSHMARK
2318 && exlist->op_first != exlist->op_last)
2321 rv2cv = (UNOP*)exlist->op_last;
2323 if (rv2cv->op_type != OP_RV2CV)
2326 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2327 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2328 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2330 o->op_private |= OPpASSIGN_CV_TO_GV;
2331 rv2gv->op_private |= OPpDONT_INIT_GV;
2332 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2344 kid = cLOGOPo->op_first;
2345 if (kid->op_type == OP_NOT
2346 && (kid->op_flags & OPf_KIDS)) {
2347 if (o->op_type == OP_AND) {
2348 OpTYPE_set(o, OP_OR);
2350 OpTYPE_set(o, OP_AND);
2360 next_kid = OpSIBLING(cUNOPo->op_first);
2364 if (o->op_flags & OPf_STACKED)
2371 if (!(o->op_flags & OPf_KIDS))
2382 next_kid = cLISTOPo->op_first;
2385 /* If the first kid after pushmark is something that the padrange
2386 optimisation would reject, then null the list and the pushmark.
2388 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2389 && ( !(kid = OpSIBLING(kid))
2390 || ( kid->op_type != OP_PADSV
2391 && kid->op_type != OP_PADAV
2392 && kid->op_type != OP_PADHV)
2393 || kid->op_private & ~OPpLVAL_INTRO
2394 || !(kid = OpSIBLING(kid))
2395 || ( kid->op_type != OP_PADSV
2396 && kid->op_type != OP_PADAV
2397 && kid->op_type != OP_PADHV)
2398 || kid->op_private & ~OPpLVAL_INTRO)
2400 op_null(cUNOPo->op_first); /* NULL the pushmark */
2401 op_null(o); /* NULL the list */
2413 /* mortalise it, in case warnings are fatal. */
2414 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2415 "Useless use of %" SVf " in void context",
2416 SVfARG(sv_2mortal(useless_sv)));
2419 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2420 "Useless use of %s in void context",
2425 /* if a kid hasn't been nominated to process, continue with the
2426 * next sibling, or if no siblings left, go back to the parent's
2427 * siblings and so on
2431 return arg; /* at top; no parents/siblings to try */
2432 if (OpHAS_SIBLING(o))
2433 next_kid = o->op_sibparent;
2435 o = o->op_sibparent; /*try parent's next sibling */
2445 S_listkids(pTHX_ OP *o)
2447 if (o && o->op_flags & OPf_KIDS) {
2449 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2456 /* apply list context to the o subtree */
2459 Perl_list(pTHX_ OP *o)
2464 OP *next_kid = NULL; /* what op (if any) to process next */
2468 /* assumes no premature commitment */
2469 if (!o || (o->op_flags & OPf_WANT)
2470 || (PL_parser && PL_parser->error_count)
2471 || o->op_type == OP_RETURN)
2476 if ((o->op_private & OPpTARGET_MY)
2477 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2479 goto do_next; /* As if inside SASSIGN */
2482 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2484 switch (o->op_type) {
2486 if (o->op_private & OPpREPEAT_DOLIST
2487 && !(o->op_flags & OPf_STACKED))
2489 list(cBINOPo->op_first);
2490 kid = cBINOPo->op_last;
2491 /* optimise away (.....) x 1 */
2492 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2493 && SvIVX(kSVOP_sv) == 1)
2495 op_null(o); /* repeat */
2496 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2498 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2506 /* impose list context on everything except the condition */
2507 next_kid = OpSIBLING(cUNOPo->op_first);
2511 if (!(o->op_flags & OPf_KIDS))
2513 /* possibly flatten 1..10 into a constant array */
2514 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2515 list(cBINOPo->op_first);
2516 gen_constant_list(o);
2519 next_kid = cUNOPo->op_first; /* do all kids */
2523 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2524 op_null(cUNOPo->op_first); /* NULL the pushmark */
2525 op_null(o); /* NULL the list */
2527 if (o->op_flags & OPf_KIDS)
2528 next_kid = cUNOPo->op_first; /* do all kids */
2531 /* the children of these ops are usually a list of statements,
2532 * except the leaves, whose first child is a corresponding enter
2536 kid = cLISTOPo->op_first;
2540 kid = cLISTOPo->op_first;
2542 kid = OpSIBLING(kid);
2545 OP *sib = OpSIBLING(kid);
2546 /* Apply void context to all kids except the last, which
2548 * @a = do { void; void; list }
2549 * Except that 'when's are always list context, e.g.
2550 * @a = do { given(..) {
2551 * when (..) { list }
2552 * when (..) { list }
2557 /* tail call optimise calling list() on the last kid */
2561 else if (kid->op_type == OP_LEAVEWHEN)
2567 NOT_REACHED; /* NOTREACHED */
2572 /* If next_kid is set, someone in the code above wanted us to process
2573 * that kid and all its remaining siblings. Otherwise, work our way
2574 * back up the tree */
2578 return top_op; /* at top; no parents/siblings to try */
2579 if (OpHAS_SIBLING(o))
2580 next_kid = o->op_sibparent;
2582 o = o->op_sibparent; /*try parent's next sibling */
2583 switch (o->op_type) {
2589 /* should really restore PL_curcop to its old value, but
2590 * setting it to PL_compiling is better than do nothing */
2591 PL_curcop = &PL_compiling;
2603 S_scalarseq(pTHX_ OP *o)
2606 const OPCODE type = o->op_type;
2608 if (type == OP_LINESEQ || type == OP_SCOPE ||
2609 type == OP_LEAVE || type == OP_LEAVETRY)
2612 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2613 if ((sib = OpSIBLING(kid))
2614 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2615 || ( sib->op_targ != OP_NEXTSTATE
2616 && sib->op_targ != OP_DBSTATE )))
2621 PL_curcop = &PL_compiling;
2623 o->op_flags &= ~OPf_PARENS;
2624 if (PL_hints & HINT_BLOCK_SCOPE)
2625 o->op_flags |= OPf_PARENS;
2628 o = newOP(OP_STUB, 0);
2633 S_modkids(pTHX_ OP *o, I32 type)
2635 if (o && o->op_flags & OPf_KIDS) {
2637 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2638 op_lvalue(kid, type);
2644 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2645 * const fields. Also, convert CONST keys to HEK-in-SVs.
2646 * rop is the op that retrieves the hash;
2647 * key_op is the first key
2648 * real if false, only check (and possibly croak); don't update op
2652 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2658 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2660 if (rop->op_first->op_type == OP_PADSV)
2661 /* @$hash{qw(keys here)} */
2662 rop = (UNOP*)rop->op_first;
2664 /* @{$hash}{qw(keys here)} */
2665 if (rop->op_first->op_type == OP_SCOPE
2666 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2668 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2675 lexname = NULL; /* just to silence compiler warnings */
2676 fields = NULL; /* just to silence compiler warnings */
2680 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2681 SvPAD_TYPED(lexname))
2682 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2683 && isGV(*fields) && GvHV(*fields);
2685 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2687 if (key_op->op_type != OP_CONST)
2689 svp = cSVOPx_svp(key_op);
2691 /* make sure it's not a bareword under strict subs */
2692 if (key_op->op_private & OPpCONST_BARE &&
2693 key_op->op_private & OPpCONST_STRICT)
2695 no_bareword_allowed((OP*)key_op);
2698 /* Make the CONST have a shared SV */
2699 if ( !SvIsCOW_shared_hash(sv = *svp)
2700 && SvTYPE(sv) < SVt_PVMG
2706 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2707 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2708 SvREFCNT_dec_NN(sv);
2713 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2715 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2716 "in variable %" PNf " of type %" HEKf,
2717 SVfARG(*svp), PNfARG(lexname),
2718 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2723 /* info returned by S_sprintf_is_multiconcatable() */
2725 struct sprintf_ismc_info {
2726 SSize_t nargs; /* num of args to sprintf (not including the format) */
2727 char *start; /* start of raw format string */
2728 char *end; /* bytes after end of raw format string */
2729 STRLEN total_len; /* total length (in bytes) of format string, not
2730 including '%s' and half of '%%' */
2731 STRLEN variant; /* number of bytes by which total_len_p would grow
2732 if upgraded to utf8 */
2733 bool utf8; /* whether the format is utf8 */
2737 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2738 * i.e. its format argument is a const string with only '%s' and '%%'
2739 * formats, and the number of args is known, e.g.
2740 * sprintf "a=%s f=%s", $a[0], scalar(f());
2742 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2744 * If successful, the sprintf_ismc_info struct pointed to by info will be
2749 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2751 OP *pm, *constop, *kid;
2754 SSize_t nargs, nformats;
2755 STRLEN cur, total_len, variant;
2758 /* if sprintf's behaviour changes, die here so that someone
2759 * can decide whether to enhance this function or skip optimising
2760 * under those new circumstances */
2761 assert(!(o->op_flags & OPf_STACKED));
2762 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2763 assert(!(o->op_private & ~OPpARG4_MASK));
2765 pm = cUNOPo->op_first;
2766 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2768 constop = OpSIBLING(pm);
2769 if (!constop || constop->op_type != OP_CONST)
2771 sv = cSVOPx_sv(constop);
2772 if (SvMAGICAL(sv) || !SvPOK(sv))
2778 /* Scan format for %% and %s and work out how many %s there are.
2779 * Abandon if other format types are found.
2786 for (p = s; p < e; p++) {
2789 if (!UTF8_IS_INVARIANT(*p))
2795 return FALSE; /* lone % at end gives "Invalid conversion" */
2804 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2807 utf8 = cBOOL(SvUTF8(sv));
2811 /* scan args; they must all be in scalar cxt */
2814 kid = OpSIBLING(constop);
2817 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2820 kid = OpSIBLING(kid);
2823 if (nargs != nformats)
2824 return FALSE; /* e.g. sprintf("%s%s", $a); */
2827 info->nargs = nargs;
2830 info->total_len = total_len;
2831 info->variant = variant;
2839 /* S_maybe_multiconcat():
2841 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2842 * convert it (and its children) into an OP_MULTICONCAT. See the code
2843 * comments just before pp_multiconcat() for the full details of what
2844 * OP_MULTICONCAT supports.
2846 * Basically we're looking for an optree with a chain of OP_CONCATS down
2847 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2848 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2856 * STRINGIFY -- PADSV[$x]
2859 * ex-PUSHMARK -- CONCAT/S
2861 * CONCAT/S -- PADSV[$d]
2863 * CONCAT -- CONST["-"]
2865 * PADSV[$a] -- PADSV[$b]
2867 * Note that at this stage the OP_SASSIGN may have already been optimised
2868 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2872 S_maybe_multiconcat(pTHX_ OP *o)
2874 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2875 OP *topop; /* the top-most op in the concat tree (often equals o,
2876 unless there are assign/stringify ops above it */
2877 OP *parentop; /* the parent op of topop (or itself if no parent) */
2878 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2879 OP *targetop; /* the op corresponding to target=... or target.=... */
2880 OP *stringop; /* the OP_STRINGIFY op, if any */
2881 OP *nextop; /* used for recreating the op_next chain without consts */
2882 OP *kid; /* general-purpose op pointer */
2884 UNOP_AUX_item *lenp;
2885 char *const_str, *p;
2886 struct sprintf_ismc_info sprintf_info;
2888 /* store info about each arg in args[];
2889 * toparg is the highest used slot; argp is a general
2890 * pointer to args[] slots */
2892 void *p; /* initially points to const sv (or null for op);
2893 later, set to SvPV(constsv), with ... */
2894 STRLEN len; /* ... len set to SvPV(..., len) */
2895 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2899 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2902 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2903 the last-processed arg will the LHS of one,
2904 as args are processed in reverse order */
2905 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2906 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2907 U8 flags = 0; /* what will become the op_flags and ... */
2908 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2909 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2910 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2911 bool prev_was_const = FALSE; /* previous arg was a const */
2913 /* -----------------------------------------------------------------
2916 * Examine the optree non-destructively to determine whether it's
2917 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2918 * information about the optree in args[].
2928 assert( o->op_type == OP_SASSIGN
2929 || o->op_type == OP_CONCAT
2930 || o->op_type == OP_SPRINTF
2931 || o->op_type == OP_STRINGIFY);
2933 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2935 /* first see if, at the top of the tree, there is an assign,
2936 * append and/or stringify */
2938 if (topop->op_type == OP_SASSIGN) {
2940 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2942 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2944 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2947 topop = cBINOPo->op_first;
2948 targetop = OpSIBLING(topop);
2949 if (!targetop) /* probably some sort of syntax error */
2952 /* don't optimise away assign in 'local $foo = ....' */
2953 if ( (targetop->op_private & OPpLVAL_INTRO)
2954 /* these are the common ops which do 'local', but
2956 && ( targetop->op_type == OP_GVSV
2957 || targetop->op_type == OP_RV2SV
2958 || targetop->op_type == OP_AELEM
2959 || targetop->op_type == OP_HELEM
2964 else if ( topop->op_type == OP_CONCAT
2965 && (topop->op_flags & OPf_STACKED)
2966 && (!(topop->op_private & OPpCONCAT_NESTED))
2971 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2972 * decide what to do about it */
2973 assert(!(o->op_private & OPpTARGET_MY));
2975 /* barf on unknown flags */
2976 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2977 private_flags |= OPpMULTICONCAT_APPEND;
2978 targetop = cBINOPo->op_first;
2980 topop = OpSIBLING(targetop);
2982 /* $x .= <FOO> gets optimised to rcatline instead */
2983 if (topop->op_type == OP_READLINE)
2988 /* Can targetop (the LHS) if it's a padsv, be optimised
2989 * away and use OPpTARGET_MY instead?
2991 if ( (targetop->op_type == OP_PADSV)
2992 && !(targetop->op_private & OPpDEREF)
2993 && !(targetop->op_private & OPpPAD_STATE)
2994 /* we don't support 'my $x .= ...' */
2995 && ( o->op_type == OP_SASSIGN
2996 || !(targetop->op_private & OPpLVAL_INTRO))
3001 if (topop->op_type == OP_STRINGIFY) {
3002 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
3006 /* barf on unknown flags */
3007 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
3009 if ((topop->op_private & OPpTARGET_MY)) {
3010 if (o->op_type == OP_SASSIGN)
3011 return; /* can't have two assigns */
3015 private_flags |= OPpMULTICONCAT_STRINGIFY;
3017 topop = cBINOPx(topop)->op_first;
3018 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
3019 topop = OpSIBLING(topop);
3022 if (topop->op_type == OP_SPRINTF) {
3023 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
3025 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
3026 nargs = sprintf_info.nargs;
3027 total_len = sprintf_info.total_len;
3028 variant = sprintf_info.variant;
3029 utf8 = sprintf_info.utf8;
3031 private_flags |= OPpMULTICONCAT_FAKE;
3033 /* we have an sprintf op rather than a concat optree.
3034 * Skip most of the code below which is associated with
3035 * processing that optree. We also skip phase 2, determining
3036 * whether its cost effective to optimise, since for sprintf,
3037 * multiconcat is *always* faster */
3040 /* note that even if the sprintf itself isn't multiconcatable,
3041 * the expression as a whole may be, e.g. in
3042 * $x .= sprintf("%d",...)
3043 * the sprintf op will be left as-is, but the concat/S op may
3044 * be upgraded to multiconcat
3047 else if (topop->op_type == OP_CONCAT) {
3048 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
3051 if ((topop->op_private & OPpTARGET_MY)) {
3052 if (o->op_type == OP_SASSIGN || targmyop)
3053 return; /* can't have two assigns */
3058 /* Is it safe to convert a sassign/stringify/concat op into
3060 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
3061 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
3062 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3063 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
3064 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
3065 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3066 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
3067 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3069 /* Now scan the down the tree looking for a series of
3070 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3071 * stacked). For example this tree:
3076 * CONCAT/STACKED -- EXPR5
3078 * CONCAT/STACKED -- EXPR4
3084 * corresponds to an expression like
3086 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3088 * Record info about each EXPR in args[]: in particular, whether it is
3089 * a stringifiable OP_CONST and if so what the const sv is.
3091 * The reason why the last concat can't be STACKED is the difference
3094 * ((($a .= $a) .= $a) .= $a) .= $a
3097 * $a . $a . $a . $a . $a
3099 * The main difference between the optrees for those two constructs
3100 * is the presence of the last STACKED. As well as modifying $a,
3101 * the former sees the changed $a between each concat, so if $s is
3102 * initially 'a', the first returns 'a' x 16, while the latter returns
3103 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3113 if ( kid->op_type == OP_CONCAT
3117 k1 = cUNOPx(kid)->op_first;
3119 /* shouldn't happen except maybe after compile err? */
3123 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3124 if (kid->op_private & OPpTARGET_MY)
3127 stacked_last = (kid->op_flags & OPf_STACKED);
3139 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3140 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3142 /* At least two spare slots are needed to decompose both
3143 * concat args. If there are no slots left, continue to
3144 * examine the rest of the optree, but don't push new values
3145 * on args[]. If the optree as a whole is legal for conversion
3146 * (in particular that the last concat isn't STACKED), then
3147 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3148 * can be converted into an OP_MULTICONCAT now, with the first
3149 * child of that op being the remainder of the optree -
3150 * which may itself later be converted to a multiconcat op
3154 /* the last arg is the rest of the optree */
3159 else if ( argop->op_type == OP_CONST
3160 && ((sv = cSVOPx_sv(argop)))
3161 /* defer stringification until runtime of 'constant'
3162 * things that might stringify variantly, e.g. the radix
3163 * point of NVs, or overloaded RVs */
3164 && (SvPOK(sv) || SvIOK(sv))
3165 && (!SvGMAGICAL(sv))
3167 if (argop->op_private & OPpCONST_STRICT)
3168 no_bareword_allowed(argop);
3170 utf8 |= cBOOL(SvUTF8(sv));
3173 /* this const may be demoted back to a plain arg later;
3174 * make sure we have enough arg slots left */
3176 prev_was_const = !prev_was_const;
3181 prev_was_const = FALSE;
3191 return; /* we don't support ((A.=B).=C)...) */
3193 /* look for two adjacent consts and don't fold them together:
3196 * $o->concat("a")->concat("b")
3199 * (but $o .= "a" . "b" should still fold)
3202 bool seen_nonconst = FALSE;
3203 for (argp = toparg; argp >= args; argp--) {
3204 if (argp->p == NULL) {
3205 seen_nonconst = TRUE;
3211 /* both previous and current arg were constants;
3212 * leave the current OP_CONST as-is */
3220 /* -----------------------------------------------------------------
3223 * At this point we have determined that the optree *can* be converted
3224 * into a multiconcat. Having gathered all the evidence, we now decide
3225 * whether it *should*.
3229 /* we need at least one concat action, e.g.:
3235 * otherwise we could be doing something like $x = "foo", which
3236 * if treated as a concat, would fail to COW.
3238 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3241 /* Benchmarking seems to indicate that we gain if:
3242 * * we optimise at least two actions into a single multiconcat
3243 * (e.g concat+concat, sassign+concat);
3244 * * or if we can eliminate at least 1 OP_CONST;
3245 * * or if we can eliminate a padsv via OPpTARGET_MY
3249 /* eliminated at least one OP_CONST */
3251 /* eliminated an OP_SASSIGN */
3252 || o->op_type == OP_SASSIGN
3253 /* eliminated an OP_PADSV */
3254 || (!targmyop && is_targable)
3256 /* definitely a net gain to optimise */
3259 /* ... if not, what else? */
3261 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3262 * multiconcat is faster (due to not creating a temporary copy of
3263 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3269 && topop->op_type == OP_CONCAT
3271 PADOFFSET t = targmyop->op_targ;
3272 OP *k1 = cBINOPx(topop)->op_first;
3273 OP *k2 = cBINOPx(topop)->op_last;
3274 if ( k2->op_type == OP_PADSV
3276 && ( k1->op_type != OP_PADSV
3277 || k1->op_targ != t)
3282 /* need at least two concats */
3283 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3288 /* -----------------------------------------------------------------
3291 * At this point the optree has been verified as ok to be optimised
3292 * into an OP_MULTICONCAT. Now start changing things.
3297 /* stringify all const args and determine utf8ness */
3300 for (argp = args; argp <= toparg; argp++) {
3301 SV *sv = (SV*)argp->p;
3303 continue; /* not a const op */
3304 if (utf8 && !SvUTF8(sv))
3305 sv_utf8_upgrade_nomg(sv);
3306 argp->p = SvPV_nomg(sv, argp->len);
3307 total_len += argp->len;
3309 /* see if any strings would grow if converted to utf8 */
3311 variant += variant_under_utf8_count((U8 *) argp->p,
3312 (U8 *) argp->p + argp->len);
3316 /* create and populate aux struct */
3320 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3321 sizeof(UNOP_AUX_item)
3323 PERL_MULTICONCAT_HEADER_SIZE
3324 + ((nargs + 1) * (variant ? 2 : 1))
3327 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3329 /* Extract all the non-const expressions from the concat tree then
3330 * dispose of the old tree, e.g. convert the tree from this:
3334 * STRINGIFY -- TARGET
3336 * ex-PUSHMARK -- CONCAT
3351 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3353 * except that if EXPRi is an OP_CONST, it's discarded.
3355 * During the conversion process, EXPR ops are stripped from the tree
3356 * and unshifted onto o. Finally, any of o's remaining original
3357 * childen are discarded and o is converted into an OP_MULTICONCAT.
3359 * In this middle of this, o may contain both: unshifted args on the
3360 * left, and some remaining original args on the right. lastkidop
3361 * is set to point to the right-most unshifted arg to delineate
3362 * between the two sets.
3367 /* create a copy of the format with the %'s removed, and record
3368 * the sizes of the const string segments in the aux struct */
3370 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3372 p = sprintf_info.start;
3375 for (; p < sprintf_info.end; p++) {
3379 (lenp++)->ssize = q - oldq;
3386 lenp->ssize = q - oldq;
3387 assert((STRLEN)(q - const_str) == total_len);
3389 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3390 * may or may not be topop) The pushmark and const ops need to be
3391 * kept in case they're an op_next entry point.
3393 lastkidop = cLISTOPx(topop)->op_last;
3394 kid = cUNOPx(topop)->op_first; /* pushmark */
3396 op_null(OpSIBLING(kid)); /* const */
3398 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3399 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3400 lastkidop->op_next = o;
3405 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3409 /* Concatenate all const strings into const_str.
3410 * Note that args[] contains the RHS args in reverse order, so
3411 * we scan args[] from top to bottom to get constant strings
3414 for (argp = toparg; argp >= args; argp--) {
3416 /* not a const op */
3417 (++lenp)->ssize = -1;
3419 STRLEN l = argp->len;
3420 Copy(argp->p, p, l, char);
3422 if (lenp->ssize == -1)
3433 for (argp = args; argp <= toparg; argp++) {
3434 /* only keep non-const args, except keep the first-in-next-chain
3435 * arg no matter what it is (but nulled if OP_CONST), because it
3436 * may be the entry point to this subtree from the previous
3439 bool last = (argp == toparg);
3442 /* set prev to the sibling *before* the arg to be cut out,
3443 * e.g. when cutting EXPR:
3448 * prev= CONCAT -- EXPR
3451 if (argp == args && kid->op_type != OP_CONCAT) {
3452 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3453 * so the expression to be cut isn't kid->op_last but
3456 /* find the op before kid */
3458 o2 = cUNOPx(parentop)->op_first;
3459 while (o2 && o2 != kid) {
3467 else if (kid == o && lastkidop)
3468 prev = last ? lastkidop : OpSIBLING(lastkidop);
3470 prev = last ? NULL : cUNOPx(kid)->op_first;
3472 if (!argp->p || last) {
3474 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3475 /* and unshift to front of o */
3476 op_sibling_splice(o, NULL, 0, aop);
3477 /* record the right-most op added to o: later we will
3478 * free anything to the right of it */
3481 aop->op_next = nextop;
3484 /* null the const at start of op_next chain */
3488 nextop = prev->op_next;
3491 /* the last two arguments are both attached to the same concat op */
3492 if (argp < toparg - 1)
3497 /* Populate the aux struct */
3499 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3500 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3501 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3502 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3503 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3505 /* if variant > 0, calculate a variant const string and lengths where
3506 * the utf8 version of the string will take 'variant' more bytes than
3510 char *p = const_str;
3511 STRLEN ulen = total_len + variant;
3512 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3513 UNOP_AUX_item *ulens = lens + (nargs + 1);
3514 char *up = (char*)PerlMemShared_malloc(ulen);
3517 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3518 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3520 for (n = 0; n < (nargs + 1); n++) {
3522 char * orig_up = up;
3523 for (i = (lens++)->ssize; i > 0; i--) {
3525 append_utf8_from_native_byte(c, (U8**)&up);
3527 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3532 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3533 * that op's first child - an ex-PUSHMARK - because the op_next of
3534 * the previous op may point to it (i.e. it's the entry point for
3539 ? op_sibling_splice(o, lastkidop, 1, NULL)
3540 : op_sibling_splice(stringop, NULL, 1, NULL);
3541 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3542 op_sibling_splice(o, NULL, 0, pmop);
3549 * target .= A.B.C...
3555 if (o->op_type == OP_SASSIGN) {
3556 /* Move the target subtree from being the last of o's children
3557 * to being the last of o's preserved children.
3558 * Note the difference between 'target = ...' and 'target .= ...':
3559 * for the former, target is executed last; for the latter,
3562 kid = OpSIBLING(lastkidop);
3563 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3564 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3565 lastkidop->op_next = kid->op_next;
3566 lastkidop = targetop;
3569 /* Move the target subtree from being the first of o's
3570 * original children to being the first of *all* o's children.
3573 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3574 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3577 /* if the RHS of .= doesn't contain a concat (e.g.
3578 * $x .= "foo"), it gets missed by the "strip ops from the
3579 * tree and add to o" loop earlier */
3580 assert(topop->op_type != OP_CONCAT);
3582 /* in e.g. $x .= "$y", move the $y expression
3583 * from being a child of OP_STRINGIFY to being the
3584 * second child of the OP_CONCAT
3586 assert(cUNOPx(stringop)->op_first == topop);
3587 op_sibling_splice(stringop, NULL, 1, NULL);
3588 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3590 assert(topop == OpSIBLING(cBINOPo->op_first));
3599 * my $lex = A.B.C...
3602 * The original padsv op is kept but nulled in case it's the
3603 * entry point for the optree (which it will be for
3606 private_flags |= OPpTARGET_MY;
3607 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3608 o->op_targ = targetop->op_targ;
3609 targetop->op_targ = 0;
3613 flags |= OPf_STACKED;
3615 else if (targmyop) {
3616 private_flags |= OPpTARGET_MY;
3617 if (o != targmyop) {
3618 o->op_targ = targmyop->op_targ;
3619 targmyop->op_targ = 0;
3623 /* detach the emaciated husk of the sprintf/concat optree and free it */
3625 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3631 /* and convert o into a multiconcat */
3633 o->op_flags = (flags|OPf_KIDS|stacked_last
3634 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3635 o->op_private = private_flags;
3636 o->op_type = OP_MULTICONCAT;
3637 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3638 cUNOP_AUXo->op_aux = aux;
3642 /* do all the final processing on an optree (e.g. running the peephole
3643 * optimiser on it), then attach it to cv (if cv is non-null)
3647 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3651 /* XXX for some reason, evals, require and main optrees are
3652 * never attached to their CV; instead they just hang off
3653 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3654 * and get manually freed when appropriate */
3656 startp = &CvSTART(cv);
3658 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3661 optree->op_private |= OPpREFCOUNTED;
3662 OpREFCNT_set(optree, 1);
3663 optimize_optree(optree);
3665 finalize_optree(optree);
3666 S_prune_chain_head(startp);
3669 /* now that optimizer has done its work, adjust pad values */
3670 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3671 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3677 =for apidoc optimize_optree
3679 This function applies some optimisations to the optree in top-down order.
3680 It is called before the peephole optimizer, which processes ops in
3681 execution order. Note that finalize_optree() also does a top-down scan,
3682 but is called *after* the peephole optimizer.
3688 Perl_optimize_optree(pTHX_ OP* o)
3690 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3693 SAVEVPTR(PL_curcop);
3701 /* helper for optimize_optree() which optimises one op then recurses
3702 * to optimise any children.
3706 S_optimize_op(pTHX_ OP* o)
3710 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3713 OP * next_kid = NULL;
3715 assert(o->op_type != OP_FREED);
3717 switch (o->op_type) {
3720 PL_curcop = ((COP*)o); /* for warnings */
3728 S_maybe_multiconcat(aTHX_ o);
3732 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3733 /* we can't assume that op_pmreplroot->op_sibparent == o
3734 * and that it is thus possible to walk back up the tree
3735 * past op_pmreplroot. So, although we try to avoid
3736 * recursing through op trees, do it here. After all,
3737 * there are unlikely to be many nested s///e's within
3738 * the replacement part of a s///e.
3740 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3748 if (o->op_flags & OPf_KIDS)
3749 next_kid = cUNOPo->op_first;
3751 /* if a kid hasn't been nominated to process, continue with the
3752 * next sibling, or if no siblings left, go back to the parent's
3753 * siblings and so on
3757 return; /* at top; no parents/siblings to try */
3758 if (OpHAS_SIBLING(o))
3759 next_kid = o->op_sibparent;
3761 o = o->op_sibparent; /*try parent's next sibling */
3764 /* this label not yet used. Goto here if any code above sets
3774 =for apidoc finalize_optree
3776 This function finalizes the optree. Should be called directly after
3777 the complete optree is built. It does some additional
3778 checking which can't be done in the normal C<ck_>xxx functions and makes
3779 the tree thread-safe.
3784 Perl_finalize_optree(pTHX_ OP* o)
3786 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3789 SAVEVPTR(PL_curcop);
3797 /* Relocate sv to the pad for thread safety.
3798 * Despite being a "constant", the SV is written to,
3799 * for reference counts, sv_upgrade() etc. */
3800 PERL_STATIC_INLINE void
3801 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3804 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3806 ix = pad_alloc(OP_CONST, SVf_READONLY);
3807 SvREFCNT_dec(PAD_SVl(ix));
3808 PAD_SETSV(ix, *svp);
3809 /* XXX I don't know how this isn't readonly already. */
3810 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3817 =for apidoc traverse_op_tree
3819 Return the next op in a depth-first traversal of the op tree,
3820 returning NULL when the traversal is complete.
3822 The initial call must supply the root of the tree as both top and o.
3824 For now it's static, but it may be exposed to the API in the future.
3830 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3833 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3835 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3836 return cUNOPo->op_first;
3838 else if ((sib = OpSIBLING(o))) {
3842 OP *parent = o->op_sibparent;
3843 assert(!(o->op_moresib));
3844 while (parent && parent != top) {
3845 OP *sib = OpSIBLING(parent);
3848 parent = parent->op_sibparent;
3856 S_finalize_op(pTHX_ OP* o)
3859 PERL_ARGS_ASSERT_FINALIZE_OP;
3862 assert(o->op_type != OP_FREED);
3864 switch (o->op_type) {
3867 PL_curcop = ((COP*)o); /* for warnings */
3870 if (OpHAS_SIBLING(o)) {
3871 OP *sib = OpSIBLING(o);
3872 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3873 && ckWARN(WARN_EXEC)
3874 && OpHAS_SIBLING(sib))
3876 const OPCODE type = OpSIBLING(sib)->op_type;
3877 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3878 const line_t oldline = CopLINE(PL_curcop);
3879 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3880 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3881 "Statement unlikely to be reached");
3882 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3883 "\t(Maybe you meant system() when you said exec()?)\n");
3884 CopLINE_set(PL_curcop, oldline);
3891 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3892 GV * const gv = cGVOPo_gv;
3893 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3894 /* XXX could check prototype here instead of just carping */
3895 SV * const sv = sv_newmortal();
3896 gv_efullname3(sv, gv, NULL);
3897 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3898 "%" SVf "() called too early to check prototype",
3905 if (cSVOPo->op_private & OPpCONST_STRICT)
3906 no_bareword_allowed(o);
3910 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3915 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3916 case OP_METHOD_NAMED:
3917 case OP_METHOD_SUPER:
3918 case OP_METHOD_REDIR:
3919 case OP_METHOD_REDIR_SUPER:
3920 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3929 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3932 rop = (UNOP*)((BINOP*)o)->op_first;
3937 S_scalar_slice_warning(aTHX_ o);
3941 kid = OpSIBLING(cLISTOPo->op_first);
3942 if (/* I bet there's always a pushmark... */
3943 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3944 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3949 key_op = (SVOP*)(kid->op_type == OP_CONST
3951 : OpSIBLING(kLISTOP->op_first));
3953 rop = (UNOP*)((LISTOP*)o)->op_last;
3956 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3958 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3962 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3966 S_scalar_slice_warning(aTHX_ o);
3970 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3971 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3979 if (o->op_flags & OPf_KIDS) {
3982 /* check that op_last points to the last sibling, and that
3983 * the last op_sibling/op_sibparent field points back to the
3984 * parent, and that the only ops with KIDS are those which are
3985 * entitled to them */
3986 U32 type = o->op_type;
3990 if (type == OP_NULL) {
3992 /* ck_glob creates a null UNOP with ex-type GLOB
3993 * (which is a list op. So pretend it wasn't a listop */
3994 if (type == OP_GLOB)
3997 family = PL_opargs[type] & OA_CLASS_MASK;
3999 has_last = ( family == OA_BINOP
4000 || family == OA_LISTOP
4001 || family == OA_PMOP
4002 || family == OA_LOOP
4004 assert( has_last /* has op_first and op_last, or ...
4005 ... has (or may have) op_first: */
4006 || family == OA_UNOP
4007 || family == OA_UNOP_AUX
4008 || family == OA_LOGOP
4009 || family == OA_BASEOP_OR_UNOP
4010 || family == OA_FILESTATOP
4011 || family == OA_LOOPEXOP
4012 || family == OA_METHOP
4013 || type == OP_CUSTOM
4014 || type == OP_NULL /* new_logop does this */
4017 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
4018 if (!OpHAS_SIBLING(kid)) {
4020 assert(kid == cLISTOPo->op_last);
4021 assert(kid->op_sibparent == o);
4026 } while (( o = traverse_op_tree(top, o)) != NULL);
4030 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
4033 PadnameLVALUE_on(pn);
4034 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
4036 /* RT #127786: cv can be NULL due to an eval within the DB package
4037 * called from an anon sub - anon subs don't have CvOUTSIDE() set
4038 * unless they contain an eval, but calling eval within DB
4039 * pretends the eval was done in the caller's scope.
4043 assert(CvPADLIST(cv));
4045 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
4046 assert(PadnameLEN(pn));
4047 PadnameLVALUE_on(pn);
4052 S_vivifies(const OPCODE type)
4055 case OP_RV2AV: case OP_ASLICE:
4056 case OP_RV2HV: case OP_KVASLICE:
4057 case OP_RV2SV: case OP_HSLICE:
4058 case OP_AELEMFAST: case OP_KVHSLICE:
4067 /* apply lvalue reference (aliasing) context to the optree o.
4070 * o would be the list ($x,$y) and type would be OP_AASSIGN.
4071 * It may descend and apply this to children too, for example in
4072 * \( $cond ? $x, $y) = (...)
4076 S_lvref(pTHX_ OP *o, I32 type)
4082 switch (o->op_type) {
4084 o = OpSIBLING(cUNOPo->op_first);
4091 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4092 o->op_flags |= OPf_STACKED;
4093 if (o->op_flags & OPf_PARENS) {
4094 if (o->op_private & OPpLVAL_INTRO) {
4095 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4096 "localized parenthesized array in list assignment"));
4100 OpTYPE_set(o, OP_LVAVREF);
4101 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4102 o->op_flags |= OPf_MOD|OPf_REF;
4105 o->op_private |= OPpLVREF_AV;
4109 kid = cUNOPo->op_first;
4110 if (kid->op_type == OP_NULL)
4111 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4113 o->op_private = OPpLVREF_CV;
4114 if (kid->op_type == OP_GV)
4115 o->op_flags |= OPf_STACKED;
4116 else if (kid->op_type == OP_PADCV) {
4117 o->op_targ = kid->op_targ;
4119 op_free(cUNOPo->op_first);
4120 cUNOPo->op_first = NULL;
4121 o->op_flags &=~ OPf_KIDS;
4127 if (o->op_flags & OPf_PARENS) {
4129 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4130 "parenthesized hash in list assignment"));
4133 o->op_private |= OPpLVREF_HV;
4137 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4138 o->op_flags |= OPf_STACKED;
4142 if (o->op_flags & OPf_PARENS) goto parenhash;
4143 o->op_private |= OPpLVREF_HV;
4146 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4150 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4151 if (o->op_flags & OPf_PARENS) goto slurpy;
4152 o->op_private |= OPpLVREF_AV;
4157 o->op_private |= OPpLVREF_ELEM;
4158 o->op_flags |= OPf_STACKED;
4163 OpTYPE_set(o, OP_LVREFSLICE);
4164 o->op_private &= OPpLVAL_INTRO;
4168 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4170 else if (!(o->op_flags & OPf_KIDS))
4173 /* the code formerly only recursed into the first child of
4174 * a non ex-list OP_NULL. if we ever encounter such a null op with
4175 * more than one child, need to decide whether its ok to process
4176 * *all* its kids or not */
4177 assert(o->op_targ == OP_LIST
4178 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4181 o = cLISTOPo->op_first;
4185 if (o->op_flags & OPf_PARENS)
4190 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4191 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4192 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4199 OpTYPE_set(o, OP_LVREF);
4201 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4202 if (type == OP_ENTERLOOP)
4203 o->op_private |= OPpLVREF_ITER;
4208 return; /* at top; no parents/siblings to try */
4209 if (OpHAS_SIBLING(o)) {
4210 o = o->op_sibparent;
4213 o = o->op_sibparent; /*try parent's next sibling */
4219 PERL_STATIC_INLINE bool
4220 S_potential_mod_type(I32 type)
4222 /* Types that only potentially result in modification. */
4223 return type == OP_GREPSTART || type == OP_ENTERSUB
4224 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4229 =for apidoc op_lvalue
4231 Propagate lvalue ("modifiable") context to an op and its children.
4232 C<type> represents the context type, roughly based on the type of op that
4233 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4234 because it has no op type of its own (it is signalled by a flag on
4237 This function detects things that can't be modified, such as C<$x+1>, and
4238 generates errors for them. For example, C<$x+1 = 2> would cause it to be
4239 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4241 It also flags things that need to behave specially in an lvalue context,
4242 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4246 Perl_op_lvalue_flags() is a non-API lower-level interface to
4247 op_lvalue(). The flags param has these bits:
4248 OP_LVALUE_NO_CROAK: return rather than croaking on error
4253 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4257 if (!o || (PL_parser && PL_parser->error_count))
4262 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4264 OP *next_kid = NULL;
4266 if ((o->op_private & OPpTARGET_MY)
4267 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4272 /* elements of a list might be in void context because the list is
4273 in scalar context or because they are attribute sub calls */
4274 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4277 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4279 switch (o->op_type) {
4285 if ((o->op_flags & OPf_PARENS))
4290 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4291 !(o->op_flags & OPf_STACKED)) {
4292 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4293 assert(cUNOPo->op_first->op_type == OP_NULL);
4294 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4297 else { /* lvalue subroutine call */
4298 o->op_private |= OPpLVAL_INTRO;
4299 PL_modcount = RETURN_UNLIMITED_NUMBER;
4300 if (S_potential_mod_type(type)) {
4301 o->op_private |= OPpENTERSUB_INARGS;
4304 else { /* Compile-time error message: */
4305 OP *kid = cUNOPo->op_first;
4310 if (kid->op_type != OP_PUSHMARK) {
4311 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4313 "panic: unexpected lvalue entersub "
4314 "args: type/targ %ld:%" UVuf,
4315 (long)kid->op_type, (UV)kid->op_targ);
4316 kid = kLISTOP->op_first;
4318 while (OpHAS_SIBLING(kid))
4319 kid = OpSIBLING(kid);
4320 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4321 break; /* Postpone until runtime */
4324 kid = kUNOP->op_first;
4325 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4326 kid = kUNOP->op_first;
4327 if (kid->op_type == OP_NULL)
4329 "Unexpected constant lvalue entersub "
4330 "entry via type/targ %ld:%" UVuf,
4331 (long)kid->op_type, (UV)kid->op_targ);
4332 if (kid->op_type != OP_GV) {
4339 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4340 ? MUTABLE_CV(SvRV(gv))
4346 if (flags & OP_LVALUE_NO_CROAK)
4349 namesv = cv_name(cv, NULL, 0);
4350 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4351 "subroutine call of &%" SVf " in %s",
4352 SVfARG(namesv), PL_op_desc[type]),
4360 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4361 /* grep, foreach, subcalls, refgen */
4362 if (S_potential_mod_type(type))
4364 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4365 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4368 type ? PL_op_desc[type] : "local"));
4381 case OP_RIGHT_SHIFT:
4390 if (!(o->op_flags & OPf_STACKED))
4396 if (o->op_flags & OPf_STACKED) {
4400 if (!(o->op_private & OPpREPEAT_DOLIST))
4403 const I32 mods = PL_modcount;
4404 /* we recurse rather than iterate here because we need to
4405 * calculate and use the delta applied to PL_modcount by the
4406 * first child. So in something like
4407 * ($x, ($y) x 3) = split;
4408 * split knows that 4 elements are wanted
4410 modkids(cBINOPo->op_first, type);
4411 if (type != OP_AASSIGN)
4413 kid = cBINOPo->op_last;
4414 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4415 const IV iv = SvIV(kSVOP_sv);
4416 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4418 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4421 PL_modcount = RETURN_UNLIMITED_NUMBER;
4427 next_kid = OpSIBLING(cUNOPo->op_first);
4432 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4433 PL_modcount = RETURN_UNLIMITED_NUMBER;
4434 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4435 fiable since some contexts need to know. */
4436 o->op_flags |= OPf_MOD;
4441 if (scalar_mod_type(o, type))
4443 ref(cUNOPo->op_first, o->op_type);
4450 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4451 if (type == OP_LEAVESUBLV && (
4452 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4453 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4455 o->op_private |= OPpMAYBE_LVSUB;
4459 PL_modcount = RETURN_UNLIMITED_NUMBER;
4465 if (type == OP_LEAVESUBLV)
4466 o->op_private |= OPpMAYBE_LVSUB;
4470 if (type == OP_LEAVESUBLV
4471 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4472 o->op_private |= OPpMAYBE_LVSUB;
4476 PL_hints |= HINT_BLOCK_SCOPE;
4477 if (type == OP_LEAVESUBLV)
4478 o->op_private |= OPpMAYBE_LVSUB;
4483 ref(cUNOPo->op_first, o->op_type);
4487 PL_hints |= HINT_BLOCK_SCOPE;
4497 case OP_AELEMFAST_LEX:
4504 PL_modcount = RETURN_UNLIMITED_NUMBER;
4505 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4507 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4508 fiable since some contexts need to know. */
4509 o->op_flags |= OPf_MOD;
4512 if (scalar_mod_type(o, type))
4514 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4515 && type == OP_LEAVESUBLV)
4516 o->op_private |= OPpMAYBE_LVSUB;
4520 if (!type) /* local() */
4521 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4522 PNfARG(PAD_COMPNAME(o->op_targ)));
4523 if (!(o->op_private & OPpLVAL_INTRO)
4524 || ( type != OP_SASSIGN && type != OP_AASSIGN
4525 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4526 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4534 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4538 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4544 if (type == OP_LEAVESUBLV)
4545 o->op_private |= OPpMAYBE_LVSUB;
4546 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4547 /* we recurse rather than iterate here because the child
4548 * needs to be processed with a different 'type' parameter */
4550 /* substr and vec */
4551 /* If this op is in merely potential (non-fatal) modifiable
4552 context, then apply OP_ENTERSUB context to
4553 the kid op (to avoid croaking). Other-
4554 wise pass this op’s own type so the correct op is mentioned
4555 in error messages. */
4556 op_lvalue(OpSIBLING(cBINOPo->op_first),
4557 S_potential_mod_type(type)
4565 ref(cBINOPo->op_first, o->op_type);
4566 if (type == OP_ENTERSUB &&
4567 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4568 o->op_private |= OPpLVAL_DEFER;
4569 if (type == OP_LEAVESUBLV)
4570 o->op_private |= OPpMAYBE_LVSUB;
4577 o->op_private |= OPpLVALUE;
4583 if (o->op_flags & OPf_KIDS)
4584 next_kid = cLISTOPo->op_last;
4589 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4591 else if (!(o->op_flags & OPf_KIDS))
4594 if (o->op_targ != OP_LIST) {
4595 OP *sib = OpSIBLING(cLISTOPo->op_first);
4596 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4603 * compared with things like OP_MATCH which have the argument
4609 * so handle specially to correctly get "Can't modify" croaks etc
4612 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4614 /* this should trigger a "Can't modify transliteration" err */
4615 op_lvalue(sib, type);
4617 next_kid = cBINOPo->op_first;
4618 /* we assume OP_NULLs which aren't ex-list have no more than 2
4619 * children. If this assumption is wrong, increase the scan
4621 assert( !OpHAS_SIBLING(next_kid)
4622 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4628 next_kid = cLISTOPo->op_first;
4636 if (type == OP_LEAVESUBLV
4637 || !S_vivifies(cLOGOPo->op_first->op_type))
4638 next_kid = cLOGOPo->op_first;
4639 else if (type == OP_LEAVESUBLV
4640 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4641 next_kid = OpSIBLING(cLOGOPo->op_first);
4645 if (type == OP_NULL) { /* local */
4647 if (!FEATURE_MYREF_IS_ENABLED)
4648 Perl_croak(aTHX_ "The experimental declared_refs "
4649 "feature is not enabled");
4650 Perl_ck_warner_d(aTHX_
4651 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4652 "Declaring references is experimental");
4653 next_kid = cUNOPo->op_first;
4656 if (type != OP_AASSIGN && type != OP_SASSIGN
4657 && type != OP_ENTERLOOP)
4659 /* Don’t bother applying lvalue context to the ex-list. */
4660 kid = cUNOPx(cUNOPo->op_first)->op_first;
4661 assert (!OpHAS_SIBLING(kid));
4664 if (type == OP_NULL) /* local */
4666 if (type != OP_AASSIGN) goto nomod;
4667 kid = cUNOPo->op_first;
4670 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4671 S_lvref(aTHX_ kid, type);
4672 if (!PL_parser || PL_parser->error_count == ec) {
4673 if (!FEATURE_REFALIASING_IS_ENABLED)
4675 "Experimental aliasing via reference not enabled");
4676 Perl_ck_warner_d(aTHX_
4677 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4678 "Aliasing via reference is experimental");
4681 if (o->op_type == OP_REFGEN)
4682 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4687 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4688 /* This is actually @array = split. */
4689 PL_modcount = RETURN_UNLIMITED_NUMBER;
4695 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4699 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4700 their argument is a filehandle; thus \stat(".") should not set
4702 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4705 if (type != OP_LEAVESUBLV)
4706 o->op_flags |= OPf_MOD;
4708 if (type == OP_AASSIGN || type == OP_SASSIGN)
4709 o->op_flags |= OPf_SPECIAL
4710 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4711 else if (!type) { /* local() */
4714 o->op_private |= OPpLVAL_INTRO;
4715 o->op_flags &= ~OPf_SPECIAL;
4716 PL_hints |= HINT_BLOCK_SCOPE;
4721 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4722 "Useless localization of %s", OP_DESC(o));
4725 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4726 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4727 o->op_flags |= OPf_REF;
4732 return top_op; /* at top; no parents/siblings to try */
4733 if (OpHAS_SIBLING(o)) {
4734 next_kid = o->op_sibparent;
4735 if (!OpHAS_SIBLING(next_kid)) {
4736 /* a few node types don't recurse into their second child */
4737 OP *parent = next_kid->op_sibparent;
4738 I32 ptype = parent->op_type;
4739 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
4740 || ( (ptype == OP_AND || ptype == OP_OR)
4741 && (type != OP_LEAVESUBLV
4742 && S_vivifies(next_kid->op_type))
4745 /*try parent's next sibling */
4752 o = o->op_sibparent; /*try parent's next sibling */
4763 S_scalar_mod_type(const OP *o, I32 type)
4768 if (o && o->op_type == OP_RV2GV)
4792 case OP_RIGHT_SHIFT:
4821 S_is_handle_constructor(const OP *o, I32 numargs)
4823 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4825 switch (o->op_type) {
4833 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4846 S_refkids(pTHX_ OP *o, I32 type)
4848 if (o && o->op_flags & OPf_KIDS) {
4850 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4857 /* Apply reference (autovivification) context to the subtree at o.
4859 * push @{expression}, ....;
4860 * o will be the head of 'expression' and type will be OP_RV2AV.
4861 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4863 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4864 * set_op_ref is true.
4866 * Also calls scalar(o).
4870 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4874 PERL_ARGS_ASSERT_DOREF;
4876 if (PL_parser && PL_parser->error_count)
4880 switch (o->op_type) {
4882 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4883 !(o->op_flags & OPf_STACKED)) {
4884 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4885 assert(cUNOPo->op_first->op_type == OP_NULL);
4886 /* disable pushmark */
4887 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4888 o->op_flags |= OPf_SPECIAL;
4890 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4891 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4892 : type == OP_RV2HV ? OPpDEREF_HV
4894 o->op_flags |= OPf_MOD;
4900 o = OpSIBLING(cUNOPo->op_first);
4904 if (type == OP_DEFINED)
4905 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4908 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4909 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4910 : type == OP_RV2HV ? OPpDEREF_HV
4912 o->op_flags |= OPf_MOD;
4914 if (o->op_flags & OPf_KIDS) {
4916 o = cUNOPo->op_first;
4924 o->op_flags |= OPf_REF;
4927 if (type == OP_DEFINED)
4928 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4930 o = cUNOPo->op_first;
4936 o->op_flags |= OPf_REF;
4941 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4943 o = cBINOPo->op_first;
4948 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4949 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4950 : type == OP_RV2HV ? OPpDEREF_HV
4952 o->op_flags |= OPf_MOD;
4955 o = cBINOPo->op_first;
4964 if (!(o->op_flags & OPf_KIDS))
4966 o = cLISTOPo->op_last;
4975 return scalar(top_op); /* at top; no parents/siblings to try */
4976 if (OpHAS_SIBLING(o)) {
4977 o = o->op_sibparent;
4978 /* Normally skip all siblings and go straight to the parent;
4979 * the only op that requires two children to be processed
4980 * is OP_COND_EXPR */
4981 if (!OpHAS_SIBLING(o)
4982 && o->op_sibparent->op_type == OP_COND_EXPR)
4986 o = o->op_sibparent; /*try parent's next sibling */
4993 S_dup_attrlist(pTHX_ OP *o)
4997 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4999 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
5000 * where the first kid is OP_PUSHMARK and the remaining ones
5001 * are OP_CONST. We need to push the OP_CONST values.
5003 if (o->op_type == OP_CONST)
5004 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
5006 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5008 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
5009 if (o->op_type == OP_CONST)
5010 rop = op_append_elem(OP_LIST, rop,
5011 newSVOP(OP_CONST, o->op_flags,
5012 SvREFCNT_inc_NN(cSVOPo->op_sv)));
5019 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
5021 PERL_ARGS_ASSERT_APPLY_ATTRS;
5023 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
5025 /* fake up C<use attributes $pkg,$rv,@attrs> */
5027 #define ATTRSMODULE "attributes"
5028 #define ATTRSMODULE_PM "attributes.pm"
5031 aTHX_ PERL_LOADMOD_IMPORT_OPS,
5032 newSVpvs(ATTRSMODULE),
5034 op_prepend_elem(OP_LIST,
5035 newSVOP(OP_CONST, 0, stashsv),
5036 op_prepend_elem(OP_LIST,
5037 newSVOP(OP_CONST, 0,
5039 dup_attrlist(attrs))));
5044 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
5046 OP *pack, *imop, *arg;
5047 SV *meth, *stashsv, **svp;
5049 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
5054 assert(target->op_type == OP_PADSV ||
5055 target->op_type == OP_PADHV ||
5056 target->op_type == OP_PADAV);
5058 /* Ensure that attributes.pm is loaded. */
5059 /* Don't force the C<use> if we don't need it. */
5060 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
5061 if (svp && *svp != &PL_sv_undef)
5062 NOOP; /* already in %INC */
5064 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5065 newSVpvs(ATTRSMODULE), NULL);
5067 /* Need package name for method call. */
5068 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
5070 /* Build up the real arg-list. */
5071 stashsv = newSVhek(HvNAME_HEK(stash));
5073 arg = newOP(OP_PADSV, 0);
5074 arg->op_targ = target->op_targ;
5075 arg = op_prepend_elem(OP_LIST,
5076 newSVOP(OP_CONST, 0, stashsv),
5077 op_prepend_elem(OP_LIST,
5078 newUNOP(OP_REFGEN, 0,
5080 dup_attrlist(attrs)));
5082 /* Fake up a method call to import */
5083 meth = newSVpvs_share("import");
5084 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
5085 op_append_elem(OP_LIST,
5086 op_prepend_elem(OP_LIST, pack, arg),
5087 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5089 /* Combine the ops. */
5090 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
5094 =notfor apidoc apply_attrs_string
5096 Attempts to apply a list of attributes specified by the C<attrstr> and
5097 C<len> arguments to the subroutine identified by the C<cv> argument which
5098 is expected to be associated with the package identified by the C<stashpv>
5099 argument (see L<attributes>). It gets this wrong, though, in that it
5100 does not correctly identify the boundaries of the individual attribute
5101 specifications within C<attrstr>. This is not really intended for the
5102 public API, but has to be listed here for systems such as AIX which
5103 need an explicit export list for symbols. (It's called from XS code
5104 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
5105 to respect attribute syntax properly would be welcome.
5111 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
5112 const char *attrstr, STRLEN len)
5116 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
5119 len = strlen(attrstr);
5123 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
5125 const char * const sstr = attrstr;
5126 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
5127 attrs = op_append_elem(OP_LIST, attrs,
5128 newSVOP(OP_CONST, 0,
5129 newSVpvn(sstr, attrstr-sstr)));
5133 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5134 newSVpvs(ATTRSMODULE),
5135 NULL, op_prepend_elem(OP_LIST,
5136 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5137 op_prepend_elem(OP_LIST,
5138 newSVOP(OP_CONST, 0,
5139 newRV(MUTABLE_SV(cv))),
5144 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5147 OP *new_proto = NULL;
5152 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5158 if (o->op_type == OP_CONST) {
5159 pv = SvPV(cSVOPo_sv, pvlen);
5160 if (memBEGINs(pv, pvlen, "prototype(")) {
5161 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5162 SV ** const tmpo = cSVOPx_svp(o);
5163 SvREFCNT_dec(cSVOPo_sv);
5168 } else if (o->op_type == OP_LIST) {
5170 assert(o->op_flags & OPf_KIDS);
5171 lasto = cLISTOPo->op_first;
5172 assert(lasto->op_type == OP_PUSHMARK);
5173 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5174 if (o->op_type == OP_CONST) {
5175 pv = SvPV(cSVOPo_sv, pvlen);
5176 if (memBEGINs(pv, pvlen, "prototype(")) {
5177 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5178 SV ** const tmpo = cSVOPx_svp(o);
5179 SvREFCNT_dec(cSVOPo_sv);
5181 if (new_proto && ckWARN(WARN_MISC)) {
5183 const char * newp = SvPV(cSVOPo_sv, new_len);
5184 Perl_warner(aTHX_ packWARN(WARN_MISC),
5185 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5186 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5192 /* excise new_proto from the list */
5193 op_sibling_splice(*attrs, lasto, 1, NULL);
5200 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5201 would get pulled in with no real need */
5202 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5211 svname = sv_newmortal();
5212 gv_efullname3(svname, name, NULL);
5214 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5215 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5217 svname = (SV *)name;
5218 if (ckWARN(WARN_ILLEGALPROTO))
5219 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5221 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5222 STRLEN old_len, new_len;
5223 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5224 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5226 if (curstash && svname == (SV *)name
5227 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5228 svname = sv_2mortal(newSVsv(PL_curstname));
5229 sv_catpvs(svname, "::");
5230 sv_catsv(svname, (SV *)name);
5233 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5234 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5236 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5237 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5247 S_cant_declare(pTHX_ OP *o)
5249 if (o->op_type == OP_NULL
5250 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5251 o = cUNOPo->op_first;
5252 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5253 o->op_type == OP_NULL
5254 && o->op_flags & OPf_SPECIAL
5257 PL_parser->in_my == KEY_our ? "our" :
5258 PL_parser->in_my == KEY_state ? "state" :
5263 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5266 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5268 PERL_ARGS_ASSERT_MY_KID;
5270 if (!o || (PL_parser && PL_parser->error_count))
5275 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5277 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5278 my_kid(kid, attrs, imopsp);
5280 } else if (type == OP_UNDEF || type == OP_STUB) {
5282 } else if (type == OP_RV2SV || /* "our" declaration */
5285 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5286 S_cant_declare(aTHX_ o);
5288 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5290 PL_parser->in_my = FALSE;
5291 PL_parser->in_my_stash = NULL;
5292 apply_attrs(GvSTASH(gv),
5293 (type == OP_RV2SV ? GvSVn(gv) :
5294 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5295 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5298 o->op_private |= OPpOUR_INTRO;
5301 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5302 if (!FEATURE_MYREF_IS_ENABLED)
5303 Perl_croak(aTHX_ "The experimental declared_refs "
5304 "feature is not enabled");
5305 Perl_ck_warner_d(aTHX_
5306 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5307 "Declaring references is experimental");
5308 /* Kid is a nulled OP_LIST, handled above. */
5309 my_kid(cUNOPo->op_first, attrs, imopsp);
5312 else if (type != OP_PADSV &&
5315 type != OP_PUSHMARK)
5317 S_cant_declare(aTHX_ o);
5320 else if (attrs && type != OP_PUSHMARK) {
5324 PL_parser->in_my = FALSE;
5325 PL_parser->in_my_stash = NULL;
5327 /* check for C<my Dog $spot> when deciding package */
5328 stash = PAD_COMPNAME_TYPE(o->op_targ);
5330 stash = PL_curstash;
5331 apply_attrs_my(stash, o, attrs, imopsp);
5333 o->op_flags |= OPf_MOD;
5334 o->op_private |= OPpLVAL_INTRO;
5336 o->op_private |= OPpPAD_STATE;
5341 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5344 int maybe_scalar = 0;
5346 PERL_ARGS_ASSERT_MY_ATTRS;
5348 /* [perl #17376]: this appears to be premature, and results in code such as
5349 C< our(%x); > executing in list mode rather than void mode */
5351 if (o->op_flags & OPf_PARENS)
5361 o = my_kid(o, attrs, &rops);
5363 if (maybe_scalar && o->op_type == OP_PADSV) {
5364 o = scalar(op_append_list(OP_LIST, rops, o));
5365 o->op_private |= OPpLVAL_INTRO;
5368 /* The listop in rops might have a pushmark at the beginning,
5369 which will mess up list assignment. */
5370 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5371 if (rops->op_type == OP_LIST &&
5372 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5374 OP * const pushmark = lrops->op_first;
5375 /* excise pushmark */
5376 op_sibling_splice(rops, NULL, 1, NULL);
5379 o = op_append_list(OP_LIST, o, rops);
5382 PL_parser->in_my = FALSE;
5383 PL_parser->in_my_stash = NULL;
5388 Perl_sawparens(pTHX_ OP *o)
5390 PERL_UNUSED_CONTEXT;
5392 o->op_flags |= OPf_PARENS;
5397 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5401 const OPCODE ltype = left->op_type;
5402 const OPCODE rtype = right->op_type;
5404 PERL_ARGS_ASSERT_BIND_MATCH;
5406 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5407 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5409 const char * const desc
5411 rtype == OP_SUBST || rtype == OP_TRANS
5412 || rtype == OP_TRANSR
5414 ? (int)rtype : OP_MATCH];
5415 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5417 S_op_varname(aTHX_ left);
5419 Perl_warner(aTHX_ packWARN(WARN_MISC),
5420 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5421 desc, SVfARG(name), SVfARG(name));
5423 const char * const sample = (isary
5424 ? "@array" : "%hash");
5425 Perl_warner(aTHX_ packWARN(WARN_MISC),
5426 "Applying %s to %s will act on scalar(%s)",
5427 desc, sample, sample);
5431 if (rtype == OP_CONST &&
5432 cSVOPx(right)->op_private & OPpCONST_BARE &&
5433 cSVOPx(right)->op_private & OPpCONST_STRICT)
5435 no_bareword_allowed(right);
5438 /* !~ doesn't make sense with /r, so error on it for now */
5439 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5441 /* diag_listed_as: Using !~ with %s doesn't make sense */
5442 yyerror("Using !~ with s///r doesn't make sense");
5443 if (rtype == OP_TRANSR && type == OP_NOT)
5444 /* diag_listed_as: Using !~ with %s doesn't make sense */
5445 yyerror("Using !~ with tr///r doesn't make sense");
5447 ismatchop = (rtype == OP_MATCH ||
5448 rtype == OP_SUBST ||
5449 rtype == OP_TRANS || rtype == OP_TRANSR)
5450 && !(right->op_flags & OPf_SPECIAL);
5451 if (ismatchop && right->op_private & OPpTARGET_MY) {
5453 right->op_private &= ~OPpTARGET_MY;
5455 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5456 if (left->op_type == OP_PADSV
5457 && !(left->op_private & OPpLVAL_INTRO))
5459 right->op_targ = left->op_targ;
5464 right->op_flags |= OPf_STACKED;
5465 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5466 ! (rtype == OP_TRANS &&
5467 right->op_private & OPpTRANS_IDENTICAL) &&
5468 ! (rtype == OP_SUBST &&
5469 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5470 left = op_lvalue(left, rtype);
5471 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5472 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5474 o = op_prepend_elem(rtype, scalar(left), right);
5477 return newUNOP(OP_NOT, 0, scalar(o));
5481 return bind_match(type, left,
5482 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5486 Perl_invert(pTHX_ OP *o)
5490 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5494 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
5500 left = newOP(OP_NULL, 0);
5502 right = newOP(OP_NULL, 0);
5505 NewOp(0, bop, 1, BINOP);
5507 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5508 OpTYPE_set(op, type);
5509 cBINOPx(op)->op_flags = OPf_KIDS;
5510 cBINOPx(op)->op_private = 2;
5511 cBINOPx(op)->op_first = left;
5512 cBINOPx(op)->op_last = right;
5513 OpMORESIB_set(left, right);
5514 OpLASTSIB_set(right, op);
5519 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
5524 PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
5526 right = newOP(OP_NULL, 0);
5528 NewOp(0, bop, 1, BINOP);
5530 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5531 OpTYPE_set(op, type);
5532 if (ch->op_type != OP_NULL) {
5534 OP *nch, *cleft, *cright;
5535 NewOp(0, lch, 1, UNOP);
5537 OpTYPE_set(nch, OP_NULL);
5538 nch->op_flags = OPf_KIDS;
5539 cleft = cBINOPx(ch)->op_first;
5540 cright = cBINOPx(ch)->op_last;
5541 cBINOPx(ch)->op_first = NULL;
5542 cBINOPx(ch)->op_last = NULL;
5543 cBINOPx(ch)->op_private = 0;
5544 cBINOPx(ch)->op_flags = 0;
5545 cUNOPx(nch)->op_first = cright;
5546 OpMORESIB_set(cright, ch);
5547 OpMORESIB_set(ch, cleft);
5548 OpLASTSIB_set(cleft, nch);
5551 OpMORESIB_set(right, op);
5552 OpMORESIB_set(op, cUNOPx(ch)->op_first);
5553 cUNOPx(ch)->op_first = right;
5558 Perl_cmpchain_finish(pTHX_ OP *ch)
5561 PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
5562 if (ch->op_type != OP_NULL) {
5563 OPCODE cmpoptype = ch->op_type;
5564 ch = CHECKOP(cmpoptype, ch);
5565 if(!ch->op_next && ch->op_type == cmpoptype)
5566 ch = fold_constants(op_integerize(op_std_init(ch)));
5570 OP *rightarg = cUNOPx(ch)->op_first;
5571 cUNOPx(ch)->op_first = OpSIBLING(rightarg);
5572 OpLASTSIB_set(rightarg, NULL);
5574 OP *cmpop = cUNOPx(ch)->op_first;
5575 OP *leftarg = OpSIBLING(cmpop);
5576 OPCODE cmpoptype = cmpop->op_type;
5579 is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
5580 OpLASTSIB_set(cmpop, NULL);
5581 OpLASTSIB_set(leftarg, NULL);
5585 nextrightarg = NULL;
5587 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
5588 leftarg = newOP(OP_NULL, 0);
5590 cBINOPx(cmpop)->op_first = leftarg;
5591 cBINOPx(cmpop)->op_last = rightarg;
5592 OpMORESIB_set(leftarg, rightarg);
5593 OpLASTSIB_set(rightarg, cmpop);
5594 cmpop->op_flags = OPf_KIDS;
5595 cmpop->op_private = 2;
5596 cmpop = CHECKOP(cmpoptype, cmpop);
5597 if(!cmpop->op_next && cmpop->op_type == cmpoptype)
5598 cmpop = fold_constants(op_integerize(op_std_init(cmpop)));
5599 condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
5603 rightarg = nextrightarg;
5609 =for apidoc op_scope
5611 Wraps up an op tree with some additional ops so that at runtime a dynamic
5612 scope will be created. The original ops run in the new dynamic scope,
5613 and then, provided that they exit normally, the scope will be unwound.
5614 The additional ops used to create and unwind the dynamic scope will
5615 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5616 instead if the ops are simple enough to not need the full dynamic scope
5623 Perl_op_scope(pTHX_ OP *o)
5626 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5627 o = op_prepend_elem(OP_LINESEQ,
5628 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
5629 OpTYPE_set(o, OP_LEAVE);
5631 else if (o->op_type == OP_LINESEQ) {
5633 OpTYPE_set(o, OP_SCOPE);
5634 kid = ((LISTOP*)o)->op_first;
5635 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5638 /* The following deals with things like 'do {1 for 1}' */
5639 kid = OpSIBLING(kid);
5641 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5646 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5652 Perl_op_unscope(pTHX_ OP *o)
5654 if (o && o->op_type == OP_LINESEQ) {
5655 OP *kid = cLISTOPo->op_first;
5656 for(; kid; kid = OpSIBLING(kid))
5657 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5664 =for apidoc block_start
5666 Handles compile-time scope entry.
5667 Arranges for hints to be restored on block
5668 exit and also handles pad sequence numbers to make lexical variables scope
5669 right. Returns a savestack index for use with C<block_end>.
5675 Perl_block_start(pTHX_ int full)
5677 const int retval = PL_savestack_ix;
5679 PL_compiling.cop_seq = PL_cop_seqmax;
5681 pad_block_start(full);
5683 PL_hints &= ~HINT_BLOCK_SCOPE;
5684 SAVECOMPILEWARNINGS();
5685 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5686 SAVEI32(PL_compiling.cop_seq);
5687 PL_compiling.cop_seq = 0;
5689 CALL_BLOCK_HOOKS(bhk_start, full);
5695 =for apidoc block_end
5697 Handles compile-time scope exit. C<floor>
5698 is the savestack index returned by
5699 C<block_start>, and C<seq> is the body of the block. Returns the block,
5706 Perl_block_end(pTHX_ I32 floor, OP *seq)
5708 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5709 OP* retval = scalarseq(seq);
5712 /* XXX Is the null PL_parser check necessary here? */
5713 assert(PL_parser); /* Let’s find out under debugging builds. */
5714 if (PL_parser && PL_parser->parsed_sub) {
5715 o = newSTATEOP(0, NULL, NULL);
5717 retval = op_append_elem(OP_LINESEQ, retval, o);
5720 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5724 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5728 /* pad_leavemy has created a sequence of introcv ops for all my
5729 subs declared in the block. We have to replicate that list with
5730 clonecv ops, to deal with this situation:
5735 sub s1 { state sub foo { \&s2 } }
5738 Originally, I was going to have introcv clone the CV and turn
5739 off the stale flag. Since &s1 is declared before &s2, the
5740 introcv op for &s1 is executed (on sub entry) before the one for
5741 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5742 cloned, since it is a state sub) closes over &s2 and expects
5743 to see it in its outer CV’s pad. If the introcv op clones &s1,
5744 then &s2 is still marked stale. Since &s1 is not active, and
5745 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5746 ble will not stay shared’ warning. Because it is the same stub
5747 that will be used when the introcv op for &s2 is executed, clos-
5748 ing over it is safe. Hence, we have to turn off the stale flag
5749 on all lexical subs in the block before we clone any of them.
5750 Hence, having introcv clone the sub cannot work. So we create a
5751 list of ops like this:
5775 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5776 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5777 for (;; kid = OpSIBLING(kid)) {
5778 OP *newkid = newOP(OP_CLONECV, 0);
5779 newkid->op_targ = kid->op_targ;
5780 o = op_append_elem(OP_LINESEQ, o, newkid);
5781 if (kid == last) break;
5783 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5786 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5792 =for apidoc_section Compile-time scope hooks
5794 =for apidoc blockhook_register
5796 Register a set of hooks to be called when the Perl lexical scope changes
5797 at compile time. See L<perlguts/"Compile-time scope hooks">.
5803 Perl_blockhook_register(pTHX_ BHK *hk)
5805 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5807 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5811 Perl_newPROG(pTHX_ OP *o)
5815 PERL_ARGS_ASSERT_NEWPROG;
5822 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5823 ((PL_in_eval & EVAL_KEEPERR)
5824 ? OPf_SPECIAL : 0), o);
5827 assert(CxTYPE(cx) == CXt_EVAL);
5829 if ((cx->blk_gimme & G_WANT) == G_VOID)
5830 scalarvoid(PL_eval_root);
5831 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5834 scalar(PL_eval_root);
5836 start = op_linklist(PL_eval_root);
5837 PL_eval_root->op_next = 0;
5838 i = PL_savestack_ix;
5841 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5843 PL_savestack_ix = i;
5846 if (o->op_type == OP_STUB) {
5847 /* This block is entered if nothing is compiled for the main
5848 program. This will be the case for an genuinely empty main
5849 program, or one which only has BEGIN blocks etc, so already
5852 Historically (5.000) the guard above was !o. However, commit
5853 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5854 c71fccf11fde0068, changed perly.y so that newPROG() is now
5855 called with the output of block_end(), which returns a new
5856 OP_STUB for the case of an empty optree. ByteLoader (and
5857 maybe other things) also take this path, because they set up
5858 PL_main_start and PL_main_root directly, without generating an
5861 If the parsing the main program aborts (due to parse errors,
5862 or due to BEGIN or similar calling exit), then newPROG()
5863 isn't even called, and hence this code path and its cleanups
5864 are skipped. This shouldn't make a make a difference:
5865 * a non-zero return from perl_parse is a failure, and
5866 perl_destruct() should be called immediately.
5867 * however, if exit(0) is called during the parse, then
5868 perl_parse() returns 0, and perl_run() is called. As
5869 PL_main_start will be NULL, perl_run() will return
5870 promptly, and the exit code will remain 0.
5873 PL_comppad_name = 0;
5875 S_op_destroy(aTHX_ o);
5878 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5879 PL_curcop = &PL_compiling;
5880 start = LINKLIST(PL_main_root);
5881 PL_main_root->op_next = 0;
5882 S_process_optree(aTHX_ NULL, PL_main_root, start);
5883 if (!PL_parser->error_count)
5884 /* on error, leave CV slabbed so that ops left lying around
5885 * will eb cleaned up. Else unslab */
5886 cv_forget_slab(PL_compcv);
5889 /* Register with debugger */
5891 CV * const cv = get_cvs("DB::postponed", 0);
5895 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5897 call_sv(MUTABLE_SV(cv), G_DISCARD);
5904 Perl_localize(pTHX_ OP *o, I32 lex)
5906 PERL_ARGS_ASSERT_LOCALIZE;
5908 if (o->op_flags & OPf_PARENS)
5909 /* [perl #17376]: this appears to be premature, and results in code such as
5910 C< our(%x); > executing in list mode rather than void mode */
5917 if ( PL_parser->bufptr > PL_parser->oldbufptr
5918 && PL_parser->bufptr[-1] == ','
5919 && ckWARN(WARN_PARENTHESIS))
5921 char *s = PL_parser->bufptr;
5924 /* some heuristics to detect a potential error */
5925 while (*s && (memCHRs(", \t\n", *s)))
5929 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
5931 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5934 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5936 while (*s && (memCHRs(", \t\n", *s)))
5942 if (sigil && (*s == ';' || *s == '=')) {
5943 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5944 "Parentheses missing around \"%s\" list",
5946 ? (PL_parser->in_my == KEY_our
5948 : PL_parser->in_my == KEY_state
5958 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5959 PL_parser->in_my = FALSE;
5960 PL_parser->in_my_stash = NULL;
5965 Perl_jmaybe(pTHX_ OP *o)
5967 PERL_ARGS_ASSERT_JMAYBE;
5969 if (o->op_type == OP_LIST) {
5970 if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
5972 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5973 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5976 /* If the user disables this, then a warning might not be enough to alert
5977 them to a possible change of behaviour here, so throw an exception.
5979 yyerror("Multidimensional hash lookup is disabled");
5985 PERL_STATIC_INLINE OP *
5986 S_op_std_init(pTHX_ OP *o)
5988 I32 type = o->op_type;
5990 PERL_ARGS_ASSERT_OP_STD_INIT;
5992 if (PL_opargs[type] & OA_RETSCALAR)
5994 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5995 o->op_targ = pad_alloc(type, SVs_PADTMP);
6000 PERL_STATIC_INLINE OP *
6001 S_op_integerize(pTHX_ OP *o)
6003 I32 type = o->op_type;
6005 PERL_ARGS_ASSERT_OP_INTEGERIZE;
6007 /* integerize op. */
6008 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
6010 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
6013 if (type == OP_NEGATE)
6014 /* XXX might want a ck_negate() for this */
6015 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
6020 /* This function exists solely to provide a scope to limit
6021 setjmp/longjmp() messing with auto variables. It cannot be inlined because
6025 S_fold_constants_eval(pTHX) {
6041 S_fold_constants(pTHX_ OP *const o)
6045 I32 type = o->op_type;
6050 SV * const oldwarnhook = PL_warnhook;
6051 SV * const olddiehook = PL_diehook;
6053 U8 oldwarn = PL_dowarn;
6056 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
6058 if (!(PL_opargs[type] & OA_FOLDCONST))
6067 #ifdef USE_LOCALE_CTYPE
6068 if (IN_LC_COMPILETIME(LC_CTYPE))
6077 #ifdef USE_LOCALE_COLLATE
6078 if (IN_LC_COMPILETIME(LC_COLLATE))
6083 /* XXX what about the numeric ops? */
6084 #ifdef USE_LOCALE_NUMERIC
6085 if (IN_LC_COMPILETIME(LC_NUMERIC))
6090 if (!OpHAS_SIBLING(cLISTOPo->op_first)
6091 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
6094 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
6095 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
6097 const char *s = SvPVX_const(sv);
6098 while (s < SvEND(sv)) {
6099 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
6106 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
6109 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
6110 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
6114 if (PL_parser && PL_parser->error_count)
6115 goto nope; /* Don't try to run w/ errors */
6117 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
6118 switch (curop->op_type) {
6120 if ( (curop->op_private & OPpCONST_BARE)
6121 && (curop->op_private & OPpCONST_STRICT)) {
6122 no_bareword_allowed(curop);
6130 /* Foldable; move to next op in list */
6134 /* No other op types are considered foldable */
6139 curop = LINKLIST(o);
6140 old_next = o->op_next;
6144 old_cxix = cxstack_ix;
6145 create_eval_scope(NULL, G_FAKINGEVAL);
6147 /* Verify that we don't need to save it: */
6148 assert(PL_curcop == &PL_compiling);
6149 StructCopy(&PL_compiling, ¬_compiling, COP);
6150 PL_curcop = ¬_compiling;
6151 /* The above ensures that we run with all the correct hints of the
6152 currently compiling COP, but that IN_PERL_RUNTIME is true. */
6153 assert(IN_PERL_RUNTIME);
6154 PL_warnhook = PERL_WARNHOOK_FATAL;
6157 /* Effective $^W=1. */
6158 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6159 PL_dowarn |= G_WARN_ON;
6161 ret = S_fold_constants_eval(aTHX);
6165 sv = *(PL_stack_sp--);
6166 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
6167 pad_swipe(o->op_targ, FALSE);
6169 else if (SvTEMP(sv)) { /* grab mortal temp? */
6170 SvREFCNT_inc_simple_void(sv);
6173 else { assert(SvIMMORTAL(sv)); }
6176 /* Something tried to die. Abandon constant folding. */
6177 /* Pretend the error never happened. */
6179 o->op_next = old_next;
6182 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
6183 PL_warnhook = oldwarnhook;
6184 PL_diehook = olddiehook;
6185 /* XXX note that this croak may fail as we've already blown away
6186 * the stack - eg any nested evals */
6187 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6189 PL_dowarn = oldwarn;
6190 PL_warnhook = oldwarnhook;
6191 PL_diehook = olddiehook;
6192 PL_curcop = &PL_compiling;
6194 /* if we croaked, depending on how we croaked the eval scope
6195 * may or may not have already been popped */
6196 if (cxstack_ix > old_cxix) {
6197 assert(cxstack_ix == old_cxix + 1);
6198 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6199 delete_eval_scope();
6204 /* OP_STRINGIFY and constant folding are used to implement qq.
6205 Here the constant folding is an implementation detail that we
6206 want to hide. If the stringify op is itself already marked
6207 folded, however, then it is actually a folded join. */
6208 is_stringify = type == OP_STRINGIFY && !o->op_folded;
6213 else if (!SvIMMORTAL(sv)) {
6217 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6218 if (!is_stringify) newop->op_folded = 1;
6225 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6226 * the constant value being an AV holding the flattened range.
6230 S_gen_constant_list(pTHX_ OP *o)
6232 OP *curop, *old_next;
6233 SV * const oldwarnhook = PL_warnhook;
6234 SV * const olddiehook = PL_diehook;
6236 U8 oldwarn = PL_dowarn;
6246 if (PL_parser && PL_parser->error_count)
6247 return; /* Don't attempt to run with errors */
6249 curop = LINKLIST(o);
6250 old_next = o->op_next;
6252 op_was_null = o->op_type == OP_NULL;
6253 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6254 o->op_type = OP_CUSTOM;
6257 o->op_type = OP_NULL;
6258 S_prune_chain_head(&curop);
6261 old_cxix = cxstack_ix;
6262 create_eval_scope(NULL, G_FAKINGEVAL);
6264 old_curcop = PL_curcop;
6265 StructCopy(old_curcop, ¬_compiling, COP);
6266 PL_curcop = ¬_compiling;
6267 /* The above ensures that we run with all the correct hints of the
6268 current COP, but that IN_PERL_RUNTIME is true. */
6269 assert(IN_PERL_RUNTIME);
6270 PL_warnhook = PERL_WARNHOOK_FATAL;
6274 /* Effective $^W=1. */
6275 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6276 PL_dowarn |= G_WARN_ON;
6280 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6281 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6283 Perl_pp_pushmark(aTHX);
6286 assert (!(curop->op_flags & OPf_SPECIAL));
6287 assert(curop->op_type == OP_RANGE);
6288 Perl_pp_anonlist(aTHX);
6292 o->op_next = old_next;
6296 PL_warnhook = oldwarnhook;
6297 PL_diehook = olddiehook;
6298 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6303 PL_dowarn = oldwarn;
6304 PL_warnhook = oldwarnhook;
6305 PL_diehook = olddiehook;
6306 PL_curcop = old_curcop;
6308 if (cxstack_ix > old_cxix) {
6309 assert(cxstack_ix == old_cxix + 1);
6310 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6311 delete_eval_scope();
6316 OpTYPE_set(o, OP_RV2AV);
6317 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6318 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6319 o->op_opt = 0; /* needs to be revisited in rpeep() */
6320 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6322 /* replace subtree with an OP_CONST */
6323 curop = ((UNOP*)o)->op_first;
6324 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6327 if (AvFILLp(av) != -1)
6328 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6331 SvREADONLY_on(*svp);
6339 =for apidoc_section Optree Manipulation Functions
6342 /* List constructors */
6345 =for apidoc op_append_elem
6347 Append an item to the list of ops contained directly within a list-type
6348 op, returning the lengthened list. C<first> is the list-type op,
6349 and C<last> is the op to append to the list. C<optype> specifies the
6350 intended opcode for the list. If C<first> is not already a list of the
6351 right type, it will be upgraded into one. If either C<first> or C<last>
6352 is null, the other is returned unchanged.
6358 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6366 if (first->op_type != (unsigned)type
6367 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6369 return newLISTOP(type, 0, first, last);
6372 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6373 first->op_flags |= OPf_KIDS;
6378 =for apidoc op_append_list
6380 Concatenate the lists of ops contained directly within two list-type ops,
6381 returning the combined list. C<first> and C<last> are the list-type ops
6382 to concatenate. C<optype> specifies the intended opcode for the list.
6383 If either C<first> or C<last> is not already a list of the right type,
6384 it will be upgraded into one. If either C<first> or C<last> is null,
6385 the other is returned unchanged.
6391 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6399 if (first->op_type != (unsigned)type)
6400 return op_prepend_elem(type, first, last);
6402 if (last->op_type != (unsigned)type)
6403 return op_append_elem(type, first, last);
6405 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6406 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6407 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6408 first->op_flags |= (last->op_flags & OPf_KIDS);
6410 S_op_destroy(aTHX_ last);
6416 =for apidoc op_prepend_elem
6418 Prepend an item to the list of ops contained directly within a list-type
6419 op, returning the lengthened list. C<first> is the op to prepend to the
6420 list, and C<last> is the list-type op. C<optype> specifies the intended
6421 opcode for the list. If C<last> is not already a list of the right type,
6422 it will be upgraded into one. If either C<first> or C<last> is null,
6423 the other is returned unchanged.
6429 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6437 if (last->op_type == (unsigned)type) {
6438 if (type == OP_LIST) { /* already a PUSHMARK there */
6439 /* insert 'first' after pushmark */
6440 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6441 if (!(first->op_flags & OPf_PARENS))
6442 last->op_flags &= ~OPf_PARENS;
6445 op_sibling_splice(last, NULL, 0, first);
6446 last->op_flags |= OPf_KIDS;
6450 return newLISTOP(type, 0, first, last);
6454 =for apidoc op_convert_list
6456 Converts C<o> into a list op if it is not one already, and then converts it
6457 into the specified C<type>, calling its check function, allocating a target if
6458 it needs one, and folding constants.
6460 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6461 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6462 C<op_convert_list> to make it the right type.
6468 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6470 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6471 if (!o || o->op_type != OP_LIST)
6472 o = force_list(o, 0);
6475 o->op_flags &= ~OPf_WANT;
6476 o->op_private &= ~OPpLVAL_INTRO;
6479 if (!(PL_opargs[type] & OA_MARK))
6480 op_null(cLISTOPo->op_first);
6482 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6483 if (kid2 && kid2->op_type == OP_COREARGS) {
6484 op_null(cLISTOPo->op_first);
6485 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6489 if (type != OP_SPLIT)
6490 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6491 * ck_split() create a real PMOP and leave the op's type as listop
6492 * for now. Otherwise op_free() etc will crash.
6494 OpTYPE_set(o, type);
6496 o->op_flags |= flags;
6497 if (flags & OPf_FOLDED)
6500 o = CHECKOP(type, o);
6501 if (o->op_type != (unsigned)type)
6504 return fold_constants(op_integerize(op_std_init(o)));
6511 =for apidoc_section Optree construction
6513 =for apidoc newNULLLIST
6515 Constructs, checks, and returns a new C<stub> op, which represents an
6516 empty list expression.
6522 Perl_newNULLLIST(pTHX)
6524 return newOP(OP_STUB, 0);
6527 /* promote o and any siblings to be a list if its not already; i.e.
6535 * pushmark - o - A - B
6537 * If nullit it true, the list op is nulled.
6541 S_force_list(pTHX_ OP *o, bool nullit)
6543 if (!o || o->op_type != OP_LIST) {
6546 /* manually detach any siblings then add them back later */
6547 rest = OpSIBLING(o);
6548 OpLASTSIB_set(o, NULL);
6550 o = newLISTOP(OP_LIST, 0, o, NULL);
6552 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6560 =for apidoc newLISTOP
6562 Constructs, checks, and returns an op of any list type. C<type> is
6563 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6564 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6565 supply up to two ops to be direct children of the list op; they are
6566 consumed by this function and become part of the constructed op tree.
6568 For most list operators, the check function expects all the kid ops to be
6569 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6570 appropriate. What you want to do in that case is create an op of type
6571 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6572 See L</op_convert_list> for more information.
6579 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6582 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6583 * pushmark is banned. So do it now while existing ops are in a
6584 * consistent state, in case they suddenly get freed */
6585 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6587 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6588 || type == OP_CUSTOM);
6590 NewOp(1101, listop, 1, LISTOP);
6591 OpTYPE_set(listop, type);
6594 listop->op_flags = (U8)flags;
6598 else if (!first && last)
6601 OpMORESIB_set(first, last);
6602 listop->op_first = first;
6603 listop->op_last = last;
6606 OpMORESIB_set(pushop, first);
6607 listop->op_first = pushop;
6608 listop->op_flags |= OPf_KIDS;
6610 listop->op_last = pushop;
6612 if (listop->op_last)
6613 OpLASTSIB_set(listop->op_last, (OP*)listop);
6615 return CHECKOP(type, listop);
6621 Constructs, checks, and returns an op of any base type (any type that
6622 has no extra fields). C<type> is the opcode. C<flags> gives the
6623 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6630 Perl_newOP(pTHX_ I32 type, I32 flags)
6634 if (type == -OP_ENTEREVAL) {
6635 type = OP_ENTEREVAL;
6636 flags |= OPpEVAL_BYTES<<8;
6639 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6640 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6641 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6642 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6644 NewOp(1101, o, 1, OP);
6645 OpTYPE_set(o, type);
6646 o->op_flags = (U8)flags;
6649 o->op_private = (U8)(0 | (flags >> 8));
6650 if (PL_opargs[type] & OA_RETSCALAR)
6652 if (PL_opargs[type] & OA_TARGET)
6653 o->op_targ = pad_alloc(type, SVs_PADTMP);
6654 return CHECKOP(type, o);
6660 Constructs, checks, and returns an op of any unary type. C<type> is
6661 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6662 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6663 bits, the eight bits of C<op_private>, except that the bit with value 1
6664 is automatically set. C<first> supplies an optional op to be the direct
6665 child of the unary op; it is consumed by this function and become part
6666 of the constructed op tree.
6668 =for apidoc Amnh||OPf_KIDS
6674 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6678 if (type == -OP_ENTEREVAL) {
6679 type = OP_ENTEREVAL;
6680 flags |= OPpEVAL_BYTES<<8;
6683 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6684 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6685 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6686 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6687 || type == OP_SASSIGN
6688 || type == OP_ENTERTRY
6689 || type == OP_CUSTOM
6690 || type == OP_NULL );
6693 first = newOP(OP_STUB, 0);
6694 if (PL_opargs[type] & OA_MARK)
6695 first = force_list(first, 1);
6697 NewOp(1101, unop, 1, UNOP);
6698 OpTYPE_set(unop, type);
6699 unop->op_first = first;
6700 unop->op_flags = (U8)(flags | OPf_KIDS);
6701 unop->op_private = (U8)(1 | (flags >> 8));
6703 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6704 OpLASTSIB_set(first, (OP*)unop);
6706 unop = (UNOP*) CHECKOP(type, unop);
6710 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6714 =for apidoc newUNOP_AUX
6716 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6717 initialised to C<aux>
6723 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6727 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6728 || type == OP_CUSTOM);
6730 NewOp(1101, unop, 1, UNOP_AUX);
6731 unop->op_type = (OPCODE)type;
6732 unop->op_ppaddr = PL_ppaddr[type];
6733 unop->op_first = first;
6734 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6735 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6738 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6739 OpLASTSIB_set(first, (OP*)unop);
6741 unop = (UNOP_AUX*) CHECKOP(type, unop);
6743 return op_std_init((OP *) unop);
6747 =for apidoc newMETHOP
6749 Constructs, checks, and returns an op of method type with a method name
6750 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6751 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6752 and, shifted up eight bits, the eight bits of C<op_private>, except that
6753 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6754 op which evaluates method name; it is consumed by this function and
6755 become part of the constructed op tree.
6756 Supported optypes: C<OP_METHOD>.
6762 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6765 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6766 || type == OP_CUSTOM);
6768 NewOp(1101, methop, 1, METHOP);
6770 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6771 methop->op_flags = (U8)(flags | OPf_KIDS);
6772 methop->op_u.op_first = dynamic_meth;
6773 methop->op_private = (U8)(1 | (flags >> 8));
6775 if (!OpHAS_SIBLING(dynamic_meth))
6776 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6780 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6781 methop->op_u.op_meth_sv = const_meth;
6782 methop->op_private = (U8)(0 | (flags >> 8));
6783 methop->op_next = (OP*)methop;
6787 methop->op_rclass_targ = 0;
6789 methop->op_rclass_sv = NULL;
6792 OpTYPE_set(methop, type);
6793 return CHECKOP(type, methop);
6797 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6798 PERL_ARGS_ASSERT_NEWMETHOP;
6799 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6803 =for apidoc newMETHOP_named
6805 Constructs, checks, and returns an op of method type with a constant
6806 method name. C<type> is the opcode. C<flags> gives the eight bits of
6807 C<op_flags>, and, shifted up eight bits, the eight bits of
6808 C<op_private>. C<const_meth> supplies a constant method name;
6809 it must be a shared COW string.
6810 Supported optypes: C<OP_METHOD_NAMED>.
6816 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6817 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6818 return newMETHOP_internal(type, flags, NULL, const_meth);
6822 =for apidoc newBINOP
6824 Constructs, checks, and returns an op of any binary type. C<type>
6825 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6826 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6827 the eight bits of C<op_private>, except that the bit with value 1 or
6828 2 is automatically set as required. C<first> and C<last> supply up to
6829 two ops to be the direct children of the binary op; they are consumed
6830 by this function and become part of the constructed op tree.
6836 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6840 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6841 || type == OP_NULL || type == OP_CUSTOM);
6843 NewOp(1101, binop, 1, BINOP);
6846 first = newOP(OP_NULL, 0);
6848 OpTYPE_set(binop, type);
6849 binop->op_first = first;
6850 binop->op_flags = (U8)(flags | OPf_KIDS);
6853 binop->op_private = (U8)(1 | (flags >> 8));
6856 binop->op_private = (U8)(2 | (flags >> 8));
6857 OpMORESIB_set(first, last);
6860 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6861 OpLASTSIB_set(last, (OP*)binop);
6863 binop->op_last = OpSIBLING(binop->op_first);
6865 OpLASTSIB_set(binop->op_last, (OP*)binop);
6867 binop = (BINOP*)CHECKOP(type, binop);
6868 if (binop->op_next || binop->op_type != (OPCODE)type)
6871 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6875 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
6877 const char indent[] = " ";
6879 UV len = _invlist_len(invlist);
6880 UV * array = invlist_array(invlist);
6883 PERL_ARGS_ASSERT_INVMAP_DUMP;
6885 for (i = 0; i < len; i++) {
6886 UV start = array[i];
6887 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
6889 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
6890 if (end == IV_MAX) {
6891 PerlIO_printf(Perl_debug_log, " .. INFTY");
6893 else if (end != start) {
6894 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
6897 PerlIO_printf(Perl_debug_log, " ");
6900 PerlIO_printf(Perl_debug_log, "\t");
6902 if (map[i] == TR_UNLISTED) {
6903 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
6905 else if (map[i] == TR_SPECIAL_HANDLING) {
6906 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
6909 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
6914 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6915 * containing the search and replacement strings, assemble into
6916 * a translation table attached as o->op_pv.
6917 * Free expr and repl.
6918 * It expects the toker to have already set the
6919 * OPpTRANS_COMPLEMENT
6922 * flags as appropriate; this function may add
6924 * OPpTRANS_CAN_FORCE_UTF8
6925 * OPpTRANS_IDENTICAL
6931 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6933 /* This function compiles a tr///, from data gathered from toke.c, into a
6934 * form suitable for use by do_trans() in doop.c at runtime.
6936 * It first normalizes the data, while discarding extraneous inputs; then
6937 * writes out the compiled data. The normalization allows for complete
6938 * analysis, and avoids some false negatives and positives earlier versions
6941 * The normalization form is an inversion map (described below in detail).
6942 * This is essentially the compiled form for tr///'s that require UTF-8,
6943 * and its easy to use it to write the 257-byte table for tr///'s that
6944 * don't need UTF-8. That table is identical to what's been in use for
6945 * many perl versions, except that it doesn't handle some edge cases that
6946 * it used to, involving code points above 255. The UTF-8 form now handles
6947 * these. (This could be changed with extra coding should it shown to be
6950 * If the complement (/c) option is specified, the lhs string (tstr) is
6951 * parsed into an inversion list. Complementing these is trivial. Then a
6952 * complemented tstr is built from that, and used thenceforth. This hides
6953 * the fact that it was complemented from almost all successive code.
6955 * One of the important characteristics to know about the input is whether
6956 * the transliteration may be done in place, or does a temporary need to be
6957 * allocated, then copied. If the replacement for every character in every
6958 * possible string takes up no more bytes than the character it
6959 * replaces, then it can be edited in place. Otherwise the replacement
6960 * could overwrite a byte we are about to read, depending on the strings
6961 * being processed. The comments and variable names here refer to this as
6962 * "growing". Some inputs won't grow, and might even shrink under /d, but
6963 * some inputs could grow, so we have to assume any given one might grow.
6964 * On very long inputs, the temporary could eat up a lot of memory, so we
6965 * want to avoid it if possible. For non-UTF-8 inputs, everything is
6966 * single-byte, so can be edited in place, unless there is something in the
6967 * pattern that could force it into UTF-8. The inversion map makes it
6968 * feasible to determine this. Previous versions of this code pretty much
6969 * punted on determining if UTF-8 could be edited in place. Now, this code
6970 * is rigorous in making that determination.
6972 * Another characteristic we need to know is whether the lhs and rhs are
6973 * identical. If so, and no other flags are present, the only effect of
6974 * the tr/// is to count the characters present in the input that are
6975 * mentioned in the lhs string. The implementation of that is easier and
6976 * runs faster than the more general case. Normalizing here allows for
6977 * accurate determination of this. Previously there were false negatives
6980 * Instead of 'transliterated', the comments here use 'unmapped' for the
6981 * characters that are left unchanged by the operation; otherwise they are
6984 * The lhs of the tr/// is here referred to as the t side.
6985 * The rhs of the tr/// is here referred to as the r side.
6988 SV * const tstr = ((SVOP*)expr)->op_sv;
6989 SV * const rstr = ((SVOP*)repl)->op_sv;
6992 const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
6993 const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
6996 UV t_count = 0, r_count = 0; /* Number of characters in search and
6997 replacement lists */
6999 /* khw thinks some of the private flags for this op are quaintly named.
7000 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
7001 * character when represented in UTF-8 is longer than the original
7002 * character's UTF-8 representation */
7003 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
7004 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
7005 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
7007 /* Set to true if there is some character < 256 in the lhs that maps to
7008 * above 255. If so, a non-UTF-8 match string can be forced into being in
7009 * UTF-8 by a tr/// operation. */
7010 bool can_force_utf8 = FALSE;
7012 /* What is the maximum expansion factor in UTF-8 transliterations. If a
7013 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
7014 * expansion factor is 1.5. This number is used at runtime to calculate
7015 * how much space to allocate for non-inplace transliterations. Without
7016 * this number, the worst case is 14, which is extremely unlikely to happen
7017 * in real life, and could require significant memory overhead. */
7018 NV max_expansion = 1.;
7020 UV t_range_count, r_range_count, min_range_count;
7025 UV t_cp_end = (UV) -1;
7029 UV final_map = TR_UNLISTED; /* The final character in the replacement
7030 list, updated as we go along. Initialize
7031 to something illegal */
7033 bool rstr_utf8 = cBOOL(SvUTF8(rstr));
7034 bool tstr_utf8 = cBOOL(SvUTF8(tstr));
7036 const U8* tend = t + tlen;
7037 const U8* rend = r + rlen;
7039 SV * inverted_tstr = NULL;
7044 /* This routine implements detection of a transliteration having a longer
7045 * UTF-8 representation than its source, by partitioning all the possible
7046 * code points of the platform into equivalence classes of the same UTF-8
7047 * byte length in the first pass. As it constructs the mappings, it carves
7048 * these up into smaller chunks, but doesn't merge any together. This
7049 * makes it easy to find the instances it's looking for. A second pass is
7050 * done after this has been determined which merges things together to
7051 * shrink the table for runtime. The table below is used for both ASCII
7052 * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically
7053 * increasing for code points below 256. To correct for that, the macro
7054 * CP_ADJUST defined below converts those code points to ASCII in the first
7055 * pass, and we use the ASCII partition values. That works because the
7056 * growth factor will be unaffected, which is all that is calculated during
7057 * the first pass. */
7058 UV PL_partition_by_byte_length[] = {
7060 0x80, /* Below this is 1 byte representations */
7061 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */
7062 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */
7063 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */
7064 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */
7065 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */
7069 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */
7074 PERL_ARGS_ASSERT_PMTRANS;
7076 PL_hints |= HINT_BLOCK_SCOPE;
7078 /* If /c, the search list is sorted and complemented. This is now done by
7079 * creating an inversion list from it, and then trivially inverting that.
7080 * The previous implementation used qsort, but creating the list
7081 * automatically keeps it sorted as we go along */
7084 SV * inverted_tlist = _new_invlist(tlen);
7087 DEBUG_y(PerlIO_printf(Perl_debug_log,
7088 "%s: %d: tstr before inversion=\n%s\n",
7089 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7093 /* Non-utf8 strings don't have ranges, so each character is listed
7096 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
7099 else { /* But UTF-8 strings have been parsed in toke.c to have
7100 * ranges if appropriate. */
7104 /* Get the first character */
7105 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7108 /* If the next byte indicates that this wasn't the first
7109 * element of a range, the range is just this one */
7110 if (t >= tend || *t != RANGE_INDICATOR) {
7111 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
7113 else { /* Otherwise, ignore the indicator byte, and get the
7114 final element, and add the whole range */
7116 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
7119 inverted_tlist = _add_range_to_invlist(inverted_tlist,
7123 } /* End of parse through tstr */
7125 /* The inversion list is done; now invert it */
7126 _invlist_invert(inverted_tlist);
7128 /* Now go through the inverted list and create a new tstr for the rest
7129 * of the routine to use. Since the UTF-8 version can have ranges, and
7130 * can be much more compact than the non-UTF-8 version, we create the
7131 * string in UTF-8 even if not necessary. (This is just an intermediate
7132 * value that gets thrown away anyway.) */
7133 invlist_iterinit(inverted_tlist);
7134 inverted_tstr = newSVpvs("");
7135 while (invlist_iternext(inverted_tlist, &start, &end)) {
7136 U8 temp[UTF8_MAXBYTES];
7139 /* IV_MAX keeps things from going out of bounds */
7140 start = MIN(IV_MAX, start);
7141 end = MIN(IV_MAX, end);
7143 temp_end_pos = uvchr_to_utf8(temp, start);
7144 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7147 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
7148 temp_end_pos = uvchr_to_utf8(temp, end);
7149 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7153 /* Set up so the remainder of the routine uses this complement, instead
7154 * of the actual input */
7155 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
7156 tend = t0 + temp_len;
7159 SvREFCNT_dec_NN(inverted_tlist);
7162 /* For non-/d, an empty rhs means to use the lhs */
7163 if (rlen == 0 && ! del) {
7166 rstr_utf8 = tstr_utf8;
7169 t_invlist = _new_invlist(1);
7171 /* Initialize to a single range */
7172 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7174 /* For the first pass, the lhs is partitioned such that the
7175 * number of UTF-8 bytes required to represent a code point in each
7176 * partition is the same as the number for any other code point in
7177 * that partion. We copy the pre-compiled partion. */
7178 len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
7179 invlist_extend(t_invlist, len);
7180 t_array = invlist_array(t_invlist);
7181 Copy(PL_partition_by_byte_length, t_array, len, UV);
7182 invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
7183 Newx(r_map, len + 1, UV);
7185 /* Parse the (potentially adjusted) input, creating the inversion map.
7186 * This is done in two passes. The first pass is to determine if the
7187 * transliteration can be done in place. The inversion map it creates
7188 * could be used, but generally would be larger and slower to run than the
7189 * output of the second pass, which starts with a more compact table and
7190 * allows more ranges to be merged */
7191 for (pass2 = 0; pass2 < 2; pass2++) {
7193 /* Initialize to a single range */
7194 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7196 /* In the second pass, we just have the single range */
7198 t_array = invlist_array(t_invlist);
7201 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
7202 * so as to get the well-behaved length 1 vs length 2 boundary. Only code
7203 * points below 256 differ between the two character sets in this regard. For
7204 * these, we also can't have any ranges, as they have to be individually
7207 # define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x))
7208 # define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256))
7209 # define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
7211 # define CP_ADJUST(x) (x)
7212 # define FORCE_RANGE_LEN_1(x) 0
7213 # define CP_SKIP(x) UVCHR_SKIP(x)
7216 /* And the mapping of each of the ranges is initialized. Initially,
7217 * everything is TR_UNLISTED. */
7218 for (i = 0; i < len; i++) {
7219 r_map[i] = TR_UNLISTED;
7226 t_range_count = r_range_count = 0;
7228 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
7229 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7230 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
7231 _byte_dump_string(r, rend - r, 0)));
7232 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
7233 complement, squash, del));
7234 DEBUG_y(invmap_dump(t_invlist, r_map));
7236 /* Now go through the search list constructing an inversion map. The
7237 * input is not necessarily in any particular order. Making it an
7238 * inversion map orders it, potentially simplifying, and makes it easy
7239 * to deal with at run time. This is the only place in core that
7240 * generates an inversion map; if others were introduced, it might be
7241 * better to create general purpose routines to handle them.
7242 * (Inversion maps are created in perl in other places.)
7244 * An inversion map consists of two parallel arrays. One is
7245 * essentially an inversion list: an ordered list of code points such
7246 * that each element gives the first code point of a range of
7247 * consecutive code points that map to the element in the other array
7248 * that has the same index as this one (in other words, the
7249 * corresponding element). Thus the range extends up to (but not
7250 * including) the code point given by the next higher element. In a
7251 * true inversion map, the corresponding element in the other array
7252 * gives the mapping of the first code point in the range, with the
7253 * understanding that the next higher code point in the inversion
7254 * list's range will map to the next higher code point in the map.
7256 * So if at element [i], let's say we have:
7261 * This means that A => a, B => b, C => c.... Let's say that the
7262 * situation is such that:
7266 * This means the sequence that started at [i] stops at K => k. This
7267 * illustrates that you need to look at the next element to find where
7268 * a sequence stops. Except, the highest element in the inversion list
7269 * begins a range that is understood to extend to the platform's
7272 * This routine modifies traditional inversion maps to reserve two
7275 * TR_UNLISTED (or -1) indicates that no code point in the range
7276 * is listed in the tr/// searchlist. At runtime, these are
7277 * always passed through unchanged. In the inversion map, all
7278 * points in the range are mapped to -1, instead of increasing,
7279 * like the 'L' in the example above.
7281 * We start the parse with every code point mapped to this, and as
7282 * we parse and find ones that are listed in the search list, we
7283 * carve out ranges as we go along that override that.
7285 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
7286 * range needs special handling. Again, all code points in the
7287 * range are mapped to -2, instead of increasing.
7289 * Under /d this value means the code point should be deleted from
7290 * the transliteration when encountered.
7292 * Otherwise, it marks that every code point in the range is to
7293 * map to the final character in the replacement list. This
7294 * happens only when the replacement list is shorter than the
7295 * search one, so there are things in the search list that have no
7296 * correspondence in the replacement list. For example, in
7297 * tr/a-z/A/, 'A' is the final value, and the inversion map
7298 * generated for this would be like this:
7303 * 'A' appears once, then the remainder of the range maps to -2.
7304 * The use of -2 isn't strictly necessary, as an inversion map is
7305 * capable of representing this situation, but not nearly so
7306 * compactly, and this is actually quite commonly encountered.
7307 * Indeed, the original design of this code used a full inversion
7308 * map for this. But things like
7310 * generated huge data structures, slowly, and the execution was
7311 * also slow. So the current scheme was implemented.
7313 * So, if the next element in our example is:
7317 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next
7321 * [i+4] S TR_UNLISTED
7323 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is
7324 * the final element in the arrays, every code point from S to infinity
7325 * maps to TR_UNLISTED.
7328 /* Finish up range started in what otherwise would
7329 * have been the final iteration */
7330 while (t < tend || t_range_count > 0) {
7331 bool adjacent_to_range_above = FALSE;
7332 bool adjacent_to_range_below = FALSE;
7334 bool merge_with_range_above = FALSE;
7335 bool merge_with_range_below = FALSE;
7337 UV span, invmap_range_length_remaining;
7341 /* If we are in the middle of processing a range in the 'target'
7342 * side, the previous iteration has set us up. Otherwise, look at
7343 * the next character in the search list */
7344 if (t_range_count <= 0) {
7347 /* Here, not in the middle of a range, and not UTF-8. The
7348 * next code point is the single byte where we're at */
7349 t_cp = CP_ADJUST(*t);
7356 /* Here, not in the middle of a range, and is UTF-8. The
7357 * next code point is the next UTF-8 char in the input. We
7358 * know the input is valid, because the toker constructed
7360 t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
7363 /* UTF-8 strings (only) have been parsed in toke.c to have
7364 * ranges. See if the next byte indicates that this was
7365 * the first element of a range. If so, get the final
7366 * element and calculate the range size. If not, the range
7368 if ( t < tend && *t == RANGE_INDICATOR
7369 && ! FORCE_RANGE_LEN_1(t_cp))
7372 t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
7381 /* Count the total number of listed code points * */
7382 t_count += t_range_count;
7385 /* Similarly, get the next character in the replacement list */
7386 if (r_range_count <= 0) {
7389 /* But if we've exhausted the rhs, there is nothing to map
7390 * to, except the special handling one, and we make the
7391 * range the same size as the lhs one. */
7392 r_cp = TR_SPECIAL_HANDLING;
7393 r_range_count = t_range_count;
7396 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7397 "final_map =%" UVXf "\n", final_map));
7402 r_cp = CP_ADJUST(*r);
7409 r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
7411 if ( r < rend && *r == RANGE_INDICATOR
7412 && ! FORCE_RANGE_LEN_1(r_cp))
7415 r_range_count = valid_utf8_to_uvchr(r,
7416 &r_char_len) - r_cp + 1;
7424 if (r_cp == TR_SPECIAL_HANDLING) {
7425 r_range_count = t_range_count;
7428 /* This is the final character so far */
7429 final_map = r_cp + r_range_count - 1;
7431 r_count += r_range_count;
7435 /* Here, we have the next things ready in both sides. They are
7436 * potentially ranges. We try to process as big a chunk as
7437 * possible at once, but the lhs and rhs must be synchronized, so
7438 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
7440 min_range_count = MIN(t_range_count, r_range_count);
7442 /* Search the inversion list for the entry that contains the input
7443 * code point <cp>. The inversion map was initialized to cover the
7444 * entire range of possible inputs, so this should not fail. So
7445 * the return value is the index into the list's array of the range
7446 * that contains <cp>, that is, 'i' such that array[i] <= cp <
7448 j = _invlist_search(t_invlist, t_cp);
7452 /* Here, the data structure might look like:
7455 * [i-1] J j # J-L => j-l
7456 * [i] M -1 # M => default; as do N, O, P, Q
7457 * [i+1] R x # R => x, S => x+1, T => x+2
7458 * [i+2] U y # U => y, V => y+1, ...
7460 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7462 * where 'x' and 'y' above are not to be taken literally.
7464 * The maximum chunk we can handle in this loop iteration, is the
7465 * smallest of the three components: the lhs 't_', the rhs 'r_',
7466 * and the remainder of the range in element [i]. (In pass 1, that
7467 * range will have everything in it be of the same class; we can't
7468 * cross into another class.) 'min_range_count' already contains
7469 * the smallest of the first two values. The final one is
7470 * irrelevant if the map is to the special indicator */
7472 invmap_range_length_remaining = (i + 1 < len)
7473 ? t_array[i+1] - t_cp
7475 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
7477 /* The end point of this chunk is where we are, plus the span, but
7478 * never larger than the platform's infinity */
7479 t_cp_end = MIN(IV_MAX, t_cp + span - 1);
7481 if (r_cp == TR_SPECIAL_HANDLING) {
7483 /* If unmatched lhs code points map to the final map, use that
7484 * value. This being set to TR_SPECIAL_HANDLING indicates that
7485 * we don't have a final map: unmatched lhs code points are
7487 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
7490 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
7492 /* If something on the lhs is below 256, and something on the
7493 * rhs is above, there is a potential mapping here across that
7494 * boundary. Indeed the only way there isn't is if both sides
7495 * start at the same point. That means they both cross at the
7496 * same time. But otherwise one crosses before the other */
7497 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
7498 can_force_utf8 = TRUE;
7502 /* If a character appears in the search list more than once, the
7503 * 2nd and succeeding occurrences are ignored, so only do this
7504 * range if haven't already processed this character. (The range
7505 * has been set up so that all members in it will be of the same
7507 if (r_map[i] == TR_UNLISTED) {
7508 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7509 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
7510 t_cp, t_cp_end, r_cp, r_cp_end));
7512 /* This is the first definition for this chunk, hence is valid
7513 * and needs to be processed. Here and in the comments below,
7514 * we use the above sample data. The t_cp chunk must be any
7515 * contiguous subset of M, N, O, P, and/or Q.
7517 * In the first pass, calculate if there is any possible input
7518 * string that has a character whose transliteration will be
7519 * longer than it. If none, the transliteration may be done
7520 * in-place, as it can't write over a so-far unread byte.
7521 * Otherwise, a copy must first be made. This could be
7522 * expensive for long inputs.
7524 * In the first pass, the t_invlist has been partitioned so
7525 * that all elements in any single range have the same number
7526 * of bytes in their UTF-8 representations. And the r space is
7527 * either a single byte, or a range of strictly monotonically
7528 * increasing code points. So the final element in the range
7529 * will be represented by no fewer bytes than the initial one.
7530 * That means that if the final code point in the t range has
7531 * at least as many bytes as the final code point in the r,
7532 * then all code points in the t range have at least as many
7533 * bytes as their corresponding r range element. But if that's
7534 * not true, the transliteration of at least the final code
7535 * point grows in length. As an example, suppose we had
7536 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
7537 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
7538 * platforms. We have deliberately set up the data structure
7539 * so that any range in the lhs gets split into chunks for
7540 * processing, such that every code point in a chunk has the
7541 * same number of UTF-8 bytes. We only have to check the final
7542 * code point in the rhs against any code point in the lhs. */
7544 && r_cp_end != TR_SPECIAL_HANDLING
7545 && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
7547 /* Here, we will need to make a copy of the input string
7548 * before doing the transliteration. The worst possible
7549 * case is an expansion ratio of 14:1. This is rare, and
7550 * we'd rather allocate only the necessary amount of extra
7551 * memory for that copy. We can calculate the worst case
7552 * for this particular transliteration is by keeping track
7553 * of the expansion factor for each range.
7555 * Consider tr/\xCB/\X{E000}/. The maximum expansion
7556 * factor is 1 byte going to 3 if the target string is not
7557 * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We
7558 * could pass two different values so doop could choose
7559 * based on the UTF-8ness of the target. But khw thinks
7560 * (perhaps wrongly) that is overkill. It is used only to
7561 * make sure we malloc enough space.
7563 * If no target string can force the result to be UTF-8,
7564 * then we don't have to worry about the case of the target
7565 * string not being UTF-8 */
7566 NV t_size = (can_force_utf8 && t_cp < 256)
7568 : CP_SKIP(t_cp_end);
7569 NV ratio = CP_SKIP(r_cp_end) / t_size;
7571 o->op_private |= OPpTRANS_GROWS;
7573 /* Now that we know it grows, we can keep track of the
7575 if (ratio > max_expansion) {
7576 max_expansion = ratio;
7577 DEBUG_y(PerlIO_printf(Perl_debug_log,
7578 "New expansion factor: %" NVgf "\n",
7583 /* The very first range is marked as adjacent to the
7584 * non-existent range below it, as it causes things to "just
7587 * If the lowest code point in this chunk is M, it adjoins the
7589 if (t_cp == t_array[i]) {
7590 adjacent_to_range_below = TRUE;
7592 /* And if the map has the same offset from the beginning of
7593 * the range as does this new code point (or both are for
7594 * TR_SPECIAL_HANDLING), this chunk can be completely
7595 * merged with the range below. EXCEPT, in the first pass,
7596 * we don't merge ranges whose UTF-8 byte representations
7597 * have different lengths, so that we can more easily
7598 * detect if a replacement is longer than the source, that
7599 * is if it 'grows'. But in the 2nd pass, there's no
7600 * reason to not merge */
7601 if ( (i > 0 && ( pass2
7602 || CP_SKIP(t_array[i-1])
7604 && ( ( r_cp == TR_SPECIAL_HANDLING
7605 && r_map[i-1] == TR_SPECIAL_HANDLING)
7606 || ( r_cp != TR_SPECIAL_HANDLING
7607 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
7609 merge_with_range_below = TRUE;
7613 /* Similarly, if the highest code point in this chunk is 'Q',
7614 * it adjoins the range above, and if the map is suitable, can
7615 * be merged with it */
7616 if ( t_cp_end >= IV_MAX - 1
7618 && t_cp_end + 1 == t_array[i+1]))
7620 adjacent_to_range_above = TRUE;
7623 || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
7624 && ( ( r_cp == TR_SPECIAL_HANDLING
7625 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
7626 || ( r_cp != TR_SPECIAL_HANDLING
7627 && r_cp_end == r_map[i+1] - 1)))
7629 merge_with_range_above = TRUE;
7633 if (merge_with_range_below && merge_with_range_above) {
7635 /* Here the new chunk looks like M => m, ... Q => q; and
7636 * the range above is like R => r, .... Thus, the [i-1]
7637 * and [i+1] ranges should be seamlessly melded so the
7640 * [i-1] J j # J-T => j-t
7641 * [i] U y # U => y, V => y+1, ...
7643 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7645 Move(t_array + i + 2, t_array + i, len - i - 2, UV);
7646 Move(r_map + i + 2, r_map + i, len - i - 2, UV);
7648 invlist_set_len(t_invlist,
7650 *(get_invlist_offset_addr(t_invlist)));
7652 else if (merge_with_range_below) {
7654 /* Here the new chunk looks like M => m, .... But either
7655 * (or both) it doesn't extend all the way up through Q; or
7656 * the range above doesn't start with R => r. */
7657 if (! adjacent_to_range_above) {
7659 /* In the first case, let's say the new chunk extends
7660 * through O. We then want:
7662 * [i-1] J j # J-O => j-o
7663 * [i] P -1 # P => -1, Q => -1
7664 * [i+1] R x # R => x, S => x+1, T => x+2
7665 * [i+2] U y # U => y, V => y+1, ...
7667 * [-1] Z -1 # Z => default; as do Z+1, ...
7670 t_array[i] = t_cp_end + 1;
7671 r_map[i] = TR_UNLISTED;
7673 else { /* Adjoins the range above, but can't merge with it
7674 (because 'x' is not the next map after q) */
7676 * [i-1] J j # J-Q => j-q
7677 * [i] R x # R => x, S => x+1, T => x+2
7678 * [i+1] U y # U => y, V => y+1, ...
7680 * [-1] Z -1 # Z => default; as do Z+1, ...
7684 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7685 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7687 invlist_set_len(t_invlist, len,
7688 *(get_invlist_offset_addr(t_invlist)));
7691 else if (merge_with_range_above) {
7693 /* Here the new chunk ends with Q => q, and the range above
7694 * must start with R => r, so the two can be merged. But
7695 * either (or both) the new chunk doesn't extend all the
7696 * way down to M; or the mapping of the final code point
7697 * range below isn't m */
7698 if (! adjacent_to_range_below) {
7700 /* In the first case, let's assume the new chunk starts
7701 * with P => p. Then, because it's merge-able with the
7702 * range above, that range must be R => r. We want:
7704 * [i-1] J j # J-L => j-l
7705 * [i] M -1 # M => -1, N => -1
7706 * [i+1] P p # P-T => p-t
7707 * [i+2] U y # U => y, V => y+1, ...
7709 * [-1] Z -1 # Z => default; as do Z+1, ...
7712 t_array[i+1] = t_cp;
7715 else { /* Adjoins the range below, but can't merge with it
7718 * [i-1] J j # J-L => j-l
7719 * [i] M x # M-T => x-5 .. x+2
7720 * [i+1] U y # U => y, V => y+1, ...
7722 * [-1] Z -1 # Z => default; as do Z+1, ...
7725 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7726 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7730 invlist_set_len(t_invlist, len,
7731 *(get_invlist_offset_addr(t_invlist)));
7734 else if (adjacent_to_range_below && adjacent_to_range_above) {
7735 /* The new chunk completely fills the gap between the
7736 * ranges on either side, but can't merge with either of
7739 * [i-1] J j # J-L => j-l
7740 * [i] M z # M => z, N => z+1 ... Q => z+4
7741 * [i+1] R x # R => x, S => x+1, T => x+2
7742 * [i+2] U y # U => y, V => y+1, ...
7744 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7748 else if (adjacent_to_range_below) {
7749 /* The new chunk adjoins the range below, but not the range
7750 * above, and can't merge. Let's assume the chunk ends at
7753 * [i-1] J j # J-L => j-l
7754 * [i] M z # M => z, N => z+1, O => z+2
7755 * [i+1] P -1 # P => -1, Q => -1
7756 * [i+2] R x # R => x, S => x+1, T => x+2
7757 * [i+3] U y # U => y, V => y+1, ...
7759 * [-w] Z -1 # Z => default; as do Z+1, ... infinity
7761 invlist_extend(t_invlist, len + 1);
7762 t_array = invlist_array(t_invlist);
7763 Renew(r_map, len + 1, UV);
7765 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7766 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7768 t_array[i+1] = t_cp_end + 1;
7769 r_map[i+1] = TR_UNLISTED;
7771 invlist_set_len(t_invlist, len,
7772 *(get_invlist_offset_addr(t_invlist)));
7774 else if (adjacent_to_range_above) {
7775 /* The new chunk adjoins the range above, but not the range
7776 * below, and can't merge. Let's assume the new chunk
7779 * [i-1] J j # J-L => j-l
7780 * [i] M -1 # M => default, N => default
7781 * [i+1] O z # O => z, P => z+1, Q => z+2
7782 * [i+2] R x # R => x, S => x+1, T => x+2
7783 * [i+3] U y # U => y, V => y+1, ...
7785 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7787 invlist_extend(t_invlist, len + 1);
7788 t_array = invlist_array(t_invlist);
7789 Renew(r_map, len + 1, UV);
7791 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7792 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7793 t_array[i+1] = t_cp;
7796 invlist_set_len(t_invlist, len,
7797 *(get_invlist_offset_addr(t_invlist)));
7800 /* The new chunk adjoins neither the range above, nor the
7801 * range below. Lets assume it is N..P => n..p
7803 * [i-1] J j # J-L => j-l
7804 * [i] M -1 # M => default
7805 * [i+1] N n # N..P => n..p
7806 * [i+2] Q -1 # Q => default
7807 * [i+3] R x # R => x, S => x+1, T => x+2
7808 * [i+4] U y # U => y, V => y+1, ...
7810 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7813 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7814 "Before fixing up: len=%d, i=%d\n",
7815 (int) len, (int) i));
7816 DEBUG_yv(invmap_dump(t_invlist, r_map));
7818 invlist_extend(t_invlist, len + 2);
7819 t_array = invlist_array(t_invlist);
7820 Renew(r_map, len + 2, UV);
7822 Move(t_array + i + 1,
7823 t_array + i + 2 + 1, len - i - (2 - 1), UV);
7825 r_map + i + 2 + 1, len - i - (2 - 1), UV);
7828 invlist_set_len(t_invlist, len,
7829 *(get_invlist_offset_addr(t_invlist)));
7831 t_array[i+1] = t_cp;
7834 t_array[i+2] = t_cp_end + 1;
7835 r_map[i+2] = TR_UNLISTED;
7837 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7838 "After iteration: span=%" UVuf ", t_range_count=%"
7839 UVuf " r_range_count=%" UVuf "\n",
7840 span, t_range_count, r_range_count));
7841 DEBUG_yv(invmap_dump(t_invlist, r_map));
7842 } /* End of this chunk needs to be processed */
7844 /* Done with this chunk. */
7846 if (t_cp >= IV_MAX) {
7849 t_range_count -= span;
7850 if (r_cp != TR_SPECIAL_HANDLING) {
7852 r_range_count -= span;
7858 } /* End of loop through the search list */
7860 /* We don't need an exact count, but we do need to know if there is
7861 * anything left over in the replacement list. So, just assume it's
7862 * one byte per character */
7866 } /* End of passes */
7868 SvREFCNT_dec(inverted_tstr);
7870 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
7871 DEBUG_y(invmap_dump(t_invlist, r_map));
7873 /* We now have normalized the input into an inversion map.
7875 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op
7876 * except for the count, and streamlined runtime code can be used */
7877 if (!del && !squash) {
7879 /* They are identical if they point to same address, or if everything
7880 * maps to UNLISTED or to itself. This catches things that not looking
7881 * at the normalized inversion map doesn't catch, like tr/aa/ab/ or
7882 * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */
7884 for (i = 0; i < len; i++) {
7885 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
7886 goto done_identical_check;
7891 /* Here have gone through entire list, and didn't find any
7892 * non-identical mappings */
7893 o->op_private |= OPpTRANS_IDENTICAL;
7895 done_identical_check: ;
7898 t_array = invlist_array(t_invlist);
7900 /* If has components above 255, we generally need to use the inversion map
7904 && t_array[len-1] > 255
7905 /* If the final range is 0x100-INFINITY and is a special
7906 * mapping, the table implementation can handle it */
7907 && ! ( t_array[len-1] == 256
7908 && ( r_map[len-1] == TR_UNLISTED
7909 || r_map[len-1] == TR_SPECIAL_HANDLING))))
7913 /* A UTF-8 op is generated, indicated by this flag. This op is an
7915 o->op_private |= OPpTRANS_USE_SVOP;
7917 if (can_force_utf8) {
7918 o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
7921 /* The inversion map is pushed; first the list. */
7922 invmap = MUTABLE_AV(newAV());
7923 av_push(invmap, t_invlist);
7925 /* 2nd is the mapping */
7926 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
7927 av_push(invmap, r_map_sv);
7929 /* 3rd is the max possible expansion factor */
7930 av_push(invmap, newSVnv(max_expansion));
7932 /* Characters that are in the search list, but not in the replacement
7933 * list are mapped to the final character in the replacement list */
7934 if (! del && r_count < t_count) {
7935 av_push(invmap, newSVuv(final_map));
7939 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
7940 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
7941 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
7942 SvPADTMP_on(invmap);
7943 SvREADONLY_on(invmap);
7945 cSVOPo->op_sv = (SV *) invmap;
7953 /* The OPtrans_map struct already contains one slot; hence the -1. */
7954 SSize_t struct_size = sizeof(OPtrans_map)
7955 + (256 - 1 + 1)*sizeof(short);
7957 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
7958 * table. Entries with the value TR_UNMAPPED indicate chars not to be
7959 * translated, while TR_DELETE indicates a search char without a
7960 * corresponding replacement char under /d.
7962 * In addition, an extra slot at the end is used to store the final
7963 * repeating char, or TR_R_EMPTY under an empty replacement list, or
7964 * TR_DELETE under /d; which makes the runtime code easier.
7967 /* Indicate this is an op_pv */
7968 o->op_private &= ~OPpTRANS_USE_SVOP;
7970 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7972 cPVOPo->op_pv = (char*)tbl;
7974 for (i = 0; i < len; i++) {
7975 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7976 short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7977 short to = (short) r_map[i];
7979 bool do_increment = TRUE;
7981 /* Any code points above our limit should be irrelevant */
7982 if (t_array[i] >= tbl->size) break;
7984 /* Set up the map */
7985 if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7986 to = (short) final_map;
7987 do_increment = FALSE;
7990 do_increment = FALSE;
7993 /* Create a map for everything in this range. The value increases
7994 * except for the special cases */
7995 for (j = (short) t_array[i]; j < upper; j++) {
7997 if (do_increment) to++;
8001 tbl->map[tbl->size] = del
8005 : (short) TR_R_EMPTY;
8006 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
8007 for (i = 0; i < tbl->size; i++) {
8008 if (tbl->map[i] < 0) {
8009 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
8010 (unsigned) i, tbl->map[i]));
8013 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
8014 (unsigned) i, tbl->map[i]));
8016 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
8017 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
8020 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
8021 (unsigned) tbl->size, tbl->map[tbl->size]));
8023 SvREFCNT_dec(t_invlist);
8025 #if 0 /* code that added excess above-255 chars at the end of the table, in
8026 case we ever want to not use the inversion map implementation for
8033 /* More replacement chars than search chars:
8034 * store excess replacement chars at end of main table.
8037 struct_size += excess;
8038 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
8039 struct_size + excess * sizeof(short));
8040 tbl->size += excess;
8041 cPVOPo->op_pv = (char*)tbl;
8043 for (i = 0; i < excess; i++)
8044 tbl->map[i + 256] = r[j+i];
8047 /* no more replacement chars than search chars */
8053 DEBUG_y(PerlIO_printf(Perl_debug_log,
8054 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
8055 " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
8056 del, squash, complement,
8057 cBOOL(o->op_private & OPpTRANS_IDENTICAL),
8058 cBOOL(o->op_private & OPpTRANS_USE_SVOP),
8059 cBOOL(o->op_private & OPpTRANS_GROWS),
8060 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
8065 if(del && rlen != 0 && r_count == t_count) {
8066 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
8067 } else if(r_count > t_count) {
8068 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
8081 Constructs, checks, and returns an op of any pattern matching type.
8082 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
8083 and, shifted up eight bits, the eight bits of C<op_private>.
8089 Perl_newPMOP(pTHX_ I32 type, I32 flags)
8093 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
8094 || type == OP_CUSTOM);
8096 NewOp(1101, pmop, 1, PMOP);
8097 OpTYPE_set(pmop, type);
8098 pmop->op_flags = (U8)flags;
8099 pmop->op_private = (U8)(0 | (flags >> 8));
8100 if (PL_opargs[type] & OA_RETSCALAR)
8103 if (PL_hints & HINT_RE_TAINT)
8104 pmop->op_pmflags |= PMf_RETAINT;
8105 #ifdef USE_LOCALE_CTYPE
8106 if (IN_LC_COMPILETIME(LC_CTYPE)) {
8107 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
8112 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
8114 if (PL_hints & HINT_RE_FLAGS) {
8115 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8116 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
8118 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
8119 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8120 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
8122 if (reflags && SvOK(reflags)) {
8123 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
8129 assert(SvPOK(PL_regex_pad[0]));
8130 if (SvCUR(PL_regex_pad[0])) {
8131 /* Pop off the "packed" IV from the end. */
8132 SV *const repointer_list = PL_regex_pad[0];
8133 const char *p = SvEND(repointer_list) - sizeof(IV);
8134 const IV offset = *((IV*)p);
8136 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
8138 SvEND_set(repointer_list, p);
8140 pmop->op_pmoffset = offset;
8141 /* This slot should be free, so assert this: */
8142 assert(PL_regex_pad[offset] == &PL_sv_undef);
8144 SV * const repointer = &PL_sv_undef;
8145 av_push(PL_regex_padav, repointer);
8146 pmop->op_pmoffset = av_top_index(PL_regex_padav);
8147 PL_regex_pad = AvARRAY(PL_regex_padav);
8151 return CHECKOP(type, pmop);
8159 /* Any pad names in scope are potentially lvalues. */
8160 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
8161 PADNAME *pn = PAD_COMPNAME_SV(i);
8162 if (!pn || !PadnameLEN(pn))
8164 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
8165 S_mark_padname_lvalue(aTHX_ pn);
8169 /* Given some sort of match op o, and an expression expr containing a
8170 * pattern, either compile expr into a regex and attach it to o (if it's
8171 * constant), or convert expr into a runtime regcomp op sequence (if it's
8174 * Flags currently has 2 bits of meaning:
8175 * 1: isreg indicates that the pattern is part of a regex construct, eg
8176 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
8177 * split "pattern", which aren't. In the former case, expr will be a list
8178 * if the pattern contains more than one term (eg /a$b/).
8179 * 2: The pattern is for a split.
8181 * When the pattern has been compiled within a new anon CV (for
8182 * qr/(?{...})/ ), then floor indicates the savestack level just before
8183 * the new sub was created
8185 * tr/// is also handled.
8189 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
8193 I32 repl_has_vars = 0;
8194 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
8195 bool is_compiletime;
8197 bool isreg = cBOOL(flags & 1);
8198 bool is_split = cBOOL(flags & 2);
8200 PERL_ARGS_ASSERT_PMRUNTIME;
8203 return pmtrans(o, expr, repl);
8206 /* find whether we have any runtime or code elements;
8207 * at the same time, temporarily set the op_next of each DO block;
8208 * then when we LINKLIST, this will cause the DO blocks to be excluded
8209 * from the op_next chain (and from having LINKLIST recursively
8210 * applied to them). We fix up the DOs specially later */
8214 if (expr->op_type == OP_LIST) {
8216 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8217 if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
8219 assert(!child->op_next);
8220 if (UNLIKELY(!OpHAS_SIBLING(child))) {
8221 assert(PL_parser && PL_parser->error_count);
8222 /* This can happen with qr/ (?{(^{})/. Just fake up
8223 the op we were expecting to see, to avoid crashing
8225 op_sibling_splice(expr, child, 0,
8226 newSVOP(OP_CONST, 0, &PL_sv_no));
8228 child->op_next = OpSIBLING(child);
8230 else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
8234 else if (expr->op_type != OP_CONST)
8239 /* fix up DO blocks; treat each one as a separate little sub;
8240 * also, mark any arrays as LIST/REF */
8242 if (expr->op_type == OP_LIST) {
8244 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8246 if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
8247 assert( !(child->op_flags & OPf_WANT));
8248 /* push the array rather than its contents. The regex
8249 * engine will retrieve and join the elements later */
8250 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
8254 if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
8256 child->op_next = NULL; /* undo temporary hack from above */
8259 if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
8260 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
8262 assert(leaveop->op_first->op_type == OP_ENTER);
8263 assert(OpHAS_SIBLING(leaveop->op_first));
8264 child->op_next = OpSIBLING(leaveop->op_first);
8266 assert(leaveop->op_flags & OPf_KIDS);
8267 assert(leaveop->op_last->op_next == (OP*)leaveop);
8268 leaveop->op_next = NULL; /* stop on last op */
8269 op_null((OP*)leaveop);
8273 OP *scope = cLISTOPx(child)->op_first;
8274 assert(scope->op_type == OP_SCOPE);
8275 assert(scope->op_flags & OPf_KIDS);
8276 scope->op_next = NULL; /* stop on last op */
8280 /* XXX optimize_optree() must be called on o before
8281 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
8282 * currently cope with a peephole-optimised optree.
8283 * Calling optimize_optree() here ensures that condition
8284 * is met, but may mean optimize_optree() is applied
8285 * to the same optree later (where hopefully it won't do any
8286 * harm as it can't convert an op to multiconcat if it's
8287 * already been converted */
8288 optimize_optree(child);
8290 /* have to peep the DOs individually as we've removed it from
8291 * the op_next chain */
8293 S_prune_chain_head(&(child->op_next));
8295 /* runtime finalizes as part of finalizing whole tree */
8296 finalize_optree(child);
8299 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
8300 assert( !(expr->op_flags & OPf_WANT));
8301 /* push the array rather than its contents. The regex
8302 * engine will retrieve and join the elements later */
8303 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
8306 PL_hints |= HINT_BLOCK_SCOPE;
8308 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
8310 if (is_compiletime) {
8311 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
8312 regexp_engine const *eng = current_re_engine();
8315 /* make engine handle split ' ' specially */
8316 pm->op_pmflags |= PMf_SPLIT;
8317 rx_flags |= RXf_SPLIT;
8320 if (!has_code || !eng->op_comp) {
8321 /* compile-time simple constant pattern */
8323 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
8324 /* whoops! we guessed that a qr// had a code block, but we
8325 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
8326 * that isn't required now. Note that we have to be pretty
8327 * confident that nothing used that CV's pad while the
8328 * regex was parsed, except maybe op targets for \Q etc.
8329 * If there were any op targets, though, they should have
8330 * been stolen by constant folding.
8334 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
8335 while (++i <= AvFILLp(PL_comppad)) {
8336 # ifdef USE_PAD_RESET
8337 /* under USE_PAD_RESET, pad swipe replaces a swiped
8338 * folded constant with a fresh padtmp */
8339 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
8341 assert(!PL_curpad[i]);
8345 /* This LEAVE_SCOPE will restore PL_compcv to point to the
8346 * outer CV (the one whose slab holds the pm op). The
8347 * inner CV (which holds expr) will be freed later, once
8348 * all the entries on the parse stack have been popped on
8349 * return from this function. Which is why its safe to
8350 * call op_free(expr) below.
8353 pm->op_pmflags &= ~PMf_HAS_CV;
8356 /* Skip compiling if parser found an error for this pattern */
8357 if (pm->op_pmflags & PMf_HAS_ERROR) {
8363 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8364 rx_flags, pm->op_pmflags)
8365 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8366 rx_flags, pm->op_pmflags)
8371 /* compile-time pattern that includes literal code blocks */
8375 /* Skip compiling if parser found an error for this pattern */
8376 if (pm->op_pmflags & PMf_HAS_ERROR) {
8380 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8383 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
8386 if (pm->op_pmflags & PMf_HAS_CV) {
8388 /* this QR op (and the anon sub we embed it in) is never
8389 * actually executed. It's just a placeholder where we can
8390 * squirrel away expr in op_code_list without the peephole
8391 * optimiser etc processing it for a second time */
8392 OP *qr = newPMOP(OP_QR, 0);
8393 ((PMOP*)qr)->op_code_list = expr;
8395 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
8396 SvREFCNT_inc_simple_void(PL_compcv);
8397 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8398 ReANY(re)->qr_anoncv = cv;
8400 /* attach the anon CV to the pad so that
8401 * pad_fixup_inner_anons() can find it */
8402 (void)pad_add_anon(cv, o->op_type);
8403 SvREFCNT_inc_simple_void(cv);
8406 pm->op_code_list = expr;
8411 /* runtime pattern: build chain of regcomp etc ops */
8413 PADOFFSET cv_targ = 0;
8415 reglist = isreg && expr->op_type == OP_LIST;
8420 pm->op_code_list = expr;
8421 /* don't free op_code_list; its ops are embedded elsewhere too */
8422 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
8426 /* make engine handle split ' ' specially */
8427 pm->op_pmflags |= PMf_SPLIT;
8429 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
8430 * to allow its op_next to be pointed past the regcomp and
8431 * preceding stacking ops;
8432 * OP_REGCRESET is there to reset taint before executing the
8434 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
8435 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
8437 if (pm->op_pmflags & PMf_HAS_CV) {
8438 /* we have a runtime qr with literal code. This means
8439 * that the qr// has been wrapped in a new CV, which
8440 * means that runtime consts, vars etc will have been compiled
8441 * against a new pad. So... we need to execute those ops
8442 * within the environment of the new CV. So wrap them in a call
8443 * to a new anon sub. i.e. for
8447 * we build an anon sub that looks like
8449 * sub { "a", $b, '(?{...})' }
8451 * and call it, passing the returned list to regcomp.
8452 * Or to put it another way, the list of ops that get executed
8456 * ------ -------------------
8457 * pushmark (for regcomp)
8458 * pushmark (for entersub)
8462 * regcreset regcreset
8464 * const("a") const("a")
8466 * const("(?{...})") const("(?{...})")
8471 SvREFCNT_inc_simple_void(PL_compcv);
8472 CvLVALUE_on(PL_compcv);
8473 /* these lines are just an unrolled newANONATTRSUB */
8474 expr = newSVOP(OP_ANONCODE, 0,
8475 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
8476 cv_targ = expr->op_targ;
8477 expr = newUNOP(OP_REFGEN, 0, expr);
8479 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
8482 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
8483 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
8484 | (reglist ? OPf_STACKED : 0);
8485 rcop->op_targ = cv_targ;
8487 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
8488 if (PL_hints & HINT_RE_EVAL)
8489 S_set_haseval(aTHX);
8491 /* establish postfix order */
8492 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
8494 rcop->op_next = expr;
8495 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
8498 rcop->op_next = LINKLIST(expr);
8499 expr->op_next = (OP*)rcop;
8502 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
8508 /* If we are looking at s//.../e with a single statement, get past
8509 the implicit do{}. */
8510 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
8511 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
8512 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
8515 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
8516 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
8517 && !OpHAS_SIBLING(sib))
8520 if (curop->op_type == OP_CONST)
8522 else if (( (curop->op_type == OP_RV2SV ||
8523 curop->op_type == OP_RV2AV ||
8524 curop->op_type == OP_RV2HV ||
8525 curop->op_type == OP_RV2GV)
8526 && cUNOPx(curop)->op_first
8527 && cUNOPx(curop)->op_first->op_type == OP_GV )
8528 || curop->op_type == OP_PADSV
8529 || curop->op_type == OP_PADAV
8530 || curop->op_type == OP_PADHV
8531 || curop->op_type == OP_PADANY) {
8539 || !RX_PRELEN(PM_GETRE(pm))
8540 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
8542 pm->op_pmflags |= PMf_CONST; /* const for long enough */
8543 op_prepend_elem(o->op_type, scalar(repl), o);
8546 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
8547 rcop->op_private = 1;
8549 /* establish postfix order */
8550 rcop->op_next = LINKLIST(repl);
8551 repl->op_next = (OP*)rcop;
8553 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
8554 assert(!(pm->op_pmflags & PMf_ONCE));
8555 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
8566 Constructs, checks, and returns an op of any type that involves an
8567 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
8568 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
8569 takes ownership of one reference to it.
8575 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
8579 PERL_ARGS_ASSERT_NEWSVOP;
8581 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8582 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8583 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8584 || type == OP_CUSTOM);
8586 NewOp(1101, svop, 1, SVOP);
8587 OpTYPE_set(svop, type);
8589 svop->op_next = (OP*)svop;
8590 svop->op_flags = (U8)flags;
8591 svop->op_private = (U8)(0 | (flags >> 8));
8592 if (PL_opargs[type] & OA_RETSCALAR)
8594 if (PL_opargs[type] & OA_TARGET)
8595 svop->op_targ = pad_alloc(type, SVs_PADTMP);
8596 return CHECKOP(type, svop);
8600 =for apidoc newDEFSVOP
8602 Constructs and returns an op to access C<$_>.
8608 Perl_newDEFSVOP(pTHX)
8610 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
8616 =for apidoc newPADOP
8618 Constructs, checks, and returns an op of any type that involves a
8619 reference to a pad element. C<type> is the opcode. C<flags> gives the
8620 eight bits of C<op_flags>. A pad slot is automatically allocated, and
8621 is populated with C<sv>; this function takes ownership of one reference
8624 This function only exists if Perl has been compiled to use ithreads.
8630 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
8634 PERL_ARGS_ASSERT_NEWPADOP;
8636 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8637 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8638 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8639 || type == OP_CUSTOM);
8641 NewOp(1101, padop, 1, PADOP);
8642 OpTYPE_set(padop, type);
8644 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
8645 SvREFCNT_dec(PAD_SVl(padop->op_padix));
8646 PAD_SETSV(padop->op_padix, sv);
8648 padop->op_next = (OP*)padop;
8649 padop->op_flags = (U8)flags;
8650 if (PL_opargs[type] & OA_RETSCALAR)
8652 if (PL_opargs[type] & OA_TARGET)
8653 padop->op_targ = pad_alloc(type, SVs_PADTMP);
8654 return CHECKOP(type, padop);
8657 #endif /* USE_ITHREADS */
8662 Constructs, checks, and returns an op of any type that involves an
8663 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
8664 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
8665 reference; calling this function does not transfer ownership of any
8672 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
8674 PERL_ARGS_ASSERT_NEWGVOP;
8677 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8679 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8686 Constructs, checks, and returns an op of any type that involves an
8687 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
8688 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
8689 Depending on the op type, the memory referenced by C<pv> may be freed
8690 when the op is destroyed. If the op is of a freeing type, C<pv> must
8691 have been allocated using C<PerlMemShared_malloc>.
8697 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
8699 const bool utf8 = cBOOL(flags & SVf_UTF8);
8704 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8705 || type == OP_RUNCV || type == OP_CUSTOM
8706 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
8708 NewOp(1101, pvop, 1, PVOP);
8709 OpTYPE_set(pvop, type);
8711 pvop->op_next = (OP*)pvop;
8712 pvop->op_flags = (U8)flags;
8713 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
8714 if (PL_opargs[type] & OA_RETSCALAR)
8716 if (PL_opargs[type] & OA_TARGET)
8717 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
8718 return CHECKOP(type, pvop);
8722 Perl_package(pTHX_ OP *o)
8724 SV *const sv = cSVOPo->op_sv;
8726 PERL_ARGS_ASSERT_PACKAGE;
8728 SAVEGENERICSV(PL_curstash);
8729 save_item(PL_curstname);
8731 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
8733 sv_setsv(PL_curstname, sv);
8735 PL_hints |= HINT_BLOCK_SCOPE;
8736 PL_parser->copline = NOLINE;
8742 Perl_package_version( pTHX_ OP *v )
8744 U32 savehints = PL_hints;
8745 PERL_ARGS_ASSERT_PACKAGE_VERSION;
8746 PL_hints &= ~HINT_STRICT_VARS;
8747 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
8748 PL_hints = savehints;
8753 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
8758 SV *use_version = NULL;
8760 PERL_ARGS_ASSERT_UTILIZE;
8762 if (idop->op_type != OP_CONST)
8763 Perl_croak(aTHX_ "Module name must be constant");
8768 SV * const vesv = ((SVOP*)version)->op_sv;
8770 if (!arg && !SvNIOKp(vesv)) {
8777 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
8778 Perl_croak(aTHX_ "Version number must be a constant number");
8780 /* Make copy of idop so we don't free it twice */
8781 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8783 /* Fake up a method call to VERSION */
8784 meth = newSVpvs_share("VERSION");
8785 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8786 op_append_elem(OP_LIST,
8787 op_prepend_elem(OP_LIST, pack, version),
8788 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
8792 /* Fake up an import/unimport */
8793 if (arg && arg->op_type == OP_STUB) {
8794 imop = arg; /* no import on explicit () */
8796 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
8797 imop = NULL; /* use 5.0; */
8799 use_version = ((SVOP*)idop)->op_sv;
8801 idop->op_private |= OPpCONST_NOVER;
8806 /* Make copy of idop so we don't free it twice */
8807 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8809 /* Fake up a method call to import/unimport */
8811 ? newSVpvs_share("import") : newSVpvs_share("unimport");
8812 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8813 op_append_elem(OP_LIST,
8814 op_prepend_elem(OP_LIST, pack, arg),
8815 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
8819 /* Fake up the BEGIN {}, which does its thing immediately. */
8821 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
8824 op_append_elem(OP_LINESEQ,
8825 op_append_elem(OP_LINESEQ,
8826 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
8827 newSTATEOP(0, NULL, veop)),
8828 newSTATEOP(0, NULL, imop) ));
8832 * feature bundle that corresponds to the required version. */
8833 use_version = sv_2mortal(new_version(use_version));
8834 S_enable_feature_bundle(aTHX_ use_version);
8836 /* If a version >= 5.11.0 is requested, strictures are on by default! */
8837 if (vcmp(use_version,
8838 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
8839 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8840 PL_hints |= HINT_STRICT_REFS;
8841 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8842 PL_hints |= HINT_STRICT_SUBS;
8843 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8844 PL_hints |= HINT_STRICT_VARS;
8846 /* otherwise they are off */
8848 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8849 PL_hints &= ~HINT_STRICT_REFS;
8850 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8851 PL_hints &= ~HINT_STRICT_SUBS;
8852 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8853 PL_hints &= ~HINT_STRICT_VARS;
8857 /* The "did you use incorrect case?" warning used to be here.
8858 * The problem is that on case-insensitive filesystems one
8859 * might get false positives for "use" (and "require"):
8860 * "use Strict" or "require CARP" will work. This causes
8861 * portability problems for the script: in case-strict
8862 * filesystems the script will stop working.
8864 * The "incorrect case" warning checked whether "use Foo"
8865 * imported "Foo" to your namespace, but that is wrong, too:
8866 * there is no requirement nor promise in the language that
8867 * a Foo.pm should or would contain anything in package "Foo".
8869 * There is very little Configure-wise that can be done, either:
8870 * the case-sensitivity of the build filesystem of Perl does not
8871 * help in guessing the case-sensitivity of the runtime environment.
8874 PL_hints |= HINT_BLOCK_SCOPE;
8875 PL_parser->copline = NOLINE;
8876 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
8880 =for apidoc_section Embedding and Interpreter Cloning
8882 =for apidoc load_module
8884 Loads the module whose name is pointed to by the string part of C<name>.
8885 Note that the actual module name, not its filename, should be given.
8886 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
8887 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
8888 trailing arguments can be used to specify arguments to the module's C<import()>
8889 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
8890 on the flags. The flags argument is a bitwise-ORed collection of any of
8891 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
8892 (or 0 for no flags).
8894 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
8895 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
8896 the trailing optional arguments may be omitted entirely. Otherwise, if
8897 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
8898 exactly one C<OP*>, containing the op tree that produces the relevant import
8899 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
8900 will be used as import arguments; and the list must be terminated with C<(SV*)
8901 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
8902 set, the trailing C<NULL> pointer is needed even if no import arguments are
8903 desired. The reference count for each specified C<SV*> argument is
8904 decremented. In addition, the C<name> argument is modified.
8906 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
8909 =for apidoc Amnh||PERL_LOADMOD_DENY
8910 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
8911 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
8913 =for apidoc vload_module
8914 Like C<L</load_module>> but the arguments are an encapsulated argument list.
8916 =for apidoc load_module_nocontext
8917 Like C<L</load_module>> but does not take a thread context (C<aTHX>) parameter,
8918 so is used in situations where the caller doesn't already have the thread
8924 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
8928 PERL_ARGS_ASSERT_LOAD_MODULE;
8930 va_start(args, ver);
8931 vload_module(flags, name, ver, &args);
8935 #ifdef PERL_IMPLICIT_CONTEXT
8937 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8941 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8942 va_start(args, ver);
8943 vload_module(flags, name, ver, &args);
8949 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8955 PERL_ARGS_ASSERT_VLOAD_MODULE;
8957 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8958 * that it has a PL_parser to play with while doing that, and also
8959 * that it doesn't mess with any existing parser, by creating a tmp
8960 * new parser with lex_start(). This won't actually be used for much,
8961 * since pp_require() will create another parser for the real work.
8962 * The ENTER/LEAVE pair protect callers from any side effects of use.
8964 * start_subparse() creates a new PL_compcv. This means that any ops
8965 * allocated below will be allocated from that CV's op slab, and so
8966 * will be automatically freed if the utilise() fails
8970 SAVEVPTR(PL_curcop);
8971 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8972 floor = start_subparse(FALSE, 0);
8974 modname = newSVOP(OP_CONST, 0, name);
8975 modname->op_private |= OPpCONST_BARE;
8977 veop = newSVOP(OP_CONST, 0, ver);
8981 if (flags & PERL_LOADMOD_NOIMPORT) {
8982 imop = sawparens(newNULLLIST());
8984 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8985 imop = va_arg(*args, OP*);
8990 sv = va_arg(*args, SV*);
8992 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8993 sv = va_arg(*args, SV*);
8997 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
9001 PERL_STATIC_INLINE OP *
9002 S_new_entersubop(pTHX_ GV *gv, OP *arg)
9004 return newUNOP(OP_ENTERSUB, OPf_STACKED,
9005 newLISTOP(OP_LIST, 0, arg,
9006 newUNOP(OP_RV2CV, 0,
9007 newGVOP(OP_GV, 0, gv))));
9011 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
9016 PERL_ARGS_ASSERT_DOFILE;
9018 if (!force_builtin && (gv = gv_override("do", 2))) {
9019 doop = S_new_entersubop(aTHX_ gv, term);
9022 doop = newUNOP(OP_DOFILE, 0, scalar(term));
9028 =for apidoc_section Optree construction
9030 =for apidoc newSLICEOP
9032 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
9033 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
9034 be set automatically, and, shifted up eight bits, the eight bits of
9035 C<op_private>, except that the bit with value 1 or 2 is automatically
9036 set as required. C<listval> and C<subscript> supply the parameters of
9037 the slice; they are consumed by this function and become part of the
9038 constructed op tree.
9044 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
9046 return newBINOP(OP_LSLICE, flags,
9047 list(force_list(subscript, 1)),
9048 list(force_list(listval, 1)) );
9051 #define ASSIGN_SCALAR 0
9052 #define ASSIGN_LIST 1
9053 #define ASSIGN_REF 2
9055 /* given the optree o on the LHS of an assignment, determine whether its:
9056 * ASSIGN_SCALAR $x = ...
9057 * ASSIGN_LIST ($x) = ...
9058 * ASSIGN_REF \$x = ...
9062 S_assignment_type(pTHX_ const OP *o)
9071 if (o->op_type == OP_SREFGEN)
9073 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
9074 type = kid->op_type;
9075 flags = o->op_flags | kid->op_flags;
9076 if (!(flags & OPf_PARENS)
9077 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
9078 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
9082 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
9083 o = cUNOPo->op_first;
9084 flags = o->op_flags;
9086 ret = ASSIGN_SCALAR;
9089 if (type == OP_COND_EXPR) {
9090 OP * const sib = OpSIBLING(cLOGOPo->op_first);
9091 const I32 t = assignment_type(sib);
9092 const I32 f = assignment_type(OpSIBLING(sib));
9094 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
9096 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
9097 yyerror("Assignment to both a list and a scalar");
9098 return ASSIGN_SCALAR;
9101 if (type == OP_LIST &&
9102 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
9103 o->op_private & OPpLVAL_INTRO)
9106 if (type == OP_LIST || flags & OPf_PARENS ||
9107 type == OP_RV2AV || type == OP_RV2HV ||
9108 type == OP_ASLICE || type == OP_HSLICE ||
9109 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
9112 if (type == OP_PADAV || type == OP_PADHV)
9115 if (type == OP_RV2SV)
9122 S_newONCEOP(pTHX_ OP *initop, OP *padop)
9124 const PADOFFSET target = padop->op_targ;
9125 OP *const other = newOP(OP_PADSV,
9127 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
9128 OP *const first = newOP(OP_NULL, 0);
9129 OP *const nullop = newCONDOP(0, first, initop, other);
9130 /* XXX targlex disabled for now; see ticket #124160
9131 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
9133 OP *const condop = first->op_next;
9135 OpTYPE_set(condop, OP_ONCE);
9136 other->op_targ = target;
9137 nullop->op_flags |= OPf_WANT_SCALAR;
9139 /* Store the initializedness of state vars in a separate
9142 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
9143 /* hijacking PADSTALE for uninitialized state variables */
9144 SvPADSTALE_on(PAD_SVl(condop->op_targ));
9150 =for apidoc newASSIGNOP
9152 Constructs, checks, and returns an assignment op. C<left> and C<right>
9153 supply the parameters of the assignment; they are consumed by this
9154 function and become part of the constructed op tree.
9156 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
9157 a suitable conditional optree is constructed. If C<optype> is the opcode
9158 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
9159 performs the binary operation and assigns the result to the left argument.
9160 Either way, if C<optype> is non-zero then C<flags> has no effect.
9162 If C<optype> is zero, then a plain scalar or list assignment is
9163 constructed. Which type of assignment it is is automatically determined.
9164 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9165 will be set automatically, and, shifted up eight bits, the eight bits
9166 of C<op_private>, except that the bit with value 1 or 2 is automatically
9173 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
9179 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
9180 right = scalar(right);
9181 return newLOGOP(optype, 0,
9182 op_lvalue(scalar(left), optype),
9183 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
9186 return newBINOP(optype, OPf_STACKED,
9187 op_lvalue(scalar(left), optype), scalar(right));
9191 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
9192 OP *state_var_op = NULL;
9193 static const char no_list_state[] = "Initialization of state variables"
9194 " in list currently forbidden";
9197 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
9198 left->op_private &= ~ OPpSLICEWARNING;
9201 left = op_lvalue(left, OP_AASSIGN);
9202 curop = list(force_list(left, 1));
9203 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
9204 o->op_private = (U8)(0 | (flags >> 8));
9206 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
9208 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
9209 if (!(left->op_flags & OPf_PARENS) &&
9210 lop->op_type == OP_PUSHMARK &&
9211 (vop = OpSIBLING(lop)) &&
9212 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
9213 !(vop->op_flags & OPf_PARENS) &&
9214 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
9215 (OPpLVAL_INTRO|OPpPAD_STATE) &&
9216 (eop = OpSIBLING(vop)) &&
9217 eop->op_type == OP_ENTERSUB &&
9218 !OpHAS_SIBLING(eop)) {
9222 if ((lop->op_type == OP_PADSV ||
9223 lop->op_type == OP_PADAV ||
9224 lop->op_type == OP_PADHV ||
9225 lop->op_type == OP_PADANY)
9226 && (lop->op_private & OPpPAD_STATE)
9228 yyerror(no_list_state);
9229 lop = OpSIBLING(lop);
9233 else if ( (left->op_private & OPpLVAL_INTRO)
9234 && (left->op_private & OPpPAD_STATE)
9235 && ( left->op_type == OP_PADSV
9236 || left->op_type == OP_PADAV
9237 || left->op_type == OP_PADHV
9238 || left->op_type == OP_PADANY)
9240 /* All single variable list context state assignments, hence
9250 if (left->op_flags & OPf_PARENS)
9251 yyerror(no_list_state);
9253 state_var_op = left;
9256 /* optimise @a = split(...) into:
9257 * @{expr}: split(..., @{expr}) (where @a is not flattened)
9258 * @a, my @a, local @a: split(...) (where @a is attached to
9259 * the split op itself)
9263 && right->op_type == OP_SPLIT
9264 /* don't do twice, e.g. @b = (@a = split) */
9265 && !(right->op_private & OPpSPLIT_ASSIGN))
9269 if ( ( left->op_type == OP_RV2AV
9270 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
9271 || left->op_type == OP_PADAV)
9273 /* @pkg or @lex or local @pkg' or 'my @lex' */
9277 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
9278 = cPADOPx(gvop)->op_padix;
9279 cPADOPx(gvop)->op_padix = 0; /* steal it */
9281 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
9282 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
9283 cSVOPx(gvop)->op_sv = NULL; /* steal it */
9285 right->op_private |=
9286 left->op_private & OPpOUR_INTRO;
9289 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
9290 left->op_targ = 0; /* steal it */
9291 right->op_private |= OPpSPLIT_LEX;
9293 right->op_private |= left->op_private & OPpLVAL_INTRO;
9296 tmpop = cUNOPo->op_first; /* to list (nulled) */
9297 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
9298 assert(OpSIBLING(tmpop) == right);
9299 assert(!OpHAS_SIBLING(right));
9300 /* detach the split subtreee from the o tree,
9301 * then free the residual o tree */
9302 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
9303 op_free(o); /* blow off assign */
9304 right->op_private |= OPpSPLIT_ASSIGN;
9305 right->op_flags &= ~OPf_WANT;
9306 /* "I don't know and I don't care." */
9309 else if (left->op_type == OP_RV2AV) {
9312 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
9313 assert(OpSIBLING(pushop) == left);
9314 /* Detach the array ... */
9315 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
9316 /* ... and attach it to the split. */
9317 op_sibling_splice(right, cLISTOPx(right)->op_last,
9319 right->op_flags |= OPf_STACKED;
9320 /* Detach split and expunge aassign as above. */
9323 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
9324 ((LISTOP*)right)->op_last->op_type == OP_CONST)
9326 /* convert split(...,0) to split(..., PL_modcount+1) */
9328 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
9329 SV * const sv = *svp;
9330 if (SvIOK(sv) && SvIVX(sv) == 0)
9332 if (right->op_private & OPpSPLIT_IMPLIM) {
9333 /* our own SV, created in ck_split */
9335 sv_setiv(sv, PL_modcount+1);
9338 /* SV may belong to someone else */
9340 *svp = newSViv(PL_modcount+1);
9347 o = S_newONCEOP(aTHX_ o, state_var_op);
9350 if (assign_type == ASSIGN_REF)
9351 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
9353 right = newOP(OP_UNDEF, 0);
9354 if (right->op_type == OP_READLINE) {
9355 right->op_flags |= OPf_STACKED;
9356 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
9360 o = newBINOP(OP_SASSIGN, flags,
9361 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
9367 =for apidoc newSTATEOP
9369 Constructs a state op (COP). The state op is normally a C<nextstate> op,
9370 but will be a C<dbstate> op if debugging is enabled for currently-compiled
9371 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
9372 If C<label> is non-null, it supplies the name of a label to attach to
9373 the state op; this function takes ownership of the memory pointed at by
9374 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
9377 If C<o> is null, the state op is returned. Otherwise the state op is
9378 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
9379 is consumed by this function and becomes part of the returned op tree.
9385 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
9387 const U32 seq = intro_my();
9388 const U32 utf8 = flags & SVf_UTF8;
9391 PL_parser->parsed_sub = 0;
9395 NewOp(1101, cop, 1, COP);
9396 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
9397 OpTYPE_set(cop, OP_DBSTATE);
9400 OpTYPE_set(cop, OP_NEXTSTATE);
9402 cop->op_flags = (U8)flags;
9403 CopHINTS_set(cop, PL_hints);
9405 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
9407 cop->op_next = (OP*)cop;
9410 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9411 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
9413 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
9415 PL_hints |= HINT_BLOCK_SCOPE;
9416 /* It seems that we need to defer freeing this pointer, as other parts
9417 of the grammar end up wanting to copy it after this op has been
9422 if (PL_parser->preambling != NOLINE) {
9423 CopLINE_set(cop, PL_parser->preambling);
9424 PL_parser->copline = NOLINE;
9426 else if (PL_parser->copline == NOLINE)
9427 CopLINE_set(cop, CopLINE(PL_curcop));
9429 CopLINE_set(cop, PL_parser->copline);
9430 PL_parser->copline = NOLINE;
9433 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
9435 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
9437 CopSTASH_set(cop, PL_curstash);
9439 if (cop->op_type == OP_DBSTATE) {
9440 /* this line can have a breakpoint - store the cop in IV */
9441 AV *av = CopFILEAVx(PL_curcop);
9443 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
9444 if (svp && *svp != &PL_sv_undef ) {
9445 (void)SvIOK_on(*svp);
9446 SvIV_set(*svp, PTR2IV(cop));
9451 if (flags & OPf_SPECIAL)
9453 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
9457 =for apidoc newLOGOP
9459 Constructs, checks, and returns a logical (flow control) op. C<type>
9460 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
9461 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
9462 the eight bits of C<op_private>, except that the bit with value 1 is
9463 automatically set. C<first> supplies the expression controlling the
9464 flow, and C<other> supplies the side (alternate) chain of ops; they are
9465 consumed by this function and become part of the constructed op tree.
9471 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
9473 PERL_ARGS_ASSERT_NEWLOGOP;
9475 return new_logop(type, flags, &first, &other);
9479 /* See if the optree o contains a single OP_CONST (plus possibly
9480 * surrounding enter/nextstate/null etc). If so, return it, else return
9485 S_search_const(pTHX_ OP *o)
9487 PERL_ARGS_ASSERT_SEARCH_CONST;
9490 switch (o->op_type) {
9494 if (o->op_flags & OPf_KIDS) {
9495 o = cUNOPo->op_first;
9504 if (!(o->op_flags & OPf_KIDS))
9506 kid = cLISTOPo->op_first;
9509 switch (kid->op_type) {
9513 kid = OpSIBLING(kid);
9516 if (kid != cLISTOPo->op_last)
9523 kid = cLISTOPo->op_last;
9535 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
9542 int prepend_not = 0;
9544 PERL_ARGS_ASSERT_NEW_LOGOP;
9549 /* [perl #59802]: Warn about things like "return $a or $b", which
9550 is parsed as "(return $a) or $b" rather than "return ($a or
9551 $b)". NB: This also applies to xor, which is why we do it
9554 switch (first->op_type) {
9558 /* XXX: Perhaps we should emit a stronger warning for these.
9559 Even with the high-precedence operator they don't seem to do
9562 But until we do, fall through here.
9568 /* XXX: Currently we allow people to "shoot themselves in the
9569 foot" by explicitly writing "(return $a) or $b".
9571 Warn unless we are looking at the result from folding or if
9572 the programmer explicitly grouped the operators like this.
9573 The former can occur with e.g.
9575 use constant FEATURE => ( $] >= ... );
9576 sub { not FEATURE and return or do_stuff(); }
9578 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
9579 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9580 "Possible precedence issue with control flow operator");
9581 /* XXX: Should we optimze this to "return $a;" (i.e. remove
9587 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
9588 return newBINOP(type, flags, scalar(first), scalar(other));
9590 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
9591 || type == OP_CUSTOM);
9593 scalarboolean(first);
9595 /* search for a constant op that could let us fold the test */
9596 if ((cstop = search_const(first))) {
9597 if (cstop->op_private & OPpCONST_STRICT)
9598 no_bareword_allowed(cstop);
9599 else if ((cstop->op_private & OPpCONST_BARE))
9600 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
9601 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
9602 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
9603 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
9604 /* Elide the (constant) lhs, since it can't affect the outcome */
9606 if (other->op_type == OP_CONST)
9607 other->op_private |= OPpCONST_SHORTCIRCUIT;
9609 if (other->op_type == OP_LEAVE)
9610 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
9611 else if (other->op_type == OP_MATCH
9612 || other->op_type == OP_SUBST
9613 || other->op_type == OP_TRANSR
9614 || other->op_type == OP_TRANS)
9615 /* Mark the op as being unbindable with =~ */
9616 other->op_flags |= OPf_SPECIAL;
9618 other->op_folded = 1;
9622 /* Elide the rhs, since the outcome is entirely determined by
9623 * the (constant) lhs */
9625 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
9626 const OP *o2 = other;
9627 if ( ! (o2->op_type == OP_LIST
9628 && (( o2 = cUNOPx(o2)->op_first))
9629 && o2->op_type == OP_PUSHMARK
9630 && (( o2 = OpSIBLING(o2))) )
9633 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
9634 || o2->op_type == OP_PADHV)
9635 && o2->op_private & OPpLVAL_INTRO
9636 && !(o2->op_private & OPpPAD_STATE))
9638 Perl_croak(aTHX_ "This use of my() in false conditional is "
9639 "no longer allowed");
9643 if (cstop->op_type == OP_CONST)
9644 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
9649 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
9650 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
9652 const OP * const k1 = ((UNOP*)first)->op_first;
9653 const OP * const k2 = OpSIBLING(k1);
9655 switch (first->op_type)
9658 if (k2 && k2->op_type == OP_READLINE
9659 && (k2->op_flags & OPf_STACKED)
9660 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9662 warnop = k2->op_type;
9667 if (k1->op_type == OP_READDIR
9668 || k1->op_type == OP_GLOB
9669 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9670 || k1->op_type == OP_EACH
9671 || k1->op_type == OP_AEACH)
9673 warnop = ((k1->op_type == OP_NULL)
9674 ? (OPCODE)k1->op_targ : k1->op_type);
9679 const line_t oldline = CopLINE(PL_curcop);
9680 /* This ensures that warnings are reported at the first line
9681 of the construction, not the last. */
9682 CopLINE_set(PL_curcop, PL_parser->copline);
9683 Perl_warner(aTHX_ packWARN(WARN_MISC),
9684 "Value of %s%s can be \"0\"; test with defined()",
9686 ((warnop == OP_READLINE || warnop == OP_GLOB)
9687 ? " construct" : "() operator"));
9688 CopLINE_set(PL_curcop, oldline);
9692 /* optimize AND and OR ops that have NOTs as children */
9693 if (first->op_type == OP_NOT
9694 && (first->op_flags & OPf_KIDS)
9695 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
9696 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
9698 if (type == OP_AND || type == OP_OR) {
9704 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
9706 prepend_not = 1; /* prepend a NOT op later */
9711 logop = alloc_LOGOP(type, first, LINKLIST(other));
9712 logop->op_flags |= (U8)flags;
9713 logop->op_private = (U8)(1 | (flags >> 8));
9715 /* establish postfix order */
9716 logop->op_next = LINKLIST(first);
9717 first->op_next = (OP*)logop;
9718 assert(!OpHAS_SIBLING(first));
9719 op_sibling_splice((OP*)logop, first, 0, other);
9721 CHECKOP(type,logop);
9723 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
9724 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
9732 =for apidoc newCONDOP
9734 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
9735 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9736 will be set automatically, and, shifted up eight bits, the eight bits of
9737 C<op_private>, except that the bit with value 1 is automatically set.
9738 C<first> supplies the expression selecting between the two branches,
9739 and C<trueop> and C<falseop> supply the branches; they are consumed by
9740 this function and become part of the constructed op tree.
9746 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
9753 PERL_ARGS_ASSERT_NEWCONDOP;
9756 return newLOGOP(OP_AND, 0, first, trueop);
9758 return newLOGOP(OP_OR, 0, first, falseop);
9760 scalarboolean(first);
9761 if ((cstop = search_const(first))) {
9762 /* Left or right arm of the conditional? */
9763 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
9764 OP *live = left ? trueop : falseop;
9765 OP *const dead = left ? falseop : trueop;
9766 if (cstop->op_private & OPpCONST_BARE &&
9767 cstop->op_private & OPpCONST_STRICT) {
9768 no_bareword_allowed(cstop);
9772 if (live->op_type == OP_LEAVE)
9773 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
9774 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
9775 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
9776 /* Mark the op as being unbindable with =~ */
9777 live->op_flags |= OPf_SPECIAL;
9778 live->op_folded = 1;
9781 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
9782 logop->op_flags |= (U8)flags;
9783 logop->op_private = (U8)(1 | (flags >> 8));
9784 logop->op_next = LINKLIST(falseop);
9786 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
9789 /* establish postfix order */
9790 start = LINKLIST(first);
9791 first->op_next = (OP*)logop;
9793 /* make first, trueop, falseop siblings */
9794 op_sibling_splice((OP*)logop, first, 0, trueop);
9795 op_sibling_splice((OP*)logop, trueop, 0, falseop);
9797 o = newUNOP(OP_NULL, 0, (OP*)logop);
9799 trueop->op_next = falseop->op_next = o;
9806 =for apidoc newRANGE
9808 Constructs and returns a C<range> op, with subordinate C<flip> and
9809 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
9810 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
9811 for both the C<flip> and C<range> ops, except that the bit with value
9812 1 is automatically set. C<left> and C<right> supply the expressions
9813 controlling the endpoints of the range; they are consumed by this function
9814 and become part of the constructed op tree.
9820 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
9828 PERL_ARGS_ASSERT_NEWRANGE;
9830 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
9831 range->op_flags = OPf_KIDS;
9832 leftstart = LINKLIST(left);
9833 range->op_private = (U8)(1 | (flags >> 8));
9835 /* make left and right siblings */
9836 op_sibling_splice((OP*)range, left, 0, right);
9838 range->op_next = (OP*)range;
9839 flip = newUNOP(OP_FLIP, flags, (OP*)range);
9840 flop = newUNOP(OP_FLOP, 0, flip);
9841 o = newUNOP(OP_NULL, 0, flop);
9843 range->op_next = leftstart;
9845 left->op_next = flip;
9846 right->op_next = flop;
9849 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9850 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9852 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9853 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9854 SvPADTMP_on(PAD_SV(flip->op_targ));
9856 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9857 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9859 /* check barewords before they might be optimized aways */
9860 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9861 no_bareword_allowed(left);
9862 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9863 no_bareword_allowed(right);
9866 if (!flip->op_private || !flop->op_private)
9867 LINKLIST(o); /* blow off optimizer unless constant */
9873 =for apidoc newLOOPOP
9875 Constructs, checks, and returns an op tree expressing a loop. This is
9876 only a loop in the control flow through the op tree; it does not have
9877 the heavyweight loop structure that allows exiting the loop by C<last>
9878 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
9879 top-level op, except that some bits will be set automatically as required.
9880 C<expr> supplies the expression controlling loop iteration, and C<block>
9881 supplies the body of the loop; they are consumed by this function and
9882 become part of the constructed op tree. C<debuggable> is currently
9883 unused and should always be 1.
9889 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9893 const bool once = block && block->op_flags & OPf_SPECIAL &&
9894 block->op_type == OP_NULL;
9896 PERL_UNUSED_ARG(debuggable);
9900 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
9901 || ( expr->op_type == OP_NOT
9902 && cUNOPx(expr)->op_first->op_type == OP_CONST
9903 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9906 /* Return the block now, so that S_new_logop does not try to
9910 return block; /* do {} while 0 does once */
9913 if (expr->op_type == OP_READLINE
9914 || expr->op_type == OP_READDIR
9915 || expr->op_type == OP_GLOB
9916 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9917 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9918 expr = newUNOP(OP_DEFINED, 0,
9919 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9920 } else if (expr->op_flags & OPf_KIDS) {
9921 const OP * const k1 = ((UNOP*)expr)->op_first;
9922 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9923 switch (expr->op_type) {
9925 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9926 && (k2->op_flags & OPf_STACKED)
9927 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9928 expr = newUNOP(OP_DEFINED, 0, expr);
9932 if (k1 && (k1->op_type == OP_READDIR
9933 || k1->op_type == OP_GLOB
9934 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9935 || k1->op_type == OP_EACH
9936 || k1->op_type == OP_AEACH))
9937 expr = newUNOP(OP_DEFINED, 0, expr);
9943 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9944 * op, in listop. This is wrong. [perl #27024] */
9946 block = newOP(OP_NULL, 0);
9947 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9948 o = new_logop(OP_AND, 0, &expr, &listop);
9955 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
9957 if (once && o != listop)
9959 assert(cUNOPo->op_first->op_type == OP_AND
9960 || cUNOPo->op_first->op_type == OP_OR);
9961 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
9965 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
9967 o->op_flags |= flags;
9969 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9974 =for apidoc newWHILEOP
9976 Constructs, checks, and returns an op tree expressing a C<while> loop.
9977 This is a heavyweight loop, with structure that allows exiting the loop
9978 by C<last> and suchlike.
9980 C<loop> is an optional preconstructed C<enterloop> op to use in the
9981 loop; if it is null then a suitable op will be constructed automatically.
9982 C<expr> supplies the loop's controlling expression. C<block> supplies the
9983 main body of the loop, and C<cont> optionally supplies a C<continue> block
9984 that operates as a second half of the body. All of these optree inputs
9985 are consumed by this function and become part of the constructed op tree.
9987 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9988 op and, shifted up eight bits, the eight bits of C<op_private> for
9989 the C<leaveloop> op, except that (in both cases) some bits will be set
9990 automatically. C<debuggable> is currently unused and should always be 1.
9991 C<has_my> can be supplied as true to force the
9992 loop body to be enclosed in its own scope.
9998 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9999 OP *expr, OP *block, OP *cont, I32 has_my)
10007 PERL_UNUSED_ARG(debuggable);
10010 if (expr->op_type == OP_READLINE
10011 || expr->op_type == OP_READDIR
10012 || expr->op_type == OP_GLOB
10013 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
10014 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
10015 expr = newUNOP(OP_DEFINED, 0,
10016 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
10017 } else if (expr->op_flags & OPf_KIDS) {
10018 const OP * const k1 = ((UNOP*)expr)->op_first;
10019 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
10020 switch (expr->op_type) {
10022 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
10023 && (k2->op_flags & OPf_STACKED)
10024 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
10025 expr = newUNOP(OP_DEFINED, 0, expr);
10029 if (k1 && (k1->op_type == OP_READDIR
10030 || k1->op_type == OP_GLOB
10031 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
10032 || k1->op_type == OP_EACH
10033 || k1->op_type == OP_AEACH))
10034 expr = newUNOP(OP_DEFINED, 0, expr);
10041 block = newOP(OP_NULL, 0);
10042 else if (cont || has_my) {
10043 block = op_scope(block);
10047 next = LINKLIST(cont);
10050 OP * const unstack = newOP(OP_UNSTACK, 0);
10053 cont = op_append_elem(OP_LINESEQ, cont, unstack);
10057 listop = op_append_list(OP_LINESEQ, block, cont);
10059 redo = LINKLIST(listop);
10063 o = new_logop(OP_AND, 0, &expr, &listop);
10064 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
10065 op_free((OP*)loop);
10066 return expr; /* listop already freed by new_logop */
10069 ((LISTOP*)listop)->op_last->op_next =
10070 (o == listop ? redo : LINKLIST(o));
10076 NewOp(1101,loop,1,LOOP);
10077 OpTYPE_set(loop, OP_ENTERLOOP);
10078 loop->op_private = 0;
10079 loop->op_next = (OP*)loop;
10082 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
10084 loop->op_redoop = redo;
10085 loop->op_lastop = o;
10086 o->op_private |= loopflags;
10089 loop->op_nextop = next;
10091 loop->op_nextop = o;
10093 o->op_flags |= flags;
10094 o->op_private |= (flags >> 8);
10099 =for apidoc newFOROP
10101 Constructs, checks, and returns an op tree expressing a C<foreach>
10102 loop (iteration through a list of values). This is a heavyweight loop,
10103 with structure that allows exiting the loop by C<last> and suchlike.
10105 C<sv> optionally supplies the variable that will be aliased to each
10106 item in turn; if null, it defaults to C<$_>.
10107 C<expr> supplies the list of values to iterate over. C<block> supplies
10108 the main body of the loop, and C<cont> optionally supplies a C<continue>
10109 block that operates as a second half of the body. All of these optree
10110 inputs are consumed by this function and become part of the constructed
10113 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10114 op and, shifted up eight bits, the eight bits of C<op_private> for
10115 the C<leaveloop> op, except that (in both cases) some bits will be set
10122 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
10126 PADOFFSET padoff = 0;
10128 I32 iterpflags = 0;
10130 PERL_ARGS_ASSERT_NEWFOROP;
10133 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
10134 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
10135 OpTYPE_set(sv, OP_RV2GV);
10137 /* The op_type check is needed to prevent a possible segfault
10138 * if the loop variable is undeclared and 'strict vars' is in
10139 * effect. This is illegal but is nonetheless parsed, so we
10140 * may reach this point with an OP_CONST where we're expecting
10143 if (cUNOPx(sv)->op_first->op_type == OP_GV
10144 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
10145 iterpflags |= OPpITER_DEF;
10147 else if (sv->op_type == OP_PADSV) { /* private variable */
10148 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
10149 padoff = sv->op_targ;
10153 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
10155 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
10158 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
10160 PADNAME * const pn = PAD_COMPNAME(padoff);
10161 const char * const name = PadnamePV(pn);
10163 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
10164 iterpflags |= OPpITER_DEF;
10168 sv = newGVOP(OP_GV, 0, PL_defgv);
10169 iterpflags |= OPpITER_DEF;
10172 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
10173 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
10174 iterflags |= OPf_STACKED;
10176 else if (expr->op_type == OP_NULL &&
10177 (expr->op_flags & OPf_KIDS) &&
10178 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
10180 /* Basically turn for($x..$y) into the same as for($x,$y), but we
10181 * set the STACKED flag to indicate that these values are to be
10182 * treated as min/max values by 'pp_enteriter'.
10184 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
10185 LOGOP* const range = (LOGOP*) flip->op_first;
10186 OP* const left = range->op_first;
10187 OP* const right = OpSIBLING(left);
10190 range->op_flags &= ~OPf_KIDS;
10191 /* detach range's children */
10192 op_sibling_splice((OP*)range, NULL, -1, NULL);
10194 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
10195 listop->op_first->op_next = range->op_next;
10196 left->op_next = range->op_other;
10197 right->op_next = (OP*)listop;
10198 listop->op_next = listop->op_first;
10201 expr = (OP*)(listop);
10203 iterflags |= OPf_STACKED;
10206 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
10209 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
10210 op_append_elem(OP_LIST, list(expr),
10212 assert(!loop->op_next);
10213 /* for my $x () sets OPpLVAL_INTRO;
10214 * for our $x () sets OPpOUR_INTRO */
10215 loop->op_private = (U8)iterpflags;
10217 /* upgrade loop from a LISTOP to a LOOPOP;
10218 * keep it in-place if there's space */
10219 if (loop->op_slabbed
10220 && OpSLOT(loop)->opslot_size
10221 < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
10223 /* no space; allocate new op */
10225 NewOp(1234,tmp,1,LOOP);
10226 Copy(loop,tmp,1,LISTOP);
10227 assert(loop->op_last->op_sibparent == (OP*)loop);
10228 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
10229 S_op_destroy(aTHX_ (OP*)loop);
10232 else if (!loop->op_slabbed)
10234 /* loop was malloc()ed */
10235 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
10236 OpLASTSIB_set(loop->op_last, (OP*)loop);
10238 loop->op_targ = padoff;
10239 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
10244 =for apidoc newLOOPEX
10246 Constructs, checks, and returns a loop-exiting op (such as C<goto>
10247 or C<last>). C<type> is the opcode. C<label> supplies the parameter
10248 determining the target of the op; it is consumed by this function and
10249 becomes part of the constructed op tree.
10255 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
10259 PERL_ARGS_ASSERT_NEWLOOPEX;
10261 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
10262 || type == OP_CUSTOM);
10264 if (type != OP_GOTO) {
10265 /* "last()" means "last" */
10266 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
10267 o = newOP(type, OPf_SPECIAL);
10271 /* Check whether it's going to be a goto &function */
10272 if (label->op_type == OP_ENTERSUB
10273 && !(label->op_flags & OPf_STACKED))
10274 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
10277 /* Check for a constant argument */
10278 if (label->op_type == OP_CONST) {
10279 SV * const sv = ((SVOP *)label)->op_sv;
10281 const char *s = SvPV_const(sv,l);
10282 if (l == strlen(s)) {
10284 SvUTF8(((SVOP*)label)->op_sv),
10286 SvPV_nolen_const(((SVOP*)label)->op_sv)));
10290 /* If we have already created an op, we do not need the label. */
10293 else o = newUNOP(type, OPf_STACKED, label);
10295 PL_hints |= HINT_BLOCK_SCOPE;
10299 /* if the condition is a literal array or hash
10300 (or @{ ... } etc), make a reference to it.
10303 S_ref_array_or_hash(pTHX_ OP *cond)
10306 && (cond->op_type == OP_RV2AV
10307 || cond->op_type == OP_PADAV
10308 || cond->op_type == OP_RV2HV
10309 || cond->op_type == OP_PADHV))
10311 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
10314 && (cond->op_type == OP_ASLICE
10315 || cond->op_type == OP_KVASLICE
10316 || cond->op_type == OP_HSLICE
10317 || cond->op_type == OP_KVHSLICE)) {
10319 /* anonlist now needs a list from this op, was previously used in
10320 * scalar context */
10321 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
10322 cond->op_flags |= OPf_WANT_LIST;
10324 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
10331 /* These construct the optree fragments representing given()
10334 entergiven and enterwhen are LOGOPs; the op_other pointer
10335 points up to the associated leave op. We need this so we
10336 can put it in the context and make break/continue work.
10337 (Also, of course, pp_enterwhen will jump straight to
10338 op_other if the match fails.)
10342 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
10343 I32 enter_opcode, I32 leave_opcode,
10344 PADOFFSET entertarg)
10349 PERL_ARGS_ASSERT_NEWGIVWHENOP;
10350 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
10352 enterop = alloc_LOGOP(enter_opcode, block, NULL);
10353 enterop->op_targ = 0;
10354 enterop->op_private = 0;
10356 o = newUNOP(leave_opcode, 0, (OP *) enterop);
10359 /* prepend cond if we have one */
10360 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
10362 o->op_next = LINKLIST(cond);
10363 cond->op_next = (OP *) enterop;
10366 /* This is a default {} block */
10367 enterop->op_flags |= OPf_SPECIAL;
10368 o ->op_flags |= OPf_SPECIAL;
10370 o->op_next = (OP *) enterop;
10373 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
10374 entergiven and enterwhen both
10377 enterop->op_next = LINKLIST(block);
10378 block->op_next = enterop->op_other = o;
10384 /* For the purposes of 'when(implied_smartmatch)'
10385 * versus 'when(boolean_expression)',
10386 * does this look like a boolean operation? For these purposes
10387 a boolean operation is:
10388 - a subroutine call [*]
10389 - a logical connective
10390 - a comparison operator
10391 - a filetest operator, with the exception of -s -M -A -C
10392 - defined(), exists() or eof()
10393 - /$re/ or $foo =~ /$re/
10395 [*] possibly surprising
10398 S_looks_like_bool(pTHX_ const OP *o)
10400 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
10402 switch(o->op_type) {
10405 return looks_like_bool(cLOGOPo->op_first);
10409 OP* sibl = OpSIBLING(cLOGOPo->op_first);
10412 looks_like_bool(cLOGOPo->op_first)
10413 && looks_like_bool(sibl));
10419 o->op_flags & OPf_KIDS
10420 && looks_like_bool(cUNOPo->op_first));
10424 case OP_NOT: case OP_XOR:
10426 case OP_EQ: case OP_NE: case OP_LT:
10427 case OP_GT: case OP_LE: case OP_GE:
10429 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
10430 case OP_I_GT: case OP_I_LE: case OP_I_GE:
10432 case OP_SEQ: case OP_SNE: case OP_SLT:
10433 case OP_SGT: case OP_SLE: case OP_SGE:
10435 case OP_SMARTMATCH:
10437 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
10438 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
10439 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
10440 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
10441 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
10442 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
10443 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
10444 case OP_FTTEXT: case OP_FTBINARY:
10446 case OP_DEFINED: case OP_EXISTS:
10447 case OP_MATCH: case OP_EOF:
10455 /* optimised-away (index() != -1) or similar comparison */
10456 if (o->op_private & OPpTRUEBOOL)
10461 /* Detect comparisons that have been optimized away */
10462 if (cSVOPo->op_sv == &PL_sv_yes
10463 || cSVOPo->op_sv == &PL_sv_no)
10476 =for apidoc newGIVENOP
10478 Constructs, checks, and returns an op tree expressing a C<given> block.
10479 C<cond> supplies the expression to whose value C<$_> will be locally
10480 aliased, and C<block> supplies the body of the C<given> construct; they
10481 are consumed by this function and become part of the constructed op tree.
10482 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
10488 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
10490 PERL_ARGS_ASSERT_NEWGIVENOP;
10491 PERL_UNUSED_ARG(defsv_off);
10493 assert(!defsv_off);
10494 return newGIVWHENOP(
10495 ref_array_or_hash(cond),
10497 OP_ENTERGIVEN, OP_LEAVEGIVEN,
10502 =for apidoc newWHENOP
10504 Constructs, checks, and returns an op tree expressing a C<when> block.
10505 C<cond> supplies the test expression, and C<block> supplies the block
10506 that will be executed if the test evaluates to true; they are consumed
10507 by this function and become part of the constructed op tree. C<cond>
10508 will be interpreted DWIMically, often as a comparison against C<$_>,
10509 and may be null to generate a C<default> block.
10515 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
10517 const bool cond_llb = (!cond || looks_like_bool(cond));
10520 PERL_ARGS_ASSERT_NEWWHENOP;
10525 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
10527 scalar(ref_array_or_hash(cond)));
10530 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
10533 /* must not conflict with SVf_UTF8 */
10534 #define CV_CKPROTO_CURSTASH 0x1
10537 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
10538 const STRLEN len, const U32 flags)
10540 SV *name = NULL, *msg;
10541 const char * cvp = SvROK(cv)
10542 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
10543 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
10546 STRLEN clen = CvPROTOLEN(cv), plen = len;
10548 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
10550 if (p == NULL && cvp == NULL)
10553 if (!ckWARN_d(WARN_PROTOTYPE))
10557 p = S_strip_spaces(aTHX_ p, &plen);
10558 cvp = S_strip_spaces(aTHX_ cvp, &clen);
10559 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
10560 if (plen == clen && memEQ(cvp, p, plen))
10563 if (flags & SVf_UTF8) {
10564 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
10568 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
10574 msg = sv_newmortal();
10579 gv_efullname3(name = sv_newmortal(), gv, NULL);
10580 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
10581 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
10582 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
10583 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
10584 sv_catpvs(name, "::");
10586 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
10587 assert (CvNAMED(SvRV_const(gv)));
10588 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
10590 else sv_catsv(name, (SV *)gv);
10592 else name = (SV *)gv;
10594 sv_setpvs(msg, "Prototype mismatch:");
10596 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
10598 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
10599 UTF8fARG(SvUTF8(cv),clen,cvp)
10602 sv_catpvs(msg, ": none");
10603 sv_catpvs(msg, " vs ");
10605 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
10607 sv_catpvs(msg, "none");
10608 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
10611 static void const_sv_xsub(pTHX_ CV* cv);
10612 static void const_av_xsub(pTHX_ CV* cv);
10616 =for apidoc_section Optree Manipulation Functions
10618 =for apidoc cv_const_sv
10620 If C<cv> is a constant sub eligible for inlining, returns the constant
10621 value returned by the sub. Otherwise, returns C<NULL>.
10623 Constant subs can be created with C<newCONSTSUB> or as described in
10624 L<perlsub/"Constant Functions">.
10629 Perl_cv_const_sv(const CV *const cv)
10634 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
10636 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10637 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
10642 Perl_cv_const_sv_or_av(const CV * const cv)
10646 if (SvROK(cv)) return SvRV((SV *)cv);
10647 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
10648 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10651 /* op_const_sv: examine an optree to determine whether it's in-lineable.
10652 * Can be called in 2 ways:
10655 * look for a single OP_CONST with attached value: return the value
10657 * allow_lex && !CvCONST(cv);
10659 * examine the clone prototype, and if contains only a single
10660 * OP_CONST, return the value; or if it contains a single PADSV ref-
10661 * erencing an outer lexical, turn on CvCONST to indicate the CV is
10662 * a candidate for "constizing" at clone time, and return NULL.
10666 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
10669 bool padsv = FALSE;
10674 for (; o; o = o->op_next) {
10675 const OPCODE type = o->op_type;
10677 if (type == OP_NEXTSTATE || type == OP_LINESEQ
10679 || type == OP_PUSHMARK)
10681 if (type == OP_DBSTATE)
10683 if (type == OP_LEAVESUB)
10687 if (type == OP_CONST && cSVOPo->op_sv)
10688 sv = cSVOPo->op_sv;
10689 else if (type == OP_UNDEF && !o->op_private) {
10693 else if (allow_lex && type == OP_PADSV) {
10694 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
10696 sv = &PL_sv_undef; /* an arbitrary non-null value */
10714 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10715 PADNAME * const name, SV ** const const_svp)
10718 assert (o || name);
10719 assert (const_svp);
10721 if (CvFLAGS(PL_compcv)) {
10722 /* might have had built-in attrs applied */
10723 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10724 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10725 && ckWARN(WARN_MISC))
10727 /* protect against fatal warnings leaking compcv */
10728 SAVEFREESV(PL_compcv);
10729 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10730 SvREFCNT_inc_simple_void_NN(PL_compcv);
10733 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10734 & ~(CVf_LVALUE * pureperl));
10739 /* redundant check for speed: */
10740 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10741 const line_t oldline = CopLINE(PL_curcop);
10744 : sv_2mortal(newSVpvn_utf8(
10745 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
10747 if (PL_parser && PL_parser->copline != NOLINE)
10748 /* This ensures that warnings are reported at the first
10749 line of a redefinition, not the last. */
10750 CopLINE_set(PL_curcop, PL_parser->copline);
10751 /* protect against fatal warnings leaking compcv */
10752 SAVEFREESV(PL_compcv);
10753 report_redefined_cv(namesv, cv, const_svp);
10754 SvREFCNT_inc_simple_void_NN(PL_compcv);
10755 CopLINE_set(PL_curcop, oldline);
10762 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10767 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10770 CV *compcv = PL_compcv;
10773 PADOFFSET pax = o->op_targ;
10774 CV *outcv = CvOUTSIDE(PL_compcv);
10777 bool reusable = FALSE;
10779 #ifdef PERL_DEBUG_READONLY_OPS
10780 OPSLAB *slab = NULL;
10783 PERL_ARGS_ASSERT_NEWMYSUB;
10785 PL_hints |= HINT_BLOCK_SCOPE;
10787 /* Find the pad slot for storing the new sub.
10788 We cannot use PL_comppad, as it is the pad owned by the new sub. We
10789 need to look in CvOUTSIDE and find the pad belonging to the enclos-
10790 ing sub. And then we need to dig deeper if this is a lexical from
10792 my sub foo; sub { sub foo { } }
10795 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10796 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10797 pax = PARENT_PAD_INDEX(name);
10798 outcv = CvOUTSIDE(outcv);
10803 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10804 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10805 spot = (CV **)svspot;
10807 if (!(PL_parser && PL_parser->error_count))
10808 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10811 assert(proto->op_type == OP_CONST);
10812 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10813 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10823 if (PL_parser && PL_parser->error_count) {
10825 SvREFCNT_dec(PL_compcv);
10830 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10832 svspot = (SV **)(spot = &clonee);
10834 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10837 assert (SvTYPE(*spot) == SVt_PVCV);
10838 if (CvNAMED(*spot))
10839 hek = CvNAME_HEK(*spot);
10842 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10843 CvNAME_HEK_set(*spot, hek =
10846 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10850 CvLEXICAL_on(*spot);
10852 cv = PadnamePROTOCV(name);
10853 svspot = (SV **)(spot = &PadnamePROTOCV(name));
10857 /* This makes sub {}; work as expected. */
10858 if (block->op_type == OP_STUB) {
10859 const line_t l = PL_parser->copline;
10861 block = newSTATEOP(0, NULL, 0);
10862 PL_parser->copline = l;
10864 block = CvLVALUE(compcv)
10865 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10866 ? newUNOP(OP_LEAVESUBLV, 0,
10867 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10868 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10869 start = LINKLIST(block);
10870 block->op_next = 0;
10871 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10872 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10880 const bool exists = CvROOT(cv) || CvXSUB(cv);
10882 /* if the subroutine doesn't exist and wasn't pre-declared
10883 * with a prototype, assume it will be AUTOLOADed,
10884 * skipping the prototype check
10886 if (exists || SvPOK(cv))
10887 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10889 /* already defined? */
10891 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10897 /* just a "sub foo;" when &foo is already defined */
10898 SAVEFREESV(compcv);
10902 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10909 SvREFCNT_inc_simple_void_NN(const_sv);
10910 SvFLAGS(const_sv) |= SVs_PADTMP;
10912 assert(!CvROOT(cv) && !CvCONST(cv));
10913 cv_forget_slab(cv);
10916 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10917 CvFILE_set_from_cop(cv, PL_curcop);
10918 CvSTASH_set(cv, PL_curstash);
10921 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10922 CvXSUBANY(cv).any_ptr = const_sv;
10923 CvXSUB(cv) = const_sv_xsub;
10927 CvFLAGS(cv) |= CvMETHOD(compcv);
10929 SvREFCNT_dec(compcv);
10934 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10935 determine whether this sub definition is in the same scope as its
10936 declaration. If this sub definition is inside an inner named pack-
10937 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10938 the package sub. So check PadnameOUTER(name) too.
10940 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10941 assert(!CvWEAKOUTSIDE(compcv));
10942 SvREFCNT_dec(CvOUTSIDE(compcv));
10943 CvWEAKOUTSIDE_on(compcv);
10945 /* XXX else do we have a circular reference? */
10947 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
10948 /* transfer PL_compcv to cv */
10950 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10951 cv_flags_t preserved_flags =
10952 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10953 PADLIST *const temp_padl = CvPADLIST(cv);
10954 CV *const temp_cv = CvOUTSIDE(cv);
10955 const cv_flags_t other_flags =
10956 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10957 OP * const cvstart = CvSTART(cv);
10961 CvFLAGS(compcv) | preserved_flags;
10962 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10963 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10964 CvPADLIST_set(cv, CvPADLIST(compcv));
10965 CvOUTSIDE(compcv) = temp_cv;
10966 CvPADLIST_set(compcv, temp_padl);
10967 CvSTART(cv) = CvSTART(compcv);
10968 CvSTART(compcv) = cvstart;
10969 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10970 CvFLAGS(compcv) |= other_flags;
10973 Safefree(CvFILE(cv));
10977 /* inner references to compcv must be fixed up ... */
10978 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10979 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10980 ++PL_sub_generation;
10983 /* Might have had built-in attributes applied -- propagate them. */
10984 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10986 /* ... before we throw it away */
10987 SvREFCNT_dec(compcv);
10988 PL_compcv = compcv = cv;
10997 if (!CvNAME_HEK(cv)) {
10998 if (hek) (void)share_hek_hek(hek);
11001 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
11002 hek = share_hek(PadnamePV(name)+1,
11003 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
11006 CvNAME_HEK_set(cv, hek);
11012 if (CvFILE(cv) && CvDYNFILE(cv))
11013 Safefree(CvFILE(cv));
11014 CvFILE_set_from_cop(cv, PL_curcop);
11015 CvSTASH_set(cv, PL_curstash);
11018 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11020 SvUTF8_on(MUTABLE_SV(cv));
11024 /* If we assign an optree to a PVCV, then we've defined a
11025 * subroutine that the debugger could be able to set a breakpoint
11026 * in, so signal to pp_entereval that it should not throw away any
11027 * saved lines at scope exit. */
11029 PL_breakable_sub_gen++;
11030 CvROOT(cv) = block;
11031 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11032 itself has a refcount. */
11034 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11035 #ifdef PERL_DEBUG_READONLY_OPS
11036 slab = (OPSLAB *)CvSTART(cv);
11038 S_process_optree(aTHX_ cv, block, start);
11043 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11044 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
11048 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11049 SV * const tmpstr = sv_newmortal();
11050 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11051 GV_ADDMULTI, SVt_PVHV);
11053 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11054 CopFILE(PL_curcop),
11056 (long)CopLINE(PL_curcop));
11057 if (HvNAME_HEK(PL_curstash)) {
11058 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
11059 sv_catpvs(tmpstr, "::");
11062 sv_setpvs(tmpstr, "__ANON__::");
11064 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
11065 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
11066 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11067 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11068 hv = GvHVn(db_postponed);
11069 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11070 CV * const pcv = GvCV(db_postponed);
11076 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11084 assert(CvDEPTH(outcv));
11086 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
11088 cv_clone_into(clonee, *spot);
11089 else *spot = cv_clone(clonee);
11090 SvREFCNT_dec_NN(clonee);
11094 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
11095 PADOFFSET depth = CvDEPTH(outcv);
11098 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
11100 *svspot = SvREFCNT_inc_simple_NN(cv);
11101 SvREFCNT_dec(oldcv);
11107 PL_parser->copline = NOLINE;
11108 LEAVE_SCOPE(floor);
11109 #ifdef PERL_DEBUG_READONLY_OPS
11118 =for apidoc newATTRSUB_x
11120 Construct a Perl subroutine, also performing some surrounding jobs.
11122 This function is expected to be called in a Perl compilation context,
11123 and some aspects of the subroutine are taken from global variables
11124 associated with compilation. In particular, C<PL_compcv> represents
11125 the subroutine that is currently being compiled. It must be non-null
11126 when this function is called, and some aspects of the subroutine being
11127 constructed are taken from it. The constructed subroutine may actually
11128 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
11130 If C<block> is null then the subroutine will have no body, and for the
11131 time being it will be an error to call it. This represents a forward
11132 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
11133 non-null then it provides the Perl code of the subroutine body, which
11134 will be executed when the subroutine is called. This body includes
11135 any argument unwrapping code resulting from a subroutine signature or
11136 similar. The pad use of the code must correspond to the pad attached
11137 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
11138 C<leavesublv> op; this function will add such an op. C<block> is consumed
11139 by this function and will become part of the constructed subroutine.
11141 C<proto> specifies the subroutine's prototype, unless one is supplied
11142 as an attribute (see below). If C<proto> is null, then the subroutine
11143 will not have a prototype. If C<proto> is non-null, it must point to a
11144 C<const> op whose value is a string, and the subroutine will have that
11145 string as its prototype. If a prototype is supplied as an attribute, the
11146 attribute takes precedence over C<proto>, but in that case C<proto> should
11147 preferably be null. In any case, C<proto> is consumed by this function.
11149 C<attrs> supplies attributes to be applied the subroutine. A handful of
11150 attributes take effect by built-in means, being applied to C<PL_compcv>
11151 immediately when seen. Other attributes are collected up and attached
11152 to the subroutine by this route. C<attrs> may be null to supply no
11153 attributes, or point to a C<const> op for a single attribute, or point
11154 to a C<list> op whose children apart from the C<pushmark> are C<const>
11155 ops for one or more attributes. Each C<const> op must be a string,
11156 giving the attribute name optionally followed by parenthesised arguments,
11157 in the manner in which attributes appear in Perl source. The attributes
11158 will be applied to the sub by this function. C<attrs> is consumed by
11161 If C<o_is_gv> is false and C<o> is null, then the subroutine will
11162 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
11163 must point to a C<const> OP, which will be consumed by this function,
11164 and its string value supplies a name for the subroutine. The name may
11165 be qualified or unqualified, and if it is unqualified then a default
11166 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
11167 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
11168 by which the subroutine will be named.
11170 If there is already a subroutine of the specified name, then the new
11171 sub will either replace the existing one in the glob or be merged with
11172 the existing one. A warning may be generated about redefinition.
11174 If the subroutine has one of a few special names, such as C<BEGIN> or
11175 C<END>, then it will be claimed by the appropriate queue for automatic
11176 running of phase-related subroutines. In this case the relevant glob will
11177 be left not containing any subroutine, even if it did contain one before.
11178 In the case of C<BEGIN>, the subroutine will be executed and the reference
11179 to it disposed of before this function returns.
11181 The function returns a pointer to the constructed subroutine. If the sub
11182 is anonymous then ownership of one counted reference to the subroutine
11183 is transferred to the caller. If the sub is named then the caller does
11184 not get ownership of a reference. In most such cases, where the sub
11185 has a non-phase name, the sub will be alive at the point it is returned
11186 by virtue of being contained in the glob that names it. A phase-named
11187 subroutine will usually be alive by virtue of the reference owned by the
11188 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11189 been executed, will quite likely have been destroyed already by the
11190 time this function returns, making it erroneous for the caller to make
11191 any use of the returned pointer. It is the caller's responsibility to
11192 ensure that it knows which of these situations applies.
11194 =for apidoc newATTRSUB
11195 Construct a Perl subroutine, also performing some surrounding jobs.
11197 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter set to
11198 FALSE. This means that if C<o> is null, the new sub will be anonymous; otherwise
11199 the name will be derived from C<o> in the way described (as with all other
11200 details) in L<perlintern/C<newATTRSUB_x>>.
11203 Like C<L</newATTRSUB>>, but without attributes.
11208 /* _x = extended */
11210 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
11211 OP *block, bool o_is_gv)
11215 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11217 CV *cv = NULL; /* the previous CV with this name, if any */
11219 const bool ec = PL_parser && PL_parser->error_count;
11220 /* If the subroutine has no body, no attributes, and no builtin attributes
11221 then it's just a sub declaration, and we may be able to get away with
11222 storing with a placeholder scalar in the symbol table, rather than a
11223 full CV. If anything is present then it will take a full CV to
11225 const I32 gv_fetch_flags
11226 = ec ? GV_NOADD_NOINIT :
11227 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
11228 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
11230 const char * const name =
11231 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
11233 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
11234 bool evanescent = FALSE;
11236 #ifdef PERL_DEBUG_READONLY_OPS
11237 OPSLAB *slab = NULL;
11245 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
11246 hek and CvSTASH pointer together can imply the GV. If the name
11247 contains a package name, then GvSTASH(CvGV(cv)) may differ from
11248 CvSTASH, so forego the optimisation if we find any.
11249 Also, we may be called from load_module at run time, so
11250 PL_curstash (which sets CvSTASH) may not point to the stash the
11251 sub is stored in. */
11252 /* XXX This optimization is currently disabled for packages other
11253 than main, since there was too much CPAN breakage. */
11255 ec ? GV_NOADD_NOINIT
11256 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
11257 || PL_curstash != PL_defstash
11258 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
11260 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
11261 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
11263 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
11264 SV * const sv = sv_newmortal();
11265 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
11266 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11267 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11268 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
11270 } else if (PL_curstash) {
11271 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
11274 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
11280 move_proto_attr(&proto, &attrs, gv, 0);
11283 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
11288 assert(proto->op_type == OP_CONST);
11289 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11290 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11306 SvREFCNT_dec(PL_compcv);
11311 if (name && block) {
11312 const char *s = (char *) my_memrchr(name, ':', namlen);
11313 s = s ? s+1 : name;
11314 if (strEQ(s, "BEGIN")) {
11315 if (PL_in_eval & EVAL_KEEPERR)
11316 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
11318 SV * const errsv = ERRSV;
11319 /* force display of errors found but not reported */
11320 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
11321 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
11328 if (!block && SvTYPE(gv) != SVt_PVGV) {
11329 /* If we are not defining a new sub and the existing one is not a
11331 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
11332 /* We are applying attributes to an existing sub, so we need it
11333 upgraded if it is a constant. */
11334 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
11335 gv_init_pvn(gv, PL_curstash, name, namlen,
11336 SVf_UTF8 * name_is_utf8);
11338 else { /* Maybe prototype now, and had at maximum
11339 a prototype or const/sub ref before. */
11340 if (SvTYPE(gv) > SVt_NULL) {
11341 cv_ckproto_len_flags((const CV *)gv,
11342 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11348 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
11350 SvUTF8_on(MUTABLE_SV(gv));
11353 sv_setiv(MUTABLE_SV(gv), -1);
11356 SvREFCNT_dec(PL_compcv);
11357 cv = PL_compcv = NULL;
11362 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
11366 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
11372 /* This makes sub {}; work as expected. */
11373 if (block->op_type == OP_STUB) {
11374 const line_t l = PL_parser->copline;
11376 block = newSTATEOP(0, NULL, 0);
11377 PL_parser->copline = l;
11379 block = CvLVALUE(PL_compcv)
11380 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
11381 && (!isGV(gv) || !GvASSUMECV(gv)))
11382 ? newUNOP(OP_LEAVESUBLV, 0,
11383 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
11384 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
11385 start = LINKLIST(block);
11386 block->op_next = 0;
11387 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
11389 S_op_const_sv(aTHX_ start, PL_compcv,
11390 cBOOL(CvCLONE(PL_compcv)));
11397 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
11398 cv_ckproto_len_flags((const CV *)gv,
11399 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11400 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
11402 /* All the other code for sub redefinition warnings expects the
11403 clobbered sub to be a CV. Instead of making all those code
11404 paths more complex, just inline the RV version here. */
11405 const line_t oldline = CopLINE(PL_curcop);
11406 assert(IN_PERL_COMPILETIME);
11407 if (PL_parser && PL_parser->copline != NOLINE)
11408 /* This ensures that warnings are reported at the first
11409 line of a redefinition, not the last. */
11410 CopLINE_set(PL_curcop, PL_parser->copline);
11411 /* protect against fatal warnings leaking compcv */
11412 SAVEFREESV(PL_compcv);
11414 if (ckWARN(WARN_REDEFINE)
11415 || ( ckWARN_d(WARN_REDEFINE)
11416 && ( !const_sv || SvRV(gv) == const_sv
11417 || sv_cmp(SvRV(gv), const_sv) ))) {
11419 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11420 "Constant subroutine %" SVf " redefined",
11421 SVfARG(cSVOPo->op_sv));
11424 SvREFCNT_inc_simple_void_NN(PL_compcv);
11425 CopLINE_set(PL_curcop, oldline);
11426 SvREFCNT_dec(SvRV(gv));
11431 const bool exists = CvROOT(cv) || CvXSUB(cv);
11433 /* if the subroutine doesn't exist and wasn't pre-declared
11434 * with a prototype, assume it will be AUTOLOADed,
11435 * skipping the prototype check
11437 if (exists || SvPOK(cv))
11438 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
11439 /* already defined (or promised)? */
11440 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
11441 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
11447 /* just a "sub foo;" when &foo is already defined */
11448 SAVEFREESV(PL_compcv);
11455 SvREFCNT_inc_simple_void_NN(const_sv);
11456 SvFLAGS(const_sv) |= SVs_PADTMP;
11458 assert(!CvROOT(cv) && !CvCONST(cv));
11459 cv_forget_slab(cv);
11460 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
11461 CvXSUBANY(cv).any_ptr = const_sv;
11462 CvXSUB(cv) = const_sv_xsub;
11466 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11469 if (isGV(gv) || CvMETHOD(PL_compcv)) {
11470 if (name && isGV(gv))
11471 GvCV_set(gv, NULL);
11472 cv = newCONSTSUB_flags(
11473 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
11477 assert(SvREFCNT((SV*)cv) != 0);
11478 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11482 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11483 prepare_SV_for_RV((SV *)gv);
11484 SvOK_off((SV *)gv);
11487 SvRV_set(gv, const_sv);
11491 SvREFCNT_dec(PL_compcv);
11496 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
11497 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
11500 if (cv) { /* must reuse cv if autoloaded */
11501 /* transfer PL_compcv to cv */
11503 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11504 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
11505 PADLIST *const temp_av = CvPADLIST(cv);
11506 CV *const temp_cv = CvOUTSIDE(cv);
11507 const cv_flags_t other_flags =
11508 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11509 OP * const cvstart = CvSTART(cv);
11513 assert(!CvCVGV_RC(cv));
11514 assert(CvGV(cv) == gv);
11518 PERL_HASH(hash, name, namlen);
11528 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
11530 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
11531 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
11532 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
11533 CvOUTSIDE(PL_compcv) = temp_cv;
11534 CvPADLIST_set(PL_compcv, temp_av);
11535 CvSTART(cv) = CvSTART(PL_compcv);
11536 CvSTART(PL_compcv) = cvstart;
11537 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11538 CvFLAGS(PL_compcv) |= other_flags;
11541 Safefree(CvFILE(cv));
11543 CvFILE_set_from_cop(cv, PL_curcop);
11544 CvSTASH_set(cv, PL_curstash);
11546 /* inner references to PL_compcv must be fixed up ... */
11547 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
11548 if (PERLDB_INTER)/* Advice debugger on the new sub. */
11549 ++PL_sub_generation;
11552 /* Might have had built-in attributes applied -- propagate them. */
11553 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
11555 /* ... before we throw it away */
11556 SvREFCNT_dec(PL_compcv);
11561 if (name && isGV(gv)) {
11564 if (HvENAME_HEK(GvSTASH(gv)))
11565 /* sub Foo::bar { (shift)+1 } */
11566 gv_method_changed(gv);
11570 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11571 prepare_SV_for_RV((SV *)gv);
11572 SvOK_off((SV *)gv);
11575 SvRV_set(gv, (SV *)cv);
11576 if (HvENAME_HEK(PL_curstash))
11577 mro_method_changed_in(PL_curstash);
11581 assert(SvREFCNT((SV*)cv) != 0);
11583 if (!CvHASGV(cv)) {
11588 PERL_HASH(hash, name, namlen);
11589 CvNAME_HEK_set(cv, share_hek(name,
11595 CvFILE_set_from_cop(cv, PL_curcop);
11596 CvSTASH_set(cv, PL_curstash);
11600 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11602 SvUTF8_on(MUTABLE_SV(cv));
11606 /* If we assign an optree to a PVCV, then we've defined a
11607 * subroutine that the debugger could be able to set a breakpoint
11608 * in, so signal to pp_entereval that it should not throw away any
11609 * saved lines at scope exit. */
11611 PL_breakable_sub_gen++;
11612 CvROOT(cv) = block;
11613 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11614 itself has a refcount. */
11616 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11617 #ifdef PERL_DEBUG_READONLY_OPS
11618 slab = (OPSLAB *)CvSTART(cv);
11620 S_process_optree(aTHX_ cv, block, start);
11625 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11626 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
11627 ? GvSTASH(CvGV(cv))
11631 apply_attrs(stash, MUTABLE_SV(cv), attrs);
11633 SvREFCNT_inc_simple_void_NN(cv);
11636 if (block && has_name) {
11637 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11638 SV * const tmpstr = cv_name(cv,NULL,0);
11639 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11640 GV_ADDMULTI, SVt_PVHV);
11642 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11643 CopFILE(PL_curcop),
11645 (long)CopLINE(PL_curcop));
11646 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11647 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11648 hv = GvHVn(db_postponed);
11649 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11650 CV * const pcv = GvCV(db_postponed);
11656 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11662 if (PL_parser && PL_parser->error_count)
11663 clear_special_blocks(name, gv, cv);
11666 process_special_blocks(floor, name, gv, cv);
11672 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11674 PL_parser->copline = NOLINE;
11675 LEAVE_SCOPE(floor);
11677 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11679 #ifdef PERL_DEBUG_READONLY_OPS
11683 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11684 pad_add_weakref(cv);
11690 S_clear_special_blocks(pTHX_ const char *const fullname,
11691 GV *const gv, CV *const cv) {
11695 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11697 colon = strrchr(fullname,':');
11698 name = colon ? colon + 1 : fullname;
11700 if ((*name == 'B' && strEQ(name, "BEGIN"))
11701 || (*name == 'E' && strEQ(name, "END"))
11702 || (*name == 'U' && strEQ(name, "UNITCHECK"))
11703 || (*name == 'C' && strEQ(name, "CHECK"))
11704 || (*name == 'I' && strEQ(name, "INIT"))) {
11709 GvCV_set(gv, NULL);
11710 SvREFCNT_dec_NN(MUTABLE_SV(cv));
11714 /* Returns true if the sub has been freed. */
11716 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11720 const char *const colon = strrchr(fullname,':');
11721 const char *const name = colon ? colon + 1 : fullname;
11723 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11725 if (*name == 'B') {
11726 if (strEQ(name, "BEGIN")) {
11727 const I32 oldscope = PL_scopestack_ix;
11730 if (floor) LEAVE_SCOPE(floor);
11732 PUSHSTACKi(PERLSI_REQUIRE);
11733 SAVECOPFILE(&PL_compiling);
11734 SAVECOPLINE(&PL_compiling);
11735 SAVEVPTR(PL_curcop);
11737 DEBUG_x( dump_sub(gv) );
11738 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11739 GvCV_set(gv,0); /* cv has been hijacked */
11740 call_list(oldscope, PL_beginav);
11744 return !PL_savebegin;
11749 if (*name == 'E') {
11750 if (strEQ(name, "END")) {
11751 DEBUG_x( dump_sub(gv) );
11752 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11755 } else if (*name == 'U') {
11756 if (strEQ(name, "UNITCHECK")) {
11757 /* It's never too late to run a unitcheck block */
11758 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11762 } else if (*name == 'C') {
11763 if (strEQ(name, "CHECK")) {
11765 /* diag_listed_as: Too late to run %s block */
11766 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11767 "Too late to run CHECK block");
11768 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11772 } else if (*name == 'I') {
11773 if (strEQ(name, "INIT")) {
11775 /* diag_listed_as: Too late to run %s block */
11776 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11777 "Too late to run INIT block");
11778 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11784 DEBUG_x( dump_sub(gv) );
11786 GvCV_set(gv,0); /* cv has been hijacked */
11792 =for apidoc newCONSTSUB
11794 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11795 rather than of counted length, and no flags are set. (This means that
11796 C<name> is always interpreted as Latin-1.)
11802 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11804 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11808 =for apidoc newCONSTSUB_flags
11810 Construct a constant subroutine, also performing some surrounding
11811 jobs. A scalar constant-valued subroutine is eligible for inlining
11812 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11813 123 }>>. Other kinds of constant subroutine have other treatment.
11815 The subroutine will have an empty prototype and will ignore any arguments
11816 when called. Its constant behaviour is determined by C<sv>. If C<sv>
11817 is null, the subroutine will yield an empty list. If C<sv> points to a
11818 scalar, the subroutine will always yield that scalar. If C<sv> points
11819 to an array, the subroutine will always yield a list of the elements of
11820 that array in list context, or the number of elements in the array in
11821 scalar context. This function takes ownership of one counted reference
11822 to the scalar or array, and will arrange for the object to live as long
11823 as the subroutine does. If C<sv> points to a scalar then the inlining
11824 assumes that the value of the scalar will never change, so the caller
11825 must ensure that the scalar is not subsequently written to. If C<sv>
11826 points to an array then no such assumption is made, so it is ostensibly
11827 safe to mutate the array or its elements, but whether this is really
11828 supported has not been determined.
11830 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11831 Other aspects of the subroutine will be left in their default state.
11832 The caller is free to mutate the subroutine beyond its initial state
11833 after this function has returned.
11835 If C<name> is null then the subroutine will be anonymous, with its
11836 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11837 subroutine will be named accordingly, referenced by the appropriate glob.
11838 C<name> is a string of length C<len> bytes giving a sigilless symbol
11839 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11840 otherwise. The name may be either qualified or unqualified. If the
11841 name is unqualified then it defaults to being in the stash specified by
11842 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11843 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11846 C<flags> should not have bits set other than C<SVf_UTF8>.
11848 If there is already a subroutine of the specified name, then the new sub
11849 will replace the existing one in the glob. A warning may be generated
11850 about the redefinition.
11852 If the subroutine has one of a few special names, such as C<BEGIN> or
11853 C<END>, then it will be claimed by the appropriate queue for automatic
11854 running of phase-related subroutines. In this case the relevant glob will
11855 be left not containing any subroutine, even if it did contain one before.
11856 Execution of the subroutine will likely be a no-op, unless C<sv> was
11857 a tied array or the caller modified the subroutine in some interesting
11858 way before it was executed. In the case of C<BEGIN>, the treatment is
11859 buggy: the sub will be executed when only half built, and may be deleted
11860 prematurely, possibly causing a crash.
11862 The function returns a pointer to the constructed subroutine. If the sub
11863 is anonymous then ownership of one counted reference to the subroutine
11864 is transferred to the caller. If the sub is named then the caller does
11865 not get ownership of a reference. In most such cases, where the sub
11866 has a non-phase name, the sub will be alive at the point it is returned
11867 by virtue of being contained in the glob that names it. A phase-named
11868 subroutine will usually be alive by virtue of the reference owned by
11869 the phase's automatic run queue. A C<BEGIN> subroutine may have been
11870 destroyed already by the time this function returns, but currently bugs
11871 occur in that case before the caller gets control. It is the caller's
11872 responsibility to ensure that it knows which of these situations applies.
11878 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11882 const char *const file = CopFILE(PL_curcop);
11886 if (IN_PERL_RUNTIME) {
11887 /* at runtime, it's not safe to manipulate PL_curcop: it may be
11888 * an op shared between threads. Use a non-shared COP for our
11890 SAVEVPTR(PL_curcop);
11891 SAVECOMPILEWARNINGS();
11892 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11893 PL_curcop = &PL_compiling;
11895 SAVECOPLINE(PL_curcop);
11896 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11899 PL_hints &= ~HINT_BLOCK_SCOPE;
11902 SAVEGENERICSV(PL_curstash);
11903 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11906 /* Protect sv against leakage caused by fatal warnings. */
11907 if (sv) SAVEFREESV(sv);
11909 /* file becomes the CvFILE. For an XS, it's usually static storage,
11910 and so doesn't get free()d. (It's expected to be from the C pre-
11911 processor __FILE__ directive). But we need a dynamically allocated one,
11912 and we need it to get freed. */
11913 cv = newXS_len_flags(name, len,
11914 sv && SvTYPE(sv) == SVt_PVAV
11917 file ? file : "", "",
11918 &sv, XS_DYNAMIC_FILENAME | flags);
11920 assert(SvREFCNT((SV*)cv) != 0);
11921 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11932 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
11933 static storage, as it is used directly as CvFILE(), without a copy being made.
11939 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11941 PERL_ARGS_ASSERT_NEWXS;
11942 return newXS_len_flags(
11943 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11948 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11949 const char *const filename, const char *const proto,
11952 PERL_ARGS_ASSERT_NEWXS_FLAGS;
11953 return newXS_len_flags(
11954 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11959 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11961 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11962 return newXS_len_flags(
11963 name, strlen(name), subaddr, NULL, NULL, NULL, 0
11968 =for apidoc newXS_len_flags
11970 Construct an XS subroutine, also performing some surrounding jobs.
11972 The subroutine will have the entry point C<subaddr>. It will have
11973 the prototype specified by the nul-terminated string C<proto>, or
11974 no prototype if C<proto> is null. The prototype string is copied;
11975 the caller can mutate the supplied string afterwards. If C<filename>
11976 is non-null, it must be a nul-terminated filename, and the subroutine
11977 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
11978 point directly to the supplied string, which must be static. If C<flags>
11979 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11982 Other aspects of the subroutine will be left in their default state.
11983 If anything else needs to be done to the subroutine for it to function
11984 correctly, it is the caller's responsibility to do that after this
11985 function has constructed it. However, beware of the subroutine
11986 potentially being destroyed before this function returns, as described
11989 If C<name> is null then the subroutine will be anonymous, with its
11990 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11991 subroutine will be named accordingly, referenced by the appropriate glob.
11992 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11993 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11994 The name may be either qualified or unqualified, with the stash defaulting
11995 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
11996 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11997 they have there, such as C<GV_ADDWARN>. The symbol is always added to
11998 the stash if necessary, with C<GV_ADDMULTI> semantics.
12000 If there is already a subroutine of the specified name, then the new sub
12001 will replace the existing one in the glob. A warning may be generated
12002 about the redefinition. If the old subroutine was C<CvCONST> then the
12003 decision about whether to warn is influenced by an expectation about
12004 whether the new subroutine will become a constant of similar value.
12005 That expectation is determined by C<const_svp>. (Note that the call to
12006 this function doesn't make the new subroutine C<CvCONST> in any case;
12007 that is left to the caller.) If C<const_svp> is null then it indicates
12008 that the new subroutine will not become a constant. If C<const_svp>
12009 is non-null then it indicates that the new subroutine will become a
12010 constant, and it points to an C<SV*> that provides the constant value
12011 that the subroutine will have.
12013 If the subroutine has one of a few special names, such as C<BEGIN> or
12014 C<END>, then it will be claimed by the appropriate queue for automatic
12015 running of phase-related subroutines. In this case the relevant glob will
12016 be left not containing any subroutine, even if it did contain one before.
12017 In the case of C<BEGIN>, the subroutine will be executed and the reference
12018 to it disposed of before this function returns, and also before its
12019 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
12020 constructed by this function to be ready for execution then the caller
12021 must prevent this happening by giving the subroutine a different name.
12023 The function returns a pointer to the constructed subroutine. If the sub
12024 is anonymous then ownership of one counted reference to the subroutine
12025 is transferred to the caller. If the sub is named then the caller does
12026 not get ownership of a reference. In most such cases, where the sub
12027 has a non-phase name, the sub will be alive at the point it is returned
12028 by virtue of being contained in the glob that names it. A phase-named
12029 subroutine will usually be alive by virtue of the reference owned by the
12030 phase's automatic run queue. But a C<BEGIN> subroutine, having already
12031 been executed, will quite likely have been destroyed already by the
12032 time this function returns, making it erroneous for the caller to make
12033 any use of the returned pointer. It is the caller's responsibility to
12034 ensure that it knows which of these situations applies.
12040 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
12041 XSUBADDR_t subaddr, const char *const filename,
12042 const char *const proto, SV **const_svp,
12046 bool interleave = FALSE;
12047 bool evanescent = FALSE;
12049 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
12052 GV * const gv = gv_fetchpvn(
12053 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
12054 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
12055 sizeof("__ANON__::__ANON__") - 1,
12056 GV_ADDMULTI | flags, SVt_PVCV);
12058 if ((cv = (name ? GvCV(gv) : NULL))) {
12060 /* just a cached method */
12064 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
12065 /* already defined (or promised) */
12066 /* Redundant check that allows us to avoid creating an SV
12067 most of the time: */
12068 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
12069 report_redefined_cv(newSVpvn_flags(
12070 name,len,(flags&SVf_UTF8)|SVs_TEMP
12081 if (cv) /* must reuse cv if autoloaded */
12084 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12088 if (HvENAME_HEK(GvSTASH(gv)))
12089 gv_method_changed(gv); /* newXS */
12093 assert(SvREFCNT((SV*)cv) != 0);
12097 /* XSUBs can't be perl lang/perl5db.pl debugged
12098 if (PERLDB_LINE_OR_SAVESRC)
12099 (void)gv_fetchfile(filename); */
12100 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
12101 if (flags & XS_DYNAMIC_FILENAME) {
12103 CvFILE(cv) = savepv(filename);
12105 /* NOTE: not copied, as it is expected to be an external constant string */
12106 CvFILE(cv) = (char *)filename;
12109 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
12110 CvFILE(cv) = (char*)PL_xsubfilename;
12113 CvXSUB(cv) = subaddr;
12114 #ifndef PERL_IMPLICIT_CONTEXT
12115 CvHSCXT(cv) = &PL_stack_sp;
12121 evanescent = process_special_blocks(0, name, gv, cv);
12124 } /* <- not a conditional branch */
12127 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12129 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
12130 if (interleave) LEAVE;
12131 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12135 /* Add a stub CV to a typeglob.
12136 * This is the implementation of a forward declaration, 'sub foo';'
12140 Perl_newSTUB(pTHX_ GV *gv, bool fake)
12142 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12144 PERL_ARGS_ASSERT_NEWSTUB;
12145 assert(!GvCVu(gv));
12148 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
12149 gv_method_changed(gv);
12151 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
12155 CvGV_set(cv, cvgv);
12156 CvFILE_set_from_cop(cv, PL_curcop);
12157 CvSTASH_set(cv, PL_curstash);
12163 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
12170 if (PL_parser && PL_parser->error_count) {
12176 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
12177 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
12180 if ((cv = GvFORM(gv))) {
12181 if (ckWARN(WARN_REDEFINE)) {
12182 const line_t oldline = CopLINE(PL_curcop);
12183 if (PL_parser && PL_parser->copline != NOLINE)
12184 CopLINE_set(PL_curcop, PL_parser->copline);
12186 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12187 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
12189 /* diag_listed_as: Format %s redefined */
12190 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12191 "Format STDOUT redefined");
12193 CopLINE_set(PL_curcop, oldline);
12198 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
12200 CvFILE_set_from_cop(cv, PL_curcop);
12203 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
12205 start = LINKLIST(root);
12207 S_process_optree(aTHX_ cv, root, start);
12208 cv_forget_slab(cv);
12213 PL_parser->copline = NOLINE;
12214 LEAVE_SCOPE(floor);
12215 PL_compiling.cop_seq = 0;
12219 Perl_newANONLIST(pTHX_ OP *o)
12221 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
12225 Perl_newANONHASH(pTHX_ OP *o)
12227 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
12231 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
12233 return newANONATTRSUB(floor, proto, NULL, block);
12237 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
12239 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
12241 newSVOP(OP_ANONCODE, 0,
12243 if (CvANONCONST(cv))
12244 anoncode = newUNOP(OP_ANONCONST, 0,
12245 op_convert_list(OP_ENTERSUB,
12246 OPf_STACKED|OPf_WANT_SCALAR,
12248 return newUNOP(OP_REFGEN, 0, anoncode);
12252 Perl_oopsAV(pTHX_ OP *o)
12255 PERL_ARGS_ASSERT_OOPSAV;
12257 switch (o->op_type) {
12260 OpTYPE_set(o, OP_PADAV);
12261 return ref(o, OP_RV2AV);
12265 OpTYPE_set(o, OP_RV2AV);
12270 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
12277 Perl_oopsHV(pTHX_ OP *o)
12280 PERL_ARGS_ASSERT_OOPSHV;
12282 switch (o->op_type) {
12285 OpTYPE_set(o, OP_PADHV);
12286 return ref(o, OP_RV2HV);
12290 OpTYPE_set(o, OP_RV2HV);
12291 /* rv2hv steals the bottom bit for its own uses */
12292 o->op_private &= ~OPpARG1_MASK;
12297 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
12304 Perl_newAVREF(pTHX_ OP *o)
12307 PERL_ARGS_ASSERT_NEWAVREF;
12309 if (o->op_type == OP_PADANY) {
12310 OpTYPE_set(o, OP_PADAV);
12313 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
12314 Perl_croak(aTHX_ "Can't use an array as a reference");
12316 return newUNOP(OP_RV2AV, 0, scalar(o));
12320 Perl_newGVREF(pTHX_ I32 type, OP *o)
12322 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
12323 return newUNOP(OP_NULL, 0, o);
12324 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
12328 Perl_newHVREF(pTHX_ OP *o)
12331 PERL_ARGS_ASSERT_NEWHVREF;
12333 if (o->op_type == OP_PADANY) {
12334 OpTYPE_set(o, OP_PADHV);
12337 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12338 Perl_croak(aTHX_ "Can't use a hash as a reference");
12340 return newUNOP(OP_RV2HV, 0, scalar(o));
12344 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12346 if (o->op_type == OP_PADANY) {
12347 OpTYPE_set(o, OP_PADCV);
12349 return newUNOP(OP_RV2CV, flags, scalar(o));
12353 Perl_newSVREF(pTHX_ OP *o)
12356 PERL_ARGS_ASSERT_NEWSVREF;
12358 if (o->op_type == OP_PADANY) {
12359 OpTYPE_set(o, OP_PADSV);
12363 return newUNOP(OP_RV2SV, 0, scalar(o));
12366 /* Check routines. See the comments at the top of this file for details
12367 * on when these are called */
12370 Perl_ck_anoncode(pTHX_ OP *o)
12372 PERL_ARGS_ASSERT_CK_ANONCODE;
12374 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12375 cSVOPo->op_sv = NULL;
12380 S_io_hints(pTHX_ OP *o)
12382 #if O_BINARY != 0 || O_TEXT != 0
12384 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12386 SV **svp = hv_fetchs(table, "open_IN", FALSE);
12389 const char *d = SvPV_const(*svp, len);
12390 const I32 mode = mode_from_discipline(d, len);
12391 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12393 if (mode & O_BINARY)
12394 o->op_private |= OPpOPEN_IN_RAW;
12398 o->op_private |= OPpOPEN_IN_CRLF;
12402 svp = hv_fetchs(table, "open_OUT", FALSE);
12405 const char *d = SvPV_const(*svp, len);
12406 const I32 mode = mode_from_discipline(d, len);
12407 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12409 if (mode & O_BINARY)
12410 o->op_private |= OPpOPEN_OUT_RAW;
12414 o->op_private |= OPpOPEN_OUT_CRLF;
12419 PERL_UNUSED_CONTEXT;
12420 PERL_UNUSED_ARG(o);
12425 Perl_ck_backtick(pTHX_ OP *o)
12430 PERL_ARGS_ASSERT_CK_BACKTICK;
12432 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12433 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12434 && (gv = gv_override("readpipe",8)))
12436 /* detach rest of siblings from o and its first child */
12437 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12438 newop = S_new_entersubop(aTHX_ gv, sibl);
12440 else if (!(o->op_flags & OPf_KIDS))
12441 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12446 S_io_hints(aTHX_ o);
12451 Perl_ck_bitop(pTHX_ OP *o)
12453 PERL_ARGS_ASSERT_CK_BITOP;
12455 o->op_private = (U8)(PL_hints & HINT_INTEGER);
12457 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12458 && OP_IS_INFIX_BIT(o->op_type))
12460 const OP * const left = cBINOPo->op_first;
12461 const OP * const right = OpSIBLING(left);
12462 if ((OP_IS_NUMCOMPARE(left->op_type) &&
12463 (left->op_flags & OPf_PARENS) == 0) ||
12464 (OP_IS_NUMCOMPARE(right->op_type) &&
12465 (right->op_flags & OPf_PARENS) == 0))
12466 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12467 "Possible precedence problem on bitwise %s operator",
12468 o->op_type == OP_BIT_OR
12469 ||o->op_type == OP_NBIT_OR ? "|"
12470 : o->op_type == OP_BIT_AND
12471 ||o->op_type == OP_NBIT_AND ? "&"
12472 : o->op_type == OP_BIT_XOR
12473 ||o->op_type == OP_NBIT_XOR ? "^"
12474 : o->op_type == OP_SBIT_OR ? "|."
12475 : o->op_type == OP_SBIT_AND ? "&." : "^."
12481 PERL_STATIC_INLINE bool
12482 is_dollar_bracket(pTHX_ const OP * const o)
12485 PERL_UNUSED_CONTEXT;
12486 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12487 && (kid = cUNOPx(o)->op_first)
12488 && kid->op_type == OP_GV
12489 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12492 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12495 Perl_ck_cmp(pTHX_ OP *o)
12501 OP *indexop, *constop, *start;
12505 PERL_ARGS_ASSERT_CK_CMP;
12507 is_eq = ( o->op_type == OP_EQ
12508 || o->op_type == OP_NE
12509 || o->op_type == OP_I_EQ
12510 || o->op_type == OP_I_NE);
12512 if (!is_eq && ckWARN(WARN_SYNTAX)) {
12513 const OP *kid = cUNOPo->op_first;
12516 ( is_dollar_bracket(aTHX_ kid)
12517 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12519 || ( kid->op_type == OP_CONST
12520 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12524 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12525 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12528 /* convert (index(...) == -1) and variations into
12529 * (r)index/BOOL(,NEG)
12534 indexop = cUNOPo->op_first;
12535 constop = OpSIBLING(indexop);
12537 if (indexop->op_type == OP_CONST) {
12539 indexop = OpSIBLING(constop);
12544 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12547 /* ($lex = index(....)) == -1 */
12548 if (indexop->op_private & OPpTARGET_MY)
12551 if (constop->op_type != OP_CONST)
12554 sv = cSVOPx_sv(constop);
12555 if (!(sv && SvIOK_notUV(sv)))
12559 if (iv != -1 && iv != 0)
12563 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12564 if (!(iv0 ^ reverse))
12568 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12573 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12574 if (!(iv0 ^ reverse))
12578 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12583 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12589 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12595 indexop->op_flags &= ~OPf_PARENS;
12596 indexop->op_flags |= (o->op_flags & OPf_PARENS);
12597 indexop->op_private |= OPpTRUEBOOL;
12599 indexop->op_private |= OPpINDEX_BOOLNEG;
12600 /* cut out the index op and free the eq,const ops */
12601 (void)op_sibling_splice(o, start, 1, NULL);
12609 Perl_ck_concat(pTHX_ OP *o)
12611 const OP * const kid = cUNOPo->op_first;
12613 PERL_ARGS_ASSERT_CK_CONCAT;
12614 PERL_UNUSED_CONTEXT;
12616 /* reuse the padtmp returned by the concat child */
12617 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12618 !(kUNOP->op_first->op_flags & OPf_MOD))
12620 o->op_flags |= OPf_STACKED;
12621 o->op_private |= OPpCONCAT_NESTED;
12627 Perl_ck_spair(pTHX_ OP *o)
12630 PERL_ARGS_ASSERT_CK_SPAIR;
12632 if (o->op_flags & OPf_KIDS) {
12636 const OPCODE type = o->op_type;
12637 o = modkids(ck_fun(o), type);
12638 kid = cUNOPo->op_first;
12639 kidkid = kUNOP->op_first;
12640 newop = OpSIBLING(kidkid);
12642 const OPCODE type = newop->op_type;
12643 if (OpHAS_SIBLING(newop))
12645 if (o->op_type == OP_REFGEN
12646 && ( type == OP_RV2CV
12647 || ( !(newop->op_flags & OPf_PARENS)
12648 && ( type == OP_RV2AV || type == OP_PADAV
12649 || type == OP_RV2HV || type == OP_PADHV))))
12650 NOOP; /* OK (allow srefgen for \@a and \%h) */
12651 else if (OP_GIMME(newop,0) != G_SCALAR)
12654 /* excise first sibling */
12655 op_sibling_splice(kid, NULL, 1, NULL);
12658 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12659 * and OP_CHOMP into OP_SCHOMP */
12660 o->op_ppaddr = PL_ppaddr[++o->op_type];
12665 Perl_ck_delete(pTHX_ OP *o)
12667 PERL_ARGS_ASSERT_CK_DELETE;
12671 if (o->op_flags & OPf_KIDS) {
12672 OP * const kid = cUNOPo->op_first;
12673 switch (kid->op_type) {
12675 o->op_flags |= OPf_SPECIAL;
12678 o->op_private |= OPpSLICE;
12681 o->op_flags |= OPf_SPECIAL;
12686 o->op_flags |= OPf_SPECIAL;
12689 o->op_private |= OPpKVSLICE;
12692 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12693 "element or slice");
12695 if (kid->op_private & OPpLVAL_INTRO)
12696 o->op_private |= OPpLVAL_INTRO;
12703 Perl_ck_eof(pTHX_ OP *o)
12705 PERL_ARGS_ASSERT_CK_EOF;
12707 if (o->op_flags & OPf_KIDS) {
12709 if (cLISTOPo->op_first->op_type == OP_STUB) {
12711 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12716 kid = cLISTOPo->op_first;
12717 if (kid->op_type == OP_RV2GV)
12718 kid->op_private |= OPpALLOW_FAKE;
12725 Perl_ck_eval(pTHX_ OP *o)
12728 PERL_ARGS_ASSERT_CK_EVAL;
12730 PL_hints |= HINT_BLOCK_SCOPE;
12731 if (o->op_flags & OPf_KIDS) {
12732 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12735 if (o->op_type == OP_ENTERTRY) {
12738 /* cut whole sibling chain free from o */
12739 op_sibling_splice(o, NULL, -1, NULL);
12742 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12744 /* establish postfix order */
12745 enter->op_next = (OP*)enter;
12747 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12748 OpTYPE_set(o, OP_LEAVETRY);
12749 enter->op_other = o;
12754 S_set_haseval(aTHX);
12758 const U8 priv = o->op_private;
12760 /* the newUNOP will recursively call ck_eval(), which will handle
12761 * all the stuff at the end of this function, like adding
12764 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12766 o->op_targ = (PADOFFSET)PL_hints;
12767 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12768 if ((PL_hints & HINT_LOCALIZE_HH) != 0
12769 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12770 /* Store a copy of %^H that pp_entereval can pick up. */
12771 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12773 STOREFEATUREBITSHH(hh);
12774 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12775 /* append hhop to only child */
12776 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12778 o->op_private |= OPpEVAL_HAS_HH;
12780 if (!(o->op_private & OPpEVAL_BYTES)
12781 && FEATURE_UNIEVAL_IS_ENABLED)
12782 o->op_private |= OPpEVAL_UNICODE;
12787 Perl_ck_exec(pTHX_ OP *o)
12789 PERL_ARGS_ASSERT_CK_EXEC;
12791 if (o->op_flags & OPf_STACKED) {
12794 kid = OpSIBLING(cUNOPo->op_first);
12795 if (kid->op_type == OP_RV2GV)
12804 Perl_ck_exists(pTHX_ OP *o)
12806 PERL_ARGS_ASSERT_CK_EXISTS;
12809 if (o->op_flags & OPf_KIDS) {
12810 OP * const kid = cUNOPo->op_first;
12811 if (kid->op_type == OP_ENTERSUB) {
12812 (void) ref(kid, o->op_type);
12813 if (kid->op_type != OP_RV2CV
12814 && !(PL_parser && PL_parser->error_count))
12816 "exists argument is not a subroutine name");
12817 o->op_private |= OPpEXISTS_SUB;
12819 else if (kid->op_type == OP_AELEM)
12820 o->op_flags |= OPf_SPECIAL;
12821 else if (kid->op_type != OP_HELEM)
12822 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12823 "element or a subroutine");
12830 Perl_ck_rvconst(pTHX_ OP *o)
12832 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12834 PERL_ARGS_ASSERT_CK_RVCONST;
12836 if (o->op_type == OP_RV2HV)
12837 /* rv2hv steals the bottom bit for its own uses */
12838 o->op_private &= ~OPpARG1_MASK;
12840 o->op_private |= (PL_hints & HINT_STRICT_REFS);
12842 if (kid->op_type == OP_CONST) {
12845 SV * const kidsv = kid->op_sv;
12847 /* Is it a constant from cv_const_sv()? */
12848 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12851 if (SvTYPE(kidsv) == SVt_PVAV) return o;
12852 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12853 const char *badthing;
12854 switch (o->op_type) {
12856 badthing = "a SCALAR";
12859 badthing = "an ARRAY";
12862 badthing = "a HASH";
12870 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12871 SVfARG(kidsv), badthing);
12874 * This is a little tricky. We only want to add the symbol if we
12875 * didn't add it in the lexer. Otherwise we get duplicate strict
12876 * warnings. But if we didn't add it in the lexer, we must at
12877 * least pretend like we wanted to add it even if it existed before,
12878 * or we get possible typo warnings. OPpCONST_ENTERED says
12879 * whether the lexer already added THIS instance of this symbol.
12881 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12882 gv = gv_fetchsv(kidsv,
12883 o->op_type == OP_RV2CV
12884 && o->op_private & OPpMAY_RETURN_CONSTANT
12886 : iscv | !(kid->op_private & OPpCONST_ENTERED),
12889 : o->op_type == OP_RV2SV
12891 : o->op_type == OP_RV2AV
12893 : o->op_type == OP_RV2HV
12900 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12901 && SvTYPE(SvRV(gv)) != SVt_PVCV)
12902 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12904 OpTYPE_set(kid, OP_GV);
12905 SvREFCNT_dec(kid->op_sv);
12906 #ifdef USE_ITHREADS
12907 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12908 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12909 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12910 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12911 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12913 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12915 kid->op_private = 0;
12916 /* FAKE globs in the symbol table cause weird bugs (#77810) */
12924 Perl_ck_ftst(pTHX_ OP *o)
12926 const I32 type = o->op_type;
12928 PERL_ARGS_ASSERT_CK_FTST;
12930 if (o->op_flags & OPf_REF) {
12933 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12934 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12935 const OPCODE kidtype = kid->op_type;
12937 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12938 && !kid->op_folded) {
12939 OP * const newop = newGVOP(type, OPf_REF,
12940 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12945 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12946 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12948 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12949 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12950 array_passed_to_stat, name);
12953 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12954 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12957 scalar((OP *) kid);
12958 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12959 o->op_private |= OPpFT_ACCESS;
12960 if (OP_IS_FILETEST(type)
12961 && OP_IS_FILETEST(kidtype)
12963 o->op_private |= OPpFT_STACKED;
12964 kid->op_private |= OPpFT_STACKING;
12965 if (kidtype == OP_FTTTY && (
12966 !(kid->op_private & OPpFT_STACKED)
12967 || kid->op_private & OPpFT_AFTER_t
12969 o->op_private |= OPpFT_AFTER_t;
12974 if (type == OP_FTTTY)
12975 o = newGVOP(type, OPf_REF, PL_stdingv);
12977 o = newUNOP(type, 0, newDEFSVOP());
12983 Perl_ck_fun(pTHX_ OP *o)
12985 const int type = o->op_type;
12986 I32 oa = PL_opargs[type] >> OASHIFT;
12988 PERL_ARGS_ASSERT_CK_FUN;
12990 if (o->op_flags & OPf_STACKED) {
12991 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12992 oa &= ~OA_OPTIONAL;
12994 return no_fh_allowed(o);
12997 if (o->op_flags & OPf_KIDS) {
12998 OP *prev_kid = NULL;
12999 OP *kid = cLISTOPo->op_first;
13001 bool seen_optional = FALSE;
13003 if (kid->op_type == OP_PUSHMARK ||
13004 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
13007 kid = OpSIBLING(kid);
13009 if (kid && kid->op_type == OP_COREARGS) {
13010 bool optional = FALSE;
13013 if (oa & OA_OPTIONAL) optional = TRUE;
13016 if (optional) o->op_private |= numargs;
13021 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
13022 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
13023 kid = newDEFSVOP();
13024 /* append kid to chain */
13025 op_sibling_splice(o, prev_kid, 0, kid);
13027 seen_optional = TRUE;
13034 /* list seen where single (scalar) arg expected? */
13035 if (numargs == 1 && !(oa >> 4)
13036 && kid->op_type == OP_LIST && type != OP_SCALAR)
13038 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13040 if (type != OP_DELETE) scalar(kid);
13051 if ((type == OP_PUSH || type == OP_UNSHIFT)
13052 && !OpHAS_SIBLING(kid))
13053 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
13054 "Useless use of %s with no values",
13057 if (kid->op_type == OP_CONST
13058 && ( !SvROK(cSVOPx_sv(kid))
13059 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
13061 bad_type_pv(numargs, "array", o, kid);
13062 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
13063 || kid->op_type == OP_RV2GV) {
13064 bad_type_pv(1, "array", o, kid);
13066 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
13067 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
13068 PL_op_desc[type]), 0);
13071 op_lvalue(kid, type);
13075 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
13076 bad_type_pv(numargs, "hash", o, kid);
13077 op_lvalue(kid, type);
13081 /* replace kid with newop in chain */
13083 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
13084 newop->op_next = newop;
13089 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
13090 if (kid->op_type == OP_CONST &&
13091 (kid->op_private & OPpCONST_BARE))
13093 OP * const newop = newGVOP(OP_GV, 0,
13094 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
13095 /* replace kid with newop in chain */
13096 op_sibling_splice(o, prev_kid, 1, newop);
13100 else if (kid->op_type == OP_READLINE) {
13101 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
13102 bad_type_pv(numargs, "HANDLE", o, kid);
13105 I32 flags = OPf_SPECIAL;
13107 PADOFFSET targ = 0;
13109 /* is this op a FH constructor? */
13110 if (is_handle_constructor(o,numargs)) {
13111 const char *name = NULL;
13114 bool want_dollar = TRUE;
13117 /* Set a flag to tell rv2gv to vivify
13118 * need to "prove" flag does not mean something
13119 * else already - NI-S 1999/05/07
13122 if (kid->op_type == OP_PADSV) {
13124 = PAD_COMPNAME_SV(kid->op_targ);
13125 name = PadnamePV (pn);
13126 len = PadnameLEN(pn);
13127 name_utf8 = PadnameUTF8(pn);
13129 else if (kid->op_type == OP_RV2SV
13130 && kUNOP->op_first->op_type == OP_GV)
13132 GV * const gv = cGVOPx_gv(kUNOP->op_first);
13134 len = GvNAMELEN(gv);
13135 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
13137 else if (kid->op_type == OP_AELEM
13138 || kid->op_type == OP_HELEM)
13141 OP *op = ((BINOP*)kid)->op_first;
13145 const char * const a =
13146 kid->op_type == OP_AELEM ?
13148 if (((op->op_type == OP_RV2AV) ||
13149 (op->op_type == OP_RV2HV)) &&
13150 (firstop = ((UNOP*)op)->op_first) &&
13151 (firstop->op_type == OP_GV)) {
13152 /* packagevar $a[] or $h{} */
13153 GV * const gv = cGVOPx_gv(firstop);
13156 Perl_newSVpvf(aTHX_
13161 else if (op->op_type == OP_PADAV
13162 || op->op_type == OP_PADHV) {
13163 /* lexicalvar $a[] or $h{} */
13164 const char * const padname =
13165 PAD_COMPNAME_PV(op->op_targ);
13168 Perl_newSVpvf(aTHX_
13174 name = SvPV_const(tmpstr, len);
13175 name_utf8 = SvUTF8(tmpstr);
13176 sv_2mortal(tmpstr);
13180 name = "__ANONIO__";
13182 want_dollar = FALSE;
13184 op_lvalue(kid, type);
13188 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
13189 namesv = PAD_SVl(targ);
13190 if (want_dollar && *name != '$')
13191 sv_setpvs(namesv, "$");
13194 sv_catpvn(namesv, name, len);
13195 if ( name_utf8 ) SvUTF8_on(namesv);
13199 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
13201 kid->op_targ = targ;
13202 kid->op_private |= priv;
13208 if ((type == OP_UNDEF || type == OP_POS)
13209 && numargs == 1 && !(oa >> 4)
13210 && kid->op_type == OP_LIST)
13211 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13212 op_lvalue(scalar(kid), type);
13217 kid = OpSIBLING(kid);
13219 /* FIXME - should the numargs or-ing move after the too many
13220 * arguments check? */
13221 o->op_private |= numargs;
13223 return too_many_arguments_pv(o,OP_DESC(o), 0);
13226 else if (PL_opargs[type] & OA_DEFGV) {
13227 /* Ordering of these two is important to keep f_map.t passing. */
13229 return newUNOP(type, 0, newDEFSVOP());
13233 while (oa & OA_OPTIONAL)
13235 if (oa && oa != OA_LIST)
13236 return too_few_arguments_pv(o,OP_DESC(o), 0);
13242 Perl_ck_glob(pTHX_ OP *o)
13246 PERL_ARGS_ASSERT_CK_GLOB;
13249 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13250 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13252 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13256 * \ null - const(wildcard)
13261 * \ mark - glob - rv2cv
13262 * | \ gv(CORE::GLOBAL::glob)
13264 * \ null - const(wildcard)
13266 o->op_flags |= OPf_SPECIAL;
13267 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13268 o = S_new_entersubop(aTHX_ gv, o);
13269 o = newUNOP(OP_NULL, 0, o);
13270 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13273 else o->op_flags &= ~OPf_SPECIAL;
13274 #if !defined(PERL_EXTERNAL_GLOB)
13275 if (!PL_globhook) {
13277 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13278 newSVpvs("File::Glob"), NULL, NULL, NULL);
13281 #endif /* !PERL_EXTERNAL_GLOB */
13282 gv = (GV *)newSV(0);
13283 gv_init(gv, 0, "", 0, 0);
13285 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13286 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13292 Perl_ck_grep(pTHX_ OP *o)
13296 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13298 PERL_ARGS_ASSERT_CK_GREP;
13300 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13302 if (o->op_flags & OPf_STACKED) {
13303 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13304 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13305 return no_fh_allowed(o);
13306 o->op_flags &= ~OPf_STACKED;
13308 kid = OpSIBLING(cLISTOPo->op_first);
13309 if (type == OP_MAPWHILE)
13314 if (PL_parser && PL_parser->error_count)
13316 kid = OpSIBLING(cLISTOPo->op_first);
13317 if (kid->op_type != OP_NULL)
13318 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13319 kid = kUNOP->op_first;
13321 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13322 kid->op_next = (OP*)gwop;
13323 o->op_private = gwop->op_private = 0;
13324 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13326 kid = OpSIBLING(cLISTOPo->op_first);
13327 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13328 op_lvalue(kid, OP_GREPSTART);
13334 Perl_ck_index(pTHX_ OP *o)
13336 PERL_ARGS_ASSERT_CK_INDEX;
13338 if (o->op_flags & OPf_KIDS) {
13339 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13341 kid = OpSIBLING(kid); /* get past "big" */
13342 if (kid && kid->op_type == OP_CONST) {
13343 const bool save_taint = TAINT_get;
13344 SV *sv = kSVOP->op_sv;
13345 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13346 && SvOK(sv) && !SvROK(sv))
13349 sv_copypv(sv, kSVOP->op_sv);
13350 SvREFCNT_dec_NN(kSVOP->op_sv);
13353 if (SvOK(sv)) fbm_compile(sv, 0);
13354 TAINT_set(save_taint);
13355 #ifdef NO_TAINT_SUPPORT
13356 PERL_UNUSED_VAR(save_taint);
13364 Perl_ck_lfun(pTHX_ OP *o)
13366 const OPCODE type = o->op_type;
13368 PERL_ARGS_ASSERT_CK_LFUN;
13370 return modkids(ck_fun(o), type);
13374 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
13376 PERL_ARGS_ASSERT_CK_DEFINED;
13378 if ((o->op_flags & OPf_KIDS)) {
13379 switch (cUNOPo->op_first->op_type) {
13382 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13383 " (Maybe you should just omit the defined()?)");
13384 NOT_REACHED; /* NOTREACHED */
13388 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13389 " (Maybe you should just omit the defined()?)");
13390 NOT_REACHED; /* NOTREACHED */
13401 Perl_ck_readline(pTHX_ OP *o)
13403 PERL_ARGS_ASSERT_CK_READLINE;
13405 if (o->op_flags & OPf_KIDS) {
13406 OP *kid = cLISTOPo->op_first;
13407 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13412 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13420 Perl_ck_rfun(pTHX_ OP *o)
13422 const OPCODE type = o->op_type;
13424 PERL_ARGS_ASSERT_CK_RFUN;
13426 return refkids(ck_fun(o), type);
13430 Perl_ck_listiob(pTHX_ OP *o)
13434 PERL_ARGS_ASSERT_CK_LISTIOB;
13436 kid = cLISTOPo->op_first;
13438 o = force_list(o, 1);
13439 kid = cLISTOPo->op_first;
13441 if (kid->op_type == OP_PUSHMARK)
13442 kid = OpSIBLING(kid);
13443 if (kid && o->op_flags & OPf_STACKED)
13444 kid = OpSIBLING(kid);
13445 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
13446 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13447 && !kid->op_folded) {
13448 o->op_flags |= OPf_STACKED; /* make it a filehandle */
13450 /* replace old const op with new OP_RV2GV parent */
13451 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13452 OP_RV2GV, OPf_REF);
13453 kid = OpSIBLING(kid);
13458 op_append_elem(o->op_type, o, newDEFSVOP());
13460 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13461 return listkids(o);
13465 Perl_ck_smartmatch(pTHX_ OP *o)
13467 PERL_ARGS_ASSERT_CK_SMARTMATCH;
13468 if (0 == (o->op_flags & OPf_SPECIAL)) {
13469 OP *first = cBINOPo->op_first;
13470 OP *second = OpSIBLING(first);
13472 /* Implicitly take a reference to an array or hash */
13474 /* remove the original two siblings, then add back the
13475 * (possibly different) first and second sibs.
13477 op_sibling_splice(o, NULL, 1, NULL);
13478 op_sibling_splice(o, NULL, 1, NULL);
13479 first = ref_array_or_hash(first);
13480 second = ref_array_or_hash(second);
13481 op_sibling_splice(o, NULL, 0, second);
13482 op_sibling_splice(o, NULL, 0, first);
13484 /* Implicitly take a reference to a regular expression */
13485 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13486 OpTYPE_set(first, OP_QR);
13488 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13489 OpTYPE_set(second, OP_QR);
13498 S_maybe_targlex(pTHX_ OP *o)
13500 OP * const kid = cLISTOPo->op_first;
13501 /* has a disposable target? */
13502 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13503 && !(kid->op_flags & OPf_STACKED)
13504 /* Cannot steal the second time! */
13505 && !(kid->op_private & OPpTARGET_MY)
13508 OP * const kkid = OpSIBLING(kid);
13510 /* Can just relocate the target. */
13511 if (kkid && kkid->op_type == OP_PADSV
13512 && (!(kkid->op_private & OPpLVAL_INTRO)
13513 || kkid->op_private & OPpPAD_STATE))
13515 kid->op_targ = kkid->op_targ;
13517 /* Now we do not need PADSV and SASSIGN.
13518 * Detach kid and free the rest. */
13519 op_sibling_splice(o, NULL, 1, NULL);
13521 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
13529 Perl_ck_sassign(pTHX_ OP *o)
13531 OP * const kid = cBINOPo->op_first;
13533 PERL_ARGS_ASSERT_CK_SASSIGN;
13535 if (OpHAS_SIBLING(kid)) {
13536 OP *kkid = OpSIBLING(kid);
13537 /* For state variable assignment with attributes, kkid is a list op
13538 whose op_last is a padsv. */
13539 if ((kkid->op_type == OP_PADSV ||
13540 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13541 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13544 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13545 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13546 return S_newONCEOP(aTHX_ o, kkid);
13549 return S_maybe_targlex(aTHX_ o);
13554 Perl_ck_match(pTHX_ OP *o)
13556 PERL_UNUSED_CONTEXT;
13557 PERL_ARGS_ASSERT_CK_MATCH;
13563 Perl_ck_method(pTHX_ OP *o)
13565 SV *sv, *methsv, *rclass;
13566 const char* method;
13569 STRLEN len, nsplit = 0, i;
13571 OP * const kid = cUNOPo->op_first;
13573 PERL_ARGS_ASSERT_CK_METHOD;
13574 if (kid->op_type != OP_CONST) return o;
13578 /* replace ' with :: */
13579 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13580 SvEND(sv) - SvPVX(sv) )))
13583 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13586 method = SvPVX_const(sv);
13588 utf8 = SvUTF8(sv) ? -1 : 1;
13590 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13595 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13597 if (!nsplit) { /* $proto->method() */
13599 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13602 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13604 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13607 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13608 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13609 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13610 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13612 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13613 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13615 #ifdef USE_ITHREADS
13616 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13618 cMETHOPx(new_op)->op_rclass_sv = rclass;
13625 Perl_ck_null(pTHX_ OP *o)
13627 PERL_ARGS_ASSERT_CK_NULL;
13628 PERL_UNUSED_CONTEXT;
13633 Perl_ck_open(pTHX_ OP *o)
13635 PERL_ARGS_ASSERT_CK_OPEN;
13637 S_io_hints(aTHX_ o);
13639 /* In case of three-arg dup open remove strictness
13640 * from the last arg if it is a bareword. */
13641 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13642 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
13646 if ((last->op_type == OP_CONST) && /* The bareword. */
13647 (last->op_private & OPpCONST_BARE) &&
13648 (last->op_private & OPpCONST_STRICT) &&
13649 (oa = OpSIBLING(first)) && /* The fh. */
13650 (oa = OpSIBLING(oa)) && /* The mode. */
13651 (oa->op_type == OP_CONST) &&
13652 SvPOK(((SVOP*)oa)->op_sv) &&
13653 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
13654 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
13655 (last == OpSIBLING(oa))) /* The bareword. */
13656 last->op_private &= ~OPpCONST_STRICT;
13662 Perl_ck_prototype(pTHX_ OP *o)
13664 PERL_ARGS_ASSERT_CK_PROTOTYPE;
13665 if (!(o->op_flags & OPf_KIDS)) {
13667 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13673 Perl_ck_refassign(pTHX_ OP *o)
13675 OP * const right = cLISTOPo->op_first;
13676 OP * const left = OpSIBLING(right);
13677 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13680 PERL_ARGS_ASSERT_CK_REFASSIGN;
13682 assert (left->op_type == OP_SREFGEN);
13685 /* we use OPpPAD_STATE in refassign to mean either of those things,
13686 * and the code assumes the two flags occupy the same bit position
13687 * in the various ops below */
13688 assert(OPpPAD_STATE == OPpOUR_INTRO);
13690 switch (varop->op_type) {
13692 o->op_private |= OPpLVREF_AV;
13695 o->op_private |= OPpLVREF_HV;
13699 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13700 o->op_targ = varop->op_targ;
13701 varop->op_targ = 0;
13702 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13706 o->op_private |= OPpLVREF_AV;
13708 NOT_REACHED; /* NOTREACHED */
13710 o->op_private |= OPpLVREF_HV;
13714 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13715 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13717 /* Point varop to its GV kid, detached. */
13718 varop = op_sibling_splice(varop, NULL, -1, NULL);
13722 OP * const kidparent =
13723 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13724 OP * const kid = cUNOPx(kidparent)->op_first;
13725 o->op_private |= OPpLVREF_CV;
13726 if (kid->op_type == OP_GV) {
13727 SV *sv = (SV*)cGVOPx_gv(kid);
13729 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13730 /* a CVREF here confuses pp_refassign, so make sure
13732 CV *const cv = (CV*)SvRV(sv);
13733 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
13734 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13735 assert(SvTYPE(sv) == SVt_PVGV);
13737 goto detach_and_stack;
13739 if (kid->op_type != OP_PADCV) goto bad;
13740 o->op_targ = kid->op_targ;
13746 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13747 o->op_private |= OPpLVREF_ELEM;
13750 /* Detach varop. */
13751 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13755 /* diag_listed_as: Can't modify reference to %s in %s assignment */
13756 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13761 if (!FEATURE_REFALIASING_IS_ENABLED)
13763 "Experimental aliasing via reference not enabled");
13764 Perl_ck_warner_d(aTHX_
13765 packWARN(WARN_EXPERIMENTAL__REFALIASING),
13766 "Aliasing via reference is experimental");
13768 o->op_flags |= OPf_STACKED;
13769 op_sibling_splice(o, right, 1, varop);
13772 o->op_flags &=~ OPf_STACKED;
13773 op_sibling_splice(o, right, 1, NULL);
13780 Perl_ck_repeat(pTHX_ OP *o)
13782 PERL_ARGS_ASSERT_CK_REPEAT;
13784 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13786 o->op_private |= OPpREPEAT_DOLIST;
13787 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13788 kids = force_list(kids, 1); /* promote it to a list */
13789 op_sibling_splice(o, NULL, 0, kids); /* and add back */
13797 Perl_ck_require(pTHX_ OP *o)
13801 PERL_ARGS_ASSERT_CK_REQUIRE;
13803 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
13804 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13808 if (kid->op_type == OP_CONST) {
13809 SV * const sv = kid->op_sv;
13810 U32 const was_readonly = SvREADONLY(sv);
13811 if (kid->op_private & OPpCONST_BARE) {
13815 if (was_readonly) {
13816 SvREADONLY_off(sv);
13819 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13824 /* treat ::foo::bar as foo::bar */
13825 if (len >= 2 && s[0] == ':' && s[1] == ':')
13826 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13828 DIE(aTHX_ "Bareword in require maps to empty filename");
13830 for (; s < end; s++) {
13831 if (*s == ':' && s[1] == ':') {
13833 Move(s+2, s+1, end - s - 1, char);
13837 SvEND_set(sv, end);
13838 sv_catpvs(sv, ".pm");
13839 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13840 hek = share_hek(SvPVX(sv),
13841 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13843 sv_sethek(sv, hek);
13845 SvFLAGS(sv) |= was_readonly;
13847 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13850 if (SvREFCNT(sv) > 1) {
13851 kid->op_sv = newSVpvn_share(
13852 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13853 SvREFCNT_dec_NN(sv);
13857 if (was_readonly) SvREADONLY_off(sv);
13858 PERL_HASH(hash, s, len);
13860 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13862 sv_sethek(sv, hek);
13864 SvFLAGS(sv) |= was_readonly;
13870 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13871 /* handle override, if any */
13872 && (gv = gv_override("require", 7))) {
13874 if (o->op_flags & OPf_KIDS) {
13875 kid = cUNOPo->op_first;
13876 op_sibling_splice(o, NULL, -1, NULL);
13879 kid = newDEFSVOP();
13882 newop = S_new_entersubop(aTHX_ gv, kid);
13890 Perl_ck_return(pTHX_ OP *o)
13894 PERL_ARGS_ASSERT_CK_RETURN;
13896 kid = OpSIBLING(cLISTOPo->op_first);
13897 if (PL_compcv && CvLVALUE(PL_compcv)) {
13898 for (; kid; kid = OpSIBLING(kid))
13899 op_lvalue(kid, OP_LEAVESUBLV);
13906 Perl_ck_select(pTHX_ OP *o)
13910 PERL_ARGS_ASSERT_CK_SELECT;
13912 if (o->op_flags & OPf_KIDS) {
13913 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13914 if (kid && OpHAS_SIBLING(kid)) {
13915 OpTYPE_set(o, OP_SSELECT);
13917 return fold_constants(op_integerize(op_std_init(o)));
13921 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13922 if (kid && kid->op_type == OP_RV2GV)
13923 kid->op_private &= ~HINT_STRICT_REFS;
13928 Perl_ck_shift(pTHX_ OP *o)
13930 const I32 type = o->op_type;
13932 PERL_ARGS_ASSERT_CK_SHIFT;
13934 if (!(o->op_flags & OPf_KIDS)) {
13937 if (!CvUNIQUE(PL_compcv)) {
13938 o->op_flags |= OPf_SPECIAL;
13942 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13944 return newUNOP(type, 0, scalar(argop));
13946 return scalar(ck_fun(o));
13950 Perl_ck_sort(pTHX_ OP *o)
13954 HV * const hinthv =
13955 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
13958 PERL_ARGS_ASSERT_CK_SORT;
13961 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
13963 const I32 sorthints = (I32)SvIV(*svp);
13964 if ((sorthints & HINT_SORT_STABLE) != 0)
13965 o->op_private |= OPpSORT_STABLE;
13966 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
13967 o->op_private |= OPpSORT_UNSTABLE;
13971 if (o->op_flags & OPf_STACKED)
13973 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13975 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
13976 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
13978 /* if the first arg is a code block, process it and mark sort as
13980 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13982 if (kid->op_type == OP_LEAVE)
13983 op_null(kid); /* wipe out leave */
13984 /* Prevent execution from escaping out of the sort block. */
13987 /* provide scalar context for comparison function/block */
13988 kid = scalar(firstkid);
13989 kid->op_next = kid;
13990 o->op_flags |= OPf_SPECIAL;
13992 else if (kid->op_type == OP_CONST
13993 && kid->op_private & OPpCONST_BARE) {
13997 const char * const name = SvPV(kSVOP_sv, len);
13999 assert (len < 256);
14000 Copy(name, tmpbuf+1, len, char);
14001 off = pad_findmy_pvn(tmpbuf, len+1, 0);
14002 if (off != NOT_IN_PAD) {
14003 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
14005 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
14006 sv_catpvs(fq, "::");
14007 sv_catsv(fq, kSVOP_sv);
14008 SvREFCNT_dec_NN(kSVOP_sv);
14012 OP * const padop = newOP(OP_PADCV, 0);
14013 padop->op_targ = off;
14014 /* replace the const op with the pad op */
14015 op_sibling_splice(firstkid, NULL, 1, padop);
14021 firstkid = OpSIBLING(firstkid);
14024 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
14025 /* provide list context for arguments */
14028 op_lvalue(kid, OP_GREPSTART);
14034 /* for sort { X } ..., where X is one of
14035 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
14036 * elide the second child of the sort (the one containing X),
14037 * and set these flags as appropriate
14041 * Also, check and warn on lexical $a, $b.
14045 S_simplify_sort(pTHX_ OP *o)
14047 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14051 const char *gvname;
14054 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
14056 kid = kUNOP->op_first; /* get past null */
14057 if (!(have_scopeop = kid->op_type == OP_SCOPE)
14058 && kid->op_type != OP_LEAVE)
14060 kid = kLISTOP->op_last; /* get past scope */
14061 switch(kid->op_type) {
14065 if (!have_scopeop) goto padkids;
14070 k = kid; /* remember this node*/
14071 if (kBINOP->op_first->op_type != OP_RV2SV
14072 || kBINOP->op_last ->op_type != OP_RV2SV)
14075 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
14076 then used in a comparison. This catches most, but not
14077 all cases. For instance, it catches
14078 sort { my($a); $a <=> $b }
14080 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
14081 (although why you'd do that is anyone's guess).
14085 if (!ckWARN(WARN_SYNTAX)) return;
14086 kid = kBINOP->op_first;
14088 if (kid->op_type == OP_PADSV) {
14089 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
14090 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
14091 && ( PadnamePV(name)[1] == 'a'
14092 || PadnamePV(name)[1] == 'b' ))
14093 /* diag_listed_as: "my %s" used in sort comparison */
14094 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14095 "\"%s %s\" used in sort comparison",
14096 PadnameIsSTATE(name)
14101 } while ((kid = OpSIBLING(kid)));
14104 kid = kBINOP->op_first; /* get past cmp */
14105 if (kUNOP->op_first->op_type != OP_GV)
14107 kid = kUNOP->op_first; /* get past rv2sv */
14109 if (GvSTASH(gv) != PL_curstash)
14111 gvname = GvNAME(gv);
14112 if (*gvname == 'a' && gvname[1] == '\0')
14114 else if (*gvname == 'b' && gvname[1] == '\0')
14119 kid = k; /* back to cmp */
14120 /* already checked above that it is rv2sv */
14121 kid = kBINOP->op_last; /* down to 2nd arg */
14122 if (kUNOP->op_first->op_type != OP_GV)
14124 kid = kUNOP->op_first; /* get past rv2sv */
14126 if (GvSTASH(gv) != PL_curstash)
14128 gvname = GvNAME(gv);
14130 ? !(*gvname == 'a' && gvname[1] == '\0')
14131 : !(*gvname == 'b' && gvname[1] == '\0'))
14133 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
14135 o->op_private |= OPpSORT_DESCEND;
14136 if (k->op_type == OP_NCMP)
14137 o->op_private |= OPpSORT_NUMERIC;
14138 if (k->op_type == OP_I_NCMP)
14139 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
14140 kid = OpSIBLING(cLISTOPo->op_first);
14141 /* cut out and delete old block (second sibling) */
14142 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
14147 Perl_ck_split(pTHX_ OP *o)
14152 PERL_ARGS_ASSERT_CK_SPLIT;
14154 assert(o->op_type == OP_LIST);
14156 if (o->op_flags & OPf_STACKED)
14157 return no_fh_allowed(o);
14159 kid = cLISTOPo->op_first;
14160 /* delete leading NULL node, then add a CONST if no other nodes */
14161 assert(kid->op_type == OP_NULL);
14162 op_sibling_splice(o, NULL, 1,
14163 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
14165 kid = cLISTOPo->op_first;
14167 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
14168 /* remove match expression, and replace with new optree with
14169 * a match op at its head */
14170 op_sibling_splice(o, NULL, 1, NULL);
14171 /* pmruntime will handle split " " behavior with flag==2 */
14172 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
14173 op_sibling_splice(o, NULL, 0, kid);
14176 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
14178 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
14179 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
14180 "Use of /g modifier is meaningless in split");
14183 /* eliminate the split op, and move the match op (plus any children)
14184 * into its place, then convert the match op into a split op. i.e.
14186 * SPLIT MATCH SPLIT(ex-MATCH)
14188 * MATCH - A - B - C => R - A - B - C => R - A - B - C
14194 * (R, if it exists, will be a regcomp op)
14197 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14198 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14199 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14200 OpTYPE_set(kid, OP_SPLIT);
14201 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
14202 kid->op_private = o->op_private;
14205 kid = sibs; /* kid is now the string arg of the split */
14208 kid = newDEFSVOP();
14209 op_append_elem(OP_SPLIT, o, kid);
14213 kid = OpSIBLING(kid);
14215 kid = newSVOP(OP_CONST, 0, newSViv(0));
14216 op_append_elem(OP_SPLIT, o, kid);
14217 o->op_private |= OPpSPLIT_IMPLIM;
14221 if (OpHAS_SIBLING(kid))
14222 return too_many_arguments_pv(o,OP_DESC(o), 0);
14228 Perl_ck_stringify(pTHX_ OP *o)
14230 OP * const kid = OpSIBLING(cUNOPo->op_first);
14231 PERL_ARGS_ASSERT_CK_STRINGIFY;
14232 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14233 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
14234 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
14235 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14237 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14245 Perl_ck_join(pTHX_ OP *o)
14247 OP * const kid = OpSIBLING(cLISTOPo->op_first);
14249 PERL_ARGS_ASSERT_CK_JOIN;
14251 if (kid && kid->op_type == OP_MATCH) {
14252 if (ckWARN(WARN_SYNTAX)) {
14253 const REGEXP *re = PM_GETRE(kPMOP);
14255 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14256 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14257 : newSVpvs_flags( "STRING", SVs_TEMP );
14258 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14259 "/%" SVf "/ should probably be written as \"%" SVf "\"",
14260 SVfARG(msg), SVfARG(msg));
14264 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14265 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14266 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14267 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14269 const OP * const bairn = OpSIBLING(kid); /* the list */
14270 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14271 && OP_GIMME(bairn,0) == G_SCALAR)
14273 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14274 op_sibling_splice(o, kid, 1, NULL));
14284 =for apidoc rv2cv_op_cv
14286 Examines an op, which is expected to identify a subroutine at runtime,
14287 and attempts to determine at compile time which subroutine it identifies.
14288 This is normally used during Perl compilation to determine whether
14289 a prototype can be applied to a function call. C<cvop> is the op
14290 being considered, normally an C<rv2cv> op. A pointer to the identified
14291 subroutine is returned, if it could be determined statically, and a null
14292 pointer is returned if it was not possible to determine statically.
14294 Currently, the subroutine can be identified statically if the RV that the
14295 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14296 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
14297 suitable if the constant value must be an RV pointing to a CV. Details of
14298 this process may change in future versions of Perl. If the C<rv2cv> op
14299 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14300 the subroutine statically: this flag is used to suppress compile-time
14301 magic on a subroutine call, forcing it to use default runtime behaviour.
14303 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14304 of a GV reference is modified. If a GV was examined and its CV slot was
14305 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14306 If the op is not optimised away, and the CV slot is later populated with
14307 a subroutine having a prototype, that flag eventually triggers the warning
14308 "called too early to check prototype".
14310 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14311 of returning a pointer to the subroutine it returns a pointer to the
14312 GV giving the most appropriate name for the subroutine in this context.
14313 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14314 (C<CvANON>) subroutine that is referenced through a GV it will be the
14315 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
14316 A null pointer is returned as usual if there is no statically-determinable
14319 =for apidoc Amnh||OPpEARLY_CV
14320 =for apidoc Amnh||OPpENTERSUB_AMPER
14321 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14322 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14327 /* shared by toke.c:yylex */
14329 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14331 PADNAME *name = PAD_COMPNAME(off);
14332 CV *compcv = PL_compcv;
14333 while (PadnameOUTER(name)) {
14334 assert(PARENT_PAD_INDEX(name));
14335 compcv = CvOUTSIDE(compcv);
14336 name = PadlistNAMESARRAY(CvPADLIST(compcv))
14337 [off = PARENT_PAD_INDEX(name)];
14339 assert(!PadnameIsOUR(name));
14340 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14341 return PadnamePROTOCV(name);
14343 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14347 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14352 PERL_ARGS_ASSERT_RV2CV_OP_CV;
14353 if (flags & ~RV2CVOPCV_FLAG_MASK)
14354 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14355 if (cvop->op_type != OP_RV2CV)
14357 if (cvop->op_private & OPpENTERSUB_AMPER)
14359 if (!(cvop->op_flags & OPf_KIDS))
14361 rvop = cUNOPx(cvop)->op_first;
14362 switch (rvop->op_type) {
14364 gv = cGVOPx_gv(rvop);
14366 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14367 cv = MUTABLE_CV(SvRV(gv));
14371 if (flags & RV2CVOPCV_RETURN_STUB)
14377 if (flags & RV2CVOPCV_MARK_EARLY)
14378 rvop->op_private |= OPpEARLY_CV;
14383 SV *rv = cSVOPx_sv(rvop);
14386 cv = (CV*)SvRV(rv);
14390 cv = find_lexical_cv(rvop->op_targ);
14395 } NOT_REACHED; /* NOTREACHED */
14397 if (SvTYPE((SV*)cv) != SVt_PVCV)
14399 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14400 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14404 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14405 if (CvLEXICAL(cv) || CvNAMED(cv))
14407 if (!CvANON(cv) || !gv)
14417 =for apidoc ck_entersub_args_list
14419 Performs the default fixup of the arguments part of an C<entersub>
14420 op tree. This consists of applying list context to each of the
14421 argument ops. This is the standard treatment used on a call marked
14422 with C<&>, or a method call, or a call through a subroutine reference,
14423 or any other call where the callee can't be identified at compile time,
14424 or a call where the callee has no prototype.
14430 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14434 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14436 aop = cUNOPx(entersubop)->op_first;
14437 if (!OpHAS_SIBLING(aop))
14438 aop = cUNOPx(aop)->op_first;
14439 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14440 /* skip the extra attributes->import() call implicitly added in
14441 * something like foo(my $x : bar)
14443 if ( aop->op_type == OP_ENTERSUB
14444 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14448 op_lvalue(aop, OP_ENTERSUB);
14454 =for apidoc ck_entersub_args_proto
14456 Performs the fixup of the arguments part of an C<entersub> op tree
14457 based on a subroutine prototype. This makes various modifications to
14458 the argument ops, from applying context up to inserting C<refgen> ops,
14459 and checking the number and syntactic types of arguments, as directed by
14460 the prototype. This is the standard treatment used on a subroutine call,
14461 not marked with C<&>, where the callee can be identified at compile time
14462 and has a prototype.
14464 C<protosv> supplies the subroutine prototype to be applied to the call.
14465 It may be a normal defined scalar, of which the string value will be used.
14466 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14467 that has been cast to C<SV*>) which has a prototype. The prototype
14468 supplied, in whichever form, does not need to match the actual callee
14469 referenced by the op tree.
14471 If the argument ops disagree with the prototype, for example by having
14472 an unacceptable number of arguments, a valid op tree is returned anyway.
14473 The error is reflected in the parser state, normally resulting in a single
14474 exception at the top level of parsing which covers all the compilation
14475 errors that occurred. In the error message, the callee is referred to
14476 by the name defined by the C<namegv> parameter.
14482 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14485 const char *proto, *proto_end;
14486 OP *aop, *prev, *cvop, *parent;
14489 I32 contextclass = 0;
14490 const char *e = NULL;
14491 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14492 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14493 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14494 "flags=%lx", (unsigned long) SvFLAGS(protosv));
14495 if (SvTYPE(protosv) == SVt_PVCV)
14496 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14497 else proto = SvPV(protosv, proto_len);
14498 proto = S_strip_spaces(aTHX_ proto, &proto_len);
14499 proto_end = proto + proto_len;
14500 parent = entersubop;
14501 aop = cUNOPx(entersubop)->op_first;
14502 if (!OpHAS_SIBLING(aop)) {
14504 aop = cUNOPx(aop)->op_first;
14507 aop = OpSIBLING(aop);
14508 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14509 while (aop != cvop) {
14512 if (proto >= proto_end)
14514 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14515 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14516 SVfARG(namesv)), SvUTF8(namesv));
14526 /* _ must be at the end */
14527 if (proto[1] && !memCHRs(";@%", proto[1]))
14543 if ( o3->op_type != OP_UNDEF
14544 && (o3->op_type != OP_SREFGEN
14545 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14547 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14549 bad_type_gv(arg, namegv, o3,
14550 arg == 1 ? "block or sub {}" : "sub {}");
14553 /* '*' allows any scalar type, including bareword */
14556 if (o3->op_type == OP_RV2GV)
14557 goto wrapref; /* autoconvert GLOB -> GLOBref */
14558 else if (o3->op_type == OP_CONST)
14559 o3->op_private &= ~OPpCONST_STRICT;
14565 if (o3->op_type == OP_RV2AV ||
14566 o3->op_type == OP_PADAV ||
14567 o3->op_type == OP_RV2HV ||
14568 o3->op_type == OP_PADHV
14574 case '[': case ']':
14581 switch (*proto++) {
14583 if (contextclass++ == 0) {
14584 e = (char *) memchr(proto, ']', proto_end - proto);
14585 if (!e || e == proto)
14593 if (contextclass) {
14594 const char *p = proto;
14595 const char *const end = proto;
14597 while (*--p != '[')
14598 /* \[$] accepts any scalar lvalue */
14600 && Perl_op_lvalue_flags(aTHX_
14602 OP_READ, /* not entersub */
14605 bad_type_gv(arg, namegv, o3,
14606 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14611 if (o3->op_type == OP_RV2GV)
14614 bad_type_gv(arg, namegv, o3, "symbol");
14617 if (o3->op_type == OP_ENTERSUB
14618 && !(o3->op_flags & OPf_STACKED))
14621 bad_type_gv(arg, namegv, o3, "subroutine");
14624 if (o3->op_type == OP_RV2SV ||
14625 o3->op_type == OP_PADSV ||
14626 o3->op_type == OP_HELEM ||
14627 o3->op_type == OP_AELEM)
14629 if (!contextclass) {
14630 /* \$ accepts any scalar lvalue */
14631 if (Perl_op_lvalue_flags(aTHX_
14633 OP_READ, /* not entersub */
14636 bad_type_gv(arg, namegv, o3, "scalar");
14640 if (o3->op_type == OP_RV2AV ||
14641 o3->op_type == OP_PADAV)
14643 o3->op_flags &=~ OPf_PARENS;
14647 bad_type_gv(arg, namegv, o3, "array");
14650 if (o3->op_type == OP_RV2HV ||
14651 o3->op_type == OP_PADHV)
14653 o3->op_flags &=~ OPf_PARENS;
14657 bad_type_gv(arg, namegv, o3, "hash");
14660 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14662 if (contextclass && e) {
14667 default: goto oops;
14677 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14678 SVfARG(cv_name((CV *)namegv, NULL, 0)),
14683 op_lvalue(aop, OP_ENTERSUB);
14685 aop = OpSIBLING(aop);
14687 if (aop == cvop && *proto == '_') {
14688 /* generate an access to $_ */
14689 op_sibling_splice(parent, prev, 0, newDEFSVOP());
14691 if (!optional && proto_end > proto &&
14692 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14694 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14695 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14696 SVfARG(namesv)), SvUTF8(namesv));
14702 =for apidoc ck_entersub_args_proto_or_list
14704 Performs the fixup of the arguments part of an C<entersub> op tree either
14705 based on a subroutine prototype or using default list-context processing.
14706 This is the standard treatment used on a subroutine call, not marked
14707 with C<&>, where the callee can be identified at compile time.
14709 C<protosv> supplies the subroutine prototype to be applied to the call,
14710 or indicates that there is no prototype. It may be a normal scalar,
14711 in which case if it is defined then the string value will be used
14712 as a prototype, and if it is undefined then there is no prototype.
14713 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14714 that has been cast to C<SV*>), of which the prototype will be used if it
14715 has one. The prototype (or lack thereof) supplied, in whichever form,
14716 does not need to match the actual callee referenced by the op tree.
14718 If the argument ops disagree with the prototype, for example by having
14719 an unacceptable number of arguments, a valid op tree is returned anyway.
14720 The error is reflected in the parser state, normally resulting in a single
14721 exception at the top level of parsing which covers all the compilation
14722 errors that occurred. In the error message, the callee is referred to
14723 by the name defined by the C<namegv> parameter.
14729 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14730 GV *namegv, SV *protosv)
14732 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14733 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14734 return ck_entersub_args_proto(entersubop, namegv, protosv);
14736 return ck_entersub_args_list(entersubop);
14740 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14742 IV cvflags = SvIVX(protosv);
14743 int opnum = cvflags & 0xffff;
14744 OP *aop = cUNOPx(entersubop)->op_first;
14746 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14750 if (!OpHAS_SIBLING(aop))
14751 aop = cUNOPx(aop)->op_first;
14752 aop = OpSIBLING(aop);
14753 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14755 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14756 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14757 SVfARG(namesv)), SvUTF8(namesv));
14760 op_free(entersubop);
14761 switch(cvflags >> 16) {
14762 case 'F': return newSVOP(OP_CONST, 0,
14763 newSVpv(CopFILE(PL_curcop),0));
14764 case 'L': return newSVOP(
14766 Perl_newSVpvf(aTHX_
14767 "%" IVdf, (IV)CopLINE(PL_curcop)
14770 case 'P': return newSVOP(OP_CONST, 0,
14772 ? newSVhek(HvNAME_HEK(PL_curstash))
14777 NOT_REACHED; /* NOTREACHED */
14780 OP *prev, *cvop, *first, *parent;
14783 parent = entersubop;
14784 if (!OpHAS_SIBLING(aop)) {
14786 aop = cUNOPx(aop)->op_first;
14789 first = prev = aop;
14790 aop = OpSIBLING(aop);
14791 /* find last sibling */
14793 OpHAS_SIBLING(cvop);
14794 prev = cvop, cvop = OpSIBLING(cvop))
14796 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14797 /* Usually, OPf_SPECIAL on an op with no args means that it had
14798 * parens, but these have their own meaning for that flag: */
14799 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14800 && opnum != OP_DELETE && opnum != OP_EXISTS)
14801 flags |= OPf_SPECIAL;
14802 /* excise cvop from end of sibling chain */
14803 op_sibling_splice(parent, prev, 1, NULL);
14805 if (aop == cvop) aop = NULL;
14807 /* detach remaining siblings from the first sibling, then
14808 * dispose of original optree */
14811 op_sibling_splice(parent, first, -1, NULL);
14812 op_free(entersubop);
14814 if (cvflags == (OP_ENTEREVAL | (1<<16)))
14815 flags |= OPpEVAL_BYTES <<8;
14817 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14819 case OA_BASEOP_OR_UNOP:
14820 case OA_FILESTATOP:
14822 return newOP(opnum,flags); /* zero args */
14824 return newUNOP(opnum,flags,aop); /* one arg */
14825 /* too many args */
14832 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14833 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14834 SVfARG(namesv)), SvUTF8(namesv));
14836 nextop = OpSIBLING(aop);
14842 return opnum == OP_RUNCV
14843 ? newPVOP(OP_RUNCV,0,NULL)
14846 return op_convert_list(opnum,0,aop);
14849 NOT_REACHED; /* NOTREACHED */
14854 =for apidoc cv_get_call_checker_flags
14856 Retrieves the function that will be used to fix up a call to C<cv>.
14857 Specifically, the function is applied to an C<entersub> op tree for a
14858 subroutine call, not marked with C<&>, where the callee can be identified
14859 at compile time as C<cv>.
14861 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14862 for it is returned in C<*ckobj_p>, and control flags are returned in
14863 C<*ckflags_p>. The function is intended to be called in this manner:
14865 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14867 In this call, C<entersubop> is a pointer to the C<entersub> op,
14868 which may be replaced by the check function, and C<namegv> supplies
14869 the name that should be used by the check function to refer
14870 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14871 It is permitted to apply the check function in non-standard situations,
14872 such as to a call to a different subroutine or to a method call.
14874 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
14875 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14876 instead, anything that can be used as the first argument to L</cv_name>.
14877 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14878 check function requires C<namegv> to be a genuine GV.
14880 By default, the check function is
14881 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14882 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14883 flag is clear. This implements standard prototype processing. It can
14884 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14886 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14887 indicates that the caller only knows about the genuine GV version of
14888 C<namegv>, and accordingly the corresponding bit will always be set in
14889 C<*ckflags_p>, regardless of the check function's recorded requirements.
14890 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14891 indicates the caller knows about the possibility of passing something
14892 other than a GV as C<namegv>, and accordingly the corresponding bit may
14893 be either set or clear in C<*ckflags_p>, indicating the check function's
14894 recorded requirements.
14896 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14897 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14898 (for which see above). All other bits should be clear.
14900 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14902 =for apidoc cv_get_call_checker
14904 The original form of L</cv_get_call_checker_flags>, which does not return
14905 checker flags. When using a checker function returned by this function,
14906 it is only safe to call it with a genuine GV as its C<namegv> argument.
14912 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14913 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14916 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14917 PERL_UNUSED_CONTEXT;
14918 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14920 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14921 *ckobj_p = callmg->mg_obj;
14922 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14924 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14925 *ckobj_p = (SV*)cv;
14926 *ckflags_p = gflags & MGf_REQUIRE_GV;
14931 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14934 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14935 PERL_UNUSED_CONTEXT;
14936 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14941 =for apidoc cv_set_call_checker_flags
14943 Sets the function that will be used to fix up a call to C<cv>.
14944 Specifically, the function is applied to an C<entersub> op tree for a
14945 subroutine call, not marked with C<&>, where the callee can be identified
14946 at compile time as C<cv>.
14948 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14949 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14950 The function should be defined like this:
14952 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14954 It is intended to be called in this manner:
14956 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14958 In this call, C<entersubop> is a pointer to the C<entersub> op,
14959 which may be replaced by the check function, and C<namegv> supplies
14960 the name that should be used by the check function to refer
14961 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14962 It is permitted to apply the check function in non-standard situations,
14963 such as to a call to a different subroutine or to a method call.
14965 C<namegv> may not actually be a GV. For efficiency, perl may pass a
14966 CV or other SV instead. Whatever is passed can be used as the first
14967 argument to L</cv_name>. You can force perl to pass a GV by including
14968 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14970 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14971 bit currently has a defined meaning (for which see above). All other
14972 bits should be clear.
14974 The current setting for a particular CV can be retrieved by
14975 L</cv_get_call_checker_flags>.
14977 =for apidoc cv_set_call_checker
14979 The original form of L</cv_set_call_checker_flags>, which passes it the
14980 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
14981 of that flag setting is that the check function is guaranteed to get a
14982 genuine GV as its C<namegv> argument.
14988 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14990 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14991 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14995 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14996 SV *ckobj, U32 ckflags)
14998 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14999 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
15000 if (SvMAGICAL((SV*)cv))
15001 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
15004 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
15005 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
15007 if (callmg->mg_flags & MGf_REFCOUNTED) {
15008 SvREFCNT_dec(callmg->mg_obj);
15009 callmg->mg_flags &= ~MGf_REFCOUNTED;
15011 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
15012 callmg->mg_obj = ckobj;
15013 if (ckobj != (SV*)cv) {
15014 SvREFCNT_inc_simple_void_NN(ckobj);
15015 callmg->mg_flags |= MGf_REFCOUNTED;
15017 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
15018 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
15023 S_entersub_alloc_targ(pTHX_ OP * const o)
15025 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
15026 o->op_private |= OPpENTERSUB_HASTARG;
15030 Perl_ck_subr(pTHX_ OP *o)
15035 SV **const_class = NULL;
15037 PERL_ARGS_ASSERT_CK_SUBR;
15039 aop = cUNOPx(o)->op_first;
15040 if (!OpHAS_SIBLING(aop))
15041 aop = cUNOPx(aop)->op_first;
15042 aop = OpSIBLING(aop);
15043 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
15044 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
15045 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
15047 o->op_private &= ~1;
15048 o->op_private |= (PL_hints & HINT_STRICT_REFS);
15049 if (PERLDB_SUB && PL_curstash != PL_debstash)
15050 o->op_private |= OPpENTERSUB_DB;
15051 switch (cvop->op_type) {
15053 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
15057 case OP_METHOD_NAMED:
15058 case OP_METHOD_SUPER:
15059 case OP_METHOD_REDIR:
15060 case OP_METHOD_REDIR_SUPER:
15061 o->op_flags |= OPf_REF;
15062 if (aop->op_type == OP_CONST) {
15063 aop->op_private &= ~OPpCONST_STRICT;
15064 const_class = &cSVOPx(aop)->op_sv;
15066 else if (aop->op_type == OP_LIST) {
15067 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
15068 if (sib && sib->op_type == OP_CONST) {
15069 sib->op_private &= ~OPpCONST_STRICT;
15070 const_class = &cSVOPx(sib)->op_sv;
15073 /* make class name a shared cow string to speedup method calls */
15074 /* constant string might be replaced with object, f.e. bigint */
15075 if (const_class && SvPOK(*const_class)) {
15077 const char* str = SvPV(*const_class, len);
15079 SV* const shared = newSVpvn_share(
15080 str, SvUTF8(*const_class)
15081 ? -(SSize_t)len : (SSize_t)len,
15084 if (SvREADONLY(*const_class))
15085 SvREADONLY_on(shared);
15086 SvREFCNT_dec(*const_class);
15087 *const_class = shared;
15094 S_entersub_alloc_targ(aTHX_ o);
15095 return ck_entersub_args_list(o);
15097 Perl_call_checker ckfun;
15100 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
15101 if (CvISXSUB(cv) || !CvROOT(cv))
15102 S_entersub_alloc_targ(aTHX_ o);
15104 /* The original call checker API guarantees that a GV will
15105 be provided with the right name. So, if the old API was
15106 used (or the REQUIRE_GV flag was passed), we have to reify
15107 the CV’s GV, unless this is an anonymous sub. This is not
15108 ideal for lexical subs, as its stringification will include
15109 the package. But it is the best we can do. */
15110 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
15111 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
15114 else namegv = MUTABLE_GV(cv);
15115 /* After a syntax error in a lexical sub, the cv that
15116 rv2cv_op_cv returns may be a nameless stub. */
15117 if (!namegv) return ck_entersub_args_list(o);
15120 return ckfun(aTHX_ o, namegv, ckobj);
15125 Perl_ck_svconst(pTHX_ OP *o)
15127 SV * const sv = cSVOPo->op_sv;
15128 PERL_ARGS_ASSERT_CK_SVCONST;
15129 PERL_UNUSED_CONTEXT;
15130 #ifdef PERL_COPY_ON_WRITE
15131 /* Since the read-only flag may be used to protect a string buffer, we
15132 cannot do copy-on-write with existing read-only scalars that are not
15133 already copy-on-write scalars. To allow $_ = "hello" to do COW with
15134 that constant, mark the constant as COWable here, if it is not
15135 already read-only. */
15136 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
15139 # ifdef PERL_DEBUG_READONLY_COW
15149 Perl_ck_trunc(pTHX_ OP *o)
15151 PERL_ARGS_ASSERT_CK_TRUNC;
15153 if (o->op_flags & OPf_KIDS) {
15154 SVOP *kid = (SVOP*)cUNOPo->op_first;
15156 if (kid->op_type == OP_NULL)
15157 kid = (SVOP*)OpSIBLING(kid);
15158 if (kid && kid->op_type == OP_CONST &&
15159 (kid->op_private & OPpCONST_BARE) &&
15162 o->op_flags |= OPf_SPECIAL;
15163 kid->op_private &= ~OPpCONST_STRICT;
15170 Perl_ck_substr(pTHX_ OP *o)
15172 PERL_ARGS_ASSERT_CK_SUBSTR;
15175 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15176 OP *kid = cLISTOPo->op_first;
15178 if (kid->op_type == OP_NULL)
15179 kid = OpSIBLING(kid);
15181 /* Historically, substr(delete $foo{bar},...) has been allowed
15182 with 4-arg substr. Keep it working by applying entersub
15184 op_lvalue(kid, OP_ENTERSUB);
15191 Perl_ck_tell(pTHX_ OP *o)
15193 PERL_ARGS_ASSERT_CK_TELL;
15195 if (o->op_flags & OPf_KIDS) {
15196 OP *kid = cLISTOPo->op_first;
15197 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15198 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15204 Perl_ck_each(pTHX_ OP *o)
15206 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15207 const unsigned orig_type = o->op_type;
15209 PERL_ARGS_ASSERT_CK_EACH;
15212 switch (kid->op_type) {
15218 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15219 : orig_type == OP_KEYS ? OP_AKEYS
15223 if (kid->op_private == OPpCONST_BARE
15224 || !SvROK(cSVOPx_sv(kid))
15225 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15226 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
15231 qerror(Perl_mess(aTHX_
15232 "Experimental %s on scalar is now forbidden",
15233 PL_op_desc[orig_type]));
15235 bad_type_pv(1, "hash or array", o, kid);
15243 Perl_ck_length(pTHX_ OP *o)
15245 PERL_ARGS_ASSERT_CK_LENGTH;
15249 if (ckWARN(WARN_SYNTAX)) {
15250 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15254 const bool hash = kid->op_type == OP_PADHV
15255 || kid->op_type == OP_RV2HV;
15256 switch (kid->op_type) {
15261 name = S_op_varname(aTHX_ kid);
15267 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15268 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15270 SVfARG(name), hash ? "keys " : "", SVfARG(name)
15273 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15274 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15275 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15277 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15278 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15279 "length() used on @array (did you mean \"scalar(@array)\"?)");
15288 Perl_ck_isa(pTHX_ OP *o)
15290 OP *classop = cBINOPo->op_last;
15292 PERL_ARGS_ASSERT_CK_ISA;
15294 /* Convert barename into PV */
15295 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15296 /* TODO: Optionally convert package to raw HV here */
15297 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15305 ---------------------------------------------------------
15307 Common vars in list assignment
15309 There now follows some enums and static functions for detecting
15310 common variables in list assignments. Here is a little essay I wrote
15311 for myself when trying to get my head around this. DAPM.
15315 First some random observations:
15317 * If a lexical var is an alias of something else, e.g.
15318 for my $x ($lex, $pkg, $a[0]) {...}
15319 then the act of aliasing will increase the reference count of the SV
15321 * If a package var is an alias of something else, it may still have a
15322 reference count of 1, depending on how the alias was created, e.g.
15323 in *a = *b, $a may have a refcount of 1 since the GP is shared
15324 with a single GvSV pointer to the SV. So If it's an alias of another
15325 package var, then RC may be 1; if it's an alias of another scalar, e.g.
15326 a lexical var or an array element, then it will have RC > 1.
15328 * There are many ways to create a package alias; ultimately, XS code
15329 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
15330 run-time tracing mechanisms are unlikely to be able to catch all cases.
15332 * When the LHS is all my declarations, the same vars can't appear directly
15333 on the RHS, but they can indirectly via closures, aliasing and lvalue
15334 subs. But those techniques all involve an increase in the lexical
15335 scalar's ref count.
15337 * When the LHS is all lexical vars (but not necessarily my declarations),
15338 it is possible for the same lexicals to appear directly on the RHS, and
15339 without an increased ref count, since the stack isn't refcounted.
15340 This case can be detected at compile time by scanning for common lex
15341 vars with PL_generation.
15343 * lvalue subs defeat common var detection, but they do at least
15344 return vars with a temporary ref count increment. Also, you can't
15345 tell at compile time whether a sub call is lvalue.
15350 A: There are a few circumstances where there definitely can't be any
15353 LHS empty: () = (...);
15354 RHS empty: (....) = ();
15355 RHS contains only constants or other 'can't possibly be shared'
15356 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
15357 i.e. they only contain ops not marked as dangerous, whose children
15358 are also not dangerous;
15360 LHS contains a single scalar element: e.g. ($x) = (....); because
15361 after $x has been modified, it won't be used again on the RHS;
15362 RHS contains a single element with no aggregate on LHS: e.g.
15363 ($a,$b,$c) = ($x); again, once $a has been modified, its value
15364 won't be used again.
15366 B: If LHS are all 'my' lexical var declarations (or safe ops, which
15369 my ($a, $b, @c) = ...;
15371 Due to closure and goto tricks, these vars may already have content.
15372 For the same reason, an element on the RHS may be a lexical or package
15373 alias of one of the vars on the left, or share common elements, for
15376 my ($x,$y) = f(); # $x and $y on both sides
15377 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
15382 my @a = @$ra; # elements of @a on both sides
15383 sub f { @a = 1..4; \@a }
15386 First, just consider scalar vars on LHS:
15388 RHS is safe only if (A), or in addition,
15389 * contains only lexical *scalar* vars, where neither side's
15390 lexicals have been flagged as aliases
15392 If RHS is not safe, then it's always legal to check LHS vars for
15393 RC==1, since the only RHS aliases will always be associated
15396 Note that in particular, RHS is not safe if:
15398 * it contains package scalar vars; e.g.:
15401 my ($x, $y) = (2, $x_alias);
15402 sub f { $x = 1; *x_alias = \$x; }
15404 * It contains other general elements, such as flattened or
15405 * spliced or single array or hash elements, e.g.
15408 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
15412 use feature 'refaliasing';
15413 \($a[0], $a[1]) = \($y,$x);
15416 It doesn't matter if the array/hash is lexical or package.
15418 * it contains a function call that happens to be an lvalue
15419 sub which returns one or more of the above, e.g.
15430 (so a sub call on the RHS should be treated the same
15431 as having a package var on the RHS).
15433 * any other "dangerous" thing, such an op or built-in that
15434 returns one of the above, e.g. pp_preinc
15437 If RHS is not safe, what we can do however is at compile time flag
15438 that the LHS are all my declarations, and at run time check whether
15439 all the LHS have RC == 1, and if so skip the full scan.
15441 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
15443 Here the issue is whether there can be elements of @a on the RHS
15444 which will get prematurely freed when @a is cleared prior to
15445 assignment. This is only a problem if the aliasing mechanism
15446 is one which doesn't increase the refcount - only if RC == 1
15447 will the RHS element be prematurely freed.
15449 Because the array/hash is being INTROed, it or its elements
15450 can't directly appear on the RHS:
15452 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
15454 but can indirectly, e.g.:
15458 sub f { @a = 1..3; \@a }
15460 So if the RHS isn't safe as defined by (A), we must always
15461 mortalise and bump the ref count of any remaining RHS elements
15462 when assigning to a non-empty LHS aggregate.
15464 Lexical scalars on the RHS aren't safe if they've been involved in
15467 use feature 'refaliasing';
15470 \(my $lex) = \$pkg;
15471 my @a = ($lex,3); # equivalent to ($a[0],3)
15478 Similarly with lexical arrays and hashes on the RHS:
15492 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
15493 my $a; ($a, my $b) = (....);
15495 The difference between (B) and (C) is that it is now physically
15496 possible for the LHS vars to appear on the RHS too, where they
15497 are not reference counted; but in this case, the compile-time
15498 PL_generation sweep will detect such common vars.
15500 So the rules for (C) differ from (B) in that if common vars are
15501 detected, the runtime "test RC==1" optimisation can no longer be used,
15502 and a full mark and sweep is required
15504 D: As (C), but in addition the LHS may contain package vars.
15506 Since package vars can be aliased without a corresponding refcount
15507 increase, all bets are off. It's only safe if (A). E.g.
15509 my ($x, $y) = (1,2);
15511 for $x_alias ($x) {
15512 ($x_alias, $y) = (3, $x); # whoops
15515 Ditto for LHS aggregate package vars.
15517 E: Any other dangerous ops on LHS, e.g.
15518 (f(), $a[0], @$r) = (...);
15520 this is similar to (E) in that all bets are off. In addition, it's
15521 impossible to determine at compile time whether the LHS
15522 contains a scalar or an aggregate, e.g.
15524 sub f : lvalue { @a }
15527 * ---------------------------------------------------------
15531 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
15532 * that at least one of the things flagged was seen.
15536 AAS_MY_SCALAR = 0x001, /* my $scalar */
15537 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
15538 AAS_LEX_SCALAR = 0x004, /* $lexical */
15539 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
15540 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
15541 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
15542 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
15543 AAS_DANGEROUS = 0x080, /* an op (other than the above)
15544 that's flagged OA_DANGEROUS */
15545 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
15546 not in any of the categories above */
15547 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
15552 /* helper function for S_aassign_scan().
15553 * check a PAD-related op for commonality and/or set its generation number.
15554 * Returns a boolean indicating whether its shared */
15557 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
15559 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
15560 /* lexical used in aliasing */
15564 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
15566 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
15573 Helper function for OPpASSIGN_COMMON* detection in rpeep().
15574 It scans the left or right hand subtree of the aassign op, and returns a
15575 set of flags indicating what sorts of things it found there.
15576 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
15577 set PL_generation on lexical vars; if the latter, we see if
15578 PL_generation matches.
15579 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
15580 This fn will increment it by the number seen. It's not intended to
15581 be an accurate count (especially as many ops can push a variable
15582 number of SVs onto the stack); rather it's used as to test whether there
15583 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
15587 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
15590 OP *effective_top_op = o;
15594 bool top = o == effective_top_op;
15596 OP* next_kid = NULL;
15598 /* first, look for a solitary @_ on the RHS */
15601 && (o->op_flags & OPf_KIDS)
15602 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
15604 OP *kid = cUNOPo->op_first;
15605 if ( ( kid->op_type == OP_PUSHMARK
15606 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
15607 && ((kid = OpSIBLING(kid)))
15608 && !OpHAS_SIBLING(kid)
15609 && kid->op_type == OP_RV2AV
15610 && !(kid->op_flags & OPf_REF)
15611 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15612 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
15613 && ((kid = cUNOPx(kid)->op_first))
15614 && kid->op_type == OP_GV
15615 && cGVOPx_gv(kid) == PL_defgv
15620 switch (o->op_type) {
15623 all_flags |= AAS_PKG_SCALAR;
15629 /* if !top, could be e.g. @a[0,1] */
15630 all_flags |= (top && (o->op_flags & OPf_REF))
15631 ? ((o->op_private & OPpLVAL_INTRO)
15632 ? AAS_MY_AGG : AAS_LEX_AGG)
15638 int comm = S_aassign_padcheck(aTHX_ o, rhs)
15639 ? AAS_LEX_SCALAR_COMM : 0;
15641 all_flags |= (o->op_private & OPpLVAL_INTRO)
15642 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
15650 if (cUNOPx(o)->op_first->op_type != OP_GV)
15651 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
15653 /* if !top, could be e.g. @a[0,1] */
15654 else if (top && (o->op_flags & OPf_REF))
15655 all_flags |= AAS_PKG_AGG;
15657 all_flags |= AAS_DANGEROUS;
15662 if (cUNOPx(o)->op_first->op_type != OP_GV) {
15664 all_flags |= AAS_DANGEROUS; /* ${expr} */
15667 all_flags |= AAS_PKG_SCALAR; /* $pkg */
15671 if (o->op_private & OPpSPLIT_ASSIGN) {
15672 /* the assign in @a = split() has been optimised away
15673 * and the @a attached directly to the split op
15674 * Treat the array as appearing on the RHS, i.e.
15675 * ... = (@a = split)
15680 if (o->op_flags & OPf_STACKED) {
15681 /* @{expr} = split() - the array expression is tacked
15682 * on as an extra child to split - process kid */
15683 next_kid = cLISTOPo->op_last;
15687 /* ... else array is directly attached to split op */
15689 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
15690 ? ((o->op_private & OPpLVAL_INTRO)
15691 ? AAS_MY_AGG : AAS_LEX_AGG)
15696 /* other args of split can't be returned */
15697 all_flags |= AAS_SAFE_SCALAR;
15701 /* undef on LHS following a var is significant, e.g.
15703 * @a = (($x, undef) = (2 => $x));
15704 * # @a shoul be (2,1) not (2,2)
15706 * undef on RHS counts as a scalar:
15707 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
15709 if ((!rhs && *scalars_p) || rhs)
15711 flags = AAS_SAFE_SCALAR;
15716 /* these are all no-ops; they don't push a potentially common SV
15717 * onto the stack, so they are neither AAS_DANGEROUS nor
15718 * AAS_SAFE_SCALAR */
15721 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
15726 /* these do nothing, but may have children */
15730 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
15732 flags = AAS_DANGEROUS;
15736 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
15737 && (o->op_private & OPpTARGET_MY))
15740 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
15741 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
15745 /* if its an unrecognised, non-dangerous op, assume that it
15746 * is the cause of at least one safe scalar */
15748 flags = AAS_SAFE_SCALAR;
15752 all_flags |= flags;
15754 /* by default, process all kids next
15755 * XXX this assumes that all other ops are "transparent" - i.e. that
15756 * they can return some of their children. While this true for e.g.
15757 * sort and grep, it's not true for e.g. map. We really need a
15758 * 'transparent' flag added to regen/opcodes
15760 if (o->op_flags & OPf_KIDS) {
15761 next_kid = cUNOPo->op_first;
15762 /* these ops do nothing but may have children; but their
15763 * children should also be treated as top-level */
15764 if ( o == effective_top_op
15765 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
15767 effective_top_op = next_kid;
15771 /* If next_kid is set, someone in the code above wanted us to process
15772 * that kid and all its remaining siblings. Otherwise, work our way
15773 * back up the tree */
15775 while (!next_kid) {
15777 return all_flags; /* at top; no parents/siblings to try */
15778 if (OpHAS_SIBLING(o)) {
15779 next_kid = o->op_sibparent;
15780 if (o == effective_top_op)
15781 effective_top_op = next_kid;
15784 if (o == effective_top_op)
15785 effective_top_op = o->op_sibparent;
15786 o = o->op_sibparent; /* try parent's next sibling */
15795 /* Check for in place reverse and sort assignments like "@a = reverse @a"
15796 and modify the optree to make them work inplace */
15799 S_inplace_aassign(pTHX_ OP *o) {
15801 OP *modop, *modop_pushmark;
15803 OP *oleft, *oleft_pushmark;
15805 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
15807 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
15809 assert(cUNOPo->op_first->op_type == OP_NULL);
15810 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
15811 assert(modop_pushmark->op_type == OP_PUSHMARK);
15812 modop = OpSIBLING(modop_pushmark);
15814 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
15817 /* no other operation except sort/reverse */
15818 if (OpHAS_SIBLING(modop))
15821 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
15822 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
15824 if (modop->op_flags & OPf_STACKED) {
15825 /* skip sort subroutine/block */
15826 assert(oright->op_type == OP_NULL);
15827 oright = OpSIBLING(oright);
15830 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
15831 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
15832 assert(oleft_pushmark->op_type == OP_PUSHMARK);
15833 oleft = OpSIBLING(oleft_pushmark);
15835 /* Check the lhs is an array */
15837 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
15838 || OpHAS_SIBLING(oleft)
15839 || (oleft->op_private & OPpLVAL_INTRO)
15843 /* Only one thing on the rhs */
15844 if (OpHAS_SIBLING(oright))
15847 /* check the array is the same on both sides */
15848 if (oleft->op_type == OP_RV2AV) {
15849 if (oright->op_type != OP_RV2AV
15850 || !cUNOPx(oright)->op_first
15851 || cUNOPx(oright)->op_first->op_type != OP_GV
15852 || cUNOPx(oleft )->op_first->op_type != OP_GV
15853 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15854 cGVOPx_gv(cUNOPx(oright)->op_first)
15858 else if (oright->op_type != OP_PADAV
15859 || oright->op_targ != oleft->op_targ
15863 /* This actually is an inplace assignment */
15865 modop->op_private |= OPpSORT_INPLACE;
15867 /* transfer MODishness etc from LHS arg to RHS arg */
15868 oright->op_flags = oleft->op_flags;
15870 /* remove the aassign op and the lhs */
15872 op_null(oleft_pushmark);
15873 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15874 op_null(cUNOPx(oleft)->op_first);
15880 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
15881 * that potentially represent a series of one or more aggregate derefs
15882 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
15883 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
15884 * additional ops left in too).
15886 * The caller will have already verified that the first few ops in the
15887 * chain following 'start' indicate a multideref candidate, and will have
15888 * set 'orig_o' to the point further on in the chain where the first index
15889 * expression (if any) begins. 'orig_action' specifies what type of
15890 * beginning has already been determined by the ops between start..orig_o
15891 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
15893 * 'hints' contains any hints flags that need adding (currently just
15894 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
15898 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
15901 UNOP_AUX_item *arg_buf = NULL;
15902 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
15903 int index_skip = -1; /* don't output index arg on this action */
15905 /* similar to regex compiling, do two passes; the first pass
15906 * determines whether the op chain is convertible and calculates the
15907 * buffer size; the second pass populates the buffer and makes any
15908 * changes necessary to ops (such as moving consts to the pad on
15909 * threaded builds).
15911 * NB: for things like Coverity, note that both passes take the same
15912 * path through the logic tree (except for 'if (pass)' bits), since
15913 * both passes are following the same op_next chain; and in
15914 * particular, if it would return early on the second pass, it would
15915 * already have returned early on the first pass.
15917 for (pass = 0; pass < 2; pass++) {
15919 UV action = orig_action;
15920 OP *first_elem_op = NULL; /* first seen aelem/helem */
15921 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
15922 int action_count = 0; /* number of actions seen so far */
15923 int action_ix = 0; /* action_count % (actions per IV) */
15924 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
15925 bool is_last = FALSE; /* no more derefs to follow */
15926 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
15927 UV action_word = 0; /* all actions so far */
15928 UNOP_AUX_item *arg = arg_buf;
15929 UNOP_AUX_item *action_ptr = arg_buf;
15931 arg++; /* reserve slot for first action word */
15934 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
15935 case MDEREF_HV_gvhv_helem:
15936 next_is_hash = TRUE;
15938 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
15939 case MDEREF_AV_gvav_aelem:
15941 #ifdef USE_ITHREADS
15942 arg->pad_offset = cPADOPx(start)->op_padix;
15943 /* stop it being swiped when nulled */
15944 cPADOPx(start)->op_padix = 0;
15946 arg->sv = cSVOPx(start)->op_sv;
15947 cSVOPx(start)->op_sv = NULL;
15953 case MDEREF_HV_padhv_helem:
15954 case MDEREF_HV_padsv_vivify_rv2hv_helem:
15955 next_is_hash = TRUE;
15957 case MDEREF_AV_padav_aelem:
15958 case MDEREF_AV_padsv_vivify_rv2av_aelem:
15960 arg->pad_offset = start->op_targ;
15961 /* we skip setting op_targ = 0 for now, since the intact
15962 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
15963 reset_start_targ = TRUE;
15968 case MDEREF_HV_pop_rv2hv_helem:
15969 next_is_hash = TRUE;
15971 case MDEREF_AV_pop_rv2av_aelem:
15975 NOT_REACHED; /* NOTREACHED */
15980 /* look for another (rv2av/hv; get index;
15981 * aelem/helem/exists/delele) sequence */
15986 UV index_type = MDEREF_INDEX_none;
15988 if (action_count) {
15989 /* if this is not the first lookup, consume the rv2av/hv */
15991 /* for N levels of aggregate lookup, we normally expect
15992 * that the first N-1 [ah]elem ops will be flagged as
15993 * /DEREF (so they autovivifiy if necessary), and the last
15994 * lookup op not to be.
15995 * For other things (like @{$h{k1}{k2}}) extra scope or
15996 * leave ops can appear, so abandon the effort in that
15998 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
16001 /* rv2av or rv2hv sKR/1 */
16003 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16004 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16005 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16008 /* at this point, we wouldn't expect any of these
16009 * possible private flags:
16010 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
16011 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
16013 ASSUME(!(o->op_private &
16014 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
16016 hints = (o->op_private & OPpHINT_STRICT_REFS);
16018 /* make sure the type of the previous /DEREF matches the
16019 * type of the next lookup */
16020 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
16023 action = next_is_hash
16024 ? MDEREF_HV_vivify_rv2hv_helem
16025 : MDEREF_AV_vivify_rv2av_aelem;
16029 /* if this is the second pass, and we're at the depth where
16030 * previously we encountered a non-simple index expression,
16031 * stop processing the index at this point */
16032 if (action_count != index_skip) {
16034 /* look for one or more simple ops that return an array
16035 * index or hash key */
16037 switch (o->op_type) {
16039 /* it may be a lexical var index */
16040 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
16041 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16042 ASSUME(!(o->op_private &
16043 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16045 if ( OP_GIMME(o,0) == G_SCALAR
16046 && !(o->op_flags & (OPf_REF|OPf_MOD))
16047 && o->op_private == 0)
16050 arg->pad_offset = o->op_targ;
16052 index_type = MDEREF_INDEX_padsv;
16058 if (next_is_hash) {
16059 /* it's a constant hash index */
16060 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
16061 /* "use constant foo => FOO; $h{+foo}" for
16062 * some weird FOO, can leave you with constants
16063 * that aren't simple strings. It's not worth
16064 * the extra hassle for those edge cases */
16069 OP * helem_op = o->op_next;
16071 ASSUME( helem_op->op_type == OP_HELEM
16072 || helem_op->op_type == OP_NULL
16074 if (helem_op->op_type == OP_HELEM) {
16075 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
16076 if ( helem_op->op_private & OPpLVAL_INTRO
16077 || rop->op_type != OP_RV2HV
16081 /* on first pass just check; on second pass
16083 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
16088 #ifdef USE_ITHREADS
16089 /* Relocate sv to the pad for thread safety */
16090 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
16091 arg->pad_offset = o->op_targ;
16094 arg->sv = cSVOPx_sv(o);
16099 /* it's a constant array index */
16101 SV *ix_sv = cSVOPo->op_sv;
16106 if ( action_count == 0
16109 && ( action == MDEREF_AV_padav_aelem
16110 || action == MDEREF_AV_gvav_aelem)
16112 maybe_aelemfast = TRUE;
16116 SvREFCNT_dec_NN(cSVOPo->op_sv);
16120 /* we've taken ownership of the SV */
16121 cSVOPo->op_sv = NULL;
16123 index_type = MDEREF_INDEX_const;
16128 /* it may be a package var index */
16130 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
16131 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
16132 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
16133 || o->op_private != 0
16138 if (kid->op_type != OP_RV2SV)
16141 ASSUME(!(kid->op_flags &
16142 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
16143 |OPf_SPECIAL|OPf_PARENS)));
16144 ASSUME(!(kid->op_private &
16146 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
16147 |OPpDEREF|OPpLVAL_INTRO)));
16148 if( (kid->op_flags &~ OPf_PARENS)
16149 != (OPf_WANT_SCALAR|OPf_KIDS)
16150 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
16155 #ifdef USE_ITHREADS
16156 arg->pad_offset = cPADOPx(o)->op_padix;
16157 /* stop it being swiped when nulled */
16158 cPADOPx(o)->op_padix = 0;
16160 arg->sv = cSVOPx(o)->op_sv;
16161 cSVOPo->op_sv = NULL;
16165 index_type = MDEREF_INDEX_gvsv;
16170 } /* action_count != index_skip */
16172 action |= index_type;
16175 /* at this point we have either:
16176 * * detected what looks like a simple index expression,
16177 * and expect the next op to be an [ah]elem, or
16178 * an nulled [ah]elem followed by a delete or exists;
16179 * * found a more complex expression, so something other
16180 * than the above follows.
16183 /* possibly an optimised away [ah]elem (where op_next is
16184 * exists or delete) */
16185 if (o->op_type == OP_NULL)
16188 /* at this point we're looking for an OP_AELEM, OP_HELEM,
16189 * OP_EXISTS or OP_DELETE */
16191 /* if a custom array/hash access checker is in scope,
16192 * abandon optimisation attempt */
16193 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16194 && PL_check[o->op_type] != Perl_ck_null)
16196 /* similarly for customised exists and delete */
16197 if ( (o->op_type == OP_EXISTS)
16198 && PL_check[o->op_type] != Perl_ck_exists)
16200 if ( (o->op_type == OP_DELETE)
16201 && PL_check[o->op_type] != Perl_ck_delete)
16204 if ( o->op_type != OP_AELEM
16205 || (o->op_private &
16206 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
16208 maybe_aelemfast = FALSE;
16210 /* look for aelem/helem/exists/delete. If it's not the last elem
16211 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
16212 * flags; if it's the last, then it mustn't have
16213 * OPpDEREF_AV/HV, but may have lots of other flags, like
16214 * OPpLVAL_INTRO etc
16217 if ( index_type == MDEREF_INDEX_none
16218 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
16219 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
16223 /* we have aelem/helem/exists/delete with valid simple index */
16225 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16226 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
16227 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
16229 /* This doesn't make much sense but is legal:
16230 * @{ local $x[0][0] } = 1
16231 * Since scope exit will undo the autovivification,
16232 * don't bother in the first place. The OP_LEAVE
16233 * assertion is in case there are other cases of both
16234 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
16235 * exit that would undo the local - in which case this
16236 * block of code would need rethinking.
16238 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
16240 OP *n = o->op_next;
16241 while (n && ( n->op_type == OP_NULL
16242 || n->op_type == OP_LIST
16243 || n->op_type == OP_SCALAR))
16245 assert(n && n->op_type == OP_LEAVE);
16247 o->op_private &= ~OPpDEREF;
16252 ASSUME(!(o->op_flags &
16253 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
16254 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
16256 ok = (o->op_flags &~ OPf_PARENS)
16257 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
16258 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
16260 else if (o->op_type == OP_EXISTS) {
16261 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16262 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16263 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
16264 ok = !(o->op_private & ~OPpARG1_MASK);
16266 else if (o->op_type == OP_DELETE) {
16267 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16268 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16269 ASSUME(!(o->op_private &
16270 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
16271 /* don't handle slices or 'local delete'; the latter
16272 * is fairly rare, and has a complex runtime */
16273 ok = !(o->op_private & ~OPpARG1_MASK);
16274 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
16275 /* skip handling run-tome error */
16276 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
16279 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
16280 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
16281 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
16282 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
16283 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
16284 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
16289 if (!first_elem_op)
16293 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
16298 action |= MDEREF_FLAG_last;
16302 /* at this point we have something that started
16303 * promisingly enough (with rv2av or whatever), but failed
16304 * to find a simple index followed by an
16305 * aelem/helem/exists/delete. If this is the first action,
16306 * give up; but if we've already seen at least one
16307 * aelem/helem, then keep them and add a new action with
16308 * MDEREF_INDEX_none, which causes it to do the vivify
16309 * from the end of the previous lookup, and do the deref,
16310 * but stop at that point. So $a[0][expr] will do one
16311 * av_fetch, vivify and deref, then continue executing at
16316 index_skip = action_count;
16317 action |= MDEREF_FLAG_last;
16318 if (index_type != MDEREF_INDEX_none)
16322 action_word |= (action << (action_ix * MDEREF_SHIFT));
16325 /* if there's no space for the next action, reserve a new slot
16326 * for it *before* we start adding args for that action */
16327 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
16329 action_ptr->uv = action_word;
16335 } /* while !is_last */
16340 /* slot reserved for next action word not now needed */
16343 action_ptr->uv = action_word;
16349 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
16350 if (index_skip == -1) {
16351 mderef->op_flags = o->op_flags
16352 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
16353 if (o->op_type == OP_EXISTS)
16354 mderef->op_private = OPpMULTIDEREF_EXISTS;
16355 else if (o->op_type == OP_DELETE)
16356 mderef->op_private = OPpMULTIDEREF_DELETE;
16358 mderef->op_private = o->op_private
16359 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
16361 /* accumulate strictness from every level (although I don't think
16362 * they can actually vary) */
16363 mderef->op_private |= hints;
16365 /* integrate the new multideref op into the optree and the
16368 * In general an op like aelem or helem has two child
16369 * sub-trees: the aggregate expression (a_expr) and the
16370 * index expression (i_expr):
16376 * The a_expr returns an AV or HV, while the i-expr returns an
16377 * index. In general a multideref replaces most or all of a
16378 * multi-level tree, e.g.
16394 * With multideref, all the i_exprs will be simple vars or
16395 * constants, except that i_expr1 may be arbitrary in the case
16396 * of MDEREF_INDEX_none.
16398 * The bottom-most a_expr will be either:
16399 * 1) a simple var (so padXv or gv+rv2Xv);
16400 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
16401 * so a simple var with an extra rv2Xv;
16402 * 3) or an arbitrary expression.
16404 * 'start', the first op in the execution chain, will point to
16405 * 1),2): the padXv or gv op;
16406 * 3): the rv2Xv which forms the last op in the a_expr
16407 * execution chain, and the top-most op in the a_expr
16410 * For all cases, the 'start' node is no longer required,
16411 * but we can't free it since one or more external nodes
16412 * may point to it. E.g. consider
16413 * $h{foo} = $a ? $b : $c
16414 * Here, both the op_next and op_other branches of the
16415 * cond_expr point to the gv[*h] of the hash expression, so
16416 * we can't free the 'start' op.
16418 * For expr->[...], we need to save the subtree containing the
16419 * expression; for the other cases, we just need to save the
16421 * So in all cases, we null the start op and keep it around by
16422 * making it the child of the multideref op; for the expr->
16423 * case, the expr will be a subtree of the start node.
16425 * So in the simple 1,2 case the optree above changes to
16431 * ex-gv (or ex-padxv)
16433 * with the op_next chain being
16435 * -> ex-gv -> multideref -> op-following-ex-exists ->
16437 * In the 3 case, we have
16450 * -> rest-of-a_expr subtree ->
16451 * ex-rv2xv -> multideref -> op-following-ex-exists ->
16454 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
16455 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
16456 * multideref attached as the child, e.g.
16462 * ex-rv2av - i_expr1
16470 /* if we free this op, don't free the pad entry */
16471 if (reset_start_targ)
16472 start->op_targ = 0;
16475 /* Cut the bit we need to save out of the tree and attach to
16476 * the multideref op, then free the rest of the tree */
16478 /* find parent of node to be detached (for use by splice) */
16480 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
16481 || orig_action == MDEREF_HV_pop_rv2hv_helem)
16483 /* there is an arbitrary expression preceding us, e.g.
16484 * expr->[..]? so we need to save the 'expr' subtree */
16485 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
16486 p = cUNOPx(p)->op_first;
16487 ASSUME( start->op_type == OP_RV2AV
16488 || start->op_type == OP_RV2HV);
16491 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
16492 * above for exists/delete. */
16493 while ( (p->op_flags & OPf_KIDS)
16494 && cUNOPx(p)->op_first != start
16496 p = cUNOPx(p)->op_first;
16498 ASSUME(cUNOPx(p)->op_first == start);
16500 /* detach from main tree, and re-attach under the multideref */
16501 op_sibling_splice(mderef, NULL, 0,
16502 op_sibling_splice(p, NULL, 1, NULL));
16505 start->op_next = mderef;
16507 mderef->op_next = index_skip == -1 ? o->op_next : o;
16509 /* excise and free the original tree, and replace with
16510 * the multideref op */
16511 p = op_sibling_splice(top_op, NULL, -1, mderef);
16520 Size_t size = arg - arg_buf;
16522 if (maybe_aelemfast && action_count == 1)
16525 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
16526 sizeof(UNOP_AUX_item) * (size + 1));
16527 /* for dumping etc: store the length in a hidden first slot;
16528 * we set the op_aux pointer to the second slot */
16529 arg_buf->uv = size;
16532 } /* for (pass = ...) */
16535 /* See if the ops following o are such that o will always be executed in
16536 * boolean context: that is, the SV which o pushes onto the stack will
16537 * only ever be consumed by later ops via SvTRUE(sv) or similar.
16538 * If so, set a suitable private flag on o. Normally this will be
16539 * bool_flag; but see below why maybe_flag is needed too.
16541 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
16542 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
16543 * already be taken, so you'll have to give that op two different flags.
16545 * More explanation of 'maybe_flag' and 'safe_and' parameters.
16546 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
16547 * those underlying ops) short-circuit, which means that rather than
16548 * necessarily returning a truth value, they may return the LH argument,
16549 * which may not be boolean. For example in $x = (keys %h || -1), keys
16550 * should return a key count rather than a boolean, even though its
16551 * sort-of being used in boolean context.
16553 * So we only consider such logical ops to provide boolean context to
16554 * their LH argument if they themselves are in void or boolean context.
16555 * However, sometimes the context isn't known until run-time. In this
16556 * case the op is marked with the maybe_flag flag it.
16558 * Consider the following.
16560 * sub f { ....; if (%h) { .... } }
16562 * This is actually compiled as
16564 * sub f { ....; %h && do { .... } }
16566 * Here we won't know until runtime whether the final statement (and hence
16567 * the &&) is in void context and so is safe to return a boolean value.
16568 * So mark o with maybe_flag rather than the bool_flag.
16569 * Note that there is cost associated with determining context at runtime
16570 * (e.g. a call to block_gimme()), so it may not be worth setting (at
16571 * compile time) and testing (at runtime) maybe_flag if the scalar verses
16572 * boolean costs savings are marginal.
16574 * However, we can do slightly better with && (compared to || and //):
16575 * this op only returns its LH argument when that argument is false. In
16576 * this case, as long as the op promises to return a false value which is
16577 * valid in both boolean and scalar contexts, we can mark an op consumed
16578 * by && with bool_flag rather than maybe_flag.
16579 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
16580 * than &PL_sv_no for a false result in boolean context, then it's safe. An
16581 * op which promises to handle this case is indicated by setting safe_and
16586 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
16591 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
16593 /* OPpTARGET_MY and boolean context probably don't mix well.
16594 * If someone finds a valid use case, maybe add an extra flag to this
16595 * function which indicates its safe to do so for this op? */
16596 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
16597 && (o->op_private & OPpTARGET_MY)));
16602 switch (lop->op_type) {
16607 /* these two consume the stack argument in the scalar case,
16608 * and treat it as a boolean in the non linenumber case */
16611 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
16612 || (lop->op_private & OPpFLIP_LINENUM))
16618 /* these never leave the original value on the stack */
16627 /* OR DOR and AND evaluate their arg as a boolean, but then may
16628 * leave the original scalar value on the stack when following the
16629 * op_next route. If not in void context, we need to ensure
16630 * that whatever follows consumes the arg only in boolean context
16642 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
16646 else if (!(lop->op_flags & OPf_WANT)) {
16647 /* unknown context - decide at runtime */
16659 lop = lop->op_next;
16662 o->op_private |= flag;
16667 /* mechanism for deferring recursion in rpeep() */
16669 #define MAX_DEFERRED 4
16673 if (defer_ix == (MAX_DEFERRED-1)) { \
16674 OP **defer = defer_queue[defer_base]; \
16675 CALL_RPEEP(*defer); \
16676 S_prune_chain_head(defer); \
16677 defer_base = (defer_base + 1) % MAX_DEFERRED; \
16680 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
16683 #define IS_AND_OP(o) (o->op_type == OP_AND)
16684 #define IS_OR_OP(o) (o->op_type == OP_OR)
16687 /* A peephole optimizer. We visit the ops in the order they're to execute.
16688 * See the comments at the top of this file for more details about when
16689 * peep() is called */
16692 Perl_rpeep(pTHX_ OP *o)
16695 OP* oldoldop = NULL;
16696 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
16697 int defer_base = 0;
16700 if (!o || o->op_opt)
16703 assert(o->op_type != OP_FREED);
16707 SAVEVPTR(PL_curcop);
16708 for (;; o = o->op_next) {
16709 if (o && o->op_opt)
16712 while (defer_ix >= 0) {
16714 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
16715 CALL_RPEEP(*defer);
16716 S_prune_chain_head(defer);
16723 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
16724 assert(!oldoldop || oldoldop->op_next == oldop);
16725 assert(!oldop || oldop->op_next == o);
16727 /* By default, this op has now been optimised. A couple of cases below
16728 clear this again. */
16732 /* look for a series of 1 or more aggregate derefs, e.g.
16733 * $a[1]{foo}[$i]{$k}
16734 * and replace with a single OP_MULTIDEREF op.
16735 * Each index must be either a const, or a simple variable,
16737 * First, look for likely combinations of starting ops,
16738 * corresponding to (global and lexical variants of)
16740 * $r->[...] $r->{...}
16741 * (preceding expression)->[...]
16742 * (preceding expression)->{...}
16743 * and if so, call maybe_multideref() to do a full inspection
16744 * of the op chain and if appropriate, replace with an
16752 switch (o2->op_type) {
16754 /* $pkg[..] : gv[*pkg]
16755 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
16757 /* Fail if there are new op flag combinations that we're
16758 * not aware of, rather than:
16759 * * silently failing to optimise, or
16760 * * silently optimising the flag away.
16761 * If this ASSUME starts failing, examine what new flag
16762 * has been added to the op, and decide whether the
16763 * optimisation should still occur with that flag, then
16764 * update the code accordingly. This applies to all the
16765 * other ASSUMEs in the block of code too.
16767 ASSUME(!(o2->op_flags &
16768 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
16769 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
16773 if (o2->op_type == OP_RV2AV) {
16774 action = MDEREF_AV_gvav_aelem;
16778 if (o2->op_type == OP_RV2HV) {
16779 action = MDEREF_HV_gvhv_helem;
16783 if (o2->op_type != OP_RV2SV)
16786 /* at this point we've seen gv,rv2sv, so the only valid
16787 * construct left is $pkg->[] or $pkg->{} */
16789 ASSUME(!(o2->op_flags & OPf_STACKED));
16790 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16791 != (OPf_WANT_SCALAR|OPf_MOD))
16794 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
16795 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
16796 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
16798 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
16799 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
16803 if (o2->op_type == OP_RV2AV) {
16804 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
16807 if (o2->op_type == OP_RV2HV) {
16808 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
16814 /* $lex->[...]: padsv[$lex] sM/DREFAV */
16816 ASSUME(!(o2->op_flags &
16817 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
16818 if ((o2->op_flags &
16819 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16820 != (OPf_WANT_SCALAR|OPf_MOD))
16823 ASSUME(!(o2->op_private &
16824 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16825 /* skip if state or intro, or not a deref */
16826 if ( o2->op_private != OPpDEREF_AV
16827 && o2->op_private != OPpDEREF_HV)
16831 if (o2->op_type == OP_RV2AV) {
16832 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
16835 if (o2->op_type == OP_RV2HV) {
16836 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
16843 /* $lex[..]: padav[@lex:1,2] sR *
16844 * or $lex{..}: padhv[%lex:1,2] sR */
16845 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
16846 OPf_REF|OPf_SPECIAL)));
16847 if ((o2->op_flags &
16848 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16849 != (OPf_WANT_SCALAR|OPf_REF))
16851 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
16853 /* OPf_PARENS isn't currently used in this case;
16854 * if that changes, let us know! */
16855 ASSUME(!(o2->op_flags & OPf_PARENS));
16857 /* at this point, we wouldn't expect any of the remaining
16858 * possible private flags:
16859 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
16860 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
16862 * OPpSLICEWARNING shouldn't affect runtime
16864 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
16866 action = o2->op_type == OP_PADAV
16867 ? MDEREF_AV_padav_aelem
16868 : MDEREF_HV_padhv_helem;
16870 S_maybe_multideref(aTHX_ o, o2, action, 0);
16876 action = o2->op_type == OP_RV2AV
16877 ? MDEREF_AV_pop_rv2av_aelem
16878 : MDEREF_HV_pop_rv2hv_helem;
16881 /* (expr)->[...]: rv2av sKR/1;
16882 * (expr)->{...}: rv2hv sKR/1; */
16884 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
16886 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16887 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
16888 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16891 /* at this point, we wouldn't expect any of these
16892 * possible private flags:
16893 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
16894 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
16896 ASSUME(!(o2->op_private &
16897 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
16899 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
16903 S_maybe_multideref(aTHX_ o, o2, action, hints);
16912 switch (o->op_type) {
16914 PL_curcop = ((COP*)o); /* for warnings */
16917 PL_curcop = ((COP*)o); /* for warnings */
16919 /* Optimise a "return ..." at the end of a sub to just be "...".
16920 * This saves 2 ops. Before:
16921 * 1 <;> nextstate(main 1 -e:1) v ->2
16922 * 4 <@> return K ->5
16923 * 2 <0> pushmark s ->3
16924 * - <1> ex-rv2sv sK/1 ->4
16925 * 3 <#> gvsv[*cat] s ->4
16928 * - <@> return K ->-
16929 * - <0> pushmark s ->2
16930 * - <1> ex-rv2sv sK/1 ->-
16931 * 2 <$> gvsv(*cat) s ->3
16934 OP *next = o->op_next;
16935 OP *sibling = OpSIBLING(o);
16936 if ( OP_TYPE_IS(next, OP_PUSHMARK)
16937 && OP_TYPE_IS(sibling, OP_RETURN)
16938 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
16939 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
16940 ||OP_TYPE_IS(sibling->op_next->op_next,
16942 && cUNOPx(sibling)->op_first == next
16943 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
16946 /* Look through the PUSHMARK's siblings for one that
16947 * points to the RETURN */
16948 OP *top = OpSIBLING(next);
16949 while (top && top->op_next) {
16950 if (top->op_next == sibling) {
16951 top->op_next = sibling->op_next;
16952 o->op_next = next->op_next;
16955 top = OpSIBLING(top);
16960 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
16962 * This latter form is then suitable for conversion into padrange
16963 * later on. Convert:
16965 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
16969 * nextstate1 -> listop -> nextstate3
16971 * pushmark -> padop1 -> padop2
16973 if (o->op_next && (
16974 o->op_next->op_type == OP_PADSV
16975 || o->op_next->op_type == OP_PADAV
16976 || o->op_next->op_type == OP_PADHV
16978 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
16979 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
16980 && o->op_next->op_next->op_next && (
16981 o->op_next->op_next->op_next->op_type == OP_PADSV
16982 || o->op_next->op_next->op_next->op_type == OP_PADAV
16983 || o->op_next->op_next->op_next->op_type == OP_PADHV
16985 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
16986 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
16987 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
16988 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
16990 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
16993 ns2 = pad1->op_next;
16994 pad2 = ns2->op_next;
16995 ns3 = pad2->op_next;
16997 /* we assume here that the op_next chain is the same as
16998 * the op_sibling chain */
16999 assert(OpSIBLING(o) == pad1);
17000 assert(OpSIBLING(pad1) == ns2);
17001 assert(OpSIBLING(ns2) == pad2);
17002 assert(OpSIBLING(pad2) == ns3);
17004 /* excise and delete ns2 */
17005 op_sibling_splice(NULL, pad1, 1, NULL);
17008 /* excise pad1 and pad2 */
17009 op_sibling_splice(NULL, o, 2, NULL);
17011 /* create new listop, with children consisting of:
17012 * a new pushmark, pad1, pad2. */
17013 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
17014 newop->op_flags |= OPf_PARENS;
17015 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17017 /* insert newop between o and ns3 */
17018 op_sibling_splice(NULL, o, 0, newop);
17020 /*fixup op_next chain */
17021 newpm = cUNOPx(newop)->op_first; /* pushmark */
17022 o ->op_next = newpm;
17023 newpm->op_next = pad1;
17024 pad1 ->op_next = pad2;
17025 pad2 ->op_next = newop; /* listop */
17026 newop->op_next = ns3;
17028 /* Ensure pushmark has this flag if padops do */
17029 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
17030 newpm->op_flags |= OPf_MOD;
17036 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
17037 to carry two labels. For now, take the easier option, and skip
17038 this optimisation if the first NEXTSTATE has a label. */
17039 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
17040 OP *nextop = o->op_next;
17042 switch (nextop->op_type) {
17047 nextop = nextop->op_next;
17053 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
17056 oldop->op_next = nextop;
17058 /* Skip (old)oldop assignment since the current oldop's
17059 op_next already points to the next op. */
17066 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
17067 if (o->op_next->op_private & OPpTARGET_MY) {
17068 if (o->op_flags & OPf_STACKED) /* chained concats */
17069 break; /* ignore_optimization */
17071 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
17072 o->op_targ = o->op_next->op_targ;
17073 o->op_next->op_targ = 0;
17074 o->op_private |= OPpTARGET_MY;
17077 op_null(o->op_next);
17081 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
17082 break; /* Scalar stub must produce undef. List stub is noop */
17086 if (o->op_targ == OP_NEXTSTATE
17087 || o->op_targ == OP_DBSTATE)
17089 PL_curcop = ((COP*)o);
17091 /* XXX: We avoid setting op_seq here to prevent later calls
17092 to rpeep() from mistakenly concluding that optimisation
17093 has already occurred. This doesn't fix the real problem,
17094 though (See 20010220.007 (#5874)). AMS 20010719 */
17095 /* op_seq functionality is now replaced by op_opt */
17103 oldop->op_next = o->op_next;
17117 convert repeat into a stub with no kids.
17119 if (o->op_next->op_type == OP_CONST
17120 || ( o->op_next->op_type == OP_PADSV
17121 && !(o->op_next->op_private & OPpLVAL_INTRO))
17122 || ( o->op_next->op_type == OP_GV
17123 && o->op_next->op_next->op_type == OP_RV2SV
17124 && !(o->op_next->op_next->op_private
17125 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
17127 const OP *kid = o->op_next->op_next;
17128 if (o->op_next->op_type == OP_GV)
17129 kid = kid->op_next;
17130 /* kid is now the ex-list. */
17131 if (kid->op_type == OP_NULL
17132 && (kid = kid->op_next)->op_type == OP_CONST
17133 /* kid is now the repeat count. */
17134 && kid->op_next->op_type == OP_REPEAT
17135 && kid->op_next->op_private & OPpREPEAT_DOLIST
17136 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
17137 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
17140 o = kid->op_next; /* repeat */
17141 oldop->op_next = o;
17142 op_free(cBINOPo->op_first);
17143 op_free(cBINOPo->op_last );
17144 o->op_flags &=~ OPf_KIDS;
17145 /* stub is a baseop; repeat is a binop */
17146 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
17147 OpTYPE_set(o, OP_STUB);
17153 /* Convert a series of PAD ops for my vars plus support into a
17154 * single padrange op. Basically
17156 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
17158 * becomes, depending on circumstances, one of
17160 * padrange ----------------------------------> (list) -> rest
17161 * padrange --------------------------------------------> rest
17163 * where all the pad indexes are sequential and of the same type
17165 * We convert the pushmark into a padrange op, then skip
17166 * any other pad ops, and possibly some trailing ops.
17167 * Note that we don't null() the skipped ops, to make it
17168 * easier for Deparse to undo this optimisation (and none of
17169 * the skipped ops are holding any resourses). It also makes
17170 * it easier for find_uninit_var(), as it can just ignore
17171 * padrange, and examine the original pad ops.
17175 OP *followop = NULL; /* the op that will follow the padrange op */
17178 PADOFFSET base = 0; /* init only to stop compiler whining */
17179 bool gvoid = 0; /* init only to stop compiler whining */
17180 bool defav = 0; /* seen (...) = @_ */
17181 bool reuse = 0; /* reuse an existing padrange op */
17183 /* look for a pushmark -> gv[_] -> rv2av */
17188 if ( p->op_type == OP_GV
17189 && cGVOPx_gv(p) == PL_defgv
17190 && (rv2av = p->op_next)
17191 && rv2av->op_type == OP_RV2AV
17192 && !(rv2av->op_flags & OPf_REF)
17193 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
17194 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
17196 q = rv2av->op_next;
17197 if (q->op_type == OP_NULL)
17199 if (q->op_type == OP_PUSHMARK) {
17209 /* scan for PAD ops */
17211 for (p = p->op_next; p; p = p->op_next) {
17212 if (p->op_type == OP_NULL)
17215 if (( p->op_type != OP_PADSV
17216 && p->op_type != OP_PADAV
17217 && p->op_type != OP_PADHV
17219 /* any private flag other than INTRO? e.g. STATE */
17220 || (p->op_private & ~OPpLVAL_INTRO)
17224 /* let $a[N] potentially be optimised into AELEMFAST_LEX
17226 if ( p->op_type == OP_PADAV
17228 && p->op_next->op_type == OP_CONST
17229 && p->op_next->op_next
17230 && p->op_next->op_next->op_type == OP_AELEM
17234 /* for 1st padop, note what type it is and the range
17235 * start; for the others, check that it's the same type
17236 * and that the targs are contiguous */
17238 intro = (p->op_private & OPpLVAL_INTRO);
17240 gvoid = OP_GIMME(p,0) == G_VOID;
17243 if ((p->op_private & OPpLVAL_INTRO) != intro)
17245 /* Note that you'd normally expect targs to be
17246 * contiguous in my($a,$b,$c), but that's not the case
17247 * when external modules start doing things, e.g.
17248 * Function::Parameters */
17249 if (p->op_targ != base + count)
17251 assert(p->op_targ == base + count);
17252 /* Either all the padops or none of the padops should
17253 be in void context. Since we only do the optimisa-
17254 tion for av/hv when the aggregate itself is pushed
17255 on to the stack (one item), there is no need to dis-
17256 tinguish list from scalar context. */
17257 if (gvoid != (OP_GIMME(p,0) == G_VOID))
17261 /* for AV, HV, only when we're not flattening */
17262 if ( p->op_type != OP_PADSV
17264 && !(p->op_flags & OPf_REF)
17268 if (count >= OPpPADRANGE_COUNTMASK)
17271 /* there's a biggest base we can fit into a
17272 * SAVEt_CLEARPADRANGE in pp_padrange.
17273 * (The sizeof() stuff will be constant-folded, and is
17274 * intended to avoid getting "comparison is always false"
17275 * compiler warnings. See the comments above
17276 * MEM_WRAP_CHECK for more explanation on why we do this
17277 * in a weird way to avoid compiler warnings.)
17280 && (8*sizeof(base) >
17281 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
17283 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17285 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17289 /* Success! We've got another valid pad op to optimise away */
17291 followop = p->op_next;
17294 if (count < 1 || (count == 1 && !defav))
17297 /* pp_padrange in specifically compile-time void context
17298 * skips pushing a mark and lexicals; in all other contexts
17299 * (including unknown till runtime) it pushes a mark and the
17300 * lexicals. We must be very careful then, that the ops we
17301 * optimise away would have exactly the same effect as the
17303 * In particular in void context, we can only optimise to
17304 * a padrange if we see the complete sequence
17305 * pushmark, pad*v, ...., list
17306 * which has the net effect of leaving the markstack as it
17307 * was. Not pushing onto the stack (whereas padsv does touch
17308 * the stack) makes no difference in void context.
17312 if (followop->op_type == OP_LIST
17313 && OP_GIMME(followop,0) == G_VOID
17316 followop = followop->op_next; /* skip OP_LIST */
17318 /* consolidate two successive my(...);'s */
17321 && oldoldop->op_type == OP_PADRANGE
17322 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
17323 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
17324 && !(oldoldop->op_flags & OPf_SPECIAL)
17327 assert(oldoldop->op_next == oldop);
17328 assert( oldop->op_type == OP_NEXTSTATE
17329 || oldop->op_type == OP_DBSTATE);
17330 assert(oldop->op_next == o);
17333 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
17335 /* Do not assume pad offsets for $c and $d are con-
17340 if ( oldoldop->op_targ + old_count == base
17341 && old_count < OPpPADRANGE_COUNTMASK - count) {
17342 base = oldoldop->op_targ;
17343 count += old_count;
17348 /* if there's any immediately following singleton
17349 * my var's; then swallow them and the associated
17351 * my ($a,$b); my $c; my $d;
17353 * my ($a,$b,$c,$d);
17356 while ( ((p = followop->op_next))
17357 && ( p->op_type == OP_PADSV
17358 || p->op_type == OP_PADAV
17359 || p->op_type == OP_PADHV)
17360 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
17361 && (p->op_private & OPpLVAL_INTRO) == intro
17362 && !(p->op_private & ~OPpLVAL_INTRO)
17364 && ( p->op_next->op_type == OP_NEXTSTATE
17365 || p->op_next->op_type == OP_DBSTATE)
17366 && count < OPpPADRANGE_COUNTMASK
17367 && base + count == p->op_targ
17370 followop = p->op_next;
17378 assert(oldoldop->op_type == OP_PADRANGE);
17379 oldoldop->op_next = followop;
17380 oldoldop->op_private = (intro | count);
17386 /* Convert the pushmark into a padrange.
17387 * To make Deparse easier, we guarantee that a padrange was
17388 * *always* formerly a pushmark */
17389 assert(o->op_type == OP_PUSHMARK);
17390 o->op_next = followop;
17391 OpTYPE_set(o, OP_PADRANGE);
17393 /* bit 7: INTRO; bit 6..0: count */
17394 o->op_private = (intro | count);
17395 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
17396 | gvoid * OPf_WANT_VOID
17397 | (defav ? OPf_SPECIAL : 0));
17403 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17404 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17409 /*'keys %h' in void or scalar context: skip the OP_KEYS
17410 * and perform the functionality directly in the RV2HV/PADHV
17413 if (o->op_flags & OPf_REF) {
17414 OP *k = o->op_next;
17415 U8 want = (k->op_flags & OPf_WANT);
17417 && k->op_type == OP_KEYS
17418 && ( want == OPf_WANT_VOID
17419 || want == OPf_WANT_SCALAR)
17420 && !(k->op_private & OPpMAYBE_LVSUB)
17421 && !(k->op_flags & OPf_MOD)
17423 o->op_next = k->op_next;
17424 o->op_flags &= ~(OPf_REF|OPf_WANT);
17425 o->op_flags |= want;
17426 o->op_private |= (o->op_type == OP_PADHV ?
17427 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
17428 /* for keys(%lex), hold onto the OP_KEYS's targ
17429 * since padhv doesn't have its own targ to return
17431 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
17436 /* see if %h is used in boolean context */
17437 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17438 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17441 if (o->op_type != OP_PADHV)
17445 if ( o->op_type == OP_PADAV
17446 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17448 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17451 /* Skip over state($x) in void context. */
17452 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
17453 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
17455 oldop->op_next = o->op_next;
17456 goto redo_nextstate;
17458 if (o->op_type != OP_PADAV)
17462 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
17463 OP* const pop = (o->op_type == OP_PADAV) ?
17464 o->op_next : o->op_next->op_next;
17466 if (pop && pop->op_type == OP_CONST &&
17467 ((PL_op = pop->op_next)) &&
17468 pop->op_next->op_type == OP_AELEM &&
17469 !(pop->op_next->op_private &
17470 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
17471 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
17474 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
17475 no_bareword_allowed(pop);
17476 if (o->op_type == OP_GV)
17477 op_null(o->op_next);
17478 op_null(pop->op_next);
17480 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
17481 o->op_next = pop->op_next->op_next;
17482 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
17483 o->op_private = (U8)i;
17484 if (o->op_type == OP_GV) {
17487 o->op_type = OP_AELEMFAST;
17490 o->op_type = OP_AELEMFAST_LEX;
17492 if (o->op_type != OP_GV)
17496 /* Remove $foo from the op_next chain in void context. */
17498 && ( o->op_next->op_type == OP_RV2SV
17499 || o->op_next->op_type == OP_RV2AV
17500 || o->op_next->op_type == OP_RV2HV )
17501 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17502 && !(o->op_next->op_private & OPpLVAL_INTRO))
17504 oldop->op_next = o->op_next->op_next;
17505 /* Reprocess the previous op if it is a nextstate, to
17506 allow double-nextstate optimisation. */
17508 if (oldop->op_type == OP_NEXTSTATE) {
17515 o = oldop->op_next;
17518 else if (o->op_next->op_type == OP_RV2SV) {
17519 if (!(o->op_next->op_private & OPpDEREF)) {
17520 op_null(o->op_next);
17521 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
17523 o->op_next = o->op_next->op_next;
17524 OpTYPE_set(o, OP_GVSV);
17527 else if (o->op_next->op_type == OP_READLINE
17528 && o->op_next->op_next->op_type == OP_CONCAT
17529 && (o->op_next->op_next->op_flags & OPf_STACKED))
17531 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
17532 OpTYPE_set(o, OP_RCATLINE);
17533 o->op_flags |= OPf_STACKED;
17534 op_null(o->op_next->op_next);
17535 op_null(o->op_next);
17546 case OP_CMPCHAIN_AND:
17547 while (cLOGOP->op_other->op_type == OP_NULL)
17548 cLOGOP->op_other = cLOGOP->op_other->op_next;
17549 while (o->op_next && ( o->op_type == o->op_next->op_type
17550 || o->op_next->op_type == OP_NULL))
17551 o->op_next = o->op_next->op_next;
17553 /* If we're an OR and our next is an AND in void context, we'll
17554 follow its op_other on short circuit, same for reverse.
17555 We can't do this with OP_DOR since if it's true, its return
17556 value is the underlying value which must be evaluated
17560 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
17561 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
17563 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17565 o->op_next = ((LOGOP*)o->op_next)->op_other;
17567 DEFER(cLOGOP->op_other);
17572 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17573 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17582 case OP_ARGDEFELEM:
17583 while (cLOGOP->op_other->op_type == OP_NULL)
17584 cLOGOP->op_other = cLOGOP->op_other->op_next;
17585 DEFER(cLOGOP->op_other);
17590 while (cLOOP->op_redoop->op_type == OP_NULL)
17591 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
17592 while (cLOOP->op_nextop->op_type == OP_NULL)
17593 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
17594 while (cLOOP->op_lastop->op_type == OP_NULL)
17595 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
17596 /* a while(1) loop doesn't have an op_next that escapes the
17597 * loop, so we have to explicitly follow the op_lastop to
17598 * process the rest of the code */
17599 DEFER(cLOOP->op_lastop);
17603 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
17604 DEFER(cLOGOPo->op_other);
17608 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17609 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17610 assert(!(cPMOP->op_pmflags & PMf_ONCE));
17611 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
17612 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
17613 cPMOP->op_pmstashstartu.op_pmreplstart
17614 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
17615 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
17621 if (o->op_flags & OPf_SPECIAL) {
17622 /* first arg is a code block */
17623 OP * const nullop = OpSIBLING(cLISTOP->op_first);
17624 OP * kid = cUNOPx(nullop)->op_first;
17626 assert(nullop->op_type == OP_NULL);
17627 assert(kid->op_type == OP_SCOPE
17628 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
17629 /* since OP_SORT doesn't have a handy op_other-style
17630 * field that can point directly to the start of the code
17631 * block, store it in the otherwise-unused op_next field
17632 * of the top-level OP_NULL. This will be quicker at
17633 * run-time, and it will also allow us to remove leading
17634 * OP_NULLs by just messing with op_nexts without
17635 * altering the basic op_first/op_sibling layout. */
17636 kid = kLISTOP->op_first;
17638 (kid->op_type == OP_NULL
17639 && ( kid->op_targ == OP_NEXTSTATE
17640 || kid->op_targ == OP_DBSTATE ))
17641 || kid->op_type == OP_STUB
17642 || kid->op_type == OP_ENTER
17643 || (PL_parser && PL_parser->error_count));
17644 nullop->op_next = kid->op_next;
17645 DEFER(nullop->op_next);
17648 /* check that RHS of sort is a single plain array */
17649 oright = cUNOPo->op_first;
17650 if (!oright || oright->op_type != OP_PUSHMARK)
17653 if (o->op_private & OPpSORT_INPLACE)
17656 /* reverse sort ... can be optimised. */
17657 if (!OpHAS_SIBLING(cUNOPo)) {
17658 /* Nothing follows us on the list. */
17659 OP * const reverse = o->op_next;
17661 if (reverse->op_type == OP_REVERSE &&
17662 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
17663 OP * const pushmark = cUNOPx(reverse)->op_first;
17664 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
17665 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
17666 /* reverse -> pushmark -> sort */
17667 o->op_private |= OPpSORT_REVERSE;
17669 pushmark->op_next = oright->op_next;
17679 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
17681 LISTOP *enter, *exlist;
17683 if (o->op_private & OPpSORT_INPLACE)
17686 enter = (LISTOP *) o->op_next;
17689 if (enter->op_type == OP_NULL) {
17690 enter = (LISTOP *) enter->op_next;
17694 /* for $a (...) will have OP_GV then OP_RV2GV here.
17695 for (...) just has an OP_GV. */
17696 if (enter->op_type == OP_GV) {
17697 gvop = (OP *) enter;
17698 enter = (LISTOP *) enter->op_next;
17701 if (enter->op_type == OP_RV2GV) {
17702 enter = (LISTOP *) enter->op_next;
17708 if (enter->op_type != OP_ENTERITER)
17711 iter = enter->op_next;
17712 if (!iter || iter->op_type != OP_ITER)
17715 expushmark = enter->op_first;
17716 if (!expushmark || expushmark->op_type != OP_NULL
17717 || expushmark->op_targ != OP_PUSHMARK)
17720 exlist = (LISTOP *) OpSIBLING(expushmark);
17721 if (!exlist || exlist->op_type != OP_NULL
17722 || exlist->op_targ != OP_LIST)
17725 if (exlist->op_last != o) {
17726 /* Mmm. Was expecting to point back to this op. */
17729 theirmark = exlist->op_first;
17730 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
17733 if (OpSIBLING(theirmark) != o) {
17734 /* There's something between the mark and the reverse, eg
17735 for (1, reverse (...))
17740 ourmark = ((LISTOP *)o)->op_first;
17741 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
17744 ourlast = ((LISTOP *)o)->op_last;
17745 if (!ourlast || ourlast->op_next != o)
17748 rv2av = OpSIBLING(ourmark);
17749 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
17750 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
17751 /* We're just reversing a single array. */
17752 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
17753 enter->op_flags |= OPf_STACKED;
17756 /* We don't have control over who points to theirmark, so sacrifice
17758 theirmark->op_next = ourmark->op_next;
17759 theirmark->op_flags = ourmark->op_flags;
17760 ourlast->op_next = gvop ? gvop : (OP *) enter;
17763 enter->op_private |= OPpITER_REVERSED;
17764 iter->op_private |= OPpITER_REVERSED;
17768 o = oldop->op_next;
17770 NOT_REACHED; /* NOTREACHED */
17776 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
17777 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
17782 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
17783 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
17786 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
17788 sv = newRV((SV *)PL_compcv);
17792 OpTYPE_set(o, OP_CONST);
17793 o->op_flags |= OPf_SPECIAL;
17794 cSVOPo->op_sv = sv;
17799 if (OP_GIMME(o,0) == G_VOID
17800 || ( o->op_next->op_type == OP_LINESEQ
17801 && ( o->op_next->op_next->op_type == OP_LEAVESUB
17802 || ( o->op_next->op_next->op_type == OP_RETURN
17803 && !CvLVALUE(PL_compcv)))))
17805 OP *right = cBINOP->op_first;
17824 OP *left = OpSIBLING(right);
17825 if (left->op_type == OP_SUBSTR
17826 && (left->op_private & 7) < 4) {
17828 /* cut out right */
17829 op_sibling_splice(o, NULL, 1, NULL);
17830 /* and insert it as second child of OP_SUBSTR */
17831 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
17833 left->op_private |= OPpSUBSTR_REPL_FIRST;
17835 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17842 int l, r, lr, lscalars, rscalars;
17844 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
17845 Note that we do this now rather than in newASSIGNOP(),
17846 since only by now are aliased lexicals flagged as such
17848 See the essay "Common vars in list assignment" above for
17849 the full details of the rationale behind all the conditions
17852 PL_generation sorcery:
17853 To detect whether there are common vars, the global var
17854 PL_generation is incremented for each assign op we scan.
17855 Then we run through all the lexical variables on the LHS,
17856 of the assignment, setting a spare slot in each of them to
17857 PL_generation. Then we scan the RHS, and if any lexicals
17858 already have that value, we know we've got commonality.
17859 Also, if the generation number is already set to
17860 PERL_INT_MAX, then the variable is involved in aliasing, so
17861 we also have potential commonality in that case.
17867 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
17870 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
17874 /* After looking for things which are *always* safe, this main
17875 * if/else chain selects primarily based on the type of the
17876 * LHS, gradually working its way down from the more dangerous
17877 * to the more restrictive and thus safer cases */
17879 if ( !l /* () = ....; */
17880 || !r /* .... = (); */
17881 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
17882 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
17883 || (lscalars < 2) /* ($x, undef) = ... */
17885 NOOP; /* always safe */
17887 else if (l & AAS_DANGEROUS) {
17888 /* always dangerous */
17889 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17890 o->op_private |= OPpASSIGN_COMMON_AGG;
17892 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
17893 /* package vars are always dangerous - too many
17894 * aliasing possibilities */
17895 if (l & AAS_PKG_SCALAR)
17896 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17897 if (l & AAS_PKG_AGG)
17898 o->op_private |= OPpASSIGN_COMMON_AGG;
17900 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
17901 |AAS_LEX_SCALAR|AAS_LEX_AGG))
17903 /* LHS contains only lexicals and safe ops */
17905 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
17906 o->op_private |= OPpASSIGN_COMMON_AGG;
17908 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
17909 if (lr & AAS_LEX_SCALAR_COMM)
17910 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17911 else if ( !(l & AAS_LEX_SCALAR)
17912 && (r & AAS_DEFAV))
17916 * as scalar-safe for performance reasons.
17917 * (it will still have been marked _AGG if necessary */
17920 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
17921 /* if there are only lexicals on the LHS and no
17922 * common ones on the RHS, then we assume that the
17923 * only way those lexicals could also get
17924 * on the RHS is via some sort of dereffing or
17927 * ($lex, $x) = (1, $$r)
17928 * and in this case we assume the var must have
17929 * a bumped ref count. So if its ref count is 1,
17930 * it must only be on the LHS.
17932 o->op_private |= OPpASSIGN_COMMON_RC1;
17937 * may have to handle aggregate on LHS, but we can't
17938 * have common scalars. */
17941 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
17943 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17944 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
17949 /* see if ref() is used in boolean context */
17950 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17951 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17955 /* see if the op is used in known boolean context,
17956 * but not if OA_TARGLEX optimisation is enabled */
17957 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17958 && !(o->op_private & OPpTARGET_MY)
17960 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17964 /* see if the op is used in known boolean context */
17965 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17966 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17970 Perl_cpeep_t cpeep =
17971 XopENTRYCUSTOM(o, xop_peep);
17973 cpeep(aTHX_ o, oldop);
17978 /* did we just null the current op? If so, re-process it to handle
17979 * eliding "empty" ops from the chain */
17980 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
17993 Perl_peep(pTHX_ OP *o)
17999 =for apidoc_section Custom Operators
18001 =for apidoc Perl_custom_op_xop
18002 Return the XOP structure for a given custom op. This macro should be
18003 considered internal to C<OP_NAME> and the other access macros: use them instead.
18004 This macro does call a function. Prior
18005 to 5.19.6, this was implemented as a
18012 /* use PERL_MAGIC_ext to call a function to free the xop structure when
18013 * freeing PL_custom_ops */
18016 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
18020 PERL_UNUSED_ARG(mg);
18021 xop = INT2PTR(XOP *, SvIV(sv));
18022 Safefree(xop->xop_name);
18023 Safefree(xop->xop_desc);
18029 static const MGVTBL custom_op_register_vtbl = {
18034 custom_op_register_free, /* free */
18044 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
18050 static const XOP xop_null = { 0, 0, 0, 0, 0 };
18052 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
18053 assert(o->op_type == OP_CUSTOM);
18055 /* This is wrong. It assumes a function pointer can be cast to IV,
18056 * which isn't guaranteed, but this is what the old custom OP code
18057 * did. In principle it should be safer to Copy the bytes of the
18058 * pointer into a PV: since the new interface is hidden behind
18059 * functions, this can be changed later if necessary. */
18060 /* Change custom_op_xop if this ever happens */
18061 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
18064 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18066 /* See if the op isn't registered, but its name *is* registered.
18067 * That implies someone is using the pre-5.14 API,where only name and
18068 * description could be registered. If so, fake up a real
18070 * We only check for an existing name, and assume no one will have
18071 * just registered a desc */
18072 if (!he && PL_custom_op_names &&
18073 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
18078 /* XXX does all this need to be shared mem? */
18079 Newxz(xop, 1, XOP);
18080 pv = SvPV(HeVAL(he), l);
18081 XopENTRY_set(xop, xop_name, savepvn(pv, l));
18082 if (PL_custom_op_descs &&
18083 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
18085 pv = SvPV(HeVAL(he), l);
18086 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
18088 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
18089 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18090 /* add magic to the SV so that the xop struct (pointed to by
18091 * SvIV(sv)) is freed. Normally a static xop is registered, but
18092 * for this backcompat hack, we've alloced one */
18093 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
18094 &custom_op_register_vtbl, NULL, 0);
18099 xop = (XOP *)&xop_null;
18101 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
18105 if(field == XOPe_xop_ptr) {
18108 const U32 flags = XopFLAGS(xop);
18109 if(flags & field) {
18111 case XOPe_xop_name:
18112 any.xop_name = xop->xop_name;
18114 case XOPe_xop_desc:
18115 any.xop_desc = xop->xop_desc;
18117 case XOPe_xop_class:
18118 any.xop_class = xop->xop_class;
18120 case XOPe_xop_peep:
18121 any.xop_peep = xop->xop_peep;
18124 NOT_REACHED; /* NOTREACHED */
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;
18142 NOT_REACHED; /* NOTREACHED */
18147 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
18148 * op.c: In function 'Perl_custom_op_get_field':
18149 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
18150 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
18151 * expands to assert(0), which expands to ((0) ? (void)0 :
18152 * __assert(...)), and gcc doesn't know that __assert can never return. */
18158 =for apidoc custom_op_register
18159 Register a custom op. See L<perlguts/"Custom Operators">.
18165 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
18169 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
18171 /* see the comment in custom_op_xop */
18172 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
18174 if (!PL_custom_ops)
18175 PL_custom_ops = newHV();
18177 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
18178 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
18183 =for apidoc core_prototype
18185 This function assigns the prototype of the named core function to C<sv>, or
18186 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
18187 C<NULL> if the core function has no prototype. C<code> is a code as returned
18188 by C<keyword()>. It must not be equal to 0.
18194 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
18197 int i = 0, n = 0, seen_question = 0, defgv = 0;
18199 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
18200 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
18201 bool nullret = FALSE;
18203 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
18207 if (!sv) sv = sv_newmortal();
18209 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
18211 switch (code < 0 ? -code : code) {
18212 case KEY_and : case KEY_chop: case KEY_chomp:
18213 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
18214 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
18215 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
18216 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
18217 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
18218 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
18219 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
18220 case KEY_x : case KEY_xor :
18221 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
18222 case KEY_glob: retsetpvs("_;", OP_GLOB);
18223 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
18224 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
18225 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
18226 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
18227 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
18229 case KEY_evalbytes:
18230 name = "entereval"; break;
18238 while (i < MAXO) { /* The slow way. */
18239 if (strEQ(name, PL_op_name[i])
18240 || strEQ(name, PL_op_desc[i]))
18242 if (nullret) { assert(opnum); *opnum = i; return NULL; }
18249 defgv = PL_opargs[i] & OA_DEFGV;
18250 oa = PL_opargs[i] >> OASHIFT;
18252 if (oa & OA_OPTIONAL && !seen_question && (
18253 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
18258 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
18259 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
18260 /* But globs are already references (kinda) */
18261 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
18265 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
18266 && !scalar_mod_type(NULL, i)) {
18271 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
18275 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
18276 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
18277 str[n-1] = '_'; defgv = 0;
18281 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
18283 sv_setpvn(sv, str, n - 1);
18284 if (opnum) *opnum = i;
18289 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
18292 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
18293 newSVOP(OP_COREARGS,0,coreargssv);
18296 PERL_ARGS_ASSERT_CORESUB_OP;
18300 return op_append_elem(OP_LINESEQ,
18303 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
18310 o = newUNOP(OP_AVHVSWITCH,0,argop);
18311 o->op_private = opnum-OP_EACH;
18313 case OP_SELECT: /* which represents OP_SSELECT as well */
18318 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
18319 newSVOP(OP_CONST, 0, newSVuv(1))
18321 coresub_op(newSVuv((UV)OP_SSELECT), 0,
18323 coresub_op(coreargssv, 0, OP_SELECT)
18327 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
18329 return op_append_elem(
18332 opnum == OP_WANTARRAY || opnum == OP_RUNCV
18333 ? OPpOFFBYONE << 8 : 0)
18335 case OA_BASEOP_OR_UNOP:
18336 if (opnum == OP_ENTEREVAL) {
18337 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
18338 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
18340 else o = newUNOP(opnum,0,argop);
18341 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
18344 if (is_handle_constructor(o, 1))
18345 argop->op_private |= OPpCOREARGS_DEREF1;
18346 if (scalar_mod_type(NULL, opnum))
18347 argop->op_private |= OPpCOREARGS_SCALARMOD;
18351 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
18352 if (is_handle_constructor(o, 2))
18353 argop->op_private |= OPpCOREARGS_DEREF2;
18354 if (opnum == OP_SUBSTR) {
18355 o->op_private |= OPpMAYBE_LVSUB;
18364 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
18365 SV * const *new_const_svp)
18367 const char *hvname;
18368 bool is_const = !!CvCONST(old_cv);
18369 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
18371 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
18373 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
18375 /* They are 2 constant subroutines generated from
18376 the same constant. This probably means that
18377 they are really the "same" proxy subroutine
18378 instantiated in 2 places. Most likely this is
18379 when a constant is exported twice. Don't warn.
18382 (ckWARN(WARN_REDEFINE)
18384 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
18385 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
18386 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
18387 strEQ(hvname, "autouse"))
18391 && ckWARN_d(WARN_REDEFINE)
18392 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
18395 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
18397 ? "Constant subroutine %" SVf " redefined"
18398 : "Subroutine %" SVf " redefined",
18403 =for apidoc_section Hook manipulation
18405 These functions provide convenient and thread-safe means of manipulating
18412 =for apidoc wrap_op_checker
18414 Puts a C function into the chain of check functions for a specified op
18415 type. This is the preferred way to manipulate the L</PL_check> array.
18416 C<opcode> specifies which type of op is to be affected. C<new_checker>
18417 is a pointer to the C function that is to be added to that opcode's
18418 check chain, and C<old_checker_p> points to the storage location where a
18419 pointer to the next function in the chain will be stored. The value of
18420 C<new_checker> is written into the L</PL_check> array, while the value
18421 previously stored there is written to C<*old_checker_p>.
18423 L</PL_check> is global to an entire process, and a module wishing to
18424 hook op checking may find itself invoked more than once per process,
18425 typically in different threads. To handle that situation, this function
18426 is idempotent. The location C<*old_checker_p> must initially (once
18427 per process) contain a null pointer. A C variable of static duration
18428 (declared at file scope, typically also marked C<static> to give
18429 it internal linkage) will be implicitly initialised appropriately,
18430 if it does not have an explicit initialiser. This function will only
18431 actually modify the check chain if it finds C<*old_checker_p> to be null.
18432 This function is also thread safe on the small scale. It uses appropriate
18433 locking to avoid race conditions in accessing L</PL_check>.
18435 When this function is called, the function referenced by C<new_checker>
18436 must be ready to be called, except for C<*old_checker_p> being unfilled.
18437 In a threading situation, C<new_checker> may be called immediately,
18438 even before this function has returned. C<*old_checker_p> will always
18439 be appropriately set before C<new_checker> is called. If C<new_checker>
18440 decides not to do anything special with an op that it is given (which
18441 is the usual case for most uses of op check hooking), it must chain the
18442 check function referenced by C<*old_checker_p>.
18444 Taken all together, XS code to hook an op checker should typically look
18445 something like this:
18447 static Perl_check_t nxck_frob;
18448 static OP *myck_frob(pTHX_ OP *op) {
18450 op = nxck_frob(aTHX_ op);
18455 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
18457 If you want to influence compilation of calls to a specific subroutine,
18458 then use L</cv_set_call_checker_flags> rather than hooking checking of
18459 all C<entersub> ops.
18465 Perl_wrap_op_checker(pTHX_ Optype opcode,
18466 Perl_check_t new_checker, Perl_check_t *old_checker_p)
18469 PERL_UNUSED_CONTEXT;
18470 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
18471 if (*old_checker_p) return;
18472 OP_CHECK_MUTEX_LOCK;
18473 if (!*old_checker_p) {
18474 *old_checker_p = PL_check[opcode];
18475 PL_check[opcode] = new_checker;
18477 OP_CHECK_MUTEX_UNLOCK;
18482 /* Efficient sub that returns a constant scalar value. */
18484 const_sv_xsub(pTHX_ CV* cv)
18487 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
18488 PERL_UNUSED_ARG(items);
18498 const_av_xsub(pTHX_ CV* cv)
18501 AV * const av = MUTABLE_AV(XSANY.any_ptr);
18509 if (SvRMAGICAL(av))
18510 Perl_croak(aTHX_ "Magical list constants are not supported");
18511 if (GIMME_V != G_ARRAY) {
18513 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
18516 EXTEND(SP, AvFILLp(av)+1);
18517 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
18518 XSRETURN(AvFILLp(av)+1);
18521 /* Copy an existing cop->cop_warnings field.
18522 * If it's one of the standard addresses, just re-use the address.
18523 * This is the e implementation for the DUP_WARNINGS() macro
18527 Perl_dup_warnings(pTHX_ STRLEN* warnings)
18530 STRLEN *new_warnings;
18532 if (warnings == NULL || specialWARN(warnings))
18535 size = sizeof(*warnings) + *warnings;
18537 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
18538 Copy(warnings, new_warnings, size, char);
18539 return new_warnings;
18543 * ex: set ts=8 sts=4 sw=4 et: