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 *))
210 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
212 /* requires double parens and aTHX_ */
213 #define DEBUG_S_warn(args) \
215 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
219 /* malloc a new op slab (suitable for attaching to PL_compcv).
220 * sz is in units of pointers */
223 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
227 /* opslot_offset is only U16 */
228 assert(sz < U16_MAX);
230 #ifdef PERL_DEBUG_READONLY_OPS
231 slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
232 PROT_READ|PROT_WRITE,
233 MAP_ANON|MAP_PRIVATE, -1, 0);
234 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
235 (unsigned long) sz, slab));
236 if (slab == MAP_FAILED) {
237 perror("mmap failed");
241 slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
243 slab->opslab_size = (U16)sz;
246 /* The context is unused in non-Windows */
249 slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
250 slab->opslab_head = head ? head : slab;
251 DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
252 (unsigned int)slab->opslab_size, (void*)slab,
253 (void*)(slab->opslab_head)));
257 /* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
258 #define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
259 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
261 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
263 S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) {
264 U16 sz = OpSLOT(o)->opslot_size;
265 U16 index = OPSLOT_SIZE_TO_INDEX(sz);
267 assert(sz >= OPSLOT_SIZE_BASE);
268 /* make sure the array is large enough to include ops this large */
269 if (!slab->opslab_freed) {
270 /* we don't have a free list array yet, make a new one */
271 slab->opslab_freed_size = index+1;
272 slab->opslab_freed = (OP**)PerlMemShared_calloc((slab->opslab_freed_size), sizeof(OP*));
274 if (!slab->opslab_freed)
277 else if (index >= slab->opslab_freed_size) {
278 /* It's probably not worth doing exponential expansion here, the number of op sizes
281 /* We already have a list that isn't large enough, expand it */
282 size_t newsize = index+1;
283 OP **p = (OP **)PerlMemShared_realloc(slab->opslab_freed, newsize * sizeof(OP*));
288 Zero(p+slab->opslab_freed_size, newsize - slab->opslab_freed_size, OP *);
290 slab->opslab_freed = p;
291 slab->opslab_freed_size = newsize;
294 o->op_next = slab->opslab_freed[index];
295 slab->opslab_freed[index] = o;
298 /* Returns a sz-sized block of memory (suitable for holding an op) from
299 * a free slot in the chain of op slabs attached to PL_compcv.
300 * Allocates a new slab if necessary.
301 * if PL_compcv isn't compiling, malloc() instead.
305 Perl_Slab_Alloc(pTHX_ size_t sz)
307 OPSLAB *head_slab; /* first slab in the chain */
313 /* We only allocate ops from the slab during subroutine compilation.
314 We find the slab via PL_compcv, hence that must be non-NULL. It could
315 also be pointing to a subroutine which is now fully set up (CvROOT()
316 pointing to the top of the optree for that sub), or a subroutine
317 which isn't using the slab allocator. If our sanity checks aren't met,
318 don't use a slab, but allocate the OP directly from the heap. */
319 if (!PL_compcv || CvROOT(PL_compcv)
320 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
322 o = (OP*)PerlMemShared_calloc(1, sz);
326 /* While the subroutine is under construction, the slabs are accessed via
327 CvSTART(), to avoid needing to expand PVCV by one pointer for something
328 unneeded at runtime. Once a subroutine is constructed, the slabs are
329 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
330 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
332 if (!CvSTART(PL_compcv)) {
334 (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
335 CvSLABBED_on(PL_compcv);
336 head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
338 else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
340 opsz = SIZE_TO_PSIZE(sz);
341 sz = opsz + OPSLOT_HEADER_P;
343 /* The head slab for each CV maintains a free list of OPs. In particular, constant folding
344 will free up OPs, so it makes sense to re-use them where possible. A
345 freed up slot is used in preference to a new allocation. */
346 if (head_slab->opslab_freed &&
347 OPSLOT_SIZE_TO_INDEX(sz) < head_slab->opslab_freed_size) {
350 /* look for a large enough size with any freed ops */
351 for (base_index = OPSLOT_SIZE_TO_INDEX(sz);
352 base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
356 if (base_index < head_slab->opslab_freed_size) {
357 /* found a freed op */
358 o = head_slab->opslab_freed[base_index];
360 DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p",
362 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
364 head_slab->opslab_freed[base_index] = o->op_next;
365 Zero(o, opsz, I32 *);
371 #define INIT_OPSLOT(s) \
372 slot->opslot_offset = DIFF(slab2, slot) ; \
373 slot->opslot_size = s; \
374 slab2->opslab_free_space -= s; \
375 o = &slot->opslot_op; \
378 /* The partially-filled slab is next in the chain. */
379 slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
380 if (slab2->opslab_free_space < sz) {
381 /* Remaining space is too small. */
382 /* If we can fit a BASEOP, add it to the free chain, so as not
384 if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
385 slot = &slab2->opslab_slots;
386 INIT_OPSLOT(slab2->opslab_free_space);
387 o->op_type = OP_FREED;
388 link_freed_op(head_slab, o);
391 /* Create a new slab. Make this one twice as big. */
392 slab2 = S_new_slab(aTHX_ head_slab,
393 slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2
395 : slab2->opslab_size * 2);
396 slab2->opslab_next = head_slab->opslab_next;
397 head_slab->opslab_next = slab2;
399 assert(slab2->opslab_size >= sz);
401 /* Create a new op slot */
403 ((I32 **)&slab2->opslab_slots
404 + slab2->opslab_free_space - sz);
405 assert(slot >= &slab2->opslab_slots);
407 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
408 (void*)o, (void*)slab2, (void*)head_slab));
411 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
412 assert(!o->op_moresib);
413 assert(!o->op_sibparent);
420 #ifdef PERL_DEBUG_READONLY_OPS
422 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
424 PERL_ARGS_ASSERT_SLAB_TO_RO;
426 if (slab->opslab_readonly) return;
427 slab->opslab_readonly = 1;
428 for (; slab; slab = slab->opslab_next) {
429 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
430 (unsigned long) slab->opslab_size, slab));*/
431 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
432 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
433 (unsigned long)slab->opslab_size, errno);
438 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
442 PERL_ARGS_ASSERT_SLAB_TO_RW;
444 if (!slab->opslab_readonly) return;
446 for (; slab2; slab2 = slab2->opslab_next) {
447 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
448 (unsigned long) size, slab2));*/
449 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
450 PROT_READ|PROT_WRITE)) {
451 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
452 (unsigned long)slab2->opslab_size, errno);
455 slab->opslab_readonly = 0;
459 # define Slab_to_rw(op) NOOP
462 /* This cannot possibly be right, but it was copied from the old slab
463 allocator, to which it was originally added, without explanation, in
466 # define PerlMemShared PerlMem
469 /* make freed ops die if they're inadvertently executed */
474 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
479 /* Return the block of memory used by an op to the free list of
480 * the OP slab associated with that op.
484 Perl_Slab_Free(pTHX_ void *op)
486 OP * const o = (OP *)op;
489 PERL_ARGS_ASSERT_SLAB_FREE;
492 o->op_ppaddr = S_pp_freed;
495 if (!o->op_slabbed) {
497 PerlMemShared_free(op);
502 /* If this op is already freed, our refcount will get screwy. */
503 assert(o->op_type != OP_FREED);
504 o->op_type = OP_FREED;
505 link_freed_op(slab, o);
506 DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p",
508 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
510 OpslabREFCNT_dec_padok(slab);
514 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
516 const bool havepad = !!PL_comppad;
517 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
520 PAD_SAVE_SETNULLPAD();
526 /* Free a chain of OP slabs. Should only be called after all ops contained
527 * in it have been freed. At this point, its reference count should be 1,
528 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
529 * and just directly calls opslab_free().
530 * (Note that the reference count which PL_compcv held on the slab should
531 * have been removed once compilation of the sub was complete).
537 Perl_opslab_free(pTHX_ OPSLAB *slab)
540 PERL_ARGS_ASSERT_OPSLAB_FREE;
542 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
543 assert(slab->opslab_refcnt == 1);
544 PerlMemShared_free(slab->opslab_freed);
546 slab2 = slab->opslab_next;
548 slab->opslab_refcnt = ~(size_t)0;
550 #ifdef PERL_DEBUG_READONLY_OPS
551 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
553 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
554 perror("munmap failed");
558 PerlMemShared_free(slab);
564 /* like opslab_free(), but first calls op_free() on any ops in the slab
565 * not marked as OP_FREED
569 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
573 size_t savestack_count = 0;
575 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
578 OPSLOT *slot = (OPSLOT*)
579 ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
580 OPSLOT *end = (OPSLOT*)
581 ((I32**)slab2 + slab2->opslab_size);
583 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
585 if (slot->opslot_op.op_type != OP_FREED
586 && !(slot->opslot_op.op_savefree
592 assert(slot->opslot_op.op_slabbed);
593 op_free(&slot->opslot_op);
594 if (slab->opslab_refcnt == 1) goto free;
597 } while ((slab2 = slab2->opslab_next));
598 /* > 1 because the CV still holds a reference count. */
599 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
601 assert(savestack_count == slab->opslab_refcnt-1);
603 /* Remove the CV’s reference count. */
604 slab->opslab_refcnt--;
611 #ifdef PERL_DEBUG_READONLY_OPS
613 Perl_op_refcnt_inc(pTHX_ OP *o)
616 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
617 if (slab && slab->opslab_readonly) {
630 Perl_op_refcnt_dec(pTHX_ OP *o)
633 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
635 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
637 if (slab && slab->opslab_readonly) {
639 result = --o->op_targ;
642 result = --o->op_targ;
648 * In the following definition, the ", (OP*)0" is just to make the compiler
649 * think the expression is of the right type: croak actually does a Siglongjmp.
651 #define CHECKOP(type,o) \
652 ((PL_op_mask && PL_op_mask[type]) \
653 ? ( op_free((OP*)o), \
654 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
656 : PL_check[type](aTHX_ (OP*)o))
658 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
660 #define OpTYPE_set(o,type) \
662 o->op_type = (OPCODE)type; \
663 o->op_ppaddr = PL_ppaddr[type]; \
667 S_no_fh_allowed(pTHX_ OP *o)
669 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
671 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
677 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
679 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
680 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
685 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
687 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
689 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
694 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
696 PERL_ARGS_ASSERT_BAD_TYPE_PV;
698 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
699 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
703 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
705 SV * const namesv = cv_name((CV *)gv, NULL, 0);
706 PERL_ARGS_ASSERT_BAD_TYPE_GV;
708 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
709 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
713 S_no_bareword_allowed(pTHX_ OP *o)
715 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
717 qerror(Perl_mess(aTHX_
718 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
720 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
723 /* "register" allocation */
726 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
729 const bool is_our = (PL_parser->in_my == KEY_our);
731 PERL_ARGS_ASSERT_ALLOCMY;
733 if (flags & ~SVf_UTF8)
734 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
737 /* complain about "my $<special_var>" etc etc */
741 || ( (flags & SVf_UTF8)
742 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
743 || (name[1] == '_' && len > 2)))
745 const char * const type =
746 PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
747 PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
749 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
751 && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) {
752 /* diag_listed_as: Can't use global %s in %s */
753 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
754 name[0], toCTRL(name[1]),
755 (int)(len - 2), name + 2,
758 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
760 type), flags & SVf_UTF8);
764 /* allocate a spare slot and store the name in that slot */
766 off = pad_add_name_pvn(name, len,
767 (is_our ? padadd_OUR :
768 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
769 PL_parser->in_my_stash,
771 /* $_ is always in main::, even with our */
772 ? (PL_curstash && !memEQs(name,len,"$_")
778 /* anon sub prototypes contains state vars should always be cloned,
779 * otherwise the state var would be shared between anon subs */
781 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
782 CvCLONE_on(PL_compcv);
788 =head1 Optree Manipulation Functions
790 =for apidoc alloccopstash
792 Available only under threaded builds, this function allocates an entry in
793 C<PL_stashpad> for the stash passed to it.
800 Perl_alloccopstash(pTHX_ HV *hv)
802 PADOFFSET off = 0, o = 1;
803 bool found_slot = FALSE;
805 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
807 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
809 for (; o < PL_stashpadmax; ++o) {
810 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
811 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
812 found_slot = TRUE, off = o;
815 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
816 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
817 off = PL_stashpadmax;
818 PL_stashpadmax += 10;
821 PL_stashpad[PL_stashpadix = off] = hv;
826 /* free the body of an op without examining its contents.
827 * Always use this rather than FreeOp directly */
830 S_op_destroy(pTHX_ OP *o)
840 Free an op and its children. Only use this when an op is no longer linked
847 Perl_op_free(pTHX_ OP *o)
853 bool went_up = FALSE; /* whether we reached the current node by
854 following the parent pointer from a child, and
855 so have already seen this node */
857 if (!o || o->op_type == OP_FREED)
860 if (o->op_private & OPpREFCOUNTED) {
861 /* if base of tree is refcounted, just decrement */
862 switch (o->op_type) {
872 refcnt = OpREFCNT_dec(o);
875 /* Need to find and remove any pattern match ops from
876 * the list we maintain for reset(). */
877 find_and_forget_pmops(o);
890 /* free child ops before ourself, (then free ourself "on the
893 if (!went_up && o->op_flags & OPf_KIDS) {
894 next_op = cUNOPo->op_first;
898 /* find the next node to visit, *then* free the current node
899 * (can't rely on o->op_* fields being valid after o has been
902 /* The next node to visit will be either the sibling, or the
903 * parent if no siblings left, or NULL if we've worked our way
904 * back up to the top node in the tree */
905 next_op = (o == top_op) ? NULL : o->op_sibparent;
906 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
908 /* Now process the current node */
910 /* Though ops may be freed twice, freeing the op after its slab is a
912 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
913 /* During the forced freeing of ops after compilation failure, kidops
914 may be freed before their parents. */
915 if (!o || o->op_type == OP_FREED)
920 /* an op should only ever acquire op_private flags that we know about.
921 * If this fails, you may need to fix something in regen/op_private.
922 * Don't bother testing if:
923 * * the op_ppaddr doesn't match the op; someone may have
924 * overridden the op and be doing strange things with it;
925 * * we've errored, as op flags are often left in an
926 * inconsistent state then. Note that an error when
927 * compiling the main program leaves PL_parser NULL, so
928 * we can't spot faults in the main code, only
929 * evaled/required code */
931 if ( o->op_ppaddr == PL_ppaddr[type]
933 && !PL_parser->error_count)
935 assert(!(o->op_private & ~PL_op_private_valid[type]));
940 /* Call the op_free hook if it has been set. Do it now so that it's called
941 * at the right time for refcounted ops, but still before all of the kids
946 type = (OPCODE)o->op_targ;
949 Slab_to_rw(OpSLAB(o));
951 /* COP* is not cleared by op_clear() so that we may track line
952 * numbers etc even after null() */
953 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
965 /* S_op_clear_gv(): free a GV attached to an OP */
969 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
971 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
975 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
976 || o->op_type == OP_MULTIDEREF)
979 ? ((GV*)PAD_SVl(*ixp)) : NULL;
981 ? (GV*)(*svp) : NULL;
983 /* It's possible during global destruction that the GV is freed
984 before the optree. Whilst the SvREFCNT_inc is happy to bump from
985 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
986 will trigger an assertion failure, because the entry to sv_clear
987 checks that the scalar is not already freed. A check of for
988 !SvIS_FREED(gv) turns out to be invalid, because during global
989 destruction the reference count can be forced down to zero
990 (with SVf_BREAK set). In which case raising to 1 and then
991 dropping to 0 triggers cleanup before it should happen. I
992 *think* that this might actually be a general, systematic,
993 weakness of the whole idea of SVf_BREAK, in that code *is*
994 allowed to raise and lower references during global destruction,
995 so any *valid* code that happens to do this during global
996 destruction might well trigger premature cleanup. */
997 bool still_valid = gv && SvREFCNT(gv);
1000 SvREFCNT_inc_simple_void(gv);
1003 pad_swipe(*ixp, TRUE);
1011 int try_downgrade = SvREFCNT(gv) == 2;
1012 SvREFCNT_dec_NN(gv);
1014 gv_try_downgrade(gv);
1020 Perl_op_clear(pTHX_ OP *o)
1025 PERL_ARGS_ASSERT_OP_CLEAR;
1027 switch (o->op_type) {
1028 case OP_NULL: /* Was holding old type, if any. */
1031 case OP_ENTEREVAL: /* Was holding hints. */
1032 case OP_ARGDEFELEM: /* Was holding signature index. */
1036 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1043 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1045 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1048 case OP_METHOD_REDIR:
1049 case OP_METHOD_REDIR_SUPER:
1051 if (cMETHOPx(o)->op_rclass_targ) {
1052 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1053 cMETHOPx(o)->op_rclass_targ = 0;
1056 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1057 cMETHOPx(o)->op_rclass_sv = NULL;
1060 case OP_METHOD_NAMED:
1061 case OP_METHOD_SUPER:
1062 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1063 cMETHOPx(o)->op_u.op_meth_sv = NULL;
1066 pad_swipe(o->op_targ, 1);
1073 SvREFCNT_dec(cSVOPo->op_sv);
1074 cSVOPo->op_sv = NULL;
1077 Even if op_clear does a pad_free for the target of the op,
1078 pad_free doesn't actually remove the sv that exists in the pad;
1079 instead it lives on. This results in that it could be reused as
1080 a target later on when the pad was reallocated.
1083 pad_swipe(o->op_targ,1);
1093 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1098 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1099 && (o->op_private & OPpTRANS_USE_SVOP))
1102 if (cPADOPo->op_padix > 0) {
1103 pad_swipe(cPADOPo->op_padix, TRUE);
1104 cPADOPo->op_padix = 0;
1107 SvREFCNT_dec(cSVOPo->op_sv);
1108 cSVOPo->op_sv = NULL;
1112 PerlMemShared_free(cPVOPo->op_pv);
1113 cPVOPo->op_pv = NULL;
1117 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1121 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1122 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1124 if (o->op_private & OPpSPLIT_LEX)
1125 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1128 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1130 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1137 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1138 op_free(cPMOPo->op_code_list);
1139 cPMOPo->op_code_list = NULL;
1140 forget_pmop(cPMOPo);
1141 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1142 /* we use the same protection as the "SAFE" version of the PM_ macros
1143 * here since sv_clean_all might release some PMOPs
1144 * after PL_regex_padav has been cleared
1145 * and the clearing of PL_regex_padav needs to
1146 * happen before sv_clean_all
1149 if(PL_regex_pad) { /* We could be in destruction */
1150 const IV offset = (cPMOPo)->op_pmoffset;
1151 ReREFCNT_dec(PM_GETRE(cPMOPo));
1152 PL_regex_pad[offset] = &PL_sv_undef;
1153 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1157 ReREFCNT_dec(PM_GETRE(cPMOPo));
1158 PM_SETRE(cPMOPo, NULL);
1164 PerlMemShared_free(cUNOP_AUXo->op_aux);
1167 case OP_MULTICONCAT:
1169 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1170 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1171 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1172 * utf8 shared strings */
1173 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1174 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1176 PerlMemShared_free(p1);
1178 PerlMemShared_free(p2);
1179 PerlMemShared_free(aux);
1185 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1186 UV actions = items->uv;
1188 bool is_hash = FALSE;
1191 switch (actions & MDEREF_ACTION_MASK) {
1194 actions = (++items)->uv;
1197 case MDEREF_HV_padhv_helem:
1200 case MDEREF_AV_padav_aelem:
1201 pad_free((++items)->pad_offset);
1204 case MDEREF_HV_gvhv_helem:
1207 case MDEREF_AV_gvav_aelem:
1209 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1211 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1215 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1218 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1220 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1222 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1224 goto do_vivify_rv2xv_elem;
1226 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1229 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1230 pad_free((++items)->pad_offset);
1231 goto do_vivify_rv2xv_elem;
1233 case MDEREF_HV_pop_rv2hv_helem:
1234 case MDEREF_HV_vivify_rv2hv_helem:
1237 do_vivify_rv2xv_elem:
1238 case MDEREF_AV_pop_rv2av_aelem:
1239 case MDEREF_AV_vivify_rv2av_aelem:
1241 switch (actions & MDEREF_INDEX_MASK) {
1242 case MDEREF_INDEX_none:
1245 case MDEREF_INDEX_const:
1249 pad_swipe((++items)->pad_offset, 1);
1251 SvREFCNT_dec((++items)->sv);
1257 case MDEREF_INDEX_padsv:
1258 pad_free((++items)->pad_offset);
1260 case MDEREF_INDEX_gvsv:
1262 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1264 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1269 if (actions & MDEREF_FLAG_last)
1282 actions >>= MDEREF_SHIFT;
1285 /* start of malloc is at op_aux[-1], where the length is
1287 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1292 if (o->op_targ > 0) {
1293 pad_free(o->op_targ);
1299 S_cop_free(pTHX_ COP* cop)
1301 PERL_ARGS_ASSERT_COP_FREE;
1304 if (! specialWARN(cop->cop_warnings))
1305 PerlMemShared_free(cop->cop_warnings);
1306 cophh_free(CopHINTHASH_get(cop));
1307 if (PL_curcop == cop)
1312 S_forget_pmop(pTHX_ PMOP *const o)
1314 HV * const pmstash = PmopSTASH(o);
1316 PERL_ARGS_ASSERT_FORGET_PMOP;
1318 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1319 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1321 PMOP **const array = (PMOP**) mg->mg_ptr;
1322 U32 count = mg->mg_len / sizeof(PMOP**);
1326 if (array[i] == o) {
1327 /* Found it. Move the entry at the end to overwrite it. */
1328 array[i] = array[--count];
1329 mg->mg_len = count * sizeof(PMOP**);
1330 /* Could realloc smaller at this point always, but probably
1331 not worth it. Probably worth free()ing if we're the
1334 Safefree(mg->mg_ptr);
1348 S_find_and_forget_pmops(pTHX_ OP *o)
1352 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1355 switch (o->op_type) {
1360 forget_pmop((PMOP*)o);
1363 if (o->op_flags & OPf_KIDS) {
1364 o = cUNOPo->op_first;
1370 return; /* at top; no parents/siblings to try */
1371 if (OpHAS_SIBLING(o)) {
1372 o = o->op_sibparent; /* process next sibling */
1375 o = o->op_sibparent; /*try parent's next sibling */
1384 Neutralizes an op when it is no longer needed, but is still linked to from
1391 Perl_op_null(pTHX_ OP *o)
1395 PERL_ARGS_ASSERT_OP_NULL;
1397 if (o->op_type == OP_NULL)
1400 o->op_targ = o->op_type;
1401 OpTYPE_set(o, OP_NULL);
1405 Perl_op_refcnt_lock(pTHX)
1406 PERL_TSA_ACQUIRE(PL_op_mutex)
1411 PERL_UNUSED_CONTEXT;
1416 Perl_op_refcnt_unlock(pTHX)
1417 PERL_TSA_RELEASE(PL_op_mutex)
1422 PERL_UNUSED_CONTEXT;
1428 =for apidoc op_sibling_splice
1430 A general function for editing the structure of an existing chain of
1431 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1432 you to delete zero or more sequential nodes, replacing them with zero or
1433 more different nodes. Performs the necessary op_first/op_last
1434 housekeeping on the parent node and op_sibling manipulation on the
1435 children. The last deleted node will be marked as the last node by
1436 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1438 Note that op_next is not manipulated, and nodes are not freed; that is the
1439 responsibility of the caller. It also won't create a new list op for an
1440 empty list etc; use higher-level functions like op_append_elem() for that.
1442 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1443 the splicing doesn't affect the first or last op in the chain.
1445 C<start> is the node preceding the first node to be spliced. Node(s)
1446 following it will be deleted, and ops will be inserted after it. If it is
1447 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1450 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1451 If -1 or greater than or equal to the number of remaining kids, all
1452 remaining kids are deleted.
1454 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1455 If C<NULL>, no nodes are inserted.
1457 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1462 action before after returns
1463 ------ ----- ----- -------
1466 splice(P, A, 2, X-Y-Z) | | B-C
1470 splice(P, NULL, 1, X-Y) | | A
1474 splice(P, NULL, 3, NULL) | | A-B-C
1478 splice(P, B, 0, X-Y) | | NULL
1482 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1483 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1489 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1493 OP *last_del = NULL;
1494 OP *last_ins = NULL;
1497 first = OpSIBLING(start);
1501 first = cLISTOPx(parent)->op_first;
1503 assert(del_count >= -1);
1505 if (del_count && first) {
1507 while (--del_count && OpHAS_SIBLING(last_del))
1508 last_del = OpSIBLING(last_del);
1509 rest = OpSIBLING(last_del);
1510 OpLASTSIB_set(last_del, NULL);
1517 while (OpHAS_SIBLING(last_ins))
1518 last_ins = OpSIBLING(last_ins);
1519 OpMAYBESIB_set(last_ins, rest, NULL);
1525 OpMAYBESIB_set(start, insert, NULL);
1529 cLISTOPx(parent)->op_first = insert;
1531 parent->op_flags |= OPf_KIDS;
1533 parent->op_flags &= ~OPf_KIDS;
1537 /* update op_last etc */
1544 /* ought to use OP_CLASS(parent) here, but that can't handle
1545 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1547 type = parent->op_type;
1548 if (type == OP_CUSTOM) {
1550 type = XopENTRYCUSTOM(parent, xop_class);
1553 if (type == OP_NULL)
1554 type = parent->op_targ;
1555 type = PL_opargs[type] & OA_CLASS_MASK;
1558 lastop = last_ins ? last_ins : start ? start : NULL;
1559 if ( type == OA_BINOP
1560 || type == OA_LISTOP
1564 cLISTOPx(parent)->op_last = lastop;
1567 OpLASTSIB_set(lastop, parent);
1569 return last_del ? first : NULL;
1572 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1576 =for apidoc op_parent
1578 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1584 Perl_op_parent(OP *o)
1586 PERL_ARGS_ASSERT_OP_PARENT;
1587 while (OpHAS_SIBLING(o))
1589 return o->op_sibparent;
1592 /* replace the sibling following start with a new UNOP, which becomes
1593 * the parent of the original sibling; e.g.
1595 * op_sibling_newUNOP(P, A, unop-args...)
1603 * where U is the new UNOP.
1605 * parent and start args are the same as for op_sibling_splice();
1606 * type and flags args are as newUNOP().
1608 * Returns the new UNOP.
1612 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1616 kid = op_sibling_splice(parent, start, 1, NULL);
1617 newop = newUNOP(type, flags, kid);
1618 op_sibling_splice(parent, start, 0, newop);
1623 /* lowest-level newLOGOP-style function - just allocates and populates
1624 * the struct. Higher-level stuff should be done by S_new_logop() /
1625 * newLOGOP(). This function exists mainly to avoid op_first assignment
1626 * being spread throughout this file.
1630 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1635 NewOp(1101, logop, 1, LOGOP);
1636 OpTYPE_set(logop, type);
1637 logop->op_first = first;
1638 logop->op_other = other;
1640 logop->op_flags = OPf_KIDS;
1641 while (kid && OpHAS_SIBLING(kid))
1642 kid = OpSIBLING(kid);
1644 OpLASTSIB_set(kid, (OP*)logop);
1649 /* Contextualizers */
1652 =for apidoc op_contextualize
1654 Applies a syntactic context to an op tree representing an expression.
1655 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1656 or C<G_VOID> to specify the context to apply. The modified op tree
1663 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1665 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1667 case G_SCALAR: return scalar(o);
1668 case G_ARRAY: return list(o);
1669 case G_VOID: return scalarvoid(o);
1671 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1678 =for apidoc op_linklist
1679 This function is the implementation of the L</LINKLIST> macro. It should
1680 not be called directly.
1687 Perl_op_linklist(pTHX_ OP *o)
1694 PERL_ARGS_ASSERT_OP_LINKLIST;
1697 /* Descend down the tree looking for any unprocessed subtrees to
1700 if (o->op_flags & OPf_KIDS) {
1701 o = cUNOPo->op_first;
1704 o->op_next = o; /* leaf node; link to self initially */
1707 /* if we're at the top level, there either weren't any children
1708 * to process, or we've worked our way back to the top. */
1712 /* o is now processed. Next, process any sibling subtrees */
1714 if (OpHAS_SIBLING(o)) {
1719 /* Done all the subtrees at this level. Go back up a level and
1720 * link the parent in with all its (processed) children.
1723 o = o->op_sibparent;
1724 assert(!o->op_next);
1725 prevp = &(o->op_next);
1726 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1728 *prevp = kid->op_next;
1729 prevp = &(kid->op_next);
1730 kid = OpSIBLING(kid);
1738 S_scalarkids(pTHX_ OP *o)
1740 if (o && o->op_flags & OPf_KIDS) {
1742 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1749 S_scalarboolean(pTHX_ OP *o)
1751 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1753 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1754 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1755 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1756 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1757 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1758 if (ckWARN(WARN_SYNTAX)) {
1759 const line_t oldline = CopLINE(PL_curcop);
1761 if (PL_parser && PL_parser->copline != NOLINE) {
1762 /* This ensures that warnings are reported at the first line
1763 of the conditional, not the last. */
1764 CopLINE_set(PL_curcop, PL_parser->copline);
1766 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1767 CopLINE_set(PL_curcop, oldline);
1774 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1777 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1778 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1780 const char funny = o->op_type == OP_PADAV
1781 || o->op_type == OP_RV2AV ? '@' : '%';
1782 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1784 if (cUNOPo->op_first->op_type != OP_GV
1785 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1787 return varname(gv, funny, 0, NULL, 0, subscript_type);
1790 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1795 S_op_varname(pTHX_ const OP *o)
1797 return S_op_varname_subscript(aTHX_ o, 1);
1801 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1802 { /* or not so pretty :-) */
1803 if (o->op_type == OP_CONST) {
1805 if (SvPOK(*retsv)) {
1807 *retsv = sv_newmortal();
1808 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1809 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1811 else if (!SvOK(*retsv))
1814 else *retpv = "...";
1818 S_scalar_slice_warning(pTHX_ const OP *o)
1821 const bool h = o->op_type == OP_HSLICE
1822 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1828 SV *keysv = NULL; /* just to silence compiler warnings */
1829 const char *key = NULL;
1831 if (!(o->op_private & OPpSLICEWARNING))
1833 if (PL_parser && PL_parser->error_count)
1834 /* This warning can be nonsensical when there is a syntax error. */
1837 kid = cLISTOPo->op_first;
1838 kid = OpSIBLING(kid); /* get past pushmark */
1839 /* weed out false positives: any ops that can return lists */
1840 switch (kid->op_type) {
1866 /* Don't warn if we have a nulled list either. */
1867 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1870 assert(OpSIBLING(kid));
1871 name = S_op_varname(aTHX_ OpSIBLING(kid));
1872 if (!name) /* XS module fiddling with the op tree */
1874 S_op_pretty(aTHX_ kid, &keysv, &key);
1875 assert(SvPOK(name));
1876 sv_chop(name,SvPVX(name)+1);
1878 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1879 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1880 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1882 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1883 lbrack, key, rbrack);
1885 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1886 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1887 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1889 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1890 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1895 /* apply scalar context to the o subtree */
1898 Perl_scalar(pTHX_ OP *o)
1903 OP *next_kid = NULL; /* what op (if any) to process next */
1906 /* assumes no premature commitment */
1907 if (!o || (PL_parser && PL_parser->error_count)
1908 || (o->op_flags & OPf_WANT)
1909 || o->op_type == OP_RETURN)
1914 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1916 switch (o->op_type) {
1918 scalar(cBINOPo->op_first);
1919 /* convert what initially looked like a list repeat into a
1920 * scalar repeat, e.g. $s = (1) x $n
1922 if (o->op_private & OPpREPEAT_DOLIST) {
1923 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1924 assert(kid->op_type == OP_PUSHMARK);
1925 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1926 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1927 o->op_private &=~ OPpREPEAT_DOLIST;
1935 /* impose scalar context on everything except the condition */
1936 next_kid = OpSIBLING(cUNOPo->op_first);
1940 if (o->op_flags & OPf_KIDS)
1941 next_kid = cUNOPo->op_first; /* do all kids */
1944 /* the children of these ops are usually a list of statements,
1945 * except the leaves, whose first child is a corresponding enter
1950 kid = cLISTOPo->op_first;
1954 kid = cLISTOPo->op_first;
1956 kid = OpSIBLING(kid);
1959 OP *sib = OpSIBLING(kid);
1960 /* Apply void context to all kids except the last, which
1961 * is scalar (ignoring a trailing ex-nextstate in determining
1962 * if it's the last kid). E.g.
1963 * $scalar = do { void; void; scalar }
1964 * Except that 'when's are always scalar, e.g.
1965 * $scalar = do { given(..) {
1966 * when (..) { scalar }
1967 * when (..) { scalar }
1972 || ( !OpHAS_SIBLING(sib)
1973 && sib->op_type == OP_NULL
1974 && ( sib->op_targ == OP_NEXTSTATE
1975 || sib->op_targ == OP_DBSTATE )
1979 /* tail call optimise calling scalar() on the last kid */
1983 else if (kid->op_type == OP_LEAVEWHEN)
1989 NOT_REACHED; /* NOTREACHED */
1993 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1999 /* Warn about scalar context */
2000 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
2001 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
2004 const char *key = NULL;
2006 /* This warning can be nonsensical when there is a syntax error. */
2007 if (PL_parser && PL_parser->error_count)
2010 if (!ckWARN(WARN_SYNTAX)) break;
2012 kid = cLISTOPo->op_first;
2013 kid = OpSIBLING(kid); /* get past pushmark */
2014 assert(OpSIBLING(kid));
2015 name = S_op_varname(aTHX_ OpSIBLING(kid));
2016 if (!name) /* XS module fiddling with the op tree */
2018 S_op_pretty(aTHX_ kid, &keysv, &key);
2019 assert(SvPOK(name));
2020 sv_chop(name,SvPVX(name)+1);
2022 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2023 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2024 "%%%" SVf "%c%s%c in scalar context better written "
2025 "as $%" SVf "%c%s%c",
2026 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
2027 lbrack, key, rbrack);
2029 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2030 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2031 "%%%" SVf "%c%" SVf "%c in scalar context better "
2032 "written as $%" SVf "%c%" SVf "%c",
2033 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
2034 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2038 /* If next_kid is set, someone in the code above wanted us to process
2039 * that kid and all its remaining siblings. Otherwise, work our way
2040 * back up the tree */
2044 return top_op; /* at top; no parents/siblings to try */
2045 if (OpHAS_SIBLING(o))
2046 next_kid = o->op_sibparent;
2048 o = o->op_sibparent; /*try parent's next sibling */
2049 switch (o->op_type) {
2055 /* should really restore PL_curcop to its old value, but
2056 * setting it to PL_compiling is better than do nothing */
2057 PL_curcop = &PL_compiling;
2066 /* apply void context to the optree arg */
2069 Perl_scalarvoid(pTHX_ OP *arg)
2076 PERL_ARGS_ASSERT_SCALARVOID;
2080 SV *useless_sv = NULL;
2081 const char* useless = NULL;
2082 OP * next_kid = NULL;
2084 if (o->op_type == OP_NEXTSTATE
2085 || o->op_type == OP_DBSTATE
2086 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2087 || o->op_targ == OP_DBSTATE)))
2088 PL_curcop = (COP*)o; /* for warning below */
2090 /* assumes no premature commitment */
2091 want = o->op_flags & OPf_WANT;
2092 if ((want && want != OPf_WANT_SCALAR)
2093 || (PL_parser && PL_parser->error_count)
2094 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2099 if ((o->op_private & OPpTARGET_MY)
2100 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2102 /* newASSIGNOP has already applied scalar context, which we
2103 leave, as if this op is inside SASSIGN. */
2107 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2109 switch (o->op_type) {
2111 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2115 if (o->op_flags & OPf_STACKED)
2117 if (o->op_type == OP_REPEAT)
2118 scalar(cBINOPo->op_first);
2121 if ((o->op_flags & OPf_STACKED) &&
2122 !(o->op_private & OPpCONCAT_NESTED))
2126 if (o->op_private == 4)
2161 case OP_GETSOCKNAME:
2162 case OP_GETPEERNAME:
2167 case OP_GETPRIORITY:
2192 useless = OP_DESC(o);
2202 case OP_AELEMFAST_LEX:
2206 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2207 /* Otherwise it's "Useless use of grep iterator" */
2208 useless = OP_DESC(o);
2212 if (!(o->op_private & OPpSPLIT_ASSIGN))
2213 useless = OP_DESC(o);
2217 kid = cUNOPo->op_first;
2218 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2219 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2222 useless = "negative pattern binding (!~)";
2226 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2227 useless = "non-destructive substitution (s///r)";
2231 useless = "non-destructive transliteration (tr///r)";
2238 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2239 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2240 useless = "a variable";
2245 if (cSVOPo->op_private & OPpCONST_STRICT)
2246 no_bareword_allowed(o);
2248 if (ckWARN(WARN_VOID)) {
2250 /* don't warn on optimised away booleans, eg
2251 * use constant Foo, 5; Foo || print; */
2252 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2254 /* the constants 0 and 1 are permitted as they are
2255 conventionally used as dummies in constructs like
2256 1 while some_condition_with_side_effects; */
2257 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2259 else if (SvPOK(sv)) {
2260 SV * const dsv = newSVpvs("");
2262 = Perl_newSVpvf(aTHX_
2264 pv_pretty(dsv, SvPVX_const(sv),
2265 SvCUR(sv), 32, NULL, NULL,
2267 | PERL_PV_ESCAPE_NOCLEAR
2268 | PERL_PV_ESCAPE_UNI_DETECT));
2269 SvREFCNT_dec_NN(dsv);
2271 else if (SvOK(sv)) {
2272 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2275 useless = "a constant (undef)";
2278 op_null(o); /* don't execute or even remember it */
2282 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2286 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2290 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2294 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2299 UNOP *refgen, *rv2cv;
2302 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2305 rv2gv = ((BINOP *)o)->op_last;
2306 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2309 refgen = (UNOP *)((BINOP *)o)->op_first;
2311 if (!refgen || (refgen->op_type != OP_REFGEN
2312 && refgen->op_type != OP_SREFGEN))
2315 exlist = (LISTOP *)refgen->op_first;
2316 if (!exlist || exlist->op_type != OP_NULL
2317 || exlist->op_targ != OP_LIST)
2320 if (exlist->op_first->op_type != OP_PUSHMARK
2321 && exlist->op_first != exlist->op_last)
2324 rv2cv = (UNOP*)exlist->op_last;
2326 if (rv2cv->op_type != OP_RV2CV)
2329 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2330 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2331 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2333 o->op_private |= OPpASSIGN_CV_TO_GV;
2334 rv2gv->op_private |= OPpDONT_INIT_GV;
2335 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2347 kid = cLOGOPo->op_first;
2348 if (kid->op_type == OP_NOT
2349 && (kid->op_flags & OPf_KIDS)) {
2350 if (o->op_type == OP_AND) {
2351 OpTYPE_set(o, OP_OR);
2353 OpTYPE_set(o, OP_AND);
2363 next_kid = OpSIBLING(cUNOPo->op_first);
2367 if (o->op_flags & OPf_STACKED)
2374 if (!(o->op_flags & OPf_KIDS))
2385 next_kid = cLISTOPo->op_first;
2388 /* If the first kid after pushmark is something that the padrange
2389 optimisation would reject, then null the list and the pushmark.
2391 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2392 && ( !(kid = OpSIBLING(kid))
2393 || ( kid->op_type != OP_PADSV
2394 && kid->op_type != OP_PADAV
2395 && kid->op_type != OP_PADHV)
2396 || kid->op_private & ~OPpLVAL_INTRO
2397 || !(kid = OpSIBLING(kid))
2398 || ( kid->op_type != OP_PADSV
2399 && kid->op_type != OP_PADAV
2400 && kid->op_type != OP_PADHV)
2401 || kid->op_private & ~OPpLVAL_INTRO)
2403 op_null(cUNOPo->op_first); /* NULL the pushmark */
2404 op_null(o); /* NULL the list */
2416 /* mortalise it, in case warnings are fatal. */
2417 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2418 "Useless use of %" SVf " in void context",
2419 SVfARG(sv_2mortal(useless_sv)));
2422 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2423 "Useless use of %s in void context",
2428 /* if a kid hasn't been nominated to process, continue with the
2429 * next sibling, or if no siblings left, go back to the parent's
2430 * siblings and so on
2434 return arg; /* at top; no parents/siblings to try */
2435 if (OpHAS_SIBLING(o))
2436 next_kid = o->op_sibparent;
2438 o = o->op_sibparent; /*try parent's next sibling */
2448 S_listkids(pTHX_ OP *o)
2450 if (o && o->op_flags & OPf_KIDS) {
2452 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2459 /* apply list context to the o subtree */
2462 Perl_list(pTHX_ OP *o)
2467 OP *next_kid = NULL; /* what op (if any) to process next */
2471 /* assumes no premature commitment */
2472 if (!o || (o->op_flags & OPf_WANT)
2473 || (PL_parser && PL_parser->error_count)
2474 || o->op_type == OP_RETURN)
2479 if ((o->op_private & OPpTARGET_MY)
2480 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2482 goto do_next; /* As if inside SASSIGN */
2485 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2487 switch (o->op_type) {
2489 if (o->op_private & OPpREPEAT_DOLIST
2490 && !(o->op_flags & OPf_STACKED))
2492 list(cBINOPo->op_first);
2493 kid = cBINOPo->op_last;
2494 /* optimise away (.....) x 1 */
2495 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2496 && SvIVX(kSVOP_sv) == 1)
2498 op_null(o); /* repeat */
2499 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2501 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2509 /* impose list context on everything except the condition */
2510 next_kid = OpSIBLING(cUNOPo->op_first);
2514 if (!(o->op_flags & OPf_KIDS))
2516 /* possibly flatten 1..10 into a constant array */
2517 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2518 list(cBINOPo->op_first);
2519 gen_constant_list(o);
2522 next_kid = cUNOPo->op_first; /* do all kids */
2526 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2527 op_null(cUNOPo->op_first); /* NULL the pushmark */
2528 op_null(o); /* NULL the list */
2530 if (o->op_flags & OPf_KIDS)
2531 next_kid = cUNOPo->op_first; /* do all kids */
2534 /* the children of these ops are usually a list of statements,
2535 * except the leaves, whose first child is a corresponding enter
2539 kid = cLISTOPo->op_first;
2543 kid = cLISTOPo->op_first;
2545 kid = OpSIBLING(kid);
2548 OP *sib = OpSIBLING(kid);
2549 /* Apply void context to all kids except the last, which
2551 * @a = do { void; void; list }
2552 * Except that 'when's are always list context, e.g.
2553 * @a = do { given(..) {
2554 * when (..) { list }
2555 * when (..) { list }
2560 /* tail call optimise calling list() on the last kid */
2564 else if (kid->op_type == OP_LEAVEWHEN)
2570 NOT_REACHED; /* NOTREACHED */
2575 /* If next_kid is set, someone in the code above wanted us to process
2576 * that kid and all its remaining siblings. Otherwise, work our way
2577 * back up the tree */
2581 return top_op; /* at top; no parents/siblings to try */
2582 if (OpHAS_SIBLING(o))
2583 next_kid = o->op_sibparent;
2585 o = o->op_sibparent; /*try parent's next sibling */
2586 switch (o->op_type) {
2592 /* should really restore PL_curcop to its old value, but
2593 * setting it to PL_compiling is better than do nothing */
2594 PL_curcop = &PL_compiling;
2606 S_scalarseq(pTHX_ OP *o)
2609 const OPCODE type = o->op_type;
2611 if (type == OP_LINESEQ || type == OP_SCOPE ||
2612 type == OP_LEAVE || type == OP_LEAVETRY)
2615 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2616 if ((sib = OpSIBLING(kid))
2617 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2618 || ( sib->op_targ != OP_NEXTSTATE
2619 && sib->op_targ != OP_DBSTATE )))
2624 PL_curcop = &PL_compiling;
2626 o->op_flags &= ~OPf_PARENS;
2627 if (PL_hints & HINT_BLOCK_SCOPE)
2628 o->op_flags |= OPf_PARENS;
2631 o = newOP(OP_STUB, 0);
2636 S_modkids(pTHX_ OP *o, I32 type)
2638 if (o && o->op_flags & OPf_KIDS) {
2640 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2641 op_lvalue(kid, type);
2647 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2648 * const fields. Also, convert CONST keys to HEK-in-SVs.
2649 * rop is the op that retrieves the hash;
2650 * key_op is the first key
2651 * real if false, only check (and possibly croak); don't update op
2655 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2661 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2663 if (rop->op_first->op_type == OP_PADSV)
2664 /* @$hash{qw(keys here)} */
2665 rop = (UNOP*)rop->op_first;
2667 /* @{$hash}{qw(keys here)} */
2668 if (rop->op_first->op_type == OP_SCOPE
2669 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2671 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2678 lexname = NULL; /* just to silence compiler warnings */
2679 fields = NULL; /* just to silence compiler warnings */
2683 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2684 SvPAD_TYPED(lexname))
2685 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2686 && isGV(*fields) && GvHV(*fields);
2688 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2690 if (key_op->op_type != OP_CONST)
2692 svp = cSVOPx_svp(key_op);
2694 /* make sure it's not a bareword under strict subs */
2695 if (key_op->op_private & OPpCONST_BARE &&
2696 key_op->op_private & OPpCONST_STRICT)
2698 no_bareword_allowed((OP*)key_op);
2701 /* Make the CONST have a shared SV */
2702 if ( !SvIsCOW_shared_hash(sv = *svp)
2703 && SvTYPE(sv) < SVt_PVMG
2709 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2710 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2711 SvREFCNT_dec_NN(sv);
2716 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2718 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2719 "in variable %" PNf " of type %" HEKf,
2720 SVfARG(*svp), PNfARG(lexname),
2721 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2726 /* info returned by S_sprintf_is_multiconcatable() */
2728 struct sprintf_ismc_info {
2729 SSize_t nargs; /* num of args to sprintf (not including the format) */
2730 char *start; /* start of raw format string */
2731 char *end; /* bytes after end of raw format string */
2732 STRLEN total_len; /* total length (in bytes) of format string, not
2733 including '%s' and half of '%%' */
2734 STRLEN variant; /* number of bytes by which total_len_p would grow
2735 if upgraded to utf8 */
2736 bool utf8; /* whether the format is utf8 */
2740 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2741 * i.e. its format argument is a const string with only '%s' and '%%'
2742 * formats, and the number of args is known, e.g.
2743 * sprintf "a=%s f=%s", $a[0], scalar(f());
2745 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2747 * If successful, the sprintf_ismc_info struct pointed to by info will be
2752 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2754 OP *pm, *constop, *kid;
2757 SSize_t nargs, nformats;
2758 STRLEN cur, total_len, variant;
2761 /* if sprintf's behaviour changes, die here so that someone
2762 * can decide whether to enhance this function or skip optimising
2763 * under those new circumstances */
2764 assert(!(o->op_flags & OPf_STACKED));
2765 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2766 assert(!(o->op_private & ~OPpARG4_MASK));
2768 pm = cUNOPo->op_first;
2769 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2771 constop = OpSIBLING(pm);
2772 if (!constop || constop->op_type != OP_CONST)
2774 sv = cSVOPx_sv(constop);
2775 if (SvMAGICAL(sv) || !SvPOK(sv))
2781 /* Scan format for %% and %s and work out how many %s there are.
2782 * Abandon if other format types are found.
2789 for (p = s; p < e; p++) {
2792 if (!UTF8_IS_INVARIANT(*p))
2798 return FALSE; /* lone % at end gives "Invalid conversion" */
2807 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2810 utf8 = cBOOL(SvUTF8(sv));
2814 /* scan args; they must all be in scalar cxt */
2817 kid = OpSIBLING(constop);
2820 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2823 kid = OpSIBLING(kid);
2826 if (nargs != nformats)
2827 return FALSE; /* e.g. sprintf("%s%s", $a); */
2830 info->nargs = nargs;
2833 info->total_len = total_len;
2834 info->variant = variant;
2842 /* S_maybe_multiconcat():
2844 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2845 * convert it (and its children) into an OP_MULTICONCAT. See the code
2846 * comments just before pp_multiconcat() for the full details of what
2847 * OP_MULTICONCAT supports.
2849 * Basically we're looking for an optree with a chain of OP_CONCATS down
2850 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2851 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2859 * STRINGIFY -- PADSV[$x]
2862 * ex-PUSHMARK -- CONCAT/S
2864 * CONCAT/S -- PADSV[$d]
2866 * CONCAT -- CONST["-"]
2868 * PADSV[$a] -- PADSV[$b]
2870 * Note that at this stage the OP_SASSIGN may have already been optimised
2871 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2875 S_maybe_multiconcat(pTHX_ OP *o)
2878 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2879 OP *topop; /* the top-most op in the concat tree (often equals o,
2880 unless there are assign/stringify ops above it */
2881 OP *parentop; /* the parent op of topop (or itself if no parent) */
2882 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2883 OP *targetop; /* the op corresponding to target=... or target.=... */
2884 OP *stringop; /* the OP_STRINGIFY op, if any */
2885 OP *nextop; /* used for recreating the op_next chain without consts */
2886 OP *kid; /* general-purpose op pointer */
2888 UNOP_AUX_item *lenp;
2889 char *const_str, *p;
2890 struct sprintf_ismc_info sprintf_info;
2892 /* store info about each arg in args[];
2893 * toparg is the highest used slot; argp is a general
2894 * pointer to args[] slots */
2896 void *p; /* initially points to const sv (or null for op);
2897 later, set to SvPV(constsv), with ... */
2898 STRLEN len; /* ... len set to SvPV(..., len) */
2899 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2903 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2906 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2907 the last-processed arg will the LHS of one,
2908 as args are processed in reverse order */
2909 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2910 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2911 U8 flags = 0; /* what will become the op_flags and ... */
2912 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2913 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2914 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2915 bool prev_was_const = FALSE; /* previous arg was a const */
2917 /* -----------------------------------------------------------------
2920 * Examine the optree non-destructively to determine whether it's
2921 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2922 * information about the optree in args[].
2932 assert( o->op_type == OP_SASSIGN
2933 || o->op_type == OP_CONCAT
2934 || o->op_type == OP_SPRINTF
2935 || o->op_type == OP_STRINGIFY);
2937 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2939 /* first see if, at the top of the tree, there is an assign,
2940 * append and/or stringify */
2942 if (topop->op_type == OP_SASSIGN) {
2944 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2946 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2948 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2951 topop = cBINOPo->op_first;
2952 targetop = OpSIBLING(topop);
2953 if (!targetop) /* probably some sort of syntax error */
2956 /* don't optimise away assign in 'local $foo = ....' */
2957 if ( (targetop->op_private & OPpLVAL_INTRO)
2958 /* these are the common ops which do 'local', but
2960 && ( targetop->op_type == OP_GVSV
2961 || targetop->op_type == OP_RV2SV
2962 || targetop->op_type == OP_AELEM
2963 || targetop->op_type == OP_HELEM
2968 else if ( topop->op_type == OP_CONCAT
2969 && (topop->op_flags & OPf_STACKED)
2970 && (!(topop->op_private & OPpCONCAT_NESTED))
2975 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2976 * decide what to do about it */
2977 assert(!(o->op_private & OPpTARGET_MY));
2979 /* barf on unknown flags */
2980 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2981 private_flags |= OPpMULTICONCAT_APPEND;
2982 targetop = cBINOPo->op_first;
2984 topop = OpSIBLING(targetop);
2986 /* $x .= <FOO> gets optimised to rcatline instead */
2987 if (topop->op_type == OP_READLINE)
2992 /* Can targetop (the LHS) if it's a padsv, be optimised
2993 * away and use OPpTARGET_MY instead?
2995 if ( (targetop->op_type == OP_PADSV)
2996 && !(targetop->op_private & OPpDEREF)
2997 && !(targetop->op_private & OPpPAD_STATE)
2998 /* we don't support 'my $x .= ...' */
2999 && ( o->op_type == OP_SASSIGN
3000 || !(targetop->op_private & OPpLVAL_INTRO))
3005 if (topop->op_type == OP_STRINGIFY) {
3006 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
3010 /* barf on unknown flags */
3011 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
3013 if ((topop->op_private & OPpTARGET_MY)) {
3014 if (o->op_type == OP_SASSIGN)
3015 return; /* can't have two assigns */
3019 private_flags |= OPpMULTICONCAT_STRINGIFY;
3021 topop = cBINOPx(topop)->op_first;
3022 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
3023 topop = OpSIBLING(topop);
3026 if (topop->op_type == OP_SPRINTF) {
3027 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
3029 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
3030 nargs = sprintf_info.nargs;
3031 total_len = sprintf_info.total_len;
3032 variant = sprintf_info.variant;
3033 utf8 = sprintf_info.utf8;
3035 private_flags |= OPpMULTICONCAT_FAKE;
3037 /* we have an sprintf op rather than a concat optree.
3038 * Skip most of the code below which is associated with
3039 * processing that optree. We also skip phase 2, determining
3040 * whether its cost effective to optimise, since for sprintf,
3041 * multiconcat is *always* faster */
3044 /* note that even if the sprintf itself isn't multiconcatable,
3045 * the expression as a whole may be, e.g. in
3046 * $x .= sprintf("%d",...)
3047 * the sprintf op will be left as-is, but the concat/S op may
3048 * be upgraded to multiconcat
3051 else if (topop->op_type == OP_CONCAT) {
3052 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
3055 if ((topop->op_private & OPpTARGET_MY)) {
3056 if (o->op_type == OP_SASSIGN || targmyop)
3057 return; /* can't have two assigns */
3062 /* Is it safe to convert a sassign/stringify/concat op into
3064 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
3065 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
3066 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3067 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
3068 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
3069 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3070 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
3071 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3073 /* Now scan the down the tree looking for a series of
3074 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3075 * stacked). For example this tree:
3080 * CONCAT/STACKED -- EXPR5
3082 * CONCAT/STACKED -- EXPR4
3088 * corresponds to an expression like
3090 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3092 * Record info about each EXPR in args[]: in particular, whether it is
3093 * a stringifiable OP_CONST and if so what the const sv is.
3095 * The reason why the last concat can't be STACKED is the difference
3098 * ((($a .= $a) .= $a) .= $a) .= $a
3101 * $a . $a . $a . $a . $a
3103 * The main difference between the optrees for those two constructs
3104 * is the presence of the last STACKED. As well as modifying $a,
3105 * the former sees the changed $a between each concat, so if $s is
3106 * initially 'a', the first returns 'a' x 16, while the latter returns
3107 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3117 if ( kid->op_type == OP_CONCAT
3121 k1 = cUNOPx(kid)->op_first;
3123 /* shouldn't happen except maybe after compile err? */
3127 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3128 if (kid->op_private & OPpTARGET_MY)
3131 stacked_last = (kid->op_flags & OPf_STACKED);
3143 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3144 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3146 /* At least two spare slots are needed to decompose both
3147 * concat args. If there are no slots left, continue to
3148 * examine the rest of the optree, but don't push new values
3149 * on args[]. If the optree as a whole is legal for conversion
3150 * (in particular that the last concat isn't STACKED), then
3151 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3152 * can be converted into an OP_MULTICONCAT now, with the first
3153 * child of that op being the remainder of the optree -
3154 * which may itself later be converted to a multiconcat op
3158 /* the last arg is the rest of the optree */
3163 else if ( argop->op_type == OP_CONST
3164 && ((sv = cSVOPx_sv(argop)))
3165 /* defer stringification until runtime of 'constant'
3166 * things that might stringify variantly, e.g. the radix
3167 * point of NVs, or overloaded RVs */
3168 && (SvPOK(sv) || SvIOK(sv))
3169 && (!SvGMAGICAL(sv))
3171 if (argop->op_private & OPpCONST_STRICT)
3172 no_bareword_allowed(argop);
3174 utf8 |= cBOOL(SvUTF8(sv));
3177 /* this const may be demoted back to a plain arg later;
3178 * make sure we have enough arg slots left */
3180 prev_was_const = !prev_was_const;
3185 prev_was_const = FALSE;
3195 return; /* we don't support ((A.=B).=C)...) */
3197 /* look for two adjacent consts and don't fold them together:
3200 * $o->concat("a")->concat("b")
3203 * (but $o .= "a" . "b" should still fold)
3206 bool seen_nonconst = FALSE;
3207 for (argp = toparg; argp >= args; argp--) {
3208 if (argp->p == NULL) {
3209 seen_nonconst = TRUE;
3215 /* both previous and current arg were constants;
3216 * leave the current OP_CONST as-is */
3224 /* -----------------------------------------------------------------
3227 * At this point we have determined that the optree *can* be converted
3228 * into a multiconcat. Having gathered all the evidence, we now decide
3229 * whether it *should*.
3233 /* we need at least one concat action, e.g.:
3239 * otherwise we could be doing something like $x = "foo", which
3240 * if treated as a concat, would fail to COW.
3242 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3245 /* Benchmarking seems to indicate that we gain if:
3246 * * we optimise at least two actions into a single multiconcat
3247 * (e.g concat+concat, sassign+concat);
3248 * * or if we can eliminate at least 1 OP_CONST;
3249 * * or if we can eliminate a padsv via OPpTARGET_MY
3253 /* eliminated at least one OP_CONST */
3255 /* eliminated an OP_SASSIGN */
3256 || o->op_type == OP_SASSIGN
3257 /* eliminated an OP_PADSV */
3258 || (!targmyop && is_targable)
3260 /* definitely a net gain to optimise */
3263 /* ... if not, what else? */
3265 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3266 * multiconcat is faster (due to not creating a temporary copy of
3267 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3273 && topop->op_type == OP_CONCAT
3275 PADOFFSET t = targmyop->op_targ;
3276 OP *k1 = cBINOPx(topop)->op_first;
3277 OP *k2 = cBINOPx(topop)->op_last;
3278 if ( k2->op_type == OP_PADSV
3280 && ( k1->op_type != OP_PADSV
3281 || k1->op_targ != t)
3286 /* need at least two concats */
3287 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3292 /* -----------------------------------------------------------------
3295 * At this point the optree has been verified as ok to be optimised
3296 * into an OP_MULTICONCAT. Now start changing things.
3301 /* stringify all const args and determine utf8ness */
3304 for (argp = args; argp <= toparg; argp++) {
3305 SV *sv = (SV*)argp->p;
3307 continue; /* not a const op */
3308 if (utf8 && !SvUTF8(sv))
3309 sv_utf8_upgrade_nomg(sv);
3310 argp->p = SvPV_nomg(sv, argp->len);
3311 total_len += argp->len;
3313 /* see if any strings would grow if converted to utf8 */
3315 variant += variant_under_utf8_count((U8 *) argp->p,
3316 (U8 *) argp->p + argp->len);
3320 /* create and populate aux struct */
3324 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3325 sizeof(UNOP_AUX_item)
3327 PERL_MULTICONCAT_HEADER_SIZE
3328 + ((nargs + 1) * (variant ? 2 : 1))
3331 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3333 /* Extract all the non-const expressions from the concat tree then
3334 * dispose of the old tree, e.g. convert the tree from this:
3338 * STRINGIFY -- TARGET
3340 * ex-PUSHMARK -- CONCAT
3355 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3357 * except that if EXPRi is an OP_CONST, it's discarded.
3359 * During the conversion process, EXPR ops are stripped from the tree
3360 * and unshifted onto o. Finally, any of o's remaining original
3361 * childen are discarded and o is converted into an OP_MULTICONCAT.
3363 * In this middle of this, o may contain both: unshifted args on the
3364 * left, and some remaining original args on the right. lastkidop
3365 * is set to point to the right-most unshifted arg to delineate
3366 * between the two sets.
3371 /* create a copy of the format with the %'s removed, and record
3372 * the sizes of the const string segments in the aux struct */
3374 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3376 p = sprintf_info.start;
3379 for (; p < sprintf_info.end; p++) {
3383 (lenp++)->ssize = q - oldq;
3390 lenp->ssize = q - oldq;
3391 assert((STRLEN)(q - const_str) == total_len);
3393 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3394 * may or may not be topop) The pushmark and const ops need to be
3395 * kept in case they're an op_next entry point.
3397 lastkidop = cLISTOPx(topop)->op_last;
3398 kid = cUNOPx(topop)->op_first; /* pushmark */
3400 op_null(OpSIBLING(kid)); /* const */
3402 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3403 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3404 lastkidop->op_next = o;
3409 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3413 /* Concatenate all const strings into const_str.
3414 * Note that args[] contains the RHS args in reverse order, so
3415 * we scan args[] from top to bottom to get constant strings
3418 for (argp = toparg; argp >= args; argp--) {
3420 /* not a const op */
3421 (++lenp)->ssize = -1;
3423 STRLEN l = argp->len;
3424 Copy(argp->p, p, l, char);
3426 if (lenp->ssize == -1)
3437 for (argp = args; argp <= toparg; argp++) {
3438 /* only keep non-const args, except keep the first-in-next-chain
3439 * arg no matter what it is (but nulled if OP_CONST), because it
3440 * may be the entry point to this subtree from the previous
3443 bool last = (argp == toparg);
3446 /* set prev to the sibling *before* the arg to be cut out,
3447 * e.g. when cutting EXPR:
3452 * prev= CONCAT -- EXPR
3455 if (argp == args && kid->op_type != OP_CONCAT) {
3456 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3457 * so the expression to be cut isn't kid->op_last but
3460 /* find the op before kid */
3462 o2 = cUNOPx(parentop)->op_first;
3463 while (o2 && o2 != kid) {
3471 else if (kid == o && lastkidop)
3472 prev = last ? lastkidop : OpSIBLING(lastkidop);
3474 prev = last ? NULL : cUNOPx(kid)->op_first;
3476 if (!argp->p || last) {
3478 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3479 /* and unshift to front of o */
3480 op_sibling_splice(o, NULL, 0, aop);
3481 /* record the right-most op added to o: later we will
3482 * free anything to the right of it */
3485 aop->op_next = nextop;
3488 /* null the const at start of op_next chain */
3492 nextop = prev->op_next;
3495 /* the last two arguments are both attached to the same concat op */
3496 if (argp < toparg - 1)
3501 /* Populate the aux struct */
3503 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3504 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3505 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3506 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3507 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3509 /* if variant > 0, calculate a variant const string and lengths where
3510 * the utf8 version of the string will take 'variant' more bytes than
3514 char *p = const_str;
3515 STRLEN ulen = total_len + variant;
3516 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3517 UNOP_AUX_item *ulens = lens + (nargs + 1);
3518 char *up = (char*)PerlMemShared_malloc(ulen);
3521 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3522 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3524 for (n = 0; n < (nargs + 1); n++) {
3526 char * orig_up = up;
3527 for (i = (lens++)->ssize; i > 0; i--) {
3529 append_utf8_from_native_byte(c, (U8**)&up);
3531 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3536 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3537 * that op's first child - an ex-PUSHMARK - because the op_next of
3538 * the previous op may point to it (i.e. it's the entry point for
3543 ? op_sibling_splice(o, lastkidop, 1, NULL)
3544 : op_sibling_splice(stringop, NULL, 1, NULL);
3545 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3546 op_sibling_splice(o, NULL, 0, pmop);
3553 * target .= A.B.C...
3559 if (o->op_type == OP_SASSIGN) {
3560 /* Move the target subtree from being the last of o's children
3561 * to being the last of o's preserved children.
3562 * Note the difference between 'target = ...' and 'target .= ...':
3563 * for the former, target is executed last; for the latter,
3566 kid = OpSIBLING(lastkidop);
3567 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3568 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3569 lastkidop->op_next = kid->op_next;
3570 lastkidop = targetop;
3573 /* Move the target subtree from being the first of o's
3574 * original children to being the first of *all* o's children.
3577 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3578 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3581 /* if the RHS of .= doesn't contain a concat (e.g.
3582 * $x .= "foo"), it gets missed by the "strip ops from the
3583 * tree and add to o" loop earlier */
3584 assert(topop->op_type != OP_CONCAT);
3586 /* in e.g. $x .= "$y", move the $y expression
3587 * from being a child of OP_STRINGIFY to being the
3588 * second child of the OP_CONCAT
3590 assert(cUNOPx(stringop)->op_first == topop);
3591 op_sibling_splice(stringop, NULL, 1, NULL);
3592 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3594 assert(topop == OpSIBLING(cBINOPo->op_first));
3603 * my $lex = A.B.C...
3606 * The original padsv op is kept but nulled in case it's the
3607 * entry point for the optree (which it will be for
3610 private_flags |= OPpTARGET_MY;
3611 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3612 o->op_targ = targetop->op_targ;
3613 targetop->op_targ = 0;
3617 flags |= OPf_STACKED;
3619 else if (targmyop) {
3620 private_flags |= OPpTARGET_MY;
3621 if (o != targmyop) {
3622 o->op_targ = targmyop->op_targ;
3623 targmyop->op_targ = 0;
3627 /* detach the emaciated husk of the sprintf/concat optree and free it */
3629 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3635 /* and convert o into a multiconcat */
3637 o->op_flags = (flags|OPf_KIDS|stacked_last
3638 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3639 o->op_private = private_flags;
3640 o->op_type = OP_MULTICONCAT;
3641 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3642 cUNOP_AUXo->op_aux = aux;
3646 /* do all the final processing on an optree (e.g. running the peephole
3647 * optimiser on it), then attach it to cv (if cv is non-null)
3651 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3655 /* XXX for some reason, evals, require and main optrees are
3656 * never attached to their CV; instead they just hang off
3657 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3658 * and get manually freed when appropriate */
3660 startp = &CvSTART(cv);
3662 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3665 optree->op_private |= OPpREFCOUNTED;
3666 OpREFCNT_set(optree, 1);
3667 optimize_optree(optree);
3669 finalize_optree(optree);
3670 S_prune_chain_head(startp);
3673 /* now that optimizer has done its work, adjust pad values */
3674 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3675 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3681 =for apidoc optimize_optree
3683 This function applies some optimisations to the optree in top-down order.
3684 It is called before the peephole optimizer, which processes ops in
3685 execution order. Note that finalize_optree() also does a top-down scan,
3686 but is called *after* the peephole optimizer.
3692 Perl_optimize_optree(pTHX_ OP* o)
3694 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3697 SAVEVPTR(PL_curcop);
3705 /* helper for optimize_optree() which optimises one op then recurses
3706 * to optimise any children.
3710 S_optimize_op(pTHX_ OP* o)
3714 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3717 OP * next_kid = NULL;
3719 assert(o->op_type != OP_FREED);
3721 switch (o->op_type) {
3724 PL_curcop = ((COP*)o); /* for warnings */
3732 S_maybe_multiconcat(aTHX_ o);
3736 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3737 /* we can't assume that op_pmreplroot->op_sibparent == o
3738 * and that it is thus possible to walk back up the tree
3739 * past op_pmreplroot. So, although we try to avoid
3740 * recursing through op trees, do it here. After all,
3741 * there are unlikely to be many nested s///e's within
3742 * the replacement part of a s///e.
3744 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3752 if (o->op_flags & OPf_KIDS)
3753 next_kid = cUNOPo->op_first;
3755 /* if a kid hasn't been nominated to process, continue with the
3756 * next sibling, or if no siblings left, go back to the parent's
3757 * siblings and so on
3761 return; /* at top; no parents/siblings to try */
3762 if (OpHAS_SIBLING(o))
3763 next_kid = o->op_sibparent;
3765 o = o->op_sibparent; /*try parent's next sibling */
3768 /* this label not yet used. Goto here if any code above sets
3778 =for apidoc finalize_optree
3780 This function finalizes the optree. Should be called directly after
3781 the complete optree is built. It does some additional
3782 checking which can't be done in the normal C<ck_>xxx functions and makes
3783 the tree thread-safe.
3788 Perl_finalize_optree(pTHX_ OP* o)
3790 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3793 SAVEVPTR(PL_curcop);
3801 /* Relocate sv to the pad for thread safety.
3802 * Despite being a "constant", the SV is written to,
3803 * for reference counts, sv_upgrade() etc. */
3804 PERL_STATIC_INLINE void
3805 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3808 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3810 ix = pad_alloc(OP_CONST, SVf_READONLY);
3811 SvREFCNT_dec(PAD_SVl(ix));
3812 PAD_SETSV(ix, *svp);
3813 /* XXX I don't know how this isn't readonly already. */
3814 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3821 =for apidoc traverse_op_tree
3823 Return the next op in a depth-first traversal of the op tree,
3824 returning NULL when the traversal is complete.
3826 The initial call must supply the root of the tree as both top and o.
3828 For now it's static, but it may be exposed to the API in the future.
3834 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3837 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3839 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3840 return cUNOPo->op_first;
3842 else if ((sib = OpSIBLING(o))) {
3846 OP *parent = o->op_sibparent;
3847 assert(!(o->op_moresib));
3848 while (parent && parent != top) {
3849 OP *sib = OpSIBLING(parent);
3852 parent = parent->op_sibparent;
3860 S_finalize_op(pTHX_ OP* o)
3863 PERL_ARGS_ASSERT_FINALIZE_OP;
3866 assert(o->op_type != OP_FREED);
3868 switch (o->op_type) {
3871 PL_curcop = ((COP*)o); /* for warnings */
3874 if (OpHAS_SIBLING(o)) {
3875 OP *sib = OpSIBLING(o);
3876 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3877 && ckWARN(WARN_EXEC)
3878 && OpHAS_SIBLING(sib))
3880 const OPCODE type = OpSIBLING(sib)->op_type;
3881 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3882 const line_t oldline = CopLINE(PL_curcop);
3883 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3884 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3885 "Statement unlikely to be reached");
3886 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3887 "\t(Maybe you meant system() when you said exec()?)\n");
3888 CopLINE_set(PL_curcop, oldline);
3895 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3896 GV * const gv = cGVOPo_gv;
3897 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3898 /* XXX could check prototype here instead of just carping */
3899 SV * const sv = sv_newmortal();
3900 gv_efullname3(sv, gv, NULL);
3901 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3902 "%" SVf "() called too early to check prototype",
3909 if (cSVOPo->op_private & OPpCONST_STRICT)
3910 no_bareword_allowed(o);
3914 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3919 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3920 case OP_METHOD_NAMED:
3921 case OP_METHOD_SUPER:
3922 case OP_METHOD_REDIR:
3923 case OP_METHOD_REDIR_SUPER:
3924 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3933 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3936 rop = (UNOP*)((BINOP*)o)->op_first;
3941 S_scalar_slice_warning(aTHX_ o);
3945 kid = OpSIBLING(cLISTOPo->op_first);
3946 if (/* I bet there's always a pushmark... */
3947 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3948 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3953 key_op = (SVOP*)(kid->op_type == OP_CONST
3955 : OpSIBLING(kLISTOP->op_first));
3957 rop = (UNOP*)((LISTOP*)o)->op_last;
3960 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3962 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3966 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3970 S_scalar_slice_warning(aTHX_ o);
3974 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3975 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3983 if (o->op_flags & OPf_KIDS) {
3986 /* check that op_last points to the last sibling, and that
3987 * the last op_sibling/op_sibparent field points back to the
3988 * parent, and that the only ops with KIDS are those which are
3989 * entitled to them */
3990 U32 type = o->op_type;
3994 if (type == OP_NULL) {
3996 /* ck_glob creates a null UNOP with ex-type GLOB
3997 * (which is a list op. So pretend it wasn't a listop */
3998 if (type == OP_GLOB)
4001 family = PL_opargs[type] & OA_CLASS_MASK;
4003 has_last = ( family == OA_BINOP
4004 || family == OA_LISTOP
4005 || family == OA_PMOP
4006 || family == OA_LOOP
4008 assert( has_last /* has op_first and op_last, or ...
4009 ... has (or may have) op_first: */
4010 || family == OA_UNOP
4011 || family == OA_UNOP_AUX
4012 || family == OA_LOGOP
4013 || family == OA_BASEOP_OR_UNOP
4014 || family == OA_FILESTATOP
4015 || family == OA_LOOPEXOP
4016 || family == OA_METHOP
4017 || type == OP_CUSTOM
4018 || type == OP_NULL /* new_logop does this */
4021 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
4022 if (!OpHAS_SIBLING(kid)) {
4024 assert(kid == cLISTOPo->op_last);
4025 assert(kid->op_sibparent == o);
4030 } while (( o = traverse_op_tree(top, o)) != NULL);
4034 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
4037 PadnameLVALUE_on(pn);
4038 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
4040 /* RT #127786: cv can be NULL due to an eval within the DB package
4041 * called from an anon sub - anon subs don't have CvOUTSIDE() set
4042 * unless they contain an eval, but calling eval within DB
4043 * pretends the eval was done in the caller's scope.
4047 assert(CvPADLIST(cv));
4049 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
4050 assert(PadnameLEN(pn));
4051 PadnameLVALUE_on(pn);
4056 S_vivifies(const OPCODE type)
4059 case OP_RV2AV: case OP_ASLICE:
4060 case OP_RV2HV: case OP_KVASLICE:
4061 case OP_RV2SV: case OP_HSLICE:
4062 case OP_AELEMFAST: case OP_KVHSLICE:
4071 /* apply lvalue reference (aliasing) context to the optree o.
4074 * o would be the list ($x,$y) and type would be OP_AASSIGN.
4075 * It may descend and apply this to children too, for example in
4076 * \( $cond ? $x, $y) = (...)
4080 S_lvref(pTHX_ OP *o, I32 type)
4087 switch (o->op_type) {
4089 o = OpSIBLING(cUNOPo->op_first);
4096 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4097 o->op_flags |= OPf_STACKED;
4098 if (o->op_flags & OPf_PARENS) {
4099 if (o->op_private & OPpLVAL_INTRO) {
4100 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4101 "localized parenthesized array in list assignment"));
4105 OpTYPE_set(o, OP_LVAVREF);
4106 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4107 o->op_flags |= OPf_MOD|OPf_REF;
4110 o->op_private |= OPpLVREF_AV;
4114 kid = cUNOPo->op_first;
4115 if (kid->op_type == OP_NULL)
4116 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4118 o->op_private = OPpLVREF_CV;
4119 if (kid->op_type == OP_GV)
4120 o->op_flags |= OPf_STACKED;
4121 else if (kid->op_type == OP_PADCV) {
4122 o->op_targ = kid->op_targ;
4124 op_free(cUNOPo->op_first);
4125 cUNOPo->op_first = NULL;
4126 o->op_flags &=~ OPf_KIDS;
4132 if (o->op_flags & OPf_PARENS) {
4134 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4135 "parenthesized hash in list assignment"));
4138 o->op_private |= OPpLVREF_HV;
4142 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4143 o->op_flags |= OPf_STACKED;
4147 if (o->op_flags & OPf_PARENS) goto parenhash;
4148 o->op_private |= OPpLVREF_HV;
4151 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4155 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4156 if (o->op_flags & OPf_PARENS) goto slurpy;
4157 o->op_private |= OPpLVREF_AV;
4162 o->op_private |= OPpLVREF_ELEM;
4163 o->op_flags |= OPf_STACKED;
4168 OpTYPE_set(o, OP_LVREFSLICE);
4169 o->op_private &= OPpLVAL_INTRO;
4173 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4175 else if (!(o->op_flags & OPf_KIDS))
4178 /* the code formerly only recursed into the first child of
4179 * a non ex-list OP_NULL. if we ever encounter such a null op with
4180 * more than one child, need to decide whether its ok to process
4181 * *all* its kids or not */
4182 assert(o->op_targ == OP_LIST
4183 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4186 o = cLISTOPo->op_first;
4190 if (o->op_flags & OPf_PARENS)
4195 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4196 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4197 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4204 OpTYPE_set(o, OP_LVREF);
4206 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4207 if (type == OP_ENTERLOOP)
4208 o->op_private |= OPpLVREF_ITER;
4213 return; /* at top; no parents/siblings to try */
4214 if (OpHAS_SIBLING(o)) {
4215 o = o->op_sibparent;
4218 o = o->op_sibparent; /*try parent's next sibling */
4224 PERL_STATIC_INLINE bool
4225 S_potential_mod_type(I32 type)
4227 /* Types that only potentially result in modification. */
4228 return type == OP_GREPSTART || type == OP_ENTERSUB
4229 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4234 =for apidoc op_lvalue
4236 Propagate lvalue ("modifiable") context to an op and its children.
4237 C<type> represents the context type, roughly based on the type of op that
4238 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4239 because it has no op type of its own (it is signalled by a flag on
4242 This function detects things that can't be modified, such as C<$x+1>, and
4243 generates errors for them. For example, C<$x+1 = 2> would cause it to be
4244 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4246 It also flags things that need to behave specially in an lvalue context,
4247 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4251 Perl_op_lvalue_flags() is a non-API lower-level interface to
4252 op_lvalue(). The flags param has these bits:
4253 OP_LVALUE_NO_CROAK: return rather than croaking on error
4258 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4263 if (!o || (PL_parser && PL_parser->error_count))
4268 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4270 OP *next_kid = NULL;
4272 if ((o->op_private & OPpTARGET_MY)
4273 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4278 /* elements of a list might be in void context because the list is
4279 in scalar context or because they are attribute sub calls */
4280 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4283 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4285 switch (o->op_type) {
4291 if ((o->op_flags & OPf_PARENS))
4296 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4297 !(o->op_flags & OPf_STACKED)) {
4298 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4299 assert(cUNOPo->op_first->op_type == OP_NULL);
4300 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4303 else { /* lvalue subroutine call */
4304 o->op_private |= OPpLVAL_INTRO;
4305 PL_modcount = RETURN_UNLIMITED_NUMBER;
4306 if (S_potential_mod_type(type)) {
4307 o->op_private |= OPpENTERSUB_INARGS;
4310 else { /* Compile-time error message: */
4311 OP *kid = cUNOPo->op_first;
4316 if (kid->op_type != OP_PUSHMARK) {
4317 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4319 "panic: unexpected lvalue entersub "
4320 "args: type/targ %ld:%" UVuf,
4321 (long)kid->op_type, (UV)kid->op_targ);
4322 kid = kLISTOP->op_first;
4324 while (OpHAS_SIBLING(kid))
4325 kid = OpSIBLING(kid);
4326 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4327 break; /* Postpone until runtime */
4330 kid = kUNOP->op_first;
4331 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4332 kid = kUNOP->op_first;
4333 if (kid->op_type == OP_NULL)
4335 "Unexpected constant lvalue entersub "
4336 "entry via type/targ %ld:%" UVuf,
4337 (long)kid->op_type, (UV)kid->op_targ);
4338 if (kid->op_type != OP_GV) {
4345 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4346 ? MUTABLE_CV(SvRV(gv))
4352 if (flags & OP_LVALUE_NO_CROAK)
4355 namesv = cv_name(cv, NULL, 0);
4356 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4357 "subroutine call of &%" SVf " in %s",
4358 SVfARG(namesv), PL_op_desc[type]),
4366 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4367 /* grep, foreach, subcalls, refgen */
4368 if (S_potential_mod_type(type))
4370 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4371 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4374 type ? PL_op_desc[type] : "local"));
4387 case OP_RIGHT_SHIFT:
4396 if (!(o->op_flags & OPf_STACKED))
4402 if (o->op_flags & OPf_STACKED) {
4406 if (!(o->op_private & OPpREPEAT_DOLIST))
4409 const I32 mods = PL_modcount;
4410 /* we recurse rather than iterate here because we need to
4411 * calculate and use the delta applied to PL_modcount by the
4412 * first child. So in something like
4413 * ($x, ($y) x 3) = split;
4414 * split knows that 4 elements are wanted
4416 modkids(cBINOPo->op_first, type);
4417 if (type != OP_AASSIGN)
4419 kid = cBINOPo->op_last;
4420 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4421 const IV iv = SvIV(kSVOP_sv);
4422 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4424 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4427 PL_modcount = RETURN_UNLIMITED_NUMBER;
4433 next_kid = OpSIBLING(cUNOPo->op_first);
4438 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4439 PL_modcount = RETURN_UNLIMITED_NUMBER;
4440 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4441 fiable since some contexts need to know. */
4442 o->op_flags |= OPf_MOD;
4447 if (scalar_mod_type(o, type))
4449 ref(cUNOPo->op_first, o->op_type);
4456 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4457 if (type == OP_LEAVESUBLV && (
4458 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4459 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4461 o->op_private |= OPpMAYBE_LVSUB;
4465 PL_modcount = RETURN_UNLIMITED_NUMBER;
4471 if (type == OP_LEAVESUBLV)
4472 o->op_private |= OPpMAYBE_LVSUB;
4476 if (type == OP_LEAVESUBLV
4477 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4478 o->op_private |= OPpMAYBE_LVSUB;
4482 PL_hints |= HINT_BLOCK_SCOPE;
4483 if (type == OP_LEAVESUBLV)
4484 o->op_private |= OPpMAYBE_LVSUB;
4489 ref(cUNOPo->op_first, o->op_type);
4493 PL_hints |= HINT_BLOCK_SCOPE;
4503 case OP_AELEMFAST_LEX:
4510 PL_modcount = RETURN_UNLIMITED_NUMBER;
4511 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4513 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4514 fiable since some contexts need to know. */
4515 o->op_flags |= OPf_MOD;
4518 if (scalar_mod_type(o, type))
4520 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4521 && type == OP_LEAVESUBLV)
4522 o->op_private |= OPpMAYBE_LVSUB;
4526 if (!type) /* local() */
4527 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4528 PNfARG(PAD_COMPNAME(o->op_targ)));
4529 if (!(o->op_private & OPpLVAL_INTRO)
4530 || ( type != OP_SASSIGN && type != OP_AASSIGN
4531 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4532 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4540 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4544 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4550 if (type == OP_LEAVESUBLV)
4551 o->op_private |= OPpMAYBE_LVSUB;
4552 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4553 /* we recurse rather than iterate here because the child
4554 * needs to be processed with a different 'type' parameter */
4556 /* substr and vec */
4557 /* If this op is in merely potential (non-fatal) modifiable
4558 context, then apply OP_ENTERSUB context to
4559 the kid op (to avoid croaking). Other-
4560 wise pass this op’s own type so the correct op is mentioned
4561 in error messages. */
4562 op_lvalue(OpSIBLING(cBINOPo->op_first),
4563 S_potential_mod_type(type)
4571 ref(cBINOPo->op_first, o->op_type);
4572 if (type == OP_ENTERSUB &&
4573 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4574 o->op_private |= OPpLVAL_DEFER;
4575 if (type == OP_LEAVESUBLV)
4576 o->op_private |= OPpMAYBE_LVSUB;
4583 o->op_private |= OPpLVALUE;
4589 if (o->op_flags & OPf_KIDS)
4590 next_kid = cLISTOPo->op_last;
4595 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4597 else if (!(o->op_flags & OPf_KIDS))
4600 if (o->op_targ != OP_LIST) {
4601 OP *sib = OpSIBLING(cLISTOPo->op_first);
4602 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4609 * compared with things like OP_MATCH which have the argument
4615 * so handle specially to correctly get "Can't modify" croaks etc
4618 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4620 /* this should trigger a "Can't modify transliteration" err */
4621 op_lvalue(sib, type);
4623 next_kid = cBINOPo->op_first;
4624 /* we assume OP_NULLs which aren't ex-list have no more than 2
4625 * children. If this assumption is wrong, increase the scan
4627 assert( !OpHAS_SIBLING(next_kid)
4628 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4634 next_kid = cLISTOPo->op_first;
4642 if (type == OP_LEAVESUBLV
4643 || !S_vivifies(cLOGOPo->op_first->op_type))
4644 next_kid = cLOGOPo->op_first;
4645 else if (type == OP_LEAVESUBLV
4646 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4647 next_kid = OpSIBLING(cLOGOPo->op_first);
4651 if (type == OP_NULL) { /* local */
4653 if (!FEATURE_MYREF_IS_ENABLED)
4654 Perl_croak(aTHX_ "The experimental declared_refs "
4655 "feature is not enabled");
4656 Perl_ck_warner_d(aTHX_
4657 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4658 "Declaring references is experimental");
4659 next_kid = cUNOPo->op_first;
4662 if (type != OP_AASSIGN && type != OP_SASSIGN
4663 && type != OP_ENTERLOOP)
4665 /* Don’t bother applying lvalue context to the ex-list. */
4666 kid = cUNOPx(cUNOPo->op_first)->op_first;
4667 assert (!OpHAS_SIBLING(kid));
4670 if (type == OP_NULL) /* local */
4672 if (type != OP_AASSIGN) goto nomod;
4673 kid = cUNOPo->op_first;
4676 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4677 S_lvref(aTHX_ kid, type);
4678 if (!PL_parser || PL_parser->error_count == ec) {
4679 if (!FEATURE_REFALIASING_IS_ENABLED)
4681 "Experimental aliasing via reference not enabled");
4682 Perl_ck_warner_d(aTHX_
4683 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4684 "Aliasing via reference is experimental");
4687 if (o->op_type == OP_REFGEN)
4688 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4693 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4694 /* This is actually @array = split. */
4695 PL_modcount = RETURN_UNLIMITED_NUMBER;
4701 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4705 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4706 their argument is a filehandle; thus \stat(".") should not set
4708 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4711 if (type != OP_LEAVESUBLV)
4712 o->op_flags |= OPf_MOD;
4714 if (type == OP_AASSIGN || type == OP_SASSIGN)
4715 o->op_flags |= OPf_SPECIAL
4716 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4717 else if (!type) { /* local() */
4720 o->op_private |= OPpLVAL_INTRO;
4721 o->op_flags &= ~OPf_SPECIAL;
4722 PL_hints |= HINT_BLOCK_SCOPE;
4727 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4728 "Useless localization of %s", OP_DESC(o));
4731 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4732 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4733 o->op_flags |= OPf_REF;
4738 return top_op; /* at top; no parents/siblings to try */
4739 if (OpHAS_SIBLING(o)) {
4740 next_kid = o->op_sibparent;
4741 if (!OpHAS_SIBLING(next_kid)) {
4742 /* a few node types don't recurse into their second child */
4743 OP *parent = next_kid->op_sibparent;
4744 I32 ptype = parent->op_type;
4745 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
4746 || ( (ptype == OP_AND || ptype == OP_OR)
4747 && (type != OP_LEAVESUBLV
4748 && S_vivifies(next_kid->op_type))
4751 /*try parent's next sibling */
4758 o = o->op_sibparent; /*try parent's next sibling */
4769 S_scalar_mod_type(const OP *o, I32 type)
4774 if (o && o->op_type == OP_RV2GV)
4798 case OP_RIGHT_SHIFT:
4827 S_is_handle_constructor(const OP *o, I32 numargs)
4829 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4831 switch (o->op_type) {
4839 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4852 S_refkids(pTHX_ OP *o, I32 type)
4854 if (o && o->op_flags & OPf_KIDS) {
4856 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4863 /* Apply reference (autovivification) context to the subtree at o.
4865 * push @{expression}, ....;
4866 * o will be the head of 'expression' and type will be OP_RV2AV.
4867 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4869 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4870 * set_op_ref is true.
4872 * Also calls scalar(o).
4876 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4881 PERL_ARGS_ASSERT_DOREF;
4883 if (PL_parser && PL_parser->error_count)
4887 switch (o->op_type) {
4889 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4890 !(o->op_flags & OPf_STACKED)) {
4891 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4892 assert(cUNOPo->op_first->op_type == OP_NULL);
4893 /* disable pushmark */
4894 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4895 o->op_flags |= OPf_SPECIAL;
4897 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4898 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4899 : type == OP_RV2HV ? OPpDEREF_HV
4901 o->op_flags |= OPf_MOD;
4907 o = OpSIBLING(cUNOPo->op_first);
4911 if (type == OP_DEFINED)
4912 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4915 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4916 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4917 : type == OP_RV2HV ? OPpDEREF_HV
4919 o->op_flags |= OPf_MOD;
4921 if (o->op_flags & OPf_KIDS) {
4923 o = cUNOPo->op_first;
4931 o->op_flags |= OPf_REF;
4934 if (type == OP_DEFINED)
4935 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4937 o = cUNOPo->op_first;
4943 o->op_flags |= OPf_REF;
4948 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4950 o = cBINOPo->op_first;
4955 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4956 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4957 : type == OP_RV2HV ? OPpDEREF_HV
4959 o->op_flags |= OPf_MOD;
4962 o = cBINOPo->op_first;
4971 if (!(o->op_flags & OPf_KIDS))
4973 o = cLISTOPo->op_last;
4982 return scalar(top_op); /* at top; no parents/siblings to try */
4983 if (OpHAS_SIBLING(o)) {
4984 o = o->op_sibparent;
4985 /* Normally skip all siblings and go straight to the parent;
4986 * the only op that requires two children to be processed
4987 * is OP_COND_EXPR */
4988 if (!OpHAS_SIBLING(o)
4989 && o->op_sibparent->op_type == OP_COND_EXPR)
4993 o = o->op_sibparent; /*try parent's next sibling */
5000 S_dup_attrlist(pTHX_ OP *o)
5004 PERL_ARGS_ASSERT_DUP_ATTRLIST;
5006 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
5007 * where the first kid is OP_PUSHMARK and the remaining ones
5008 * are OP_CONST. We need to push the OP_CONST values.
5010 if (o->op_type == OP_CONST)
5011 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
5013 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5015 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
5016 if (o->op_type == OP_CONST)
5017 rop = op_append_elem(OP_LIST, rop,
5018 newSVOP(OP_CONST, o->op_flags,
5019 SvREFCNT_inc_NN(cSVOPo->op_sv)));
5026 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
5028 PERL_ARGS_ASSERT_APPLY_ATTRS;
5030 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
5032 /* fake up C<use attributes $pkg,$rv,@attrs> */
5034 #define ATTRSMODULE "attributes"
5035 #define ATTRSMODULE_PM "attributes.pm"
5038 aTHX_ PERL_LOADMOD_IMPORT_OPS,
5039 newSVpvs(ATTRSMODULE),
5041 op_prepend_elem(OP_LIST,
5042 newSVOP(OP_CONST, 0, stashsv),
5043 op_prepend_elem(OP_LIST,
5044 newSVOP(OP_CONST, 0,
5046 dup_attrlist(attrs))));
5051 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
5053 OP *pack, *imop, *arg;
5054 SV *meth, *stashsv, **svp;
5056 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
5061 assert(target->op_type == OP_PADSV ||
5062 target->op_type == OP_PADHV ||
5063 target->op_type == OP_PADAV);
5065 /* Ensure that attributes.pm is loaded. */
5066 /* Don't force the C<use> if we don't need it. */
5067 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
5068 if (svp && *svp != &PL_sv_undef)
5069 NOOP; /* already in %INC */
5071 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5072 newSVpvs(ATTRSMODULE), NULL);
5074 /* Need package name for method call. */
5075 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
5077 /* Build up the real arg-list. */
5078 stashsv = newSVhek(HvNAME_HEK(stash));
5080 arg = newOP(OP_PADSV, 0);
5081 arg->op_targ = target->op_targ;
5082 arg = op_prepend_elem(OP_LIST,
5083 newSVOP(OP_CONST, 0, stashsv),
5084 op_prepend_elem(OP_LIST,
5085 newUNOP(OP_REFGEN, 0,
5087 dup_attrlist(attrs)));
5089 /* Fake up a method call to import */
5090 meth = newSVpvs_share("import");
5091 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
5092 op_append_elem(OP_LIST,
5093 op_prepend_elem(OP_LIST, pack, arg),
5094 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5096 /* Combine the ops. */
5097 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
5101 =notfor apidoc apply_attrs_string
5103 Attempts to apply a list of attributes specified by the C<attrstr> and
5104 C<len> arguments to the subroutine identified by the C<cv> argument which
5105 is expected to be associated with the package identified by the C<stashpv>
5106 argument (see L<attributes>). It gets this wrong, though, in that it
5107 does not correctly identify the boundaries of the individual attribute
5108 specifications within C<attrstr>. This is not really intended for the
5109 public API, but has to be listed here for systems such as AIX which
5110 need an explicit export list for symbols. (It's called from XS code
5111 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
5112 to respect attribute syntax properly would be welcome.
5118 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
5119 const char *attrstr, STRLEN len)
5123 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
5126 len = strlen(attrstr);
5130 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
5132 const char * const sstr = attrstr;
5133 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
5134 attrs = op_append_elem(OP_LIST, attrs,
5135 newSVOP(OP_CONST, 0,
5136 newSVpvn(sstr, attrstr-sstr)));
5140 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5141 newSVpvs(ATTRSMODULE),
5142 NULL, op_prepend_elem(OP_LIST,
5143 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5144 op_prepend_elem(OP_LIST,
5145 newSVOP(OP_CONST, 0,
5146 newRV(MUTABLE_SV(cv))),
5151 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5154 OP *new_proto = NULL;
5159 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5165 if (o->op_type == OP_CONST) {
5166 pv = SvPV(cSVOPo_sv, pvlen);
5167 if (memBEGINs(pv, pvlen, "prototype(")) {
5168 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5169 SV ** const tmpo = cSVOPx_svp(o);
5170 SvREFCNT_dec(cSVOPo_sv);
5175 } else if (o->op_type == OP_LIST) {
5177 assert(o->op_flags & OPf_KIDS);
5178 lasto = cLISTOPo->op_first;
5179 assert(lasto->op_type == OP_PUSHMARK);
5180 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5181 if (o->op_type == OP_CONST) {
5182 pv = SvPV(cSVOPo_sv, pvlen);
5183 if (memBEGINs(pv, pvlen, "prototype(")) {
5184 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5185 SV ** const tmpo = cSVOPx_svp(o);
5186 SvREFCNT_dec(cSVOPo_sv);
5188 if (new_proto && ckWARN(WARN_MISC)) {
5190 const char * newp = SvPV(cSVOPo_sv, new_len);
5191 Perl_warner(aTHX_ packWARN(WARN_MISC),
5192 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5193 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5199 /* excise new_proto from the list */
5200 op_sibling_splice(*attrs, lasto, 1, NULL);
5207 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5208 would get pulled in with no real need */
5209 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5218 svname = sv_newmortal();
5219 gv_efullname3(svname, name, NULL);
5221 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5222 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5224 svname = (SV *)name;
5225 if (ckWARN(WARN_ILLEGALPROTO))
5226 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5228 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5229 STRLEN old_len, new_len;
5230 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5231 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5233 if (curstash && svname == (SV *)name
5234 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5235 svname = sv_2mortal(newSVsv(PL_curstname));
5236 sv_catpvs(svname, "::");
5237 sv_catsv(svname, (SV *)name);
5240 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5241 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5243 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5244 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5254 S_cant_declare(pTHX_ OP *o)
5256 if (o->op_type == OP_NULL
5257 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5258 o = cUNOPo->op_first;
5259 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5260 o->op_type == OP_NULL
5261 && o->op_flags & OPf_SPECIAL
5264 PL_parser->in_my == KEY_our ? "our" :
5265 PL_parser->in_my == KEY_state ? "state" :
5270 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5273 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5275 PERL_ARGS_ASSERT_MY_KID;
5277 if (!o || (PL_parser && PL_parser->error_count))
5282 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5284 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5285 my_kid(kid, attrs, imopsp);
5287 } else if (type == OP_UNDEF || type == OP_STUB) {
5289 } else if (type == OP_RV2SV || /* "our" declaration */
5292 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5293 S_cant_declare(aTHX_ o);
5295 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5297 PL_parser->in_my = FALSE;
5298 PL_parser->in_my_stash = NULL;
5299 apply_attrs(GvSTASH(gv),
5300 (type == OP_RV2SV ? GvSVn(gv) :
5301 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5302 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5305 o->op_private |= OPpOUR_INTRO;
5308 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5309 if (!FEATURE_MYREF_IS_ENABLED)
5310 Perl_croak(aTHX_ "The experimental declared_refs "
5311 "feature is not enabled");
5312 Perl_ck_warner_d(aTHX_
5313 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5314 "Declaring references is experimental");
5315 /* Kid is a nulled OP_LIST, handled above. */
5316 my_kid(cUNOPo->op_first, attrs, imopsp);
5319 else if (type != OP_PADSV &&
5322 type != OP_PUSHMARK)
5324 S_cant_declare(aTHX_ o);
5327 else if (attrs && type != OP_PUSHMARK) {
5331 PL_parser->in_my = FALSE;
5332 PL_parser->in_my_stash = NULL;
5334 /* check for C<my Dog $spot> when deciding package */
5335 stash = PAD_COMPNAME_TYPE(o->op_targ);
5337 stash = PL_curstash;
5338 apply_attrs_my(stash, o, attrs, imopsp);
5340 o->op_flags |= OPf_MOD;
5341 o->op_private |= OPpLVAL_INTRO;
5343 o->op_private |= OPpPAD_STATE;
5348 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5351 int maybe_scalar = 0;
5353 PERL_ARGS_ASSERT_MY_ATTRS;
5355 /* [perl #17376]: this appears to be premature, and results in code such as
5356 C< our(%x); > executing in list mode rather than void mode */
5358 if (o->op_flags & OPf_PARENS)
5368 o = my_kid(o, attrs, &rops);
5370 if (maybe_scalar && o->op_type == OP_PADSV) {
5371 o = scalar(op_append_list(OP_LIST, rops, o));
5372 o->op_private |= OPpLVAL_INTRO;
5375 /* The listop in rops might have a pushmark at the beginning,
5376 which will mess up list assignment. */
5377 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5378 if (rops->op_type == OP_LIST &&
5379 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5381 OP * const pushmark = lrops->op_first;
5382 /* excise pushmark */
5383 op_sibling_splice(rops, NULL, 1, NULL);
5386 o = op_append_list(OP_LIST, o, rops);
5389 PL_parser->in_my = FALSE;
5390 PL_parser->in_my_stash = NULL;
5395 Perl_sawparens(pTHX_ OP *o)
5397 PERL_UNUSED_CONTEXT;
5399 o->op_flags |= OPf_PARENS;
5404 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5408 const OPCODE ltype = left->op_type;
5409 const OPCODE rtype = right->op_type;
5411 PERL_ARGS_ASSERT_BIND_MATCH;
5413 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5414 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5416 const char * const desc
5418 rtype == OP_SUBST || rtype == OP_TRANS
5419 || rtype == OP_TRANSR
5421 ? (int)rtype : OP_MATCH];
5422 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5424 S_op_varname(aTHX_ left);
5426 Perl_warner(aTHX_ packWARN(WARN_MISC),
5427 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5428 desc, SVfARG(name), SVfARG(name));
5430 const char * const sample = (isary
5431 ? "@array" : "%hash");
5432 Perl_warner(aTHX_ packWARN(WARN_MISC),
5433 "Applying %s to %s will act on scalar(%s)",
5434 desc, sample, sample);
5438 if (rtype == OP_CONST &&
5439 cSVOPx(right)->op_private & OPpCONST_BARE &&
5440 cSVOPx(right)->op_private & OPpCONST_STRICT)
5442 no_bareword_allowed(right);
5445 /* !~ doesn't make sense with /r, so error on it for now */
5446 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5448 /* diag_listed_as: Using !~ with %s doesn't make sense */
5449 yyerror("Using !~ with s///r doesn't make sense");
5450 if (rtype == OP_TRANSR && type == OP_NOT)
5451 /* diag_listed_as: Using !~ with %s doesn't make sense */
5452 yyerror("Using !~ with tr///r doesn't make sense");
5454 ismatchop = (rtype == OP_MATCH ||
5455 rtype == OP_SUBST ||
5456 rtype == OP_TRANS || rtype == OP_TRANSR)
5457 && !(right->op_flags & OPf_SPECIAL);
5458 if (ismatchop && right->op_private & OPpTARGET_MY) {
5460 right->op_private &= ~OPpTARGET_MY;
5462 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5463 if (left->op_type == OP_PADSV
5464 && !(left->op_private & OPpLVAL_INTRO))
5466 right->op_targ = left->op_targ;
5471 right->op_flags |= OPf_STACKED;
5472 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5473 ! (rtype == OP_TRANS &&
5474 right->op_private & OPpTRANS_IDENTICAL) &&
5475 ! (rtype == OP_SUBST &&
5476 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5477 left = op_lvalue(left, rtype);
5478 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5479 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5481 o = op_prepend_elem(rtype, scalar(left), right);
5484 return newUNOP(OP_NOT, 0, scalar(o));
5488 return bind_match(type, left,
5489 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5493 Perl_invert(pTHX_ OP *o)
5497 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5501 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
5508 left = newOP(OP_NULL, 0);
5510 right = newOP(OP_NULL, 0);
5513 NewOp(0, bop, 1, BINOP);
5515 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5516 OpTYPE_set(op, type);
5517 cBINOPx(op)->op_flags = OPf_KIDS;
5518 cBINOPx(op)->op_private = 2;
5519 cBINOPx(op)->op_first = left;
5520 cBINOPx(op)->op_last = right;
5521 OpMORESIB_set(left, right);
5522 OpLASTSIB_set(right, op);
5527 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
5533 PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
5535 right = newOP(OP_NULL, 0);
5537 NewOp(0, bop, 1, BINOP);
5539 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5540 OpTYPE_set(op, type);
5541 if (ch->op_type != OP_NULL) {
5543 OP *nch, *cleft, *cright;
5544 NewOp(0, lch, 1, UNOP);
5546 OpTYPE_set(nch, OP_NULL);
5547 nch->op_flags = OPf_KIDS;
5548 cleft = cBINOPx(ch)->op_first;
5549 cright = cBINOPx(ch)->op_last;
5550 cBINOPx(ch)->op_first = NULL;
5551 cBINOPx(ch)->op_last = NULL;
5552 cBINOPx(ch)->op_private = 0;
5553 cBINOPx(ch)->op_flags = 0;
5554 cUNOPx(nch)->op_first = cright;
5555 OpMORESIB_set(cright, ch);
5556 OpMORESIB_set(ch, cleft);
5557 OpLASTSIB_set(cleft, nch);
5560 OpMORESIB_set(right, op);
5561 OpMORESIB_set(op, cUNOPx(ch)->op_first);
5562 cUNOPx(ch)->op_first = right;
5567 Perl_cmpchain_finish(pTHX_ OP *ch)
5571 PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
5572 if (ch->op_type != OP_NULL) {
5573 OPCODE cmpoptype = ch->op_type;
5574 ch = CHECKOP(cmpoptype, ch);
5575 if(!ch->op_next && ch->op_type == cmpoptype)
5576 ch = fold_constants(op_integerize(op_std_init(ch)));
5580 OP *rightarg = cUNOPx(ch)->op_first;
5581 cUNOPx(ch)->op_first = OpSIBLING(rightarg);
5582 OpLASTSIB_set(rightarg, NULL);
5584 OP *cmpop = cUNOPx(ch)->op_first;
5585 OP *leftarg = OpSIBLING(cmpop);
5586 OPCODE cmpoptype = cmpop->op_type;
5589 is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
5590 OpLASTSIB_set(cmpop, NULL);
5591 OpLASTSIB_set(leftarg, NULL);
5595 nextrightarg = NULL;
5597 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
5598 leftarg = newOP(OP_NULL, 0);
5600 cBINOPx(cmpop)->op_first = leftarg;
5601 cBINOPx(cmpop)->op_last = rightarg;
5602 OpMORESIB_set(leftarg, rightarg);
5603 OpLASTSIB_set(rightarg, cmpop);
5604 cmpop->op_flags = OPf_KIDS;
5605 cmpop->op_private = 2;
5606 cmpop = CHECKOP(cmpoptype, cmpop);
5607 if(!cmpop->op_next && cmpop->op_type == cmpoptype)
5608 cmpop = fold_constants(op_integerize(op_std_init(cmpop)));
5609 condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
5613 rightarg = nextrightarg;
5619 =for apidoc op_scope
5621 Wraps up an op tree with some additional ops so that at runtime a dynamic
5622 scope will be created. The original ops run in the new dynamic scope,
5623 and then, provided that they exit normally, the scope will be unwound.
5624 The additional ops used to create and unwind the dynamic scope will
5625 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5626 instead if the ops are simple enough to not need the full dynamic scope
5633 Perl_op_scope(pTHX_ OP *o)
5637 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5638 o = op_prepend_elem(OP_LINESEQ,
5639 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
5640 OpTYPE_set(o, OP_LEAVE);
5642 else if (o->op_type == OP_LINESEQ) {
5644 OpTYPE_set(o, OP_SCOPE);
5645 kid = ((LISTOP*)o)->op_first;
5646 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5649 /* The following deals with things like 'do {1 for 1}' */
5650 kid = OpSIBLING(kid);
5652 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5657 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5663 Perl_op_unscope(pTHX_ OP *o)
5665 if (o && o->op_type == OP_LINESEQ) {
5666 OP *kid = cLISTOPo->op_first;
5667 for(; kid; kid = OpSIBLING(kid))
5668 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5675 =for apidoc block_start
5677 Handles compile-time scope entry.
5678 Arranges for hints to be restored on block
5679 exit and also handles pad sequence numbers to make lexical variables scope
5680 right. Returns a savestack index for use with C<block_end>.
5686 Perl_block_start(pTHX_ int full)
5688 const int retval = PL_savestack_ix;
5690 PL_compiling.cop_seq = PL_cop_seqmax;
5692 pad_block_start(full);
5694 PL_hints &= ~HINT_BLOCK_SCOPE;
5695 SAVECOMPILEWARNINGS();
5696 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5697 SAVEI32(PL_compiling.cop_seq);
5698 PL_compiling.cop_seq = 0;
5700 CALL_BLOCK_HOOKS(bhk_start, full);
5706 =for apidoc block_end
5708 Handles compile-time scope exit. C<floor>
5709 is the savestack index returned by
5710 C<block_start>, and C<seq> is the body of the block. Returns the block,
5717 Perl_block_end(pTHX_ I32 floor, OP *seq)
5719 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5720 OP* retval = scalarseq(seq);
5723 /* XXX Is the null PL_parser check necessary here? */
5724 assert(PL_parser); /* Let’s find out under debugging builds. */
5725 if (PL_parser && PL_parser->parsed_sub) {
5726 o = newSTATEOP(0, NULL, NULL);
5728 retval = op_append_elem(OP_LINESEQ, retval, o);
5731 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5735 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5739 /* pad_leavemy has created a sequence of introcv ops for all my
5740 subs declared in the block. We have to replicate that list with
5741 clonecv ops, to deal with this situation:
5746 sub s1 { state sub foo { \&s2 } }
5749 Originally, I was going to have introcv clone the CV and turn
5750 off the stale flag. Since &s1 is declared before &s2, the
5751 introcv op for &s1 is executed (on sub entry) before the one for
5752 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5753 cloned, since it is a state sub) closes over &s2 and expects
5754 to see it in its outer CV’s pad. If the introcv op clones &s1,
5755 then &s2 is still marked stale. Since &s1 is not active, and
5756 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5757 ble will not stay shared’ warning. Because it is the same stub
5758 that will be used when the introcv op for &s2 is executed, clos-
5759 ing over it is safe. Hence, we have to turn off the stale flag
5760 on all lexical subs in the block before we clone any of them.
5761 Hence, having introcv clone the sub cannot work. So we create a
5762 list of ops like this:
5786 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5787 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5788 for (;; kid = OpSIBLING(kid)) {
5789 OP *newkid = newOP(OP_CLONECV, 0);
5790 newkid->op_targ = kid->op_targ;
5791 o = op_append_elem(OP_LINESEQ, o, newkid);
5792 if (kid == last) break;
5794 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5797 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5803 =head1 Compile-time scope hooks
5805 =for apidoc blockhook_register
5807 Register a set of hooks to be called when the Perl lexical scope changes
5808 at compile time. See L<perlguts/"Compile-time scope hooks">.
5814 Perl_blockhook_register(pTHX_ BHK *hk)
5816 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5818 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5822 Perl_newPROG(pTHX_ OP *o)
5826 PERL_ARGS_ASSERT_NEWPROG;
5833 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5834 ((PL_in_eval & EVAL_KEEPERR)
5835 ? OPf_SPECIAL : 0), o);
5838 assert(CxTYPE(cx) == CXt_EVAL);
5840 if ((cx->blk_gimme & G_WANT) == G_VOID)
5841 scalarvoid(PL_eval_root);
5842 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5845 scalar(PL_eval_root);
5847 start = op_linklist(PL_eval_root);
5848 PL_eval_root->op_next = 0;
5849 i = PL_savestack_ix;
5852 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5854 PL_savestack_ix = i;
5857 if (o->op_type == OP_STUB) {
5858 /* This block is entered if nothing is compiled for the main
5859 program. This will be the case for an genuinely empty main
5860 program, or one which only has BEGIN blocks etc, so already
5863 Historically (5.000) the guard above was !o. However, commit
5864 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5865 c71fccf11fde0068, changed perly.y so that newPROG() is now
5866 called with the output of block_end(), which returns a new
5867 OP_STUB for the case of an empty optree. ByteLoader (and
5868 maybe other things) also take this path, because they set up
5869 PL_main_start and PL_main_root directly, without generating an
5872 If the parsing the main program aborts (due to parse errors,
5873 or due to BEGIN or similar calling exit), then newPROG()
5874 isn't even called, and hence this code path and its cleanups
5875 are skipped. This shouldn't make a make a difference:
5876 * a non-zero return from perl_parse is a failure, and
5877 perl_destruct() should be called immediately.
5878 * however, if exit(0) is called during the parse, then
5879 perl_parse() returns 0, and perl_run() is called. As
5880 PL_main_start will be NULL, perl_run() will return
5881 promptly, and the exit code will remain 0.
5884 PL_comppad_name = 0;
5886 S_op_destroy(aTHX_ o);
5889 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5890 PL_curcop = &PL_compiling;
5891 start = LINKLIST(PL_main_root);
5892 PL_main_root->op_next = 0;
5893 S_process_optree(aTHX_ NULL, PL_main_root, start);
5894 if (!PL_parser->error_count)
5895 /* on error, leave CV slabbed so that ops left lying around
5896 * will eb cleaned up. Else unslab */
5897 cv_forget_slab(PL_compcv);
5900 /* Register with debugger */
5902 CV * const cv = get_cvs("DB::postponed", 0);
5906 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5908 call_sv(MUTABLE_SV(cv), G_DISCARD);
5915 Perl_localize(pTHX_ OP *o, I32 lex)
5917 PERL_ARGS_ASSERT_LOCALIZE;
5919 if (o->op_flags & OPf_PARENS)
5920 /* [perl #17376]: this appears to be premature, and results in code such as
5921 C< our(%x); > executing in list mode rather than void mode */
5928 if ( PL_parser->bufptr > PL_parser->oldbufptr
5929 && PL_parser->bufptr[-1] == ','
5930 && ckWARN(WARN_PARENTHESIS))
5932 char *s = PL_parser->bufptr;
5935 /* some heuristics to detect a potential error */
5936 while (*s && (memCHRs(", \t\n", *s)))
5940 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
5942 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5945 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5947 while (*s && (memCHRs(", \t\n", *s)))
5953 if (sigil && (*s == ';' || *s == '=')) {
5954 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5955 "Parentheses missing around \"%s\" list",
5957 ? (PL_parser->in_my == KEY_our
5959 : PL_parser->in_my == KEY_state
5969 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5970 PL_parser->in_my = FALSE;
5971 PL_parser->in_my_stash = NULL;
5976 Perl_jmaybe(pTHX_ OP *o)
5978 PERL_ARGS_ASSERT_JMAYBE;
5980 if (o->op_type == OP_LIST) {
5982 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5983 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5988 PERL_STATIC_INLINE OP *
5989 S_op_std_init(pTHX_ OP *o)
5991 I32 type = o->op_type;
5993 PERL_ARGS_ASSERT_OP_STD_INIT;
5995 if (PL_opargs[type] & OA_RETSCALAR)
5997 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5998 o->op_targ = pad_alloc(type, SVs_PADTMP);
6003 PERL_STATIC_INLINE OP *
6004 S_op_integerize(pTHX_ OP *o)
6006 I32 type = o->op_type;
6008 PERL_ARGS_ASSERT_OP_INTEGERIZE;
6010 /* integerize op. */
6011 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
6014 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
6017 if (type == OP_NEGATE)
6018 /* XXX might want a ck_negate() for this */
6019 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
6024 /* This function exists solely to provide a scope to limit
6025 setjmp/longjmp() messing with auto variables. It cannot be inlined because
6029 S_fold_constants_eval(pTHX) {
6045 S_fold_constants(pTHX_ OP *const o)
6050 I32 type = o->op_type;
6055 SV * const oldwarnhook = PL_warnhook;
6056 SV * const olddiehook = PL_diehook;
6058 U8 oldwarn = PL_dowarn;
6061 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
6063 if (!(PL_opargs[type] & OA_FOLDCONST))
6072 #ifdef USE_LOCALE_CTYPE
6073 if (IN_LC_COMPILETIME(LC_CTYPE))
6082 #ifdef USE_LOCALE_COLLATE
6083 if (IN_LC_COMPILETIME(LC_COLLATE))
6088 /* XXX what about the numeric ops? */
6089 #ifdef USE_LOCALE_NUMERIC
6090 if (IN_LC_COMPILETIME(LC_NUMERIC))
6095 if (!OpHAS_SIBLING(cLISTOPo->op_first)
6096 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
6099 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
6100 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
6102 const char *s = SvPVX_const(sv);
6103 while (s < SvEND(sv)) {
6104 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
6111 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
6114 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
6115 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
6119 if (PL_parser && PL_parser->error_count)
6120 goto nope; /* Don't try to run w/ errors */
6122 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
6123 switch (curop->op_type) {
6125 if ( (curop->op_private & OPpCONST_BARE)
6126 && (curop->op_private & OPpCONST_STRICT)) {
6127 no_bareword_allowed(curop);
6135 /* Foldable; move to next op in list */
6139 /* No other op types are considered foldable */
6144 curop = LINKLIST(o);
6145 old_next = o->op_next;
6149 old_cxix = cxstack_ix;
6150 create_eval_scope(NULL, G_FAKINGEVAL);
6152 /* Verify that we don't need to save it: */
6153 assert(PL_curcop == &PL_compiling);
6154 StructCopy(&PL_compiling, ¬_compiling, COP);
6155 PL_curcop = ¬_compiling;
6156 /* The above ensures that we run with all the correct hints of the
6157 currently compiling COP, but that IN_PERL_RUNTIME is true. */
6158 assert(IN_PERL_RUNTIME);
6159 PL_warnhook = PERL_WARNHOOK_FATAL;
6162 /* Effective $^W=1. */
6163 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6164 PL_dowarn |= G_WARN_ON;
6166 ret = S_fold_constants_eval(aTHX);
6170 sv = *(PL_stack_sp--);
6171 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
6172 pad_swipe(o->op_targ, FALSE);
6174 else if (SvTEMP(sv)) { /* grab mortal temp? */
6175 SvREFCNT_inc_simple_void(sv);
6178 else { assert(SvIMMORTAL(sv)); }
6181 /* Something tried to die. Abandon constant folding. */
6182 /* Pretend the error never happened. */
6184 o->op_next = old_next;
6187 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
6188 PL_warnhook = oldwarnhook;
6189 PL_diehook = olddiehook;
6190 /* XXX note that this croak may fail as we've already blown away
6191 * the stack - eg any nested evals */
6192 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6194 PL_dowarn = oldwarn;
6195 PL_warnhook = oldwarnhook;
6196 PL_diehook = olddiehook;
6197 PL_curcop = &PL_compiling;
6199 /* if we croaked, depending on how we croaked the eval scope
6200 * may or may not have already been popped */
6201 if (cxstack_ix > old_cxix) {
6202 assert(cxstack_ix == old_cxix + 1);
6203 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6204 delete_eval_scope();
6209 /* OP_STRINGIFY and constant folding are used to implement qq.
6210 Here the constant folding is an implementation detail that we
6211 want to hide. If the stringify op is itself already marked
6212 folded, however, then it is actually a folded join. */
6213 is_stringify = type == OP_STRINGIFY && !o->op_folded;
6218 else if (!SvIMMORTAL(sv)) {
6222 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6223 if (!is_stringify) newop->op_folded = 1;
6230 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6231 * the constant value being an AV holding the flattened range.
6235 S_gen_constant_list(pTHX_ OP *o)
6238 OP *curop, *old_next;
6239 SV * const oldwarnhook = PL_warnhook;
6240 SV * const olddiehook = PL_diehook;
6242 U8 oldwarn = PL_dowarn;
6252 if (PL_parser && PL_parser->error_count)
6253 return; /* Don't attempt to run with errors */
6255 curop = LINKLIST(o);
6256 old_next = o->op_next;
6258 op_was_null = o->op_type == OP_NULL;
6259 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6260 o->op_type = OP_CUSTOM;
6263 o->op_type = OP_NULL;
6264 S_prune_chain_head(&curop);
6267 old_cxix = cxstack_ix;
6268 create_eval_scope(NULL, G_FAKINGEVAL);
6270 old_curcop = PL_curcop;
6271 StructCopy(old_curcop, ¬_compiling, COP);
6272 PL_curcop = ¬_compiling;
6273 /* The above ensures that we run with all the correct hints of the
6274 current COP, but that IN_PERL_RUNTIME is true. */
6275 assert(IN_PERL_RUNTIME);
6276 PL_warnhook = PERL_WARNHOOK_FATAL;
6280 /* Effective $^W=1. */
6281 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6282 PL_dowarn |= G_WARN_ON;
6286 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6287 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6289 Perl_pp_pushmark(aTHX);
6292 assert (!(curop->op_flags & OPf_SPECIAL));
6293 assert(curop->op_type == OP_RANGE);
6294 Perl_pp_anonlist(aTHX);
6298 o->op_next = old_next;
6302 PL_warnhook = oldwarnhook;
6303 PL_diehook = olddiehook;
6304 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6309 PL_dowarn = oldwarn;
6310 PL_warnhook = oldwarnhook;
6311 PL_diehook = olddiehook;
6312 PL_curcop = old_curcop;
6314 if (cxstack_ix > old_cxix) {
6315 assert(cxstack_ix == old_cxix + 1);
6316 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6317 delete_eval_scope();
6322 OpTYPE_set(o, OP_RV2AV);
6323 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6324 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6325 o->op_opt = 0; /* needs to be revisited in rpeep() */
6326 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6328 /* replace subtree with an OP_CONST */
6329 curop = ((UNOP*)o)->op_first;
6330 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6333 if (AvFILLp(av) != -1)
6334 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6337 SvREADONLY_on(*svp);
6345 =head1 Optree Manipulation Functions
6348 /* List constructors */
6351 =for apidoc op_append_elem
6353 Append an item to the list of ops contained directly within a list-type
6354 op, returning the lengthened list. C<first> is the list-type op,
6355 and C<last> is the op to append to the list. C<optype> specifies the
6356 intended opcode for the list. If C<first> is not already a list of the
6357 right type, it will be upgraded into one. If either C<first> or C<last>
6358 is null, the other is returned unchanged.
6364 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6372 if (first->op_type != (unsigned)type
6373 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6375 return newLISTOP(type, 0, first, last);
6378 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6379 first->op_flags |= OPf_KIDS;
6384 =for apidoc op_append_list
6386 Concatenate the lists of ops contained directly within two list-type ops,
6387 returning the combined list. C<first> and C<last> are the list-type ops
6388 to concatenate. C<optype> specifies the intended opcode for the list.
6389 If either C<first> or C<last> is not already a list of the right type,
6390 it will be upgraded into one. If either C<first> or C<last> is null,
6391 the other is returned unchanged.
6397 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6405 if (first->op_type != (unsigned)type)
6406 return op_prepend_elem(type, first, last);
6408 if (last->op_type != (unsigned)type)
6409 return op_append_elem(type, first, last);
6411 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6412 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6413 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6414 first->op_flags |= (last->op_flags & OPf_KIDS);
6416 S_op_destroy(aTHX_ last);
6422 =for apidoc op_prepend_elem
6424 Prepend an item to the list of ops contained directly within a list-type
6425 op, returning the lengthened list. C<first> is the op to prepend to the
6426 list, and C<last> is the list-type op. C<optype> specifies the intended
6427 opcode for the list. If C<last> is not already a list of the right type,
6428 it will be upgraded into one. If either C<first> or C<last> is null,
6429 the other is returned unchanged.
6435 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6443 if (last->op_type == (unsigned)type) {
6444 if (type == OP_LIST) { /* already a PUSHMARK there */
6445 /* insert 'first' after pushmark */
6446 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6447 if (!(first->op_flags & OPf_PARENS))
6448 last->op_flags &= ~OPf_PARENS;
6451 op_sibling_splice(last, NULL, 0, first);
6452 last->op_flags |= OPf_KIDS;
6456 return newLISTOP(type, 0, first, last);
6460 =for apidoc op_convert_list
6462 Converts C<o> into a list op if it is not one already, and then converts it
6463 into the specified C<type>, calling its check function, allocating a target if
6464 it needs one, and folding constants.
6466 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6467 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6468 C<op_convert_list> to make it the right type.
6474 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6477 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6478 if (!o || o->op_type != OP_LIST)
6479 o = force_list(o, 0);
6482 o->op_flags &= ~OPf_WANT;
6483 o->op_private &= ~OPpLVAL_INTRO;
6486 if (!(PL_opargs[type] & OA_MARK))
6487 op_null(cLISTOPo->op_first);
6489 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6490 if (kid2 && kid2->op_type == OP_COREARGS) {
6491 op_null(cLISTOPo->op_first);
6492 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6496 if (type != OP_SPLIT)
6497 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6498 * ck_split() create a real PMOP and leave the op's type as listop
6499 * for now. Otherwise op_free() etc will crash.
6501 OpTYPE_set(o, type);
6503 o->op_flags |= flags;
6504 if (flags & OPf_FOLDED)
6507 o = CHECKOP(type, o);
6508 if (o->op_type != (unsigned)type)
6511 return fold_constants(op_integerize(op_std_init(o)));
6518 =head1 Optree construction
6520 =for apidoc newNULLLIST
6522 Constructs, checks, and returns a new C<stub> op, which represents an
6523 empty list expression.
6529 Perl_newNULLLIST(pTHX)
6531 return newOP(OP_STUB, 0);
6534 /* promote o and any siblings to be a list if its not already; i.e.
6542 * pushmark - o - A - B
6544 * If nullit it true, the list op is nulled.
6548 S_force_list(pTHX_ OP *o, bool nullit)
6550 if (!o || o->op_type != OP_LIST) {
6553 /* manually detach any siblings then add them back later */
6554 rest = OpSIBLING(o);
6555 OpLASTSIB_set(o, NULL);
6557 o = newLISTOP(OP_LIST, 0, o, NULL);
6559 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6567 =for apidoc newLISTOP
6569 Constructs, checks, and returns an op of any list type. C<type> is
6570 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6571 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6572 supply up to two ops to be direct children of the list op; they are
6573 consumed by this function and become part of the constructed op tree.
6575 For most list operators, the check function expects all the kid ops to be
6576 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6577 appropriate. What you want to do in that case is create an op of type
6578 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6579 See L</op_convert_list> for more information.
6586 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6590 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6591 * pushmark is banned. So do it now while existing ops are in a
6592 * consistent state, in case they suddenly get freed */
6593 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6595 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6596 || type == OP_CUSTOM);
6598 NewOp(1101, listop, 1, LISTOP);
6599 OpTYPE_set(listop, type);
6602 listop->op_flags = (U8)flags;
6606 else if (!first && last)
6609 OpMORESIB_set(first, last);
6610 listop->op_first = first;
6611 listop->op_last = last;
6614 OpMORESIB_set(pushop, first);
6615 listop->op_first = pushop;
6616 listop->op_flags |= OPf_KIDS;
6618 listop->op_last = pushop;
6620 if (listop->op_last)
6621 OpLASTSIB_set(listop->op_last, (OP*)listop);
6623 return CHECKOP(type, listop);
6629 Constructs, checks, and returns an op of any base type (any type that
6630 has no extra fields). C<type> is the opcode. C<flags> gives the
6631 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6638 Perl_newOP(pTHX_ I32 type, I32 flags)
6643 if (type == -OP_ENTEREVAL) {
6644 type = OP_ENTEREVAL;
6645 flags |= OPpEVAL_BYTES<<8;
6648 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6649 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6650 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6651 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6653 NewOp(1101, o, 1, OP);
6654 OpTYPE_set(o, type);
6655 o->op_flags = (U8)flags;
6658 o->op_private = (U8)(0 | (flags >> 8));
6659 if (PL_opargs[type] & OA_RETSCALAR)
6661 if (PL_opargs[type] & OA_TARGET)
6662 o->op_targ = pad_alloc(type, SVs_PADTMP);
6663 return CHECKOP(type, o);
6669 Constructs, checks, and returns an op of any unary type. C<type> is
6670 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6671 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6672 bits, the eight bits of C<op_private>, except that the bit with value 1
6673 is automatically set. C<first> supplies an optional op to be the direct
6674 child of the unary op; it is consumed by this function and become part
6675 of the constructed op tree.
6677 =for apidoc Amnh||OPf_KIDS
6683 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6688 if (type == -OP_ENTEREVAL) {
6689 type = OP_ENTEREVAL;
6690 flags |= OPpEVAL_BYTES<<8;
6693 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6694 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6695 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6696 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6697 || type == OP_SASSIGN
6698 || type == OP_ENTERTRY
6699 || type == OP_CUSTOM
6700 || type == OP_NULL );
6703 first = newOP(OP_STUB, 0);
6704 if (PL_opargs[type] & OA_MARK)
6705 first = force_list(first, 1);
6707 NewOp(1101, unop, 1, UNOP);
6708 OpTYPE_set(unop, type);
6709 unop->op_first = first;
6710 unop->op_flags = (U8)(flags | OPf_KIDS);
6711 unop->op_private = (U8)(1 | (flags >> 8));
6713 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6714 OpLASTSIB_set(first, (OP*)unop);
6716 unop = (UNOP*) CHECKOP(type, unop);
6720 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6724 =for apidoc newUNOP_AUX
6726 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6727 initialised to C<aux>
6733 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6738 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6739 || type == OP_CUSTOM);
6741 NewOp(1101, unop, 1, UNOP_AUX);
6742 unop->op_type = (OPCODE)type;
6743 unop->op_ppaddr = PL_ppaddr[type];
6744 unop->op_first = first;
6745 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6746 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6749 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6750 OpLASTSIB_set(first, (OP*)unop);
6752 unop = (UNOP_AUX*) CHECKOP(type, unop);
6754 return op_std_init((OP *) unop);
6758 =for apidoc newMETHOP
6760 Constructs, checks, and returns an op of method type with a method name
6761 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6762 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6763 and, shifted up eight bits, the eight bits of C<op_private>, except that
6764 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6765 op which evaluates method name; it is consumed by this function and
6766 become part of the constructed op tree.
6767 Supported optypes: C<OP_METHOD>.
6773 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6777 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6778 || type == OP_CUSTOM);
6780 NewOp(1101, methop, 1, METHOP);
6782 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6783 methop->op_flags = (U8)(flags | OPf_KIDS);
6784 methop->op_u.op_first = dynamic_meth;
6785 methop->op_private = (U8)(1 | (flags >> 8));
6787 if (!OpHAS_SIBLING(dynamic_meth))
6788 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6792 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6793 methop->op_u.op_meth_sv = const_meth;
6794 methop->op_private = (U8)(0 | (flags >> 8));
6795 methop->op_next = (OP*)methop;
6799 methop->op_rclass_targ = 0;
6801 methop->op_rclass_sv = NULL;
6804 OpTYPE_set(methop, type);
6805 return CHECKOP(type, methop);
6809 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6810 PERL_ARGS_ASSERT_NEWMETHOP;
6811 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6815 =for apidoc newMETHOP_named
6817 Constructs, checks, and returns an op of method type with a constant
6818 method name. C<type> is the opcode. C<flags> gives the eight bits of
6819 C<op_flags>, and, shifted up eight bits, the eight bits of
6820 C<op_private>. C<const_meth> supplies a constant method name;
6821 it must be a shared COW string.
6822 Supported optypes: C<OP_METHOD_NAMED>.
6828 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6829 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6830 return newMETHOP_internal(type, flags, NULL, const_meth);
6834 =for apidoc newBINOP
6836 Constructs, checks, and returns an op of any binary type. C<type>
6837 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6838 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6839 the eight bits of C<op_private>, except that the bit with value 1 or
6840 2 is automatically set as required. C<first> and C<last> supply up to
6841 two ops to be the direct children of the binary op; they are consumed
6842 by this function and become part of the constructed op tree.
6848 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6853 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6854 || type == OP_NULL || type == OP_CUSTOM);
6856 NewOp(1101, binop, 1, BINOP);
6859 first = newOP(OP_NULL, 0);
6861 OpTYPE_set(binop, type);
6862 binop->op_first = first;
6863 binop->op_flags = (U8)(flags | OPf_KIDS);
6866 binop->op_private = (U8)(1 | (flags >> 8));
6869 binop->op_private = (U8)(2 | (flags >> 8));
6870 OpMORESIB_set(first, last);
6873 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6874 OpLASTSIB_set(last, (OP*)binop);
6876 binop->op_last = OpSIBLING(binop->op_first);
6878 OpLASTSIB_set(binop->op_last, (OP*)binop);
6880 binop = (BINOP*)CHECKOP(type, binop);
6881 if (binop->op_next || binop->op_type != (OPCODE)type)
6884 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6888 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
6890 const char indent[] = " ";
6892 UV len = _invlist_len(invlist);
6893 UV * array = invlist_array(invlist);
6896 PERL_ARGS_ASSERT_INVMAP_DUMP;
6898 for (i = 0; i < len; i++) {
6899 UV start = array[i];
6900 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
6902 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
6903 if (end == IV_MAX) {
6904 PerlIO_printf(Perl_debug_log, " .. INFTY");
6906 else if (end != start) {
6907 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
6910 PerlIO_printf(Perl_debug_log, " ");
6913 PerlIO_printf(Perl_debug_log, "\t");
6915 if (map[i] == TR_UNLISTED) {
6916 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
6918 else if (map[i] == TR_SPECIAL_HANDLING) {
6919 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
6922 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
6927 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6928 * containing the search and replacement strings, assemble into
6929 * a translation table attached as o->op_pv.
6930 * Free expr and repl.
6931 * It expects the toker to have already set the
6932 * OPpTRANS_COMPLEMENT
6935 * flags as appropriate; this function may add
6937 * OPpTRANS_CAN_FORCE_UTF8
6938 * OPpTRANS_IDENTICAL
6944 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6946 /* This function compiles a tr///, from data gathered from toke.c, into a
6947 * form suitable for use by do_trans() in doop.c at runtime.
6949 * It first normalizes the data, while discarding extraneous inputs; then
6950 * writes out the compiled data. The normalization allows for complete
6951 * analysis, and avoids some false negatives and positives earlier versions
6954 * The normalization form is an inversion map (described below in detail).
6955 * This is essentially the compiled form for tr///'s that require UTF-8,
6956 * and its easy to use it to write the 257-byte table for tr///'s that
6957 * don't need UTF-8. That table is identical to what's been in use for
6958 * many perl versions, except that it doesn't handle some edge cases that
6959 * it used to, involving code points above 255. The UTF-8 form now handles
6960 * these. (This could be changed with extra coding should it shown to be
6963 * If the complement (/c) option is specified, the lhs string (tstr) is
6964 * parsed into an inversion list. Complementing these is trivial. Then a
6965 * complemented tstr is built from that, and used thenceforth. This hides
6966 * the fact that it was complemented from almost all successive code.
6968 * One of the important characteristics to know about the input is whether
6969 * the transliteration may be done in place, or does a temporary need to be
6970 * allocated, then copied. If the replacement for every character in every
6971 * possible string takes up no more bytes than the character it
6972 * replaces, then it can be edited in place. Otherwise the replacement
6973 * could overwrite a byte we are about to read, depending on the strings
6974 * being processed. The comments and variable names here refer to this as
6975 * "growing". Some inputs won't grow, and might even shrink under /d, but
6976 * some inputs could grow, so we have to assume any given one might grow.
6977 * On very long inputs, the temporary could eat up a lot of memory, so we
6978 * want to avoid it if possible. For non-UTF-8 inputs, everything is
6979 * single-byte, so can be edited in place, unless there is something in the
6980 * pattern that could force it into UTF-8. The inversion map makes it
6981 * feasible to determine this. Previous versions of this code pretty much
6982 * punted on determining if UTF-8 could be edited in place. Now, this code
6983 * is rigorous in making that determination.
6985 * Another characteristic we need to know is whether the lhs and rhs are
6986 * identical. If so, and no other flags are present, the only effect of
6987 * the tr/// is to count the characters present in the input that are
6988 * mentioned in the lhs string. The implementation of that is easier and
6989 * runs faster than the more general case. Normalizing here allows for
6990 * accurate determination of this. Previously there were false negatives
6993 * Instead of 'transliterated', the comments here use 'unmapped' for the
6994 * characters that are left unchanged by the operation; otherwise they are
6997 * The lhs of the tr/// is here referred to as the t side.
6998 * The rhs of the tr/// is here referred to as the r side.
7001 SV * const tstr = ((SVOP*)expr)->op_sv;
7002 SV * const rstr = ((SVOP*)repl)->op_sv;
7005 const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
7006 const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
7009 UV t_count = 0, r_count = 0; /* Number of characters in search and
7010 replacement lists */
7012 /* khw thinks some of the private flags for this op are quaintly named.
7013 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
7014 * character when represented in UTF-8 is longer than the original
7015 * character's UTF-8 representation */
7016 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
7017 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
7018 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
7020 /* Set to true if there is some character < 256 in the lhs that maps to
7021 * above 255. If so, a non-UTF-8 match string can be forced into being in
7022 * UTF-8 by a tr/// operation. */
7023 bool can_force_utf8 = FALSE;
7025 /* What is the maximum expansion factor in UTF-8 transliterations. If a
7026 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
7027 * expansion factor is 1.5. This number is used at runtime to calculate
7028 * how much space to allocate for non-inplace transliterations. Without
7029 * this number, the worst case is 14, which is extremely unlikely to happen
7030 * in real life, and could require significant memory overhead. */
7031 NV max_expansion = 1.;
7033 UV t_range_count, r_range_count, min_range_count;
7038 UV t_cp_end = (UV) -1;
7042 UV final_map = TR_UNLISTED; /* The final character in the replacement
7043 list, updated as we go along. Initialize
7044 to something illegal */
7046 bool rstr_utf8 = cBOOL(SvUTF8(rstr));
7047 bool tstr_utf8 = cBOOL(SvUTF8(tstr));
7049 const U8* tend = t + tlen;
7050 const U8* rend = r + rlen;
7052 SV * inverted_tstr = NULL;
7057 /* This routine implements detection of a transliteration having a longer
7058 * UTF-8 representation than its source, by partitioning all the possible
7059 * code points of the platform into equivalence classes of the same UTF-8
7060 * byte length in the first pass. As it constructs the mappings, it carves
7061 * these up into smaller chunks, but doesn't merge any together. This
7062 * makes it easy to find the instances it's looking for. A second pass is
7063 * done after this has been determined which merges things together to
7064 * shrink the table for runtime. The table below is used for both ASCII
7065 * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically
7066 * increasing for code points below 256. To correct for that, the macro
7067 * CP_ADJUST defined below converts those code points to ASCII in the first
7068 * pass, and we use the ASCII partition values. That works because the
7069 * growth factor will be unaffected, which is all that is calculated during
7070 * the first pass. */
7071 UV PL_partition_by_byte_length[] = {
7073 0x80, /* Below this is 1 byte representations */
7074 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */
7075 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */
7076 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */
7077 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */
7078 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */
7082 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */
7087 PERL_ARGS_ASSERT_PMTRANS;
7089 PL_hints |= HINT_BLOCK_SCOPE;
7091 /* If /c, the search list is sorted and complemented. This is now done by
7092 * creating an inversion list from it, and then trivially inverting that.
7093 * The previous implementation used qsort, but creating the list
7094 * automatically keeps it sorted as we go along */
7097 SV * inverted_tlist = _new_invlist(tlen);
7100 DEBUG_y(PerlIO_printf(Perl_debug_log,
7101 "%s: %d: tstr before inversion=\n%s\n",
7102 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7106 /* Non-utf8 strings don't have ranges, so each character is listed
7109 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
7112 else { /* But UTF-8 strings have been parsed in toke.c to have
7113 * ranges if appropriate. */
7117 /* Get the first character */
7118 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7121 /* If the next byte indicates that this wasn't the first
7122 * element of a range, the range is just this one */
7123 if (t >= tend || *t != RANGE_INDICATOR) {
7124 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
7126 else { /* Otherwise, ignore the indicator byte, and get the
7127 final element, and add the whole range */
7129 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
7132 inverted_tlist = _add_range_to_invlist(inverted_tlist,
7136 } /* End of parse through tstr */
7138 /* The inversion list is done; now invert it */
7139 _invlist_invert(inverted_tlist);
7141 /* Now go through the inverted list and create a new tstr for the rest
7142 * of the routine to use. Since the UTF-8 version can have ranges, and
7143 * can be much more compact than the non-UTF-8 version, we create the
7144 * string in UTF-8 even if not necessary. (This is just an intermediate
7145 * value that gets thrown away anyway.) */
7146 invlist_iterinit(inverted_tlist);
7147 inverted_tstr = newSVpvs("");
7148 while (invlist_iternext(inverted_tlist, &start, &end)) {
7149 U8 temp[UTF8_MAXBYTES];
7152 /* IV_MAX keeps things from going out of bounds */
7153 start = MIN(IV_MAX, start);
7154 end = MIN(IV_MAX, end);
7156 temp_end_pos = uvchr_to_utf8(temp, start);
7157 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7160 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
7161 temp_end_pos = uvchr_to_utf8(temp, end);
7162 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7166 /* Set up so the remainder of the routine uses this complement, instead
7167 * of the actual input */
7168 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
7169 tend = t0 + temp_len;
7172 SvREFCNT_dec_NN(inverted_tlist);
7175 /* For non-/d, an empty rhs means to use the lhs */
7176 if (rlen == 0 && ! del) {
7179 rstr_utf8 = tstr_utf8;
7182 t_invlist = _new_invlist(1);
7184 /* Initialize to a single range */
7185 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7187 /* For the first pass, the lhs is partitioned such that the
7188 * number of UTF-8 bytes required to represent a code point in each
7189 * partition is the same as the number for any other code point in
7190 * that partion. We copy the pre-compiled partion. */
7191 len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
7192 invlist_extend(t_invlist, len);
7193 t_array = invlist_array(t_invlist);
7194 Copy(PL_partition_by_byte_length, t_array, len, UV);
7195 invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
7196 Newx(r_map, len + 1, UV);
7198 /* Parse the (potentially adjusted) input, creating the inversion map.
7199 * This is done in two passes. The first pass is to determine if the
7200 * transliteration can be done in place. The inversion map it creates
7201 * could be used, but generally would be larger and slower to run than the
7202 * output of the second pass, which starts with a more compact table and
7203 * allows more ranges to be merged */
7204 for (pass2 = 0; pass2 < 2; pass2++) {
7206 /* Initialize to a single range */
7207 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7209 /* In the second pass, we just have the single range */
7211 t_array = invlist_array(t_invlist);
7214 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
7215 * so as to get the well-behaved length 1 vs length 2 boundary. Only code
7216 * points below 256 differ between the two character sets in this regard. For
7217 * these, we also can't have any ranges, as they have to be individually
7220 # define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x))
7221 # define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256))
7222 # define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
7224 # define CP_ADJUST(x) (x)
7225 # define FORCE_RANGE_LEN_1(x) 0
7226 # define CP_SKIP(x) UVCHR_SKIP(x)
7229 /* And the mapping of each of the ranges is initialized. Initially,
7230 * everything is TR_UNLISTED. */
7231 for (i = 0; i < len; i++) {
7232 r_map[i] = TR_UNLISTED;
7239 t_range_count = r_range_count = 0;
7241 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
7242 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7243 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
7244 _byte_dump_string(r, rend - r, 0)));
7245 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
7246 complement, squash, del));
7247 DEBUG_y(invmap_dump(t_invlist, r_map));
7249 /* Now go through the search list constructing an inversion map. The
7250 * input is not necessarily in any particular order. Making it an
7251 * inversion map orders it, potentially simplifying, and makes it easy
7252 * to deal with at run time. This is the only place in core that
7253 * generates an inversion map; if others were introduced, it might be
7254 * better to create general purpose routines to handle them.
7255 * (Inversion maps are created in perl in other places.)
7257 * An inversion map consists of two parallel arrays. One is
7258 * essentially an inversion list: an ordered list of code points such
7259 * that each element gives the first code point of a range of
7260 * consecutive code points that map to the element in the other array
7261 * that has the same index as this one (in other words, the
7262 * corresponding element). Thus the range extends up to (but not
7263 * including) the code point given by the next higher element. In a
7264 * true inversion map, the corresponding element in the other array
7265 * gives the mapping of the first code point in the range, with the
7266 * understanding that the next higher code point in the inversion
7267 * list's range will map to the next higher code point in the map.
7269 * So if at element [i], let's say we have:
7274 * This means that A => a, B => b, C => c.... Let's say that the
7275 * situation is such that:
7279 * This means the sequence that started at [i] stops at K => k. This
7280 * illustrates that you need to look at the next element to find where
7281 * a sequence stops. Except, the highest element in the inversion list
7282 * begins a range that is understood to extend to the platform's
7285 * This routine modifies traditional inversion maps to reserve two
7288 * TR_UNLISTED (or -1) indicates that no code point in the range
7289 * is listed in the tr/// searchlist. At runtime, these are
7290 * always passed through unchanged. In the inversion map, all
7291 * points in the range are mapped to -1, instead of increasing,
7292 * like the 'L' in the example above.
7294 * We start the parse with every code point mapped to this, and as
7295 * we parse and find ones that are listed in the search list, we
7296 * carve out ranges as we go along that override that.
7298 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
7299 * range needs special handling. Again, all code points in the
7300 * range are mapped to -2, instead of increasing.
7302 * Under /d this value means the code point should be deleted from
7303 * the transliteration when encountered.
7305 * Otherwise, it marks that every code point in the range is to
7306 * map to the final character in the replacement list. This
7307 * happens only when the replacement list is shorter than the
7308 * search one, so there are things in the search list that have no
7309 * correspondence in the replacement list. For example, in
7310 * tr/a-z/A/, 'A' is the final value, and the inversion map
7311 * generated for this would be like this:
7316 * 'A' appears once, then the remainder of the range maps to -2.
7317 * The use of -2 isn't strictly necessary, as an inversion map is
7318 * capable of representing this situation, but not nearly so
7319 * compactly, and this is actually quite commonly encountered.
7320 * Indeed, the original design of this code used a full inversion
7321 * map for this. But things like
7323 * generated huge data structures, slowly, and the execution was
7324 * also slow. So the current scheme was implemented.
7326 * So, if the next element in our example is:
7330 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next
7334 * [i+4] S TR_UNLISTED
7336 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is
7337 * the final element in the arrays, every code point from S to infinity
7338 * maps to TR_UNLISTED.
7341 /* Finish up range started in what otherwise would
7342 * have been the final iteration */
7343 while (t < tend || t_range_count > 0) {
7344 bool adjacent_to_range_above = FALSE;
7345 bool adjacent_to_range_below = FALSE;
7347 bool merge_with_range_above = FALSE;
7348 bool merge_with_range_below = FALSE;
7350 UV span, invmap_range_length_remaining;
7354 /* If we are in the middle of processing a range in the 'target'
7355 * side, the previous iteration has set us up. Otherwise, look at
7356 * the next character in the search list */
7357 if (t_range_count <= 0) {
7360 /* Here, not in the middle of a range, and not UTF-8. The
7361 * next code point is the single byte where we're at */
7362 t_cp = CP_ADJUST(*t);
7369 /* Here, not in the middle of a range, and is UTF-8. The
7370 * next code point is the next UTF-8 char in the input. We
7371 * know the input is valid, because the toker constructed
7373 t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
7376 /* UTF-8 strings (only) have been parsed in toke.c to have
7377 * ranges. See if the next byte indicates that this was
7378 * the first element of a range. If so, get the final
7379 * element and calculate the range size. If not, the range
7381 if ( t < tend && *t == RANGE_INDICATOR
7382 && ! FORCE_RANGE_LEN_1(t_cp))
7385 t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
7394 /* Count the total number of listed code points * */
7395 t_count += t_range_count;
7398 /* Similarly, get the next character in the replacement list */
7399 if (r_range_count <= 0) {
7402 /* But if we've exhausted the rhs, there is nothing to map
7403 * to, except the special handling one, and we make the
7404 * range the same size as the lhs one. */
7405 r_cp = TR_SPECIAL_HANDLING;
7406 r_range_count = t_range_count;
7409 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7410 "final_map =%" UVXf "\n", final_map));
7415 r_cp = CP_ADJUST(*r);
7422 r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
7424 if ( r < rend && *r == RANGE_INDICATOR
7425 && ! FORCE_RANGE_LEN_1(r_cp))
7428 r_range_count = valid_utf8_to_uvchr(r,
7429 &r_char_len) - r_cp + 1;
7437 if (r_cp == TR_SPECIAL_HANDLING) {
7438 r_range_count = t_range_count;
7441 /* This is the final character so far */
7442 final_map = r_cp + r_range_count - 1;
7444 r_count += r_range_count;
7448 /* Here, we have the next things ready in both sides. They are
7449 * potentially ranges. We try to process as big a chunk as
7450 * possible at once, but the lhs and rhs must be synchronized, so
7451 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
7453 min_range_count = MIN(t_range_count, r_range_count);
7455 /* Search the inversion list for the entry that contains the input
7456 * code point <cp>. The inversion map was initialized to cover the
7457 * entire range of possible inputs, so this should not fail. So
7458 * the return value is the index into the list's array of the range
7459 * that contains <cp>, that is, 'i' such that array[i] <= cp <
7461 j = _invlist_search(t_invlist, t_cp);
7465 /* Here, the data structure might look like:
7468 * [i-1] J j # J-L => j-l
7469 * [i] M -1 # M => default; as do N, O, P, Q
7470 * [i+1] R x # R => x, S => x+1, T => x+2
7471 * [i+2] U y # U => y, V => y+1, ...
7473 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7475 * where 'x' and 'y' above are not to be taken literally.
7477 * The maximum chunk we can handle in this loop iteration, is the
7478 * smallest of the three components: the lhs 't_', the rhs 'r_',
7479 * and the remainder of the range in element [i]. (In pass 1, that
7480 * range will have everything in it be of the same class; we can't
7481 * cross into another class.) 'min_range_count' already contains
7482 * the smallest of the first two values. The final one is
7483 * irrelevant if the map is to the special indicator */
7485 invmap_range_length_remaining = (i + 1 < len)
7486 ? t_array[i+1] - t_cp
7488 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
7490 /* The end point of this chunk is where we are, plus the span, but
7491 * never larger than the platform's infinity */
7492 t_cp_end = MIN(IV_MAX, t_cp + span - 1);
7494 if (r_cp == TR_SPECIAL_HANDLING) {
7496 /* If unmatched lhs code points map to the final map, use that
7497 * value. This being set to TR_SPECIAL_HANDLING indicates that
7498 * we don't have a final map: unmatched lhs code points are
7500 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
7503 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
7505 /* If something on the lhs is below 256, and something on the
7506 * rhs is above, there is a potential mapping here across that
7507 * boundary. Indeed the only way there isn't is if both sides
7508 * start at the same point. That means they both cross at the
7509 * same time. But otherwise one crosses before the other */
7510 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
7511 can_force_utf8 = TRUE;
7515 /* If a character appears in the search list more than once, the
7516 * 2nd and succeeding occurrences are ignored, so only do this
7517 * range if haven't already processed this character. (The range
7518 * has been set up so that all members in it will be of the same
7520 if (r_map[i] == TR_UNLISTED) {
7521 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7522 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
7523 t_cp, t_cp_end, r_cp, r_cp_end));
7525 /* This is the first definition for this chunk, hence is valid
7526 * and needs to be processed. Here and in the comments below,
7527 * we use the above sample data. The t_cp chunk must be any
7528 * contiguous subset of M, N, O, P, and/or Q.
7530 * In the first pass, calculate if there is any possible input
7531 * string that has a character whose transliteration will be
7532 * longer than it. If none, the transliteration may be done
7533 * in-place, as it can't write over a so-far unread byte.
7534 * Otherwise, a copy must first be made. This could be
7535 * expensive for long inputs.
7537 * In the first pass, the t_invlist has been partitioned so
7538 * that all elements in any single range have the same number
7539 * of bytes in their UTF-8 representations. And the r space is
7540 * either a single byte, or a range of strictly monotonically
7541 * increasing code points. So the final element in the range
7542 * will be represented by no fewer bytes than the initial one.
7543 * That means that if the final code point in the t range has
7544 * at least as many bytes as the final code point in the r,
7545 * then all code points in the t range have at least as many
7546 * bytes as their corresponding r range element. But if that's
7547 * not true, the transliteration of at least the final code
7548 * point grows in length. As an example, suppose we had
7549 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
7550 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
7551 * platforms. We have deliberately set up the data structure
7552 * so that any range in the lhs gets split into chunks for
7553 * processing, such that every code point in a chunk has the
7554 * same number of UTF-8 bytes. We only have to check the final
7555 * code point in the rhs against any code point in the lhs. */
7557 && r_cp_end != TR_SPECIAL_HANDLING
7558 && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
7560 /* Here, we will need to make a copy of the input string
7561 * before doing the transliteration. The worst possible
7562 * case is an expansion ratio of 14:1. This is rare, and
7563 * we'd rather allocate only the necessary amount of extra
7564 * memory for that copy. We can calculate the worst case
7565 * for this particular transliteration is by keeping track
7566 * of the expansion factor for each range.
7568 * Consider tr/\xCB/\X{E000}/. The maximum expansion
7569 * factor is 1 byte going to 3 if the target string is not
7570 * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We
7571 * could pass two different values so doop could choose
7572 * based on the UTF-8ness of the target. But khw thinks
7573 * (perhaps wrongly) that is overkill. It is used only to
7574 * make sure we malloc enough space.
7576 * If no target string can force the result to be UTF-8,
7577 * then we don't have to worry about the case of the target
7578 * string not being UTF-8 */
7579 NV t_size = (can_force_utf8 && t_cp < 256)
7581 : CP_SKIP(t_cp_end);
7582 NV ratio = CP_SKIP(r_cp_end) / t_size;
7584 o->op_private |= OPpTRANS_GROWS;
7586 /* Now that we know it grows, we can keep track of the
7588 if (ratio > max_expansion) {
7589 max_expansion = ratio;
7590 DEBUG_y(PerlIO_printf(Perl_debug_log,
7591 "New expansion factor: %" NVgf "\n",
7596 /* The very first range is marked as adjacent to the
7597 * non-existent range below it, as it causes things to "just
7600 * If the lowest code point in this chunk is M, it adjoins the
7602 if (t_cp == t_array[i]) {
7603 adjacent_to_range_below = TRUE;
7605 /* And if the map has the same offset from the beginning of
7606 * the range as does this new code point (or both are for
7607 * TR_SPECIAL_HANDLING), this chunk can be completely
7608 * merged with the range below. EXCEPT, in the first pass,
7609 * we don't merge ranges whose UTF-8 byte representations
7610 * have different lengths, so that we can more easily
7611 * detect if a replacement is longer than the source, that
7612 * is if it 'grows'. But in the 2nd pass, there's no
7613 * reason to not merge */
7614 if ( (i > 0 && ( pass2
7615 || CP_SKIP(t_array[i-1])
7617 && ( ( r_cp == TR_SPECIAL_HANDLING
7618 && r_map[i-1] == TR_SPECIAL_HANDLING)
7619 || ( r_cp != TR_SPECIAL_HANDLING
7620 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
7622 merge_with_range_below = TRUE;
7626 /* Similarly, if the highest code point in this chunk is 'Q',
7627 * it adjoins the range above, and if the map is suitable, can
7628 * be merged with it */
7629 if ( t_cp_end >= IV_MAX - 1
7631 && t_cp_end + 1 == t_array[i+1]))
7633 adjacent_to_range_above = TRUE;
7636 || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
7637 && ( ( r_cp == TR_SPECIAL_HANDLING
7638 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
7639 || ( r_cp != TR_SPECIAL_HANDLING
7640 && r_cp_end == r_map[i+1] - 1)))
7642 merge_with_range_above = TRUE;
7646 if (merge_with_range_below && merge_with_range_above) {
7648 /* Here the new chunk looks like M => m, ... Q => q; and
7649 * the range above is like R => r, .... Thus, the [i-1]
7650 * and [i+1] ranges should be seamlessly melded so the
7653 * [i-1] J j # J-T => j-t
7654 * [i] U y # U => y, V => y+1, ...
7656 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7658 Move(t_array + i + 2, t_array + i, len - i - 2, UV);
7659 Move(r_map + i + 2, r_map + i, len - i - 2, UV);
7661 invlist_set_len(t_invlist,
7663 *(get_invlist_offset_addr(t_invlist)));
7665 else if (merge_with_range_below) {
7667 /* Here the new chunk looks like M => m, .... But either
7668 * (or both) it doesn't extend all the way up through Q; or
7669 * the range above doesn't start with R => r. */
7670 if (! adjacent_to_range_above) {
7672 /* In the first case, let's say the new chunk extends
7673 * through O. We then want:
7675 * [i-1] J j # J-O => j-o
7676 * [i] P -1 # P => -1, Q => -1
7677 * [i+1] R x # R => x, S => x+1, T => x+2
7678 * [i+2] U y # U => y, V => y+1, ...
7680 * [-1] Z -1 # Z => default; as do Z+1, ...
7683 t_array[i] = t_cp_end + 1;
7684 r_map[i] = TR_UNLISTED;
7686 else { /* Adjoins the range above, but can't merge with it
7687 (because 'x' is not the next map after q) */
7689 * [i-1] J j # J-Q => j-q
7690 * [i] R x # R => x, S => x+1, T => x+2
7691 * [i+1] U y # U => y, V => y+1, ...
7693 * [-1] Z -1 # Z => default; as do Z+1, ...
7697 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7698 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7700 invlist_set_len(t_invlist, len,
7701 *(get_invlist_offset_addr(t_invlist)));
7704 else if (merge_with_range_above) {
7706 /* Here the new chunk ends with Q => q, and the range above
7707 * must start with R => r, so the two can be merged. But
7708 * either (or both) the new chunk doesn't extend all the
7709 * way down to M; or the mapping of the final code point
7710 * range below isn't m */
7711 if (! adjacent_to_range_below) {
7713 /* In the first case, let's assume the new chunk starts
7714 * with P => p. Then, because it's merge-able with the
7715 * range above, that range must be R => r. We want:
7717 * [i-1] J j # J-L => j-l
7718 * [i] M -1 # M => -1, N => -1
7719 * [i+1] P p # P-T => p-t
7720 * [i+2] U y # U => y, V => y+1, ...
7722 * [-1] Z -1 # Z => default; as do Z+1, ...
7725 t_array[i+1] = t_cp;
7728 else { /* Adjoins the range below, but can't merge with it
7731 * [i-1] J j # J-L => j-l
7732 * [i] M x # M-T => x-5 .. x+2
7733 * [i+1] U y # U => y, V => y+1, ...
7735 * [-1] Z -1 # Z => default; as do Z+1, ...
7738 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7739 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7743 invlist_set_len(t_invlist, len,
7744 *(get_invlist_offset_addr(t_invlist)));
7747 else if (adjacent_to_range_below && adjacent_to_range_above) {
7748 /* The new chunk completely fills the gap between the
7749 * ranges on either side, but can't merge with either of
7752 * [i-1] J j # J-L => j-l
7753 * [i] M z # M => z, N => z+1 ... Q => z+4
7754 * [i+1] R x # R => x, S => x+1, T => x+2
7755 * [i+2] U y # U => y, V => y+1, ...
7757 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7761 else if (adjacent_to_range_below) {
7762 /* The new chunk adjoins the range below, but not the range
7763 * above, and can't merge. Let's assume the chunk ends at
7766 * [i-1] J j # J-L => j-l
7767 * [i] M z # M => z, N => z+1, O => z+2
7768 * [i+1] P -1 # P => -1, Q => -1
7769 * [i+2] R x # R => x, S => x+1, T => x+2
7770 * [i+3] U y # U => y, V => y+1, ...
7772 * [-w] Z -1 # Z => default; as do Z+1, ... infinity
7774 invlist_extend(t_invlist, len + 1);
7775 t_array = invlist_array(t_invlist);
7776 Renew(r_map, len + 1, UV);
7778 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7779 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7781 t_array[i+1] = t_cp_end + 1;
7782 r_map[i+1] = TR_UNLISTED;
7784 invlist_set_len(t_invlist, len,
7785 *(get_invlist_offset_addr(t_invlist)));
7787 else if (adjacent_to_range_above) {
7788 /* The new chunk adjoins the range above, but not the range
7789 * below, and can't merge. Let's assume the new chunk
7792 * [i-1] J j # J-L => j-l
7793 * [i] M -1 # M => default, N => default
7794 * [i+1] O z # O => z, P => z+1, Q => z+2
7795 * [i+2] R x # R => x, S => x+1, T => x+2
7796 * [i+3] U y # U => y, V => y+1, ...
7798 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7800 invlist_extend(t_invlist, len + 1);
7801 t_array = invlist_array(t_invlist);
7802 Renew(r_map, len + 1, UV);
7804 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7805 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7806 t_array[i+1] = t_cp;
7809 invlist_set_len(t_invlist, len,
7810 *(get_invlist_offset_addr(t_invlist)));
7813 /* The new chunk adjoins neither the range above, nor the
7814 * range below. Lets assume it is N..P => n..p
7816 * [i-1] J j # J-L => j-l
7817 * [i] M -1 # M => default
7818 * [i+1] N n # N..P => n..p
7819 * [i+2] Q -1 # Q => default
7820 * [i+3] R x # R => x, S => x+1, T => x+2
7821 * [i+4] U y # U => y, V => y+1, ...
7823 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7826 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7827 "Before fixing up: len=%d, i=%d\n",
7828 (int) len, (int) i));
7829 DEBUG_yv(invmap_dump(t_invlist, r_map));
7831 invlist_extend(t_invlist, len + 2);
7832 t_array = invlist_array(t_invlist);
7833 Renew(r_map, len + 2, UV);
7835 Move(t_array + i + 1,
7836 t_array + i + 2 + 1, len - i - (2 - 1), UV);
7838 r_map + i + 2 + 1, len - i - (2 - 1), UV);
7841 invlist_set_len(t_invlist, len,
7842 *(get_invlist_offset_addr(t_invlist)));
7844 t_array[i+1] = t_cp;
7847 t_array[i+2] = t_cp_end + 1;
7848 r_map[i+2] = TR_UNLISTED;
7850 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7851 "After iteration: span=%" UVuf ", t_range_count=%"
7852 UVuf " r_range_count=%" UVuf "\n",
7853 span, t_range_count, r_range_count));
7854 DEBUG_yv(invmap_dump(t_invlist, r_map));
7855 } /* End of this chunk needs to be processed */
7857 /* Done with this chunk. */
7859 if (t_cp >= IV_MAX) {
7862 t_range_count -= span;
7863 if (r_cp != TR_SPECIAL_HANDLING) {
7865 r_range_count -= span;
7871 } /* End of loop through the search list */
7873 /* We don't need an exact count, but we do need to know if there is
7874 * anything left over in the replacement list. So, just assume it's
7875 * one byte per character */
7879 } /* End of passes */
7881 SvREFCNT_dec(inverted_tstr);
7883 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
7884 DEBUG_y(invmap_dump(t_invlist, r_map));
7886 /* We now have normalized the input into an inversion map.
7888 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op
7889 * except for the count, and streamlined runtime code can be used */
7890 if (!del && !squash) {
7892 /* They are identical if they point to same address, or if everything
7893 * maps to UNLISTED or to itself. This catches things that not looking
7894 * at the normalized inversion map doesn't catch, like tr/aa/ab/ or
7895 * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */
7897 for (i = 0; i < len; i++) {
7898 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
7899 goto done_identical_check;
7904 /* Here have gone through entire list, and didn't find any
7905 * non-identical mappings */
7906 o->op_private |= OPpTRANS_IDENTICAL;
7908 done_identical_check: ;
7911 t_array = invlist_array(t_invlist);
7913 /* If has components above 255, we generally need to use the inversion map
7917 && t_array[len-1] > 255
7918 /* If the final range is 0x100-INFINITY and is a special
7919 * mapping, the table implementation can handle it */
7920 && ! ( t_array[len-1] == 256
7921 && ( r_map[len-1] == TR_UNLISTED
7922 || r_map[len-1] == TR_SPECIAL_HANDLING))))
7926 /* A UTF-8 op is generated, indicated by this flag. This op is an
7928 o->op_private |= OPpTRANS_USE_SVOP;
7930 if (can_force_utf8) {
7931 o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
7934 /* The inversion map is pushed; first the list. */
7935 invmap = MUTABLE_AV(newAV());
7936 av_push(invmap, t_invlist);
7938 /* 2nd is the mapping */
7939 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
7940 av_push(invmap, r_map_sv);
7942 /* 3rd is the max possible expansion factor */
7943 av_push(invmap, newSVnv(max_expansion));
7945 /* Characters that are in the search list, but not in the replacement
7946 * list are mapped to the final character in the replacement list */
7947 if (! del && r_count < t_count) {
7948 av_push(invmap, newSVuv(final_map));
7952 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
7953 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
7954 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
7955 SvPADTMP_on(invmap);
7956 SvREADONLY_on(invmap);
7958 cSVOPo->op_sv = (SV *) invmap;
7966 /* The OPtrans_map struct already contains one slot; hence the -1. */
7967 SSize_t struct_size = sizeof(OPtrans_map)
7968 + (256 - 1 + 1)*sizeof(short);
7970 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
7971 * table. Entries with the value TR_UNMAPPED indicate chars not to be
7972 * translated, while TR_DELETE indicates a search char without a
7973 * corresponding replacement char under /d.
7975 * In addition, an extra slot at the end is used to store the final
7976 * repeating char, or TR_R_EMPTY under an empty replacement list, or
7977 * TR_DELETE under /d; which makes the runtime code easier.
7980 /* Indicate this is an op_pv */
7981 o->op_private &= ~OPpTRANS_USE_SVOP;
7983 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7985 cPVOPo->op_pv = (char*)tbl;
7987 for (i = 0; i < len; i++) {
7988 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7989 short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7990 short to = (short) r_map[i];
7992 bool do_increment = TRUE;
7994 /* Any code points above our limit should be irrelevant */
7995 if (t_array[i] >= tbl->size) break;
7997 /* Set up the map */
7998 if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7999 to = (short) final_map;
8000 do_increment = FALSE;
8003 do_increment = FALSE;
8006 /* Create a map for everything in this range. The value increases
8007 * except for the special cases */
8008 for (j = (short) t_array[i]; j < upper; j++) {
8010 if (do_increment) to++;
8014 tbl->map[tbl->size] = del
8018 : (short) TR_R_EMPTY;
8019 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
8020 for (i = 0; i < tbl->size; i++) {
8021 if (tbl->map[i] < 0) {
8022 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
8023 (unsigned) i, tbl->map[i]));
8026 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
8027 (unsigned) i, tbl->map[i]));
8029 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
8030 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
8033 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
8034 (unsigned) tbl->size, tbl->map[tbl->size]));
8036 SvREFCNT_dec(t_invlist);
8038 #if 0 /* code that added excess above-255 chars at the end of the table, in
8039 case we ever want to not use the inversion map implementation for
8046 /* More replacement chars than search chars:
8047 * store excess replacement chars at end of main table.
8050 struct_size += excess;
8051 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
8052 struct_size + excess * sizeof(short));
8053 tbl->size += excess;
8054 cPVOPo->op_pv = (char*)tbl;
8056 for (i = 0; i < excess; i++)
8057 tbl->map[i + 256] = r[j+i];
8060 /* no more replacement chars than search chars */
8066 DEBUG_y(PerlIO_printf(Perl_debug_log,
8067 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
8068 " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
8069 del, squash, complement,
8070 cBOOL(o->op_private & OPpTRANS_IDENTICAL),
8071 cBOOL(o->op_private & OPpTRANS_USE_SVOP),
8072 cBOOL(o->op_private & OPpTRANS_GROWS),
8073 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
8078 if(del && rlen != 0 && r_count == t_count) {
8079 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
8080 } else if(r_count > t_count) {
8081 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
8094 Constructs, checks, and returns an op of any pattern matching type.
8095 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
8096 and, shifted up eight bits, the eight bits of C<op_private>.
8102 Perl_newPMOP(pTHX_ I32 type, I32 flags)
8107 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
8108 || type == OP_CUSTOM);
8110 NewOp(1101, pmop, 1, PMOP);
8111 OpTYPE_set(pmop, type);
8112 pmop->op_flags = (U8)flags;
8113 pmop->op_private = (U8)(0 | (flags >> 8));
8114 if (PL_opargs[type] & OA_RETSCALAR)
8117 if (PL_hints & HINT_RE_TAINT)
8118 pmop->op_pmflags |= PMf_RETAINT;
8119 #ifdef USE_LOCALE_CTYPE
8120 if (IN_LC_COMPILETIME(LC_CTYPE)) {
8121 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
8126 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
8128 if (PL_hints & HINT_RE_FLAGS) {
8129 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8130 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
8132 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
8133 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8134 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
8136 if (reflags && SvOK(reflags)) {
8137 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
8143 assert(SvPOK(PL_regex_pad[0]));
8144 if (SvCUR(PL_regex_pad[0])) {
8145 /* Pop off the "packed" IV from the end. */
8146 SV *const repointer_list = PL_regex_pad[0];
8147 const char *p = SvEND(repointer_list) - sizeof(IV);
8148 const IV offset = *((IV*)p);
8150 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
8152 SvEND_set(repointer_list, p);
8154 pmop->op_pmoffset = offset;
8155 /* This slot should be free, so assert this: */
8156 assert(PL_regex_pad[offset] == &PL_sv_undef);
8158 SV * const repointer = &PL_sv_undef;
8159 av_push(PL_regex_padav, repointer);
8160 pmop->op_pmoffset = av_tindex(PL_regex_padav);
8161 PL_regex_pad = AvARRAY(PL_regex_padav);
8165 return CHECKOP(type, pmop);
8173 /* Any pad names in scope are potentially lvalues. */
8174 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
8175 PADNAME *pn = PAD_COMPNAME_SV(i);
8176 if (!pn || !PadnameLEN(pn))
8178 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
8179 S_mark_padname_lvalue(aTHX_ pn);
8183 /* Given some sort of match op o, and an expression expr containing a
8184 * pattern, either compile expr into a regex and attach it to o (if it's
8185 * constant), or convert expr into a runtime regcomp op sequence (if it's
8188 * Flags currently has 2 bits of meaning:
8189 * 1: isreg indicates that the pattern is part of a regex construct, eg
8190 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
8191 * split "pattern", which aren't. In the former case, expr will be a list
8192 * if the pattern contains more than one term (eg /a$b/).
8193 * 2: The pattern is for a split.
8195 * When the pattern has been compiled within a new anon CV (for
8196 * qr/(?{...})/ ), then floor indicates the savestack level just before
8197 * the new sub was created
8199 * tr/// is also handled.
8203 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
8207 I32 repl_has_vars = 0;
8208 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
8209 bool is_compiletime;
8211 bool isreg = cBOOL(flags & 1);
8212 bool is_split = cBOOL(flags & 2);
8214 PERL_ARGS_ASSERT_PMRUNTIME;
8217 return pmtrans(o, expr, repl);
8220 /* find whether we have any runtime or code elements;
8221 * at the same time, temporarily set the op_next of each DO block;
8222 * then when we LINKLIST, this will cause the DO blocks to be excluded
8223 * from the op_next chain (and from having LINKLIST recursively
8224 * applied to them). We fix up the DOs specially later */
8228 if (expr->op_type == OP_LIST) {
8230 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8231 if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
8233 assert(!child->op_next);
8234 if (UNLIKELY(!OpHAS_SIBLING(child))) {
8235 assert(PL_parser && PL_parser->error_count);
8236 /* This can happen with qr/ (?{(^{})/. Just fake up
8237 the op we were expecting to see, to avoid crashing
8239 op_sibling_splice(expr, child, 0,
8240 newSVOP(OP_CONST, 0, &PL_sv_no));
8242 child->op_next = OpSIBLING(child);
8244 else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
8248 else if (expr->op_type != OP_CONST)
8253 /* fix up DO blocks; treat each one as a separate little sub;
8254 * also, mark any arrays as LIST/REF */
8256 if (expr->op_type == OP_LIST) {
8258 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8260 if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
8261 assert( !(child->op_flags & OPf_WANT));
8262 /* push the array rather than its contents. The regex
8263 * engine will retrieve and join the elements later */
8264 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
8268 if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
8270 child->op_next = NULL; /* undo temporary hack from above */
8273 if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
8274 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
8276 assert(leaveop->op_first->op_type == OP_ENTER);
8277 assert(OpHAS_SIBLING(leaveop->op_first));
8278 child->op_next = OpSIBLING(leaveop->op_first);
8280 assert(leaveop->op_flags & OPf_KIDS);
8281 assert(leaveop->op_last->op_next == (OP*)leaveop);
8282 leaveop->op_next = NULL; /* stop on last op */
8283 op_null((OP*)leaveop);
8287 OP *scope = cLISTOPx(child)->op_first;
8288 assert(scope->op_type == OP_SCOPE);
8289 assert(scope->op_flags & OPf_KIDS);
8290 scope->op_next = NULL; /* stop on last op */
8294 /* XXX optimize_optree() must be called on o before
8295 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
8296 * currently cope with a peephole-optimised optree.
8297 * Calling optimize_optree() here ensures that condition
8298 * is met, but may mean optimize_optree() is applied
8299 * to the same optree later (where hopefully it won't do any
8300 * harm as it can't convert an op to multiconcat if it's
8301 * already been converted */
8302 optimize_optree(child);
8304 /* have to peep the DOs individually as we've removed it from
8305 * the op_next chain */
8307 S_prune_chain_head(&(child->op_next));
8309 /* runtime finalizes as part of finalizing whole tree */
8310 finalize_optree(child);
8313 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
8314 assert( !(expr->op_flags & OPf_WANT));
8315 /* push the array rather than its contents. The regex
8316 * engine will retrieve and join the elements later */
8317 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
8320 PL_hints |= HINT_BLOCK_SCOPE;
8322 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
8324 if (is_compiletime) {
8325 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
8326 regexp_engine const *eng = current_re_engine();
8329 /* make engine handle split ' ' specially */
8330 pm->op_pmflags |= PMf_SPLIT;
8331 rx_flags |= RXf_SPLIT;
8334 if (!has_code || !eng->op_comp) {
8335 /* compile-time simple constant pattern */
8337 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
8338 /* whoops! we guessed that a qr// had a code block, but we
8339 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
8340 * that isn't required now. Note that we have to be pretty
8341 * confident that nothing used that CV's pad while the
8342 * regex was parsed, except maybe op targets for \Q etc.
8343 * If there were any op targets, though, they should have
8344 * been stolen by constant folding.
8348 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
8349 while (++i <= AvFILLp(PL_comppad)) {
8350 # ifdef USE_PAD_RESET
8351 /* under USE_PAD_RESET, pad swipe replaces a swiped
8352 * folded constant with a fresh padtmp */
8353 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
8355 assert(!PL_curpad[i]);
8359 /* This LEAVE_SCOPE will restore PL_compcv to point to the
8360 * outer CV (the one whose slab holds the pm op). The
8361 * inner CV (which holds expr) will be freed later, once
8362 * all the entries on the parse stack have been popped on
8363 * return from this function. Which is why its safe to
8364 * call op_free(expr) below.
8367 pm->op_pmflags &= ~PMf_HAS_CV;
8370 /* Skip compiling if parser found an error for this pattern */
8371 if (pm->op_pmflags & PMf_HAS_ERROR) {
8377 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8378 rx_flags, pm->op_pmflags)
8379 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8380 rx_flags, pm->op_pmflags)
8385 /* compile-time pattern that includes literal code blocks */
8389 /* Skip compiling if parser found an error for this pattern */
8390 if (pm->op_pmflags & PMf_HAS_ERROR) {
8394 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8397 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
8400 if (pm->op_pmflags & PMf_HAS_CV) {
8402 /* this QR op (and the anon sub we embed it in) is never
8403 * actually executed. It's just a placeholder where we can
8404 * squirrel away expr in op_code_list without the peephole
8405 * optimiser etc processing it for a second time */
8406 OP *qr = newPMOP(OP_QR, 0);
8407 ((PMOP*)qr)->op_code_list = expr;
8409 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
8410 SvREFCNT_inc_simple_void(PL_compcv);
8411 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8412 ReANY(re)->qr_anoncv = cv;
8414 /* attach the anon CV to the pad so that
8415 * pad_fixup_inner_anons() can find it */
8416 (void)pad_add_anon(cv, o->op_type);
8417 SvREFCNT_inc_simple_void(cv);
8420 pm->op_code_list = expr;
8425 /* runtime pattern: build chain of regcomp etc ops */
8427 PADOFFSET cv_targ = 0;
8429 reglist = isreg && expr->op_type == OP_LIST;
8434 pm->op_code_list = expr;
8435 /* don't free op_code_list; its ops are embedded elsewhere too */
8436 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
8440 /* make engine handle split ' ' specially */
8441 pm->op_pmflags |= PMf_SPLIT;
8443 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
8444 * to allow its op_next to be pointed past the regcomp and
8445 * preceding stacking ops;
8446 * OP_REGCRESET is there to reset taint before executing the
8448 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
8449 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
8451 if (pm->op_pmflags & PMf_HAS_CV) {
8452 /* we have a runtime qr with literal code. This means
8453 * that the qr// has been wrapped in a new CV, which
8454 * means that runtime consts, vars etc will have been compiled
8455 * against a new pad. So... we need to execute those ops
8456 * within the environment of the new CV. So wrap them in a call
8457 * to a new anon sub. i.e. for
8461 * we build an anon sub that looks like
8463 * sub { "a", $b, '(?{...})' }
8465 * and call it, passing the returned list to regcomp.
8466 * Or to put it another way, the list of ops that get executed
8470 * ------ -------------------
8471 * pushmark (for regcomp)
8472 * pushmark (for entersub)
8476 * regcreset regcreset
8478 * const("a") const("a")
8480 * const("(?{...})") const("(?{...})")
8485 SvREFCNT_inc_simple_void(PL_compcv);
8486 CvLVALUE_on(PL_compcv);
8487 /* these lines are just an unrolled newANONATTRSUB */
8488 expr = newSVOP(OP_ANONCODE, 0,
8489 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
8490 cv_targ = expr->op_targ;
8491 expr = newUNOP(OP_REFGEN, 0, expr);
8493 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
8496 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
8497 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
8498 | (reglist ? OPf_STACKED : 0);
8499 rcop->op_targ = cv_targ;
8501 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
8502 if (PL_hints & HINT_RE_EVAL)
8503 S_set_haseval(aTHX);
8505 /* establish postfix order */
8506 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
8508 rcop->op_next = expr;
8509 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
8512 rcop->op_next = LINKLIST(expr);
8513 expr->op_next = (OP*)rcop;
8516 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
8522 /* If we are looking at s//.../e with a single statement, get past
8523 the implicit do{}. */
8524 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
8525 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
8526 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
8529 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
8530 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
8531 && !OpHAS_SIBLING(sib))
8534 if (curop->op_type == OP_CONST)
8536 else if (( (curop->op_type == OP_RV2SV ||
8537 curop->op_type == OP_RV2AV ||
8538 curop->op_type == OP_RV2HV ||
8539 curop->op_type == OP_RV2GV)
8540 && cUNOPx(curop)->op_first
8541 && cUNOPx(curop)->op_first->op_type == OP_GV )
8542 || curop->op_type == OP_PADSV
8543 || curop->op_type == OP_PADAV
8544 || curop->op_type == OP_PADHV
8545 || curop->op_type == OP_PADANY) {
8553 || !RX_PRELEN(PM_GETRE(pm))
8554 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
8556 pm->op_pmflags |= PMf_CONST; /* const for long enough */
8557 op_prepend_elem(o->op_type, scalar(repl), o);
8560 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
8561 rcop->op_private = 1;
8563 /* establish postfix order */
8564 rcop->op_next = LINKLIST(repl);
8565 repl->op_next = (OP*)rcop;
8567 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
8568 assert(!(pm->op_pmflags & PMf_ONCE));
8569 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
8580 Constructs, checks, and returns an op of any type that involves an
8581 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
8582 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
8583 takes ownership of one reference to it.
8589 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
8594 PERL_ARGS_ASSERT_NEWSVOP;
8596 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8597 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8598 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8599 || type == OP_CUSTOM);
8601 NewOp(1101, svop, 1, SVOP);
8602 OpTYPE_set(svop, type);
8604 svop->op_next = (OP*)svop;
8605 svop->op_flags = (U8)flags;
8606 svop->op_private = (U8)(0 | (flags >> 8));
8607 if (PL_opargs[type] & OA_RETSCALAR)
8609 if (PL_opargs[type] & OA_TARGET)
8610 svop->op_targ = pad_alloc(type, SVs_PADTMP);
8611 return CHECKOP(type, svop);
8615 =for apidoc newDEFSVOP
8617 Constructs and returns an op to access C<$_>.
8623 Perl_newDEFSVOP(pTHX)
8625 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
8631 =for apidoc newPADOP
8633 Constructs, checks, and returns an op of any type that involves a
8634 reference to a pad element. C<type> is the opcode. C<flags> gives the
8635 eight bits of C<op_flags>. A pad slot is automatically allocated, and
8636 is populated with C<sv>; this function takes ownership of one reference
8639 This function only exists if Perl has been compiled to use ithreads.
8645 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
8650 PERL_ARGS_ASSERT_NEWPADOP;
8652 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8653 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8654 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8655 || type == OP_CUSTOM);
8657 NewOp(1101, padop, 1, PADOP);
8658 OpTYPE_set(padop, type);
8660 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
8661 SvREFCNT_dec(PAD_SVl(padop->op_padix));
8662 PAD_SETSV(padop->op_padix, sv);
8664 padop->op_next = (OP*)padop;
8665 padop->op_flags = (U8)flags;
8666 if (PL_opargs[type] & OA_RETSCALAR)
8668 if (PL_opargs[type] & OA_TARGET)
8669 padop->op_targ = pad_alloc(type, SVs_PADTMP);
8670 return CHECKOP(type, padop);
8673 #endif /* USE_ITHREADS */
8678 Constructs, checks, and returns an op of any type that involves an
8679 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
8680 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
8681 reference; calling this function does not transfer ownership of any
8688 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
8690 PERL_ARGS_ASSERT_NEWGVOP;
8693 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8695 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8702 Constructs, checks, and returns an op of any type that involves an
8703 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
8704 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
8705 Depending on the op type, the memory referenced by C<pv> may be freed
8706 when the op is destroyed. If the op is of a freeing type, C<pv> must
8707 have been allocated using C<PerlMemShared_malloc>.
8713 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
8716 const bool utf8 = cBOOL(flags & SVf_UTF8);
8721 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8722 || type == OP_RUNCV || type == OP_CUSTOM
8723 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
8725 NewOp(1101, pvop, 1, PVOP);
8726 OpTYPE_set(pvop, type);
8728 pvop->op_next = (OP*)pvop;
8729 pvop->op_flags = (U8)flags;
8730 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
8731 if (PL_opargs[type] & OA_RETSCALAR)
8733 if (PL_opargs[type] & OA_TARGET)
8734 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
8735 return CHECKOP(type, pvop);
8739 Perl_package(pTHX_ OP *o)
8741 SV *const sv = cSVOPo->op_sv;
8743 PERL_ARGS_ASSERT_PACKAGE;
8745 SAVEGENERICSV(PL_curstash);
8746 save_item(PL_curstname);
8748 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
8750 sv_setsv(PL_curstname, sv);
8752 PL_hints |= HINT_BLOCK_SCOPE;
8753 PL_parser->copline = NOLINE;
8759 Perl_package_version( pTHX_ OP *v )
8761 U32 savehints = PL_hints;
8762 PERL_ARGS_ASSERT_PACKAGE_VERSION;
8763 PL_hints &= ~HINT_STRICT_VARS;
8764 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
8765 PL_hints = savehints;
8770 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
8775 SV *use_version = NULL;
8777 PERL_ARGS_ASSERT_UTILIZE;
8779 if (idop->op_type != OP_CONST)
8780 Perl_croak(aTHX_ "Module name must be constant");
8785 SV * const vesv = ((SVOP*)version)->op_sv;
8787 if (!arg && !SvNIOKp(vesv)) {
8794 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
8795 Perl_croak(aTHX_ "Version number must be a constant number");
8797 /* Make copy of idop so we don't free it twice */
8798 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8800 /* Fake up a method call to VERSION */
8801 meth = newSVpvs_share("VERSION");
8802 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8803 op_append_elem(OP_LIST,
8804 op_prepend_elem(OP_LIST, pack, version),
8805 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
8809 /* Fake up an import/unimport */
8810 if (arg && arg->op_type == OP_STUB) {
8811 imop = arg; /* no import on explicit () */
8813 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
8814 imop = NULL; /* use 5.0; */
8816 use_version = ((SVOP*)idop)->op_sv;
8818 idop->op_private |= OPpCONST_NOVER;
8823 /* Make copy of idop so we don't free it twice */
8824 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8826 /* Fake up a method call to import/unimport */
8828 ? newSVpvs_share("import") : newSVpvs_share("unimport");
8829 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8830 op_append_elem(OP_LIST,
8831 op_prepend_elem(OP_LIST, pack, arg),
8832 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
8836 /* Fake up the BEGIN {}, which does its thing immediately. */
8838 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
8841 op_append_elem(OP_LINESEQ,
8842 op_append_elem(OP_LINESEQ,
8843 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
8844 newSTATEOP(0, NULL, veop)),
8845 newSTATEOP(0, NULL, imop) ));
8849 * feature bundle that corresponds to the required version. */
8850 use_version = sv_2mortal(new_version(use_version));
8851 S_enable_feature_bundle(aTHX_ use_version);
8853 /* If a version >= 5.11.0 is requested, strictures are on by default! */
8854 if (vcmp(use_version,
8855 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
8856 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8857 PL_hints |= HINT_STRICT_REFS;
8858 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8859 PL_hints |= HINT_STRICT_SUBS;
8860 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8861 PL_hints |= HINT_STRICT_VARS;
8863 /* otherwise they are off */
8865 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8866 PL_hints &= ~HINT_STRICT_REFS;
8867 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8868 PL_hints &= ~HINT_STRICT_SUBS;
8869 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8870 PL_hints &= ~HINT_STRICT_VARS;
8874 /* The "did you use incorrect case?" warning used to be here.
8875 * The problem is that on case-insensitive filesystems one
8876 * might get false positives for "use" (and "require"):
8877 * "use Strict" or "require CARP" will work. This causes
8878 * portability problems for the script: in case-strict
8879 * filesystems the script will stop working.
8881 * The "incorrect case" warning checked whether "use Foo"
8882 * imported "Foo" to your namespace, but that is wrong, too:
8883 * there is no requirement nor promise in the language that
8884 * a Foo.pm should or would contain anything in package "Foo".
8886 * There is very little Configure-wise that can be done, either:
8887 * the case-sensitivity of the build filesystem of Perl does not
8888 * help in guessing the case-sensitivity of the runtime environment.
8891 PL_hints |= HINT_BLOCK_SCOPE;
8892 PL_parser->copline = NOLINE;
8893 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
8897 =head1 Embedding Functions
8899 =for apidoc load_module
8901 Loads the module whose name is pointed to by the string part of C<name>.
8902 Note that the actual module name, not its filename, should be given.
8903 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
8904 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
8905 trailing arguments can be used to specify arguments to the module's C<import()>
8906 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
8907 on the flags. The flags argument is a bitwise-ORed collection of any of
8908 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
8909 (or 0 for no flags).
8911 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
8912 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
8913 the trailing optional arguments may be omitted entirely. Otherwise, if
8914 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
8915 exactly one C<OP*>, containing the op tree that produces the relevant import
8916 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
8917 will be used as import arguments; and the list must be terminated with C<(SV*)
8918 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
8919 set, the trailing C<NULL> pointer is needed even if no import arguments are
8920 desired. The reference count for each specified C<SV*> argument is
8921 decremented. In addition, the C<name> argument is modified.
8923 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
8926 =for apidoc Amnh||PERL_LOADMOD_DENY
8927 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
8928 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
8933 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
8937 PERL_ARGS_ASSERT_LOAD_MODULE;
8939 va_start(args, ver);
8940 vload_module(flags, name, ver, &args);
8944 #ifdef PERL_IMPLICIT_CONTEXT
8946 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8950 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8951 va_start(args, ver);
8952 vload_module(flags, name, ver, &args);
8958 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8964 PERL_ARGS_ASSERT_VLOAD_MODULE;
8966 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8967 * that it has a PL_parser to play with while doing that, and also
8968 * that it doesn't mess with any existing parser, by creating a tmp
8969 * new parser with lex_start(). This won't actually be used for much,
8970 * since pp_require() will create another parser for the real work.
8971 * The ENTER/LEAVE pair protect callers from any side effects of use.
8973 * start_subparse() creates a new PL_compcv. This means that any ops
8974 * allocated below will be allocated from that CV's op slab, and so
8975 * will be automatically freed if the utilise() fails
8979 SAVEVPTR(PL_curcop);
8980 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8981 floor = start_subparse(FALSE, 0);
8983 modname = newSVOP(OP_CONST, 0, name);
8984 modname->op_private |= OPpCONST_BARE;
8986 veop = newSVOP(OP_CONST, 0, ver);
8990 if (flags & PERL_LOADMOD_NOIMPORT) {
8991 imop = sawparens(newNULLLIST());
8993 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8994 imop = va_arg(*args, OP*);
8999 sv = va_arg(*args, SV*);
9001 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
9002 sv = va_arg(*args, SV*);
9006 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
9010 PERL_STATIC_INLINE OP *
9011 S_new_entersubop(pTHX_ GV *gv, OP *arg)
9013 return newUNOP(OP_ENTERSUB, OPf_STACKED,
9014 newLISTOP(OP_LIST, 0, arg,
9015 newUNOP(OP_RV2CV, 0,
9016 newGVOP(OP_GV, 0, gv))));
9020 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
9025 PERL_ARGS_ASSERT_DOFILE;
9027 if (!force_builtin && (gv = gv_override("do", 2))) {
9028 doop = S_new_entersubop(aTHX_ gv, term);
9031 doop = newUNOP(OP_DOFILE, 0, scalar(term));
9037 =head1 Optree construction
9039 =for apidoc newSLICEOP
9041 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
9042 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
9043 be set automatically, and, shifted up eight bits, the eight bits of
9044 C<op_private>, except that the bit with value 1 or 2 is automatically
9045 set as required. C<listval> and C<subscript> supply the parameters of
9046 the slice; they are consumed by this function and become part of the
9047 constructed op tree.
9053 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
9055 return newBINOP(OP_LSLICE, flags,
9056 list(force_list(subscript, 1)),
9057 list(force_list(listval, 1)) );
9060 #define ASSIGN_SCALAR 0
9061 #define ASSIGN_LIST 1
9062 #define ASSIGN_REF 2
9064 /* given the optree o on the LHS of an assignment, determine whether its:
9065 * ASSIGN_SCALAR $x = ...
9066 * ASSIGN_LIST ($x) = ...
9067 * ASSIGN_REF \$x = ...
9071 S_assignment_type(pTHX_ const OP *o)
9080 if (o->op_type == OP_SREFGEN)
9082 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
9083 type = kid->op_type;
9084 flags = o->op_flags | kid->op_flags;
9085 if (!(flags & OPf_PARENS)
9086 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
9087 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
9091 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
9092 o = cUNOPo->op_first;
9093 flags = o->op_flags;
9095 ret = ASSIGN_SCALAR;
9098 if (type == OP_COND_EXPR) {
9099 OP * const sib = OpSIBLING(cLOGOPo->op_first);
9100 const I32 t = assignment_type(sib);
9101 const I32 f = assignment_type(OpSIBLING(sib));
9103 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
9105 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
9106 yyerror("Assignment to both a list and a scalar");
9107 return ASSIGN_SCALAR;
9110 if (type == OP_LIST &&
9111 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
9112 o->op_private & OPpLVAL_INTRO)
9115 if (type == OP_LIST || flags & OPf_PARENS ||
9116 type == OP_RV2AV || type == OP_RV2HV ||
9117 type == OP_ASLICE || type == OP_HSLICE ||
9118 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
9121 if (type == OP_PADAV || type == OP_PADHV)
9124 if (type == OP_RV2SV)
9131 S_newONCEOP(pTHX_ OP *initop, OP *padop)
9134 const PADOFFSET target = padop->op_targ;
9135 OP *const other = newOP(OP_PADSV,
9137 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
9138 OP *const first = newOP(OP_NULL, 0);
9139 OP *const nullop = newCONDOP(0, first, initop, other);
9140 /* XXX targlex disabled for now; see ticket #124160
9141 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
9143 OP *const condop = first->op_next;
9145 OpTYPE_set(condop, OP_ONCE);
9146 other->op_targ = target;
9147 nullop->op_flags |= OPf_WANT_SCALAR;
9149 /* Store the initializedness of state vars in a separate
9152 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
9153 /* hijacking PADSTALE for uninitialized state variables */
9154 SvPADSTALE_on(PAD_SVl(condop->op_targ));
9160 =for apidoc newASSIGNOP
9162 Constructs, checks, and returns an assignment op. C<left> and C<right>
9163 supply the parameters of the assignment; they are consumed by this
9164 function and become part of the constructed op tree.
9166 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
9167 a suitable conditional optree is constructed. If C<optype> is the opcode
9168 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
9169 performs the binary operation and assigns the result to the left argument.
9170 Either way, if C<optype> is non-zero then C<flags> has no effect.
9172 If C<optype> is zero, then a plain scalar or list assignment is
9173 constructed. Which type of assignment it is is automatically determined.
9174 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9175 will be set automatically, and, shifted up eight bits, the eight bits
9176 of C<op_private>, except that the bit with value 1 or 2 is automatically
9183 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
9189 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
9190 right = scalar(right);
9191 return newLOGOP(optype, 0,
9192 op_lvalue(scalar(left), optype),
9193 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
9196 return newBINOP(optype, OPf_STACKED,
9197 op_lvalue(scalar(left), optype), scalar(right));
9201 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
9202 OP *state_var_op = NULL;
9203 static const char no_list_state[] = "Initialization of state variables"
9204 " in list currently forbidden";
9207 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
9208 left->op_private &= ~ OPpSLICEWARNING;
9211 left = op_lvalue(left, OP_AASSIGN);
9212 curop = list(force_list(left, 1));
9213 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
9214 o->op_private = (U8)(0 | (flags >> 8));
9216 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
9218 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
9219 if (!(left->op_flags & OPf_PARENS) &&
9220 lop->op_type == OP_PUSHMARK &&
9221 (vop = OpSIBLING(lop)) &&
9222 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
9223 !(vop->op_flags & OPf_PARENS) &&
9224 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
9225 (OPpLVAL_INTRO|OPpPAD_STATE) &&
9226 (eop = OpSIBLING(vop)) &&
9227 eop->op_type == OP_ENTERSUB &&
9228 !OpHAS_SIBLING(eop)) {
9232 if ((lop->op_type == OP_PADSV ||
9233 lop->op_type == OP_PADAV ||
9234 lop->op_type == OP_PADHV ||
9235 lop->op_type == OP_PADANY)
9236 && (lop->op_private & OPpPAD_STATE)
9238 yyerror(no_list_state);
9239 lop = OpSIBLING(lop);
9243 else if ( (left->op_private & OPpLVAL_INTRO)
9244 && (left->op_private & OPpPAD_STATE)
9245 && ( left->op_type == OP_PADSV
9246 || left->op_type == OP_PADAV
9247 || left->op_type == OP_PADHV
9248 || left->op_type == OP_PADANY)
9250 /* All single variable list context state assignments, hence
9260 if (left->op_flags & OPf_PARENS)
9261 yyerror(no_list_state);
9263 state_var_op = left;
9266 /* optimise @a = split(...) into:
9267 * @{expr}: split(..., @{expr}) (where @a is not flattened)
9268 * @a, my @a, local @a: split(...) (where @a is attached to
9269 * the split op itself)
9273 && right->op_type == OP_SPLIT
9274 /* don't do twice, e.g. @b = (@a = split) */
9275 && !(right->op_private & OPpSPLIT_ASSIGN))
9279 if ( ( left->op_type == OP_RV2AV
9280 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
9281 || left->op_type == OP_PADAV)
9283 /* @pkg or @lex or local @pkg' or 'my @lex' */
9287 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
9288 = cPADOPx(gvop)->op_padix;
9289 cPADOPx(gvop)->op_padix = 0; /* steal it */
9291 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
9292 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
9293 cSVOPx(gvop)->op_sv = NULL; /* steal it */
9295 right->op_private |=
9296 left->op_private & OPpOUR_INTRO;
9299 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
9300 left->op_targ = 0; /* steal it */
9301 right->op_private |= OPpSPLIT_LEX;
9303 right->op_private |= left->op_private & OPpLVAL_INTRO;
9306 tmpop = cUNOPo->op_first; /* to list (nulled) */
9307 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
9308 assert(OpSIBLING(tmpop) == right);
9309 assert(!OpHAS_SIBLING(right));
9310 /* detach the split subtreee from the o tree,
9311 * then free the residual o tree */
9312 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
9313 op_free(o); /* blow off assign */
9314 right->op_private |= OPpSPLIT_ASSIGN;
9315 right->op_flags &= ~OPf_WANT;
9316 /* "I don't know and I don't care." */
9319 else if (left->op_type == OP_RV2AV) {
9322 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
9323 assert(OpSIBLING(pushop) == left);
9324 /* Detach the array ... */
9325 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
9326 /* ... and attach it to the split. */
9327 op_sibling_splice(right, cLISTOPx(right)->op_last,
9329 right->op_flags |= OPf_STACKED;
9330 /* Detach split and expunge aassign as above. */
9333 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
9334 ((LISTOP*)right)->op_last->op_type == OP_CONST)
9336 /* convert split(...,0) to split(..., PL_modcount+1) */
9338 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
9339 SV * const sv = *svp;
9340 if (SvIOK(sv) && SvIVX(sv) == 0)
9342 if (right->op_private & OPpSPLIT_IMPLIM) {
9343 /* our own SV, created in ck_split */
9345 sv_setiv(sv, PL_modcount+1);
9348 /* SV may belong to someone else */
9350 *svp = newSViv(PL_modcount+1);
9357 o = S_newONCEOP(aTHX_ o, state_var_op);
9360 if (assign_type == ASSIGN_REF)
9361 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
9363 right = newOP(OP_UNDEF, 0);
9364 if (right->op_type == OP_READLINE) {
9365 right->op_flags |= OPf_STACKED;
9366 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
9370 o = newBINOP(OP_SASSIGN, flags,
9371 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
9377 =for apidoc newSTATEOP
9379 Constructs a state op (COP). The state op is normally a C<nextstate> op,
9380 but will be a C<dbstate> op if debugging is enabled for currently-compiled
9381 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
9382 If C<label> is non-null, it supplies the name of a label to attach to
9383 the state op; this function takes ownership of the memory pointed at by
9384 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
9387 If C<o> is null, the state op is returned. Otherwise the state op is
9388 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
9389 is consumed by this function and becomes part of the returned op tree.
9395 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
9398 const U32 seq = intro_my();
9399 const U32 utf8 = flags & SVf_UTF8;
9402 PL_parser->parsed_sub = 0;
9406 NewOp(1101, cop, 1, COP);
9407 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
9408 OpTYPE_set(cop, OP_DBSTATE);
9411 OpTYPE_set(cop, OP_NEXTSTATE);
9413 cop->op_flags = (U8)flags;
9414 CopHINTS_set(cop, PL_hints);
9416 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
9418 cop->op_next = (OP*)cop;
9421 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9422 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
9424 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
9426 PL_hints |= HINT_BLOCK_SCOPE;
9427 /* It seems that we need to defer freeing this pointer, as other parts
9428 of the grammar end up wanting to copy it after this op has been
9433 if (PL_parser->preambling != NOLINE) {
9434 CopLINE_set(cop, PL_parser->preambling);
9435 PL_parser->copline = NOLINE;
9437 else if (PL_parser->copline == NOLINE)
9438 CopLINE_set(cop, CopLINE(PL_curcop));
9440 CopLINE_set(cop, PL_parser->copline);
9441 PL_parser->copline = NOLINE;
9444 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
9446 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
9448 CopSTASH_set(cop, PL_curstash);
9450 if (cop->op_type == OP_DBSTATE) {
9451 /* this line can have a breakpoint - store the cop in IV */
9452 AV *av = CopFILEAVx(PL_curcop);
9454 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
9455 if (svp && *svp != &PL_sv_undef ) {
9456 (void)SvIOK_on(*svp);
9457 SvIV_set(*svp, PTR2IV(cop));
9462 if (flags & OPf_SPECIAL)
9464 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
9468 =for apidoc newLOGOP
9470 Constructs, checks, and returns a logical (flow control) op. C<type>
9471 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
9472 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
9473 the eight bits of C<op_private>, except that the bit with value 1 is
9474 automatically set. C<first> supplies the expression controlling the
9475 flow, and C<other> supplies the side (alternate) chain of ops; they are
9476 consumed by this function and become part of the constructed op tree.
9482 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
9484 PERL_ARGS_ASSERT_NEWLOGOP;
9486 return new_logop(type, flags, &first, &other);
9490 /* See if the optree o contains a single OP_CONST (plus possibly
9491 * surrounding enter/nextstate/null etc). If so, return it, else return
9496 S_search_const(pTHX_ OP *o)
9498 PERL_ARGS_ASSERT_SEARCH_CONST;
9501 switch (o->op_type) {
9505 if (o->op_flags & OPf_KIDS) {
9506 o = cUNOPo->op_first;
9515 if (!(o->op_flags & OPf_KIDS))
9517 kid = cLISTOPo->op_first;
9520 switch (kid->op_type) {
9524 kid = OpSIBLING(kid);
9527 if (kid != cLISTOPo->op_last)
9534 kid = cLISTOPo->op_last;
9546 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
9554 int prepend_not = 0;
9556 PERL_ARGS_ASSERT_NEW_LOGOP;
9561 /* [perl #59802]: Warn about things like "return $a or $b", which
9562 is parsed as "(return $a) or $b" rather than "return ($a or
9563 $b)". NB: This also applies to xor, which is why we do it
9566 switch (first->op_type) {
9570 /* XXX: Perhaps we should emit a stronger warning for these.
9571 Even with the high-precedence operator they don't seem to do
9574 But until we do, fall through here.
9580 /* XXX: Currently we allow people to "shoot themselves in the
9581 foot" by explicitly writing "(return $a) or $b".
9583 Warn unless we are looking at the result from folding or if
9584 the programmer explicitly grouped the operators like this.
9585 The former can occur with e.g.
9587 use constant FEATURE => ( $] >= ... );
9588 sub { not FEATURE and return or do_stuff(); }
9590 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
9591 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9592 "Possible precedence issue with control flow operator");
9593 /* XXX: Should we optimze this to "return $a;" (i.e. remove
9599 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
9600 return newBINOP(type, flags, scalar(first), scalar(other));
9602 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
9603 || type == OP_CUSTOM);
9605 scalarboolean(first);
9607 /* search for a constant op that could let us fold the test */
9608 if ((cstop = search_const(first))) {
9609 if (cstop->op_private & OPpCONST_STRICT)
9610 no_bareword_allowed(cstop);
9611 else if ((cstop->op_private & OPpCONST_BARE))
9612 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
9613 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
9614 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
9615 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
9616 /* Elide the (constant) lhs, since it can't affect the outcome */
9618 if (other->op_type == OP_CONST)
9619 other->op_private |= OPpCONST_SHORTCIRCUIT;
9621 if (other->op_type == OP_LEAVE)
9622 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
9623 else if (other->op_type == OP_MATCH
9624 || other->op_type == OP_SUBST
9625 || other->op_type == OP_TRANSR
9626 || other->op_type == OP_TRANS)
9627 /* Mark the op as being unbindable with =~ */
9628 other->op_flags |= OPf_SPECIAL;
9630 other->op_folded = 1;
9634 /* Elide the rhs, since the outcome is entirely determined by
9635 * the (constant) lhs */
9637 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
9638 const OP *o2 = other;
9639 if ( ! (o2->op_type == OP_LIST
9640 && (( o2 = cUNOPx(o2)->op_first))
9641 && o2->op_type == OP_PUSHMARK
9642 && (( o2 = OpSIBLING(o2))) )
9645 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
9646 || o2->op_type == OP_PADHV)
9647 && o2->op_private & OPpLVAL_INTRO
9648 && !(o2->op_private & OPpPAD_STATE))
9650 Perl_croak(aTHX_ "This use of my() in false conditional is "
9651 "no longer allowed");
9655 if (cstop->op_type == OP_CONST)
9656 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
9661 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
9662 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
9664 const OP * const k1 = ((UNOP*)first)->op_first;
9665 const OP * const k2 = OpSIBLING(k1);
9667 switch (first->op_type)
9670 if (k2 && k2->op_type == OP_READLINE
9671 && (k2->op_flags & OPf_STACKED)
9672 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9674 warnop = k2->op_type;
9679 if (k1->op_type == OP_READDIR
9680 || k1->op_type == OP_GLOB
9681 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9682 || k1->op_type == OP_EACH
9683 || k1->op_type == OP_AEACH)
9685 warnop = ((k1->op_type == OP_NULL)
9686 ? (OPCODE)k1->op_targ : k1->op_type);
9691 const line_t oldline = CopLINE(PL_curcop);
9692 /* This ensures that warnings are reported at the first line
9693 of the construction, not the last. */
9694 CopLINE_set(PL_curcop, PL_parser->copline);
9695 Perl_warner(aTHX_ packWARN(WARN_MISC),
9696 "Value of %s%s can be \"0\"; test with defined()",
9698 ((warnop == OP_READLINE || warnop == OP_GLOB)
9699 ? " construct" : "() operator"));
9700 CopLINE_set(PL_curcop, oldline);
9704 /* optimize AND and OR ops that have NOTs as children */
9705 if (first->op_type == OP_NOT
9706 && (first->op_flags & OPf_KIDS)
9707 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
9708 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
9710 if (type == OP_AND || type == OP_OR) {
9716 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
9718 prepend_not = 1; /* prepend a NOT op later */
9723 logop = alloc_LOGOP(type, first, LINKLIST(other));
9724 logop->op_flags |= (U8)flags;
9725 logop->op_private = (U8)(1 | (flags >> 8));
9727 /* establish postfix order */
9728 logop->op_next = LINKLIST(first);
9729 first->op_next = (OP*)logop;
9730 assert(!OpHAS_SIBLING(first));
9731 op_sibling_splice((OP*)logop, first, 0, other);
9733 CHECKOP(type,logop);
9735 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
9736 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
9744 =for apidoc newCONDOP
9746 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
9747 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9748 will be set automatically, and, shifted up eight bits, the eight bits of
9749 C<op_private>, except that the bit with value 1 is automatically set.
9750 C<first> supplies the expression selecting between the two branches,
9751 and C<trueop> and C<falseop> supply the branches; they are consumed by
9752 this function and become part of the constructed op tree.
9758 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
9766 PERL_ARGS_ASSERT_NEWCONDOP;
9769 return newLOGOP(OP_AND, 0, first, trueop);
9771 return newLOGOP(OP_OR, 0, first, falseop);
9773 scalarboolean(first);
9774 if ((cstop = search_const(first))) {
9775 /* Left or right arm of the conditional? */
9776 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
9777 OP *live = left ? trueop : falseop;
9778 OP *const dead = left ? falseop : trueop;
9779 if (cstop->op_private & OPpCONST_BARE &&
9780 cstop->op_private & OPpCONST_STRICT) {
9781 no_bareword_allowed(cstop);
9785 if (live->op_type == OP_LEAVE)
9786 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
9787 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
9788 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
9789 /* Mark the op as being unbindable with =~ */
9790 live->op_flags |= OPf_SPECIAL;
9791 live->op_folded = 1;
9794 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
9795 logop->op_flags |= (U8)flags;
9796 logop->op_private = (U8)(1 | (flags >> 8));
9797 logop->op_next = LINKLIST(falseop);
9799 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
9802 /* establish postfix order */
9803 start = LINKLIST(first);
9804 first->op_next = (OP*)logop;
9806 /* make first, trueop, falseop siblings */
9807 op_sibling_splice((OP*)logop, first, 0, trueop);
9808 op_sibling_splice((OP*)logop, trueop, 0, falseop);
9810 o = newUNOP(OP_NULL, 0, (OP*)logop);
9812 trueop->op_next = falseop->op_next = o;
9819 =for apidoc newRANGE
9821 Constructs and returns a C<range> op, with subordinate C<flip> and
9822 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
9823 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
9824 for both the C<flip> and C<range> ops, except that the bit with value
9825 1 is automatically set. C<left> and C<right> supply the expressions
9826 controlling the endpoints of the range; they are consumed by this function
9827 and become part of the constructed op tree.
9833 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
9841 PERL_ARGS_ASSERT_NEWRANGE;
9843 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
9844 range->op_flags = OPf_KIDS;
9845 leftstart = LINKLIST(left);
9846 range->op_private = (U8)(1 | (flags >> 8));
9848 /* make left and right siblings */
9849 op_sibling_splice((OP*)range, left, 0, right);
9851 range->op_next = (OP*)range;
9852 flip = newUNOP(OP_FLIP, flags, (OP*)range);
9853 flop = newUNOP(OP_FLOP, 0, flip);
9854 o = newUNOP(OP_NULL, 0, flop);
9856 range->op_next = leftstart;
9858 left->op_next = flip;
9859 right->op_next = flop;
9862 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9863 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9865 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9866 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9867 SvPADTMP_on(PAD_SV(flip->op_targ));
9869 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9870 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9872 /* check barewords before they might be optimized aways */
9873 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9874 no_bareword_allowed(left);
9875 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9876 no_bareword_allowed(right);
9879 if (!flip->op_private || !flop->op_private)
9880 LINKLIST(o); /* blow off optimizer unless constant */
9886 =for apidoc newLOOPOP
9888 Constructs, checks, and returns an op tree expressing a loop. This is
9889 only a loop in the control flow through the op tree; it does not have
9890 the heavyweight loop structure that allows exiting the loop by C<last>
9891 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
9892 top-level op, except that some bits will be set automatically as required.
9893 C<expr> supplies the expression controlling loop iteration, and C<block>
9894 supplies the body of the loop; they are consumed by this function and
9895 become part of the constructed op tree. C<debuggable> is currently
9896 unused and should always be 1.
9902 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9906 const bool once = block && block->op_flags & OPf_SPECIAL &&
9907 block->op_type == OP_NULL;
9909 PERL_UNUSED_ARG(debuggable);
9913 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
9914 || ( expr->op_type == OP_NOT
9915 && cUNOPx(expr)->op_first->op_type == OP_CONST
9916 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9919 /* Return the block now, so that S_new_logop does not try to
9923 return block; /* do {} while 0 does once */
9926 if (expr->op_type == OP_READLINE
9927 || expr->op_type == OP_READDIR
9928 || expr->op_type == OP_GLOB
9929 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9930 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9931 expr = newUNOP(OP_DEFINED, 0,
9932 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9933 } else if (expr->op_flags & OPf_KIDS) {
9934 const OP * const k1 = ((UNOP*)expr)->op_first;
9935 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9936 switch (expr->op_type) {
9938 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9939 && (k2->op_flags & OPf_STACKED)
9940 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9941 expr = newUNOP(OP_DEFINED, 0, expr);
9945 if (k1 && (k1->op_type == OP_READDIR
9946 || k1->op_type == OP_GLOB
9947 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9948 || k1->op_type == OP_EACH
9949 || k1->op_type == OP_AEACH))
9950 expr = newUNOP(OP_DEFINED, 0, expr);
9956 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9957 * op, in listop. This is wrong. [perl #27024] */
9959 block = newOP(OP_NULL, 0);
9960 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9961 o = new_logop(OP_AND, 0, &expr, &listop);
9968 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
9970 if (once && o != listop)
9972 assert(cUNOPo->op_first->op_type == OP_AND
9973 || cUNOPo->op_first->op_type == OP_OR);
9974 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
9978 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
9980 o->op_flags |= flags;
9982 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9987 =for apidoc newWHILEOP
9989 Constructs, checks, and returns an op tree expressing a C<while> loop.
9990 This is a heavyweight loop, with structure that allows exiting the loop
9991 by C<last> and suchlike.
9993 C<loop> is an optional preconstructed C<enterloop> op to use in the
9994 loop; if it is null then a suitable op will be constructed automatically.
9995 C<expr> supplies the loop's controlling expression. C<block> supplies the
9996 main body of the loop, and C<cont> optionally supplies a C<continue> block
9997 that operates as a second half of the body. All of these optree inputs
9998 are consumed by this function and become part of the constructed op tree.
10000 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10001 op and, shifted up eight bits, the eight bits of C<op_private> for
10002 the C<leaveloop> op, except that (in both cases) some bits will be set
10003 automatically. C<debuggable> is currently unused and should always be 1.
10004 C<has_my> can be supplied as true to force the
10005 loop body to be enclosed in its own scope.
10011 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
10012 OP *expr, OP *block, OP *cont, I32 has_my)
10021 PERL_UNUSED_ARG(debuggable);
10024 if (expr->op_type == OP_READLINE
10025 || expr->op_type == OP_READDIR
10026 || expr->op_type == OP_GLOB
10027 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
10028 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
10029 expr = newUNOP(OP_DEFINED, 0,
10030 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
10031 } else if (expr->op_flags & OPf_KIDS) {
10032 const OP * const k1 = ((UNOP*)expr)->op_first;
10033 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
10034 switch (expr->op_type) {
10036 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
10037 && (k2->op_flags & OPf_STACKED)
10038 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
10039 expr = newUNOP(OP_DEFINED, 0, expr);
10043 if (k1 && (k1->op_type == OP_READDIR
10044 || k1->op_type == OP_GLOB
10045 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
10046 || k1->op_type == OP_EACH
10047 || k1->op_type == OP_AEACH))
10048 expr = newUNOP(OP_DEFINED, 0, expr);
10055 block = newOP(OP_NULL, 0);
10056 else if (cont || has_my) {
10057 block = op_scope(block);
10061 next = LINKLIST(cont);
10064 OP * const unstack = newOP(OP_UNSTACK, 0);
10067 cont = op_append_elem(OP_LINESEQ, cont, unstack);
10071 listop = op_append_list(OP_LINESEQ, block, cont);
10073 redo = LINKLIST(listop);
10077 o = new_logop(OP_AND, 0, &expr, &listop);
10078 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
10079 op_free((OP*)loop);
10080 return expr; /* listop already freed by new_logop */
10083 ((LISTOP*)listop)->op_last->op_next =
10084 (o == listop ? redo : LINKLIST(o));
10090 NewOp(1101,loop,1,LOOP);
10091 OpTYPE_set(loop, OP_ENTERLOOP);
10092 loop->op_private = 0;
10093 loop->op_next = (OP*)loop;
10096 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
10098 loop->op_redoop = redo;
10099 loop->op_lastop = o;
10100 o->op_private |= loopflags;
10103 loop->op_nextop = next;
10105 loop->op_nextop = o;
10107 o->op_flags |= flags;
10108 o->op_private |= (flags >> 8);
10113 =for apidoc newFOROP
10115 Constructs, checks, and returns an op tree expressing a C<foreach>
10116 loop (iteration through a list of values). This is a heavyweight loop,
10117 with structure that allows exiting the loop by C<last> and suchlike.
10119 C<sv> optionally supplies the variable that will be aliased to each
10120 item in turn; if null, it defaults to C<$_>.
10121 C<expr> supplies the list of values to iterate over. C<block> supplies
10122 the main body of the loop, and C<cont> optionally supplies a C<continue>
10123 block that operates as a second half of the body. All of these optree
10124 inputs are consumed by this function and become part of the constructed
10127 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10128 op and, shifted up eight bits, the eight bits of C<op_private> for
10129 the C<leaveloop> op, except that (in both cases) some bits will be set
10136 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
10141 PADOFFSET padoff = 0;
10143 I32 iterpflags = 0;
10145 PERL_ARGS_ASSERT_NEWFOROP;
10148 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
10149 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
10150 OpTYPE_set(sv, OP_RV2GV);
10152 /* The op_type check is needed to prevent a possible segfault
10153 * if the loop variable is undeclared and 'strict vars' is in
10154 * effect. This is illegal but is nonetheless parsed, so we
10155 * may reach this point with an OP_CONST where we're expecting
10158 if (cUNOPx(sv)->op_first->op_type == OP_GV
10159 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
10160 iterpflags |= OPpITER_DEF;
10162 else if (sv->op_type == OP_PADSV) { /* private variable */
10163 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
10164 padoff = sv->op_targ;
10168 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
10170 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
10173 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
10175 PADNAME * const pn = PAD_COMPNAME(padoff);
10176 const char * const name = PadnamePV(pn);
10178 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
10179 iterpflags |= OPpITER_DEF;
10183 sv = newGVOP(OP_GV, 0, PL_defgv);
10184 iterpflags |= OPpITER_DEF;
10187 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
10188 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
10189 iterflags |= OPf_STACKED;
10191 else if (expr->op_type == OP_NULL &&
10192 (expr->op_flags & OPf_KIDS) &&
10193 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
10195 /* Basically turn for($x..$y) into the same as for($x,$y), but we
10196 * set the STACKED flag to indicate that these values are to be
10197 * treated as min/max values by 'pp_enteriter'.
10199 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
10200 LOGOP* const range = (LOGOP*) flip->op_first;
10201 OP* const left = range->op_first;
10202 OP* const right = OpSIBLING(left);
10205 range->op_flags &= ~OPf_KIDS;
10206 /* detach range's children */
10207 op_sibling_splice((OP*)range, NULL, -1, NULL);
10209 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
10210 listop->op_first->op_next = range->op_next;
10211 left->op_next = range->op_other;
10212 right->op_next = (OP*)listop;
10213 listop->op_next = listop->op_first;
10216 expr = (OP*)(listop);
10218 iterflags |= OPf_STACKED;
10221 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
10224 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
10225 op_append_elem(OP_LIST, list(expr),
10227 assert(!loop->op_next);
10228 /* for my $x () sets OPpLVAL_INTRO;
10229 * for our $x () sets OPpOUR_INTRO */
10230 loop->op_private = (U8)iterpflags;
10232 /* upgrade loop from a LISTOP to a LOOPOP;
10233 * keep it in-place if there's space */
10234 if (loop->op_slabbed
10235 && OpSLOT(loop)->opslot_size
10236 < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
10238 /* no space; allocate new op */
10240 NewOp(1234,tmp,1,LOOP);
10241 Copy(loop,tmp,1,LISTOP);
10242 assert(loop->op_last->op_sibparent == (OP*)loop);
10243 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
10244 S_op_destroy(aTHX_ (OP*)loop);
10247 else if (!loop->op_slabbed)
10249 /* loop was malloc()ed */
10250 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
10251 OpLASTSIB_set(loop->op_last, (OP*)loop);
10253 loop->op_targ = padoff;
10254 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
10259 =for apidoc newLOOPEX
10261 Constructs, checks, and returns a loop-exiting op (such as C<goto>
10262 or C<last>). C<type> is the opcode. C<label> supplies the parameter
10263 determining the target of the op; it is consumed by this function and
10264 becomes part of the constructed op tree.
10270 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
10274 PERL_ARGS_ASSERT_NEWLOOPEX;
10276 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
10277 || type == OP_CUSTOM);
10279 if (type != OP_GOTO) {
10280 /* "last()" means "last" */
10281 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
10282 o = newOP(type, OPf_SPECIAL);
10286 /* Check whether it's going to be a goto &function */
10287 if (label->op_type == OP_ENTERSUB
10288 && !(label->op_flags & OPf_STACKED))
10289 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
10292 /* Check for a constant argument */
10293 if (label->op_type == OP_CONST) {
10294 SV * const sv = ((SVOP *)label)->op_sv;
10296 const char *s = SvPV_const(sv,l);
10297 if (l == strlen(s)) {
10299 SvUTF8(((SVOP*)label)->op_sv),
10301 SvPV_nolen_const(((SVOP*)label)->op_sv)));
10305 /* If we have already created an op, we do not need the label. */
10308 else o = newUNOP(type, OPf_STACKED, label);
10310 PL_hints |= HINT_BLOCK_SCOPE;
10314 /* if the condition is a literal array or hash
10315 (or @{ ... } etc), make a reference to it.
10318 S_ref_array_or_hash(pTHX_ OP *cond)
10321 && (cond->op_type == OP_RV2AV
10322 || cond->op_type == OP_PADAV
10323 || cond->op_type == OP_RV2HV
10324 || cond->op_type == OP_PADHV))
10326 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
10329 && (cond->op_type == OP_ASLICE
10330 || cond->op_type == OP_KVASLICE
10331 || cond->op_type == OP_HSLICE
10332 || cond->op_type == OP_KVHSLICE)) {
10334 /* anonlist now needs a list from this op, was previously used in
10335 * scalar context */
10336 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
10337 cond->op_flags |= OPf_WANT_LIST;
10339 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
10346 /* These construct the optree fragments representing given()
10349 entergiven and enterwhen are LOGOPs; the op_other pointer
10350 points up to the associated leave op. We need this so we
10351 can put it in the context and make break/continue work.
10352 (Also, of course, pp_enterwhen will jump straight to
10353 op_other if the match fails.)
10357 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
10358 I32 enter_opcode, I32 leave_opcode,
10359 PADOFFSET entertarg)
10365 PERL_ARGS_ASSERT_NEWGIVWHENOP;
10366 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
10368 enterop = alloc_LOGOP(enter_opcode, block, NULL);
10369 enterop->op_targ = 0;
10370 enterop->op_private = 0;
10372 o = newUNOP(leave_opcode, 0, (OP *) enterop);
10375 /* prepend cond if we have one */
10376 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
10378 o->op_next = LINKLIST(cond);
10379 cond->op_next = (OP *) enterop;
10382 /* This is a default {} block */
10383 enterop->op_flags |= OPf_SPECIAL;
10384 o ->op_flags |= OPf_SPECIAL;
10386 o->op_next = (OP *) enterop;
10389 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
10390 entergiven and enterwhen both
10393 enterop->op_next = LINKLIST(block);
10394 block->op_next = enterop->op_other = o;
10400 /* For the purposes of 'when(implied_smartmatch)'
10401 * versus 'when(boolean_expression)',
10402 * does this look like a boolean operation? For these purposes
10403 a boolean operation is:
10404 - a subroutine call [*]
10405 - a logical connective
10406 - a comparison operator
10407 - a filetest operator, with the exception of -s -M -A -C
10408 - defined(), exists() or eof()
10409 - /$re/ or $foo =~ /$re/
10411 [*] possibly surprising
10414 S_looks_like_bool(pTHX_ const OP *o)
10416 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
10418 switch(o->op_type) {
10421 return looks_like_bool(cLOGOPo->op_first);
10425 OP* sibl = OpSIBLING(cLOGOPo->op_first);
10428 looks_like_bool(cLOGOPo->op_first)
10429 && looks_like_bool(sibl));
10435 o->op_flags & OPf_KIDS
10436 && looks_like_bool(cUNOPo->op_first));
10440 case OP_NOT: case OP_XOR:
10442 case OP_EQ: case OP_NE: case OP_LT:
10443 case OP_GT: case OP_LE: case OP_GE:
10445 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
10446 case OP_I_GT: case OP_I_LE: case OP_I_GE:
10448 case OP_SEQ: case OP_SNE: case OP_SLT:
10449 case OP_SGT: case OP_SLE: case OP_SGE:
10451 case OP_SMARTMATCH:
10453 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
10454 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
10455 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
10456 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
10457 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
10458 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
10459 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
10460 case OP_FTTEXT: case OP_FTBINARY:
10462 case OP_DEFINED: case OP_EXISTS:
10463 case OP_MATCH: case OP_EOF:
10471 /* optimised-away (index() != -1) or similar comparison */
10472 if (o->op_private & OPpTRUEBOOL)
10477 /* Detect comparisons that have been optimized away */
10478 if (cSVOPo->op_sv == &PL_sv_yes
10479 || cSVOPo->op_sv == &PL_sv_no)
10492 =for apidoc newGIVENOP
10494 Constructs, checks, and returns an op tree expressing a C<given> block.
10495 C<cond> supplies the expression to whose value C<$_> will be locally
10496 aliased, and C<block> supplies the body of the C<given> construct; they
10497 are consumed by this function and become part of the constructed op tree.
10498 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
10504 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
10506 PERL_ARGS_ASSERT_NEWGIVENOP;
10507 PERL_UNUSED_ARG(defsv_off);
10509 assert(!defsv_off);
10510 return newGIVWHENOP(
10511 ref_array_or_hash(cond),
10513 OP_ENTERGIVEN, OP_LEAVEGIVEN,
10518 =for apidoc newWHENOP
10520 Constructs, checks, and returns an op tree expressing a C<when> block.
10521 C<cond> supplies the test expression, and C<block> supplies the block
10522 that will be executed if the test evaluates to true; they are consumed
10523 by this function and become part of the constructed op tree. C<cond>
10524 will be interpreted DWIMically, often as a comparison against C<$_>,
10525 and may be null to generate a C<default> block.
10531 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
10533 const bool cond_llb = (!cond || looks_like_bool(cond));
10536 PERL_ARGS_ASSERT_NEWWHENOP;
10541 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
10543 scalar(ref_array_or_hash(cond)));
10546 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
10549 /* must not conflict with SVf_UTF8 */
10550 #define CV_CKPROTO_CURSTASH 0x1
10553 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
10554 const STRLEN len, const U32 flags)
10556 SV *name = NULL, *msg;
10557 const char * cvp = SvROK(cv)
10558 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
10559 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
10562 STRLEN clen = CvPROTOLEN(cv), plen = len;
10564 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
10566 if (p == NULL && cvp == NULL)
10569 if (!ckWARN_d(WARN_PROTOTYPE))
10573 p = S_strip_spaces(aTHX_ p, &plen);
10574 cvp = S_strip_spaces(aTHX_ cvp, &clen);
10575 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
10576 if (plen == clen && memEQ(cvp, p, plen))
10579 if (flags & SVf_UTF8) {
10580 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
10584 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
10590 msg = sv_newmortal();
10595 gv_efullname3(name = sv_newmortal(), gv, NULL);
10596 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
10597 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
10598 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
10599 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
10600 sv_catpvs(name, "::");
10602 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
10603 assert (CvNAMED(SvRV_const(gv)));
10604 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
10606 else sv_catsv(name, (SV *)gv);
10608 else name = (SV *)gv;
10610 sv_setpvs(msg, "Prototype mismatch:");
10612 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
10614 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
10615 UTF8fARG(SvUTF8(cv),clen,cvp)
10618 sv_catpvs(msg, ": none");
10619 sv_catpvs(msg, " vs ");
10621 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
10623 sv_catpvs(msg, "none");
10624 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
10627 static void const_sv_xsub(pTHX_ CV* cv);
10628 static void const_av_xsub(pTHX_ CV* cv);
10632 =head1 Optree Manipulation Functions
10634 =for apidoc cv_const_sv
10636 If C<cv> is a constant sub eligible for inlining, returns the constant
10637 value returned by the sub. Otherwise, returns C<NULL>.
10639 Constant subs can be created with C<newCONSTSUB> or as described in
10640 L<perlsub/"Constant Functions">.
10645 Perl_cv_const_sv(const CV *const cv)
10650 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
10652 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10653 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
10658 Perl_cv_const_sv_or_av(const CV * const cv)
10662 if (SvROK(cv)) return SvRV((SV *)cv);
10663 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
10664 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10667 /* op_const_sv: examine an optree to determine whether it's in-lineable.
10668 * Can be called in 2 ways:
10671 * look for a single OP_CONST with attached value: return the value
10673 * allow_lex && !CvCONST(cv);
10675 * examine the clone prototype, and if contains only a single
10676 * OP_CONST, return the value; or if it contains a single PADSV ref-
10677 * erencing an outer lexical, turn on CvCONST to indicate the CV is
10678 * a candidate for "constizing" at clone time, and return NULL.
10682 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
10685 bool padsv = FALSE;
10690 for (; o; o = o->op_next) {
10691 const OPCODE type = o->op_type;
10693 if (type == OP_NEXTSTATE || type == OP_LINESEQ
10695 || type == OP_PUSHMARK)
10697 if (type == OP_DBSTATE)
10699 if (type == OP_LEAVESUB)
10703 if (type == OP_CONST && cSVOPo->op_sv)
10704 sv = cSVOPo->op_sv;
10705 else if (type == OP_UNDEF && !o->op_private) {
10709 else if (allow_lex && type == OP_PADSV) {
10710 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
10712 sv = &PL_sv_undef; /* an arbitrary non-null value */
10730 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10731 PADNAME * const name, SV ** const const_svp)
10734 assert (o || name);
10735 assert (const_svp);
10737 if (CvFLAGS(PL_compcv)) {
10738 /* might have had built-in attrs applied */
10739 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10740 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10741 && ckWARN(WARN_MISC))
10743 /* protect against fatal warnings leaking compcv */
10744 SAVEFREESV(PL_compcv);
10745 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10746 SvREFCNT_inc_simple_void_NN(PL_compcv);
10749 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10750 & ~(CVf_LVALUE * pureperl));
10755 /* redundant check for speed: */
10756 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10757 const line_t oldline = CopLINE(PL_curcop);
10760 : sv_2mortal(newSVpvn_utf8(
10761 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
10763 if (PL_parser && PL_parser->copline != NOLINE)
10764 /* This ensures that warnings are reported at the first
10765 line of a redefinition, not the last. */
10766 CopLINE_set(PL_curcop, PL_parser->copline);
10767 /* protect against fatal warnings leaking compcv */
10768 SAVEFREESV(PL_compcv);
10769 report_redefined_cv(namesv, cv, const_svp);
10770 SvREFCNT_inc_simple_void_NN(PL_compcv);
10771 CopLINE_set(PL_curcop, oldline);
10778 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10783 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10786 CV *compcv = PL_compcv;
10789 PADOFFSET pax = o->op_targ;
10790 CV *outcv = CvOUTSIDE(PL_compcv);
10793 bool reusable = FALSE;
10795 #ifdef PERL_DEBUG_READONLY_OPS
10796 OPSLAB *slab = NULL;
10799 PERL_ARGS_ASSERT_NEWMYSUB;
10801 PL_hints |= HINT_BLOCK_SCOPE;
10803 /* Find the pad slot for storing the new sub.
10804 We cannot use PL_comppad, as it is the pad owned by the new sub. We
10805 need to look in CvOUTSIDE and find the pad belonging to the enclos-
10806 ing sub. And then we need to dig deeper if this is a lexical from
10808 my sub foo; sub { sub foo { } }
10811 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10812 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10813 pax = PARENT_PAD_INDEX(name);
10814 outcv = CvOUTSIDE(outcv);
10819 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10820 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10821 spot = (CV **)svspot;
10823 if (!(PL_parser && PL_parser->error_count))
10824 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10827 assert(proto->op_type == OP_CONST);
10828 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10829 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10839 if (PL_parser && PL_parser->error_count) {
10841 SvREFCNT_dec(PL_compcv);
10846 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10848 svspot = (SV **)(spot = &clonee);
10850 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10853 assert (SvTYPE(*spot) == SVt_PVCV);
10854 if (CvNAMED(*spot))
10855 hek = CvNAME_HEK(*spot);
10859 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10860 CvNAME_HEK_set(*spot, hek =
10863 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10867 CvLEXICAL_on(*spot);
10869 cv = PadnamePROTOCV(name);
10870 svspot = (SV **)(spot = &PadnamePROTOCV(name));
10874 /* This makes sub {}; work as expected. */
10875 if (block->op_type == OP_STUB) {
10876 const line_t l = PL_parser->copline;
10878 block = newSTATEOP(0, NULL, 0);
10879 PL_parser->copline = l;
10881 block = CvLVALUE(compcv)
10882 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10883 ? newUNOP(OP_LEAVESUBLV, 0,
10884 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10885 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10886 start = LINKLIST(block);
10887 block->op_next = 0;
10888 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10889 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10897 const bool exists = CvROOT(cv) || CvXSUB(cv);
10899 /* if the subroutine doesn't exist and wasn't pre-declared
10900 * with a prototype, assume it will be AUTOLOADed,
10901 * skipping the prototype check
10903 if (exists || SvPOK(cv))
10904 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10906 /* already defined? */
10908 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10914 /* just a "sub foo;" when &foo is already defined */
10915 SAVEFREESV(compcv);
10919 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10926 SvREFCNT_inc_simple_void_NN(const_sv);
10927 SvFLAGS(const_sv) |= SVs_PADTMP;
10929 assert(!CvROOT(cv) && !CvCONST(cv));
10930 cv_forget_slab(cv);
10933 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10934 CvFILE_set_from_cop(cv, PL_curcop);
10935 CvSTASH_set(cv, PL_curstash);
10938 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10939 CvXSUBANY(cv).any_ptr = const_sv;
10940 CvXSUB(cv) = const_sv_xsub;
10944 CvFLAGS(cv) |= CvMETHOD(compcv);
10946 SvREFCNT_dec(compcv);
10951 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10952 determine whether this sub definition is in the same scope as its
10953 declaration. If this sub definition is inside an inner named pack-
10954 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10955 the package sub. So check PadnameOUTER(name) too.
10957 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10958 assert(!CvWEAKOUTSIDE(compcv));
10959 SvREFCNT_dec(CvOUTSIDE(compcv));
10960 CvWEAKOUTSIDE_on(compcv);
10962 /* XXX else do we have a circular reference? */
10964 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
10965 /* transfer PL_compcv to cv */
10967 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10968 cv_flags_t preserved_flags =
10969 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10970 PADLIST *const temp_padl = CvPADLIST(cv);
10971 CV *const temp_cv = CvOUTSIDE(cv);
10972 const cv_flags_t other_flags =
10973 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10974 OP * const cvstart = CvSTART(cv);
10978 CvFLAGS(compcv) | preserved_flags;
10979 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10980 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10981 CvPADLIST_set(cv, CvPADLIST(compcv));
10982 CvOUTSIDE(compcv) = temp_cv;
10983 CvPADLIST_set(compcv, temp_padl);
10984 CvSTART(cv) = CvSTART(compcv);
10985 CvSTART(compcv) = cvstart;
10986 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10987 CvFLAGS(compcv) |= other_flags;
10990 Safefree(CvFILE(cv));
10994 /* inner references to compcv must be fixed up ... */
10995 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10996 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10997 ++PL_sub_generation;
11000 /* Might have had built-in attributes applied -- propagate them. */
11001 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
11003 /* ... before we throw it away */
11004 SvREFCNT_dec(compcv);
11005 PL_compcv = compcv = cv;
11014 if (!CvNAME_HEK(cv)) {
11015 if (hek) (void)share_hek_hek(hek);
11019 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
11020 hek = share_hek(PadnamePV(name)+1,
11021 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
11024 CvNAME_HEK_set(cv, hek);
11030 if (CvFILE(cv) && CvDYNFILE(cv))
11031 Safefree(CvFILE(cv));
11032 CvFILE_set_from_cop(cv, PL_curcop);
11033 CvSTASH_set(cv, PL_curstash);
11036 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11038 SvUTF8_on(MUTABLE_SV(cv));
11042 /* If we assign an optree to a PVCV, then we've defined a
11043 * subroutine that the debugger could be able to set a breakpoint
11044 * in, so signal to pp_entereval that it should not throw away any
11045 * saved lines at scope exit. */
11047 PL_breakable_sub_gen++;
11048 CvROOT(cv) = block;
11049 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11050 itself has a refcount. */
11052 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11053 #ifdef PERL_DEBUG_READONLY_OPS
11054 slab = (OPSLAB *)CvSTART(cv);
11056 S_process_optree(aTHX_ cv, block, start);
11061 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11062 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
11066 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11067 SV * const tmpstr = sv_newmortal();
11068 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11069 GV_ADDMULTI, SVt_PVHV);
11071 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11072 CopFILE(PL_curcop),
11074 (long)CopLINE(PL_curcop));
11075 if (HvNAME_HEK(PL_curstash)) {
11076 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
11077 sv_catpvs(tmpstr, "::");
11080 sv_setpvs(tmpstr, "__ANON__::");
11082 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
11083 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
11084 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11085 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11086 hv = GvHVn(db_postponed);
11087 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11088 CV * const pcv = GvCV(db_postponed);
11094 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11102 assert(CvDEPTH(outcv));
11104 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
11106 cv_clone_into(clonee, *spot);
11107 else *spot = cv_clone(clonee);
11108 SvREFCNT_dec_NN(clonee);
11112 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
11113 PADOFFSET depth = CvDEPTH(outcv);
11116 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
11118 *svspot = SvREFCNT_inc_simple_NN(cv);
11119 SvREFCNT_dec(oldcv);
11125 PL_parser->copline = NOLINE;
11126 LEAVE_SCOPE(floor);
11127 #ifdef PERL_DEBUG_READONLY_OPS
11136 =for apidoc newATTRSUB_x
11138 Construct a Perl subroutine, also performing some surrounding jobs.
11140 This function is expected to be called in a Perl compilation context,
11141 and some aspects of the subroutine are taken from global variables
11142 associated with compilation. In particular, C<PL_compcv> represents
11143 the subroutine that is currently being compiled. It must be non-null
11144 when this function is called, and some aspects of the subroutine being
11145 constructed are taken from it. The constructed subroutine may actually
11146 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
11148 If C<block> is null then the subroutine will have no body, and for the
11149 time being it will be an error to call it. This represents a forward
11150 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
11151 non-null then it provides the Perl code of the subroutine body, which
11152 will be executed when the subroutine is called. This body includes
11153 any argument unwrapping code resulting from a subroutine signature or
11154 similar. The pad use of the code must correspond to the pad attached
11155 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
11156 C<leavesublv> op; this function will add such an op. C<block> is consumed
11157 by this function and will become part of the constructed subroutine.
11159 C<proto> specifies the subroutine's prototype, unless one is supplied
11160 as an attribute (see below). If C<proto> is null, then the subroutine
11161 will not have a prototype. If C<proto> is non-null, it must point to a
11162 C<const> op whose value is a string, and the subroutine will have that
11163 string as its prototype. If a prototype is supplied as an attribute, the
11164 attribute takes precedence over C<proto>, but in that case C<proto> should
11165 preferably be null. In any case, C<proto> is consumed by this function.
11167 C<attrs> supplies attributes to be applied the subroutine. A handful of
11168 attributes take effect by built-in means, being applied to C<PL_compcv>
11169 immediately when seen. Other attributes are collected up and attached
11170 to the subroutine by this route. C<attrs> may be null to supply no
11171 attributes, or point to a C<const> op for a single attribute, or point
11172 to a C<list> op whose children apart from the C<pushmark> are C<const>
11173 ops for one or more attributes. Each C<const> op must be a string,
11174 giving the attribute name optionally followed by parenthesised arguments,
11175 in the manner in which attributes appear in Perl source. The attributes
11176 will be applied to the sub by this function. C<attrs> is consumed by
11179 If C<o_is_gv> is false and C<o> is null, then the subroutine will
11180 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
11181 must point to a C<const> op, which will be consumed by this function,
11182 and its string value supplies a name for the subroutine. The name may
11183 be qualified or unqualified, and if it is unqualified then a default
11184 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
11185 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
11186 by which the subroutine will be named.
11188 If there is already a subroutine of the specified name, then the new
11189 sub will either replace the existing one in the glob or be merged with
11190 the existing one. A warning may be generated about redefinition.
11192 If the subroutine has one of a few special names, such as C<BEGIN> or
11193 C<END>, then it will be claimed by the appropriate queue for automatic
11194 running of phase-related subroutines. In this case the relevant glob will
11195 be left not containing any subroutine, even if it did contain one before.
11196 In the case of C<BEGIN>, the subroutine will be executed and the reference
11197 to it disposed of before this function returns.
11199 The function returns a pointer to the constructed subroutine. If the sub
11200 is anonymous then ownership of one counted reference to the subroutine
11201 is transferred to the caller. If the sub is named then the caller does
11202 not get ownership of a reference. In most such cases, where the sub
11203 has a non-phase name, the sub will be alive at the point it is returned
11204 by virtue of being contained in the glob that names it. A phase-named
11205 subroutine will usually be alive by virtue of the reference owned by the
11206 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11207 been executed, will quite likely have been destroyed already by the
11208 time this function returns, making it erroneous for the caller to make
11209 any use of the returned pointer. It is the caller's responsibility to
11210 ensure that it knows which of these situations applies.
11215 /* _x = extended */
11217 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
11218 OP *block, bool o_is_gv)
11222 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11224 CV *cv = NULL; /* the previous CV with this name, if any */
11226 const bool ec = PL_parser && PL_parser->error_count;
11227 /* If the subroutine has no body, no attributes, and no builtin attributes
11228 then it's just a sub declaration, and we may be able to get away with
11229 storing with a placeholder scalar in the symbol table, rather than a
11230 full CV. If anything is present then it will take a full CV to
11232 const I32 gv_fetch_flags
11233 = ec ? GV_NOADD_NOINIT :
11234 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
11235 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
11237 const char * const name =
11238 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
11240 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
11241 bool evanescent = FALSE;
11243 #ifdef PERL_DEBUG_READONLY_OPS
11244 OPSLAB *slab = NULL;
11252 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
11253 hek and CvSTASH pointer together can imply the GV. If the name
11254 contains a package name, then GvSTASH(CvGV(cv)) may differ from
11255 CvSTASH, so forego the optimisation if we find any.
11256 Also, we may be called from load_module at run time, so
11257 PL_curstash (which sets CvSTASH) may not point to the stash the
11258 sub is stored in. */
11259 /* XXX This optimization is currently disabled for packages other
11260 than main, since there was too much CPAN breakage. */
11262 ec ? GV_NOADD_NOINIT
11263 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
11264 || PL_curstash != PL_defstash
11265 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
11267 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
11268 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
11270 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
11271 SV * const sv = sv_newmortal();
11272 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
11273 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11274 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11275 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
11277 } else if (PL_curstash) {
11278 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
11281 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
11287 move_proto_attr(&proto, &attrs, gv, 0);
11290 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
11295 assert(proto->op_type == OP_CONST);
11296 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11297 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11313 SvREFCNT_dec(PL_compcv);
11318 if (name && block) {
11319 const char *s = (char *) my_memrchr(name, ':', namlen);
11320 s = s ? s+1 : name;
11321 if (strEQ(s, "BEGIN")) {
11322 if (PL_in_eval & EVAL_KEEPERR)
11323 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
11325 SV * const errsv = ERRSV;
11326 /* force display of errors found but not reported */
11327 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
11328 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
11335 if (!block && SvTYPE(gv) != SVt_PVGV) {
11336 /* If we are not defining a new sub and the existing one is not a
11338 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
11339 /* We are applying attributes to an existing sub, so we need it
11340 upgraded if it is a constant. */
11341 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
11342 gv_init_pvn(gv, PL_curstash, name, namlen,
11343 SVf_UTF8 * name_is_utf8);
11345 else { /* Maybe prototype now, and had at maximum
11346 a prototype or const/sub ref before. */
11347 if (SvTYPE(gv) > SVt_NULL) {
11348 cv_ckproto_len_flags((const CV *)gv,
11349 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11355 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
11357 SvUTF8_on(MUTABLE_SV(gv));
11360 sv_setiv(MUTABLE_SV(gv), -1);
11363 SvREFCNT_dec(PL_compcv);
11364 cv = PL_compcv = NULL;
11369 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
11373 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
11379 /* This makes sub {}; work as expected. */
11380 if (block->op_type == OP_STUB) {
11381 const line_t l = PL_parser->copline;
11383 block = newSTATEOP(0, NULL, 0);
11384 PL_parser->copline = l;
11386 block = CvLVALUE(PL_compcv)
11387 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
11388 && (!isGV(gv) || !GvASSUMECV(gv)))
11389 ? newUNOP(OP_LEAVESUBLV, 0,
11390 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
11391 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
11392 start = LINKLIST(block);
11393 block->op_next = 0;
11394 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
11396 S_op_const_sv(aTHX_ start, PL_compcv,
11397 cBOOL(CvCLONE(PL_compcv)));
11404 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
11405 cv_ckproto_len_flags((const CV *)gv,
11406 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11407 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
11409 /* All the other code for sub redefinition warnings expects the
11410 clobbered sub to be a CV. Instead of making all those code
11411 paths more complex, just inline the RV version here. */
11412 const line_t oldline = CopLINE(PL_curcop);
11413 assert(IN_PERL_COMPILETIME);
11414 if (PL_parser && PL_parser->copline != NOLINE)
11415 /* This ensures that warnings are reported at the first
11416 line of a redefinition, not the last. */
11417 CopLINE_set(PL_curcop, PL_parser->copline);
11418 /* protect against fatal warnings leaking compcv */
11419 SAVEFREESV(PL_compcv);
11421 if (ckWARN(WARN_REDEFINE)
11422 || ( ckWARN_d(WARN_REDEFINE)
11423 && ( !const_sv || SvRV(gv) == const_sv
11424 || sv_cmp(SvRV(gv), const_sv) ))) {
11426 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11427 "Constant subroutine %" SVf " redefined",
11428 SVfARG(cSVOPo->op_sv));
11431 SvREFCNT_inc_simple_void_NN(PL_compcv);
11432 CopLINE_set(PL_curcop, oldline);
11433 SvREFCNT_dec(SvRV(gv));
11438 const bool exists = CvROOT(cv) || CvXSUB(cv);
11440 /* if the subroutine doesn't exist and wasn't pre-declared
11441 * with a prototype, assume it will be AUTOLOADed,
11442 * skipping the prototype check
11444 if (exists || SvPOK(cv))
11445 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
11446 /* already defined (or promised)? */
11447 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
11448 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
11454 /* just a "sub foo;" when &foo is already defined */
11455 SAVEFREESV(PL_compcv);
11462 SvREFCNT_inc_simple_void_NN(const_sv);
11463 SvFLAGS(const_sv) |= SVs_PADTMP;
11465 assert(!CvROOT(cv) && !CvCONST(cv));
11466 cv_forget_slab(cv);
11467 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
11468 CvXSUBANY(cv).any_ptr = const_sv;
11469 CvXSUB(cv) = const_sv_xsub;
11473 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11476 if (isGV(gv) || CvMETHOD(PL_compcv)) {
11477 if (name && isGV(gv))
11478 GvCV_set(gv, NULL);
11479 cv = newCONSTSUB_flags(
11480 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
11484 assert(SvREFCNT((SV*)cv) != 0);
11485 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11489 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11490 prepare_SV_for_RV((SV *)gv);
11491 SvOK_off((SV *)gv);
11494 SvRV_set(gv, const_sv);
11498 SvREFCNT_dec(PL_compcv);
11503 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
11504 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
11507 if (cv) { /* must reuse cv if autoloaded */
11508 /* transfer PL_compcv to cv */
11510 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11511 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
11512 PADLIST *const temp_av = CvPADLIST(cv);
11513 CV *const temp_cv = CvOUTSIDE(cv);
11514 const cv_flags_t other_flags =
11515 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11516 OP * const cvstart = CvSTART(cv);
11520 assert(!CvCVGV_RC(cv));
11521 assert(CvGV(cv) == gv);
11526 PERL_HASH(hash, name, namlen);
11536 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
11538 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
11539 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
11540 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
11541 CvOUTSIDE(PL_compcv) = temp_cv;
11542 CvPADLIST_set(PL_compcv, temp_av);
11543 CvSTART(cv) = CvSTART(PL_compcv);
11544 CvSTART(PL_compcv) = cvstart;
11545 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11546 CvFLAGS(PL_compcv) |= other_flags;
11549 Safefree(CvFILE(cv));
11551 CvFILE_set_from_cop(cv, PL_curcop);
11552 CvSTASH_set(cv, PL_curstash);
11554 /* inner references to PL_compcv must be fixed up ... */
11555 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
11556 if (PERLDB_INTER)/* Advice debugger on the new sub. */
11557 ++PL_sub_generation;
11560 /* Might have had built-in attributes applied -- propagate them. */
11561 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
11563 /* ... before we throw it away */
11564 SvREFCNT_dec(PL_compcv);
11569 if (name && isGV(gv)) {
11572 if (HvENAME_HEK(GvSTASH(gv)))
11573 /* sub Foo::bar { (shift)+1 } */
11574 gv_method_changed(gv);
11578 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11579 prepare_SV_for_RV((SV *)gv);
11580 SvOK_off((SV *)gv);
11583 SvRV_set(gv, (SV *)cv);
11584 if (HvENAME_HEK(PL_curstash))
11585 mro_method_changed_in(PL_curstash);
11589 assert(SvREFCNT((SV*)cv) != 0);
11591 if (!CvHASGV(cv)) {
11597 PERL_HASH(hash, name, namlen);
11598 CvNAME_HEK_set(cv, share_hek(name,
11604 CvFILE_set_from_cop(cv, PL_curcop);
11605 CvSTASH_set(cv, PL_curstash);
11609 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11611 SvUTF8_on(MUTABLE_SV(cv));
11615 /* If we assign an optree to a PVCV, then we've defined a
11616 * subroutine that the debugger could be able to set a breakpoint
11617 * in, so signal to pp_entereval that it should not throw away any
11618 * saved lines at scope exit. */
11620 PL_breakable_sub_gen++;
11621 CvROOT(cv) = block;
11622 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11623 itself has a refcount. */
11625 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11626 #ifdef PERL_DEBUG_READONLY_OPS
11627 slab = (OPSLAB *)CvSTART(cv);
11629 S_process_optree(aTHX_ cv, block, start);
11634 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11635 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
11636 ? GvSTASH(CvGV(cv))
11640 apply_attrs(stash, MUTABLE_SV(cv), attrs);
11642 SvREFCNT_inc_simple_void_NN(cv);
11645 if (block && has_name) {
11646 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11647 SV * const tmpstr = cv_name(cv,NULL,0);
11648 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11649 GV_ADDMULTI, SVt_PVHV);
11651 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11652 CopFILE(PL_curcop),
11654 (long)CopLINE(PL_curcop));
11655 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11656 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11657 hv = GvHVn(db_postponed);
11658 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11659 CV * const pcv = GvCV(db_postponed);
11665 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11671 if (PL_parser && PL_parser->error_count)
11672 clear_special_blocks(name, gv, cv);
11675 process_special_blocks(floor, name, gv, cv);
11681 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11683 PL_parser->copline = NOLINE;
11684 LEAVE_SCOPE(floor);
11686 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11688 #ifdef PERL_DEBUG_READONLY_OPS
11692 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11693 pad_add_weakref(cv);
11699 S_clear_special_blocks(pTHX_ const char *const fullname,
11700 GV *const gv, CV *const cv) {
11704 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11706 colon = strrchr(fullname,':');
11707 name = colon ? colon + 1 : fullname;
11709 if ((*name == 'B' && strEQ(name, "BEGIN"))
11710 || (*name == 'E' && strEQ(name, "END"))
11711 || (*name == 'U' && strEQ(name, "UNITCHECK"))
11712 || (*name == 'C' && strEQ(name, "CHECK"))
11713 || (*name == 'I' && strEQ(name, "INIT"))) {
11718 GvCV_set(gv, NULL);
11719 SvREFCNT_dec_NN(MUTABLE_SV(cv));
11723 /* Returns true if the sub has been freed. */
11725 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11729 const char *const colon = strrchr(fullname,':');
11730 const char *const name = colon ? colon + 1 : fullname;
11732 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11734 if (*name == 'B') {
11735 if (strEQ(name, "BEGIN")) {
11736 const I32 oldscope = PL_scopestack_ix;
11739 if (floor) LEAVE_SCOPE(floor);
11741 PUSHSTACKi(PERLSI_REQUIRE);
11742 SAVECOPFILE(&PL_compiling);
11743 SAVECOPLINE(&PL_compiling);
11744 SAVEVPTR(PL_curcop);
11746 DEBUG_x( dump_sub(gv) );
11747 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11748 GvCV_set(gv,0); /* cv has been hijacked */
11749 call_list(oldscope, PL_beginav);
11753 return !PL_savebegin;
11758 if (*name == 'E') {
11759 if (strEQ(name, "END")) {
11760 DEBUG_x( dump_sub(gv) );
11761 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11764 } else if (*name == 'U') {
11765 if (strEQ(name, "UNITCHECK")) {
11766 /* It's never too late to run a unitcheck block */
11767 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11771 } else if (*name == 'C') {
11772 if (strEQ(name, "CHECK")) {
11774 /* diag_listed_as: Too late to run %s block */
11775 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11776 "Too late to run CHECK block");
11777 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11781 } else if (*name == 'I') {
11782 if (strEQ(name, "INIT")) {
11784 /* diag_listed_as: Too late to run %s block */
11785 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11786 "Too late to run INIT block");
11787 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11793 DEBUG_x( dump_sub(gv) );
11795 GvCV_set(gv,0); /* cv has been hijacked */
11801 =for apidoc newCONSTSUB
11803 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11804 rather than of counted length, and no flags are set. (This means that
11805 C<name> is always interpreted as Latin-1.)
11811 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11813 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11817 =for apidoc newCONSTSUB_flags
11819 Construct a constant subroutine, also performing some surrounding
11820 jobs. A scalar constant-valued subroutine is eligible for inlining
11821 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11822 123 }>>. Other kinds of constant subroutine have other treatment.
11824 The subroutine will have an empty prototype and will ignore any arguments
11825 when called. Its constant behaviour is determined by C<sv>. If C<sv>
11826 is null, the subroutine will yield an empty list. If C<sv> points to a
11827 scalar, the subroutine will always yield that scalar. If C<sv> points
11828 to an array, the subroutine will always yield a list of the elements of
11829 that array in list context, or the number of elements in the array in
11830 scalar context. This function takes ownership of one counted reference
11831 to the scalar or array, and will arrange for the object to live as long
11832 as the subroutine does. If C<sv> points to a scalar then the inlining
11833 assumes that the value of the scalar will never change, so the caller
11834 must ensure that the scalar is not subsequently written to. If C<sv>
11835 points to an array then no such assumption is made, so it is ostensibly
11836 safe to mutate the array or its elements, but whether this is really
11837 supported has not been determined.
11839 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11840 Other aspects of the subroutine will be left in their default state.
11841 The caller is free to mutate the subroutine beyond its initial state
11842 after this function has returned.
11844 If C<name> is null then the subroutine will be anonymous, with its
11845 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11846 subroutine will be named accordingly, referenced by the appropriate glob.
11847 C<name> is a string of length C<len> bytes giving a sigilless symbol
11848 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11849 otherwise. The name may be either qualified or unqualified. If the
11850 name is unqualified then it defaults to being in the stash specified by
11851 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11852 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11855 C<flags> should not have bits set other than C<SVf_UTF8>.
11857 If there is already a subroutine of the specified name, then the new sub
11858 will replace the existing one in the glob. A warning may be generated
11859 about the redefinition.
11861 If the subroutine has one of a few special names, such as C<BEGIN> or
11862 C<END>, then it will be claimed by the appropriate queue for automatic
11863 running of phase-related subroutines. In this case the relevant glob will
11864 be left not containing any subroutine, even if it did contain one before.
11865 Execution of the subroutine will likely be a no-op, unless C<sv> was
11866 a tied array or the caller modified the subroutine in some interesting
11867 way before it was executed. In the case of C<BEGIN>, the treatment is
11868 buggy: the sub will be executed when only half built, and may be deleted
11869 prematurely, possibly causing a crash.
11871 The function returns a pointer to the constructed subroutine. If the sub
11872 is anonymous then ownership of one counted reference to the subroutine
11873 is transferred to the caller. If the sub is named then the caller does
11874 not get ownership of a reference. In most such cases, where the sub
11875 has a non-phase name, the sub will be alive at the point it is returned
11876 by virtue of being contained in the glob that names it. A phase-named
11877 subroutine will usually be alive by virtue of the reference owned by
11878 the phase's automatic run queue. A C<BEGIN> subroutine may have been
11879 destroyed already by the time this function returns, but currently bugs
11880 occur in that case before the caller gets control. It is the caller's
11881 responsibility to ensure that it knows which of these situations applies.
11887 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11891 const char *const file = CopFILE(PL_curcop);
11895 if (IN_PERL_RUNTIME) {
11896 /* at runtime, it's not safe to manipulate PL_curcop: it may be
11897 * an op shared between threads. Use a non-shared COP for our
11899 SAVEVPTR(PL_curcop);
11900 SAVECOMPILEWARNINGS();
11901 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11902 PL_curcop = &PL_compiling;
11904 SAVECOPLINE(PL_curcop);
11905 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11908 PL_hints &= ~HINT_BLOCK_SCOPE;
11911 SAVEGENERICSV(PL_curstash);
11912 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11915 /* Protect sv against leakage caused by fatal warnings. */
11916 if (sv) SAVEFREESV(sv);
11918 /* file becomes the CvFILE. For an XS, it's usually static storage,
11919 and so doesn't get free()d. (It's expected to be from the C pre-
11920 processor __FILE__ directive). But we need a dynamically allocated one,
11921 and we need it to get freed. */
11922 cv = newXS_len_flags(name, len,
11923 sv && SvTYPE(sv) == SVt_PVAV
11926 file ? file : "", "",
11927 &sv, XS_DYNAMIC_FILENAME | flags);
11929 assert(SvREFCNT((SV*)cv) != 0);
11930 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11941 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
11942 static storage, as it is used directly as CvFILE(), without a copy being made.
11948 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11950 PERL_ARGS_ASSERT_NEWXS;
11951 return newXS_len_flags(
11952 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11957 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11958 const char *const filename, const char *const proto,
11961 PERL_ARGS_ASSERT_NEWXS_FLAGS;
11962 return newXS_len_flags(
11963 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11968 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11970 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11971 return newXS_len_flags(
11972 name, strlen(name), subaddr, NULL, NULL, NULL, 0
11977 =for apidoc newXS_len_flags
11979 Construct an XS subroutine, also performing some surrounding jobs.
11981 The subroutine will have the entry point C<subaddr>. It will have
11982 the prototype specified by the nul-terminated string C<proto>, or
11983 no prototype if C<proto> is null. The prototype string is copied;
11984 the caller can mutate the supplied string afterwards. If C<filename>
11985 is non-null, it must be a nul-terminated filename, and the subroutine
11986 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
11987 point directly to the supplied string, which must be static. If C<flags>
11988 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11991 Other aspects of the subroutine will be left in their default state.
11992 If anything else needs to be done to the subroutine for it to function
11993 correctly, it is the caller's responsibility to do that after this
11994 function has constructed it. However, beware of the subroutine
11995 potentially being destroyed before this function returns, as described
11998 If C<name> is null then the subroutine will be anonymous, with its
11999 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
12000 subroutine will be named accordingly, referenced by the appropriate glob.
12001 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
12002 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
12003 The name may be either qualified or unqualified, with the stash defaulting
12004 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
12005 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
12006 they have there, such as C<GV_ADDWARN>. The symbol is always added to
12007 the stash if necessary, with C<GV_ADDMULTI> semantics.
12009 If there is already a subroutine of the specified name, then the new sub
12010 will replace the existing one in the glob. A warning may be generated
12011 about the redefinition. If the old subroutine was C<CvCONST> then the
12012 decision about whether to warn is influenced by an expectation about
12013 whether the new subroutine will become a constant of similar value.
12014 That expectation is determined by C<const_svp>. (Note that the call to
12015 this function doesn't make the new subroutine C<CvCONST> in any case;
12016 that is left to the caller.) If C<const_svp> is null then it indicates
12017 that the new subroutine will not become a constant. If C<const_svp>
12018 is non-null then it indicates that the new subroutine will become a
12019 constant, and it points to an C<SV*> that provides the constant value
12020 that the subroutine will have.
12022 If the subroutine has one of a few special names, such as C<BEGIN> or
12023 C<END>, then it will be claimed by the appropriate queue for automatic
12024 running of phase-related subroutines. In this case the relevant glob will
12025 be left not containing any subroutine, even if it did contain one before.
12026 In the case of C<BEGIN>, the subroutine will be executed and the reference
12027 to it disposed of before this function returns, and also before its
12028 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
12029 constructed by this function to be ready for execution then the caller
12030 must prevent this happening by giving the subroutine a different name.
12032 The function returns a pointer to the constructed subroutine. If the sub
12033 is anonymous then ownership of one counted reference to the subroutine
12034 is transferred to the caller. If the sub is named then the caller does
12035 not get ownership of a reference. In most such cases, where the sub
12036 has a non-phase name, the sub will be alive at the point it is returned
12037 by virtue of being contained in the glob that names it. A phase-named
12038 subroutine will usually be alive by virtue of the reference owned by the
12039 phase's automatic run queue. But a C<BEGIN> subroutine, having already
12040 been executed, will quite likely have been destroyed already by the
12041 time this function returns, making it erroneous for the caller to make
12042 any use of the returned pointer. It is the caller's responsibility to
12043 ensure that it knows which of these situations applies.
12049 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
12050 XSUBADDR_t subaddr, const char *const filename,
12051 const char *const proto, SV **const_svp,
12055 bool interleave = FALSE;
12056 bool evanescent = FALSE;
12058 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
12061 GV * const gv = gv_fetchpvn(
12062 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
12063 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
12064 sizeof("__ANON__::__ANON__") - 1,
12065 GV_ADDMULTI | flags, SVt_PVCV);
12067 if ((cv = (name ? GvCV(gv) : NULL))) {
12069 /* just a cached method */
12073 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
12074 /* already defined (or promised) */
12075 /* Redundant check that allows us to avoid creating an SV
12076 most of the time: */
12077 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
12078 report_redefined_cv(newSVpvn_flags(
12079 name,len,(flags&SVf_UTF8)|SVs_TEMP
12090 if (cv) /* must reuse cv if autoloaded */
12093 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12097 if (HvENAME_HEK(GvSTASH(gv)))
12098 gv_method_changed(gv); /* newXS */
12102 assert(SvREFCNT((SV*)cv) != 0);
12106 /* XSUBs can't be perl lang/perl5db.pl debugged
12107 if (PERLDB_LINE_OR_SAVESRC)
12108 (void)gv_fetchfile(filename); */
12109 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
12110 if (flags & XS_DYNAMIC_FILENAME) {
12112 CvFILE(cv) = savepv(filename);
12114 /* NOTE: not copied, as it is expected to be an external constant string */
12115 CvFILE(cv) = (char *)filename;
12118 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
12119 CvFILE(cv) = (char*)PL_xsubfilename;
12122 CvXSUB(cv) = subaddr;
12123 #ifndef PERL_IMPLICIT_CONTEXT
12124 CvHSCXT(cv) = &PL_stack_sp;
12130 evanescent = process_special_blocks(0, name, gv, cv);
12133 } /* <- not a conditional branch */
12136 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12138 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
12139 if (interleave) LEAVE;
12140 assert(evanescent || SvREFCNT((SV*)cv) != 0);
12144 /* Add a stub CV to a typeglob.
12145 * This is the implementation of a forward declaration, 'sub foo';'
12149 Perl_newSTUB(pTHX_ GV *gv, bool fake)
12151 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12153 PERL_ARGS_ASSERT_NEWSTUB;
12154 assert(!GvCVu(gv));
12157 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
12158 gv_method_changed(gv);
12160 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
12164 CvGV_set(cv, cvgv);
12165 CvFILE_set_from_cop(cv, PL_curcop);
12166 CvSTASH_set(cv, PL_curstash);
12172 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
12179 if (PL_parser && PL_parser->error_count) {
12185 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
12186 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
12189 if ((cv = GvFORM(gv))) {
12190 if (ckWARN(WARN_REDEFINE)) {
12191 const line_t oldline = CopLINE(PL_curcop);
12192 if (PL_parser && PL_parser->copline != NOLINE)
12193 CopLINE_set(PL_curcop, PL_parser->copline);
12195 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12196 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
12198 /* diag_listed_as: Format %s redefined */
12199 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12200 "Format STDOUT redefined");
12202 CopLINE_set(PL_curcop, oldline);
12207 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
12209 CvFILE_set_from_cop(cv, PL_curcop);
12212 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
12214 start = LINKLIST(root);
12216 S_process_optree(aTHX_ cv, root, start);
12217 cv_forget_slab(cv);
12222 PL_parser->copline = NOLINE;
12223 LEAVE_SCOPE(floor);
12224 PL_compiling.cop_seq = 0;
12228 Perl_newANONLIST(pTHX_ OP *o)
12230 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
12234 Perl_newANONHASH(pTHX_ OP *o)
12236 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
12240 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
12242 return newANONATTRSUB(floor, proto, NULL, block);
12246 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
12248 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
12250 newSVOP(OP_ANONCODE, 0,
12252 if (CvANONCONST(cv))
12253 anoncode = newUNOP(OP_ANONCONST, 0,
12254 op_convert_list(OP_ENTERSUB,
12255 OPf_STACKED|OPf_WANT_SCALAR,
12257 return newUNOP(OP_REFGEN, 0, anoncode);
12261 Perl_oopsAV(pTHX_ OP *o)
12265 PERL_ARGS_ASSERT_OOPSAV;
12267 switch (o->op_type) {
12270 OpTYPE_set(o, OP_PADAV);
12271 return ref(o, OP_RV2AV);
12275 OpTYPE_set(o, OP_RV2AV);
12280 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
12287 Perl_oopsHV(pTHX_ OP *o)
12291 PERL_ARGS_ASSERT_OOPSHV;
12293 switch (o->op_type) {
12296 OpTYPE_set(o, OP_PADHV);
12297 return ref(o, OP_RV2HV);
12301 OpTYPE_set(o, OP_RV2HV);
12302 /* rv2hv steals the bottom bit for its own uses */
12303 o->op_private &= ~OPpARG1_MASK;
12308 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
12315 Perl_newAVREF(pTHX_ OP *o)
12319 PERL_ARGS_ASSERT_NEWAVREF;
12321 if (o->op_type == OP_PADANY) {
12322 OpTYPE_set(o, OP_PADAV);
12325 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
12326 Perl_croak(aTHX_ "Can't use an array as a reference");
12328 return newUNOP(OP_RV2AV, 0, scalar(o));
12332 Perl_newGVREF(pTHX_ I32 type, OP *o)
12334 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
12335 return newUNOP(OP_NULL, 0, o);
12336 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
12340 Perl_newHVREF(pTHX_ OP *o)
12344 PERL_ARGS_ASSERT_NEWHVREF;
12346 if (o->op_type == OP_PADANY) {
12347 OpTYPE_set(o, OP_PADHV);
12350 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12351 Perl_croak(aTHX_ "Can't use a hash as a reference");
12353 return newUNOP(OP_RV2HV, 0, scalar(o));
12357 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12359 if (o->op_type == OP_PADANY) {
12361 OpTYPE_set(o, OP_PADCV);
12363 return newUNOP(OP_RV2CV, flags, scalar(o));
12367 Perl_newSVREF(pTHX_ OP *o)
12371 PERL_ARGS_ASSERT_NEWSVREF;
12373 if (o->op_type == OP_PADANY) {
12374 OpTYPE_set(o, OP_PADSV);
12378 return newUNOP(OP_RV2SV, 0, scalar(o));
12381 /* Check routines. See the comments at the top of this file for details
12382 * on when these are called */
12385 Perl_ck_anoncode(pTHX_ OP *o)
12387 PERL_ARGS_ASSERT_CK_ANONCODE;
12389 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12390 cSVOPo->op_sv = NULL;
12395 S_io_hints(pTHX_ OP *o)
12397 #if O_BINARY != 0 || O_TEXT != 0
12399 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12401 SV **svp = hv_fetchs(table, "open_IN", FALSE);
12404 const char *d = SvPV_const(*svp, len);
12405 const I32 mode = mode_from_discipline(d, len);
12406 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12408 if (mode & O_BINARY)
12409 o->op_private |= OPpOPEN_IN_RAW;
12413 o->op_private |= OPpOPEN_IN_CRLF;
12417 svp = hv_fetchs(table, "open_OUT", FALSE);
12420 const char *d = SvPV_const(*svp, len);
12421 const I32 mode = mode_from_discipline(d, len);
12422 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12424 if (mode & O_BINARY)
12425 o->op_private |= OPpOPEN_OUT_RAW;
12429 o->op_private |= OPpOPEN_OUT_CRLF;
12434 PERL_UNUSED_CONTEXT;
12435 PERL_UNUSED_ARG(o);
12440 Perl_ck_backtick(pTHX_ OP *o)
12445 PERL_ARGS_ASSERT_CK_BACKTICK;
12447 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12448 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12449 && (gv = gv_override("readpipe",8)))
12451 /* detach rest of siblings from o and its first child */
12452 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12453 newop = S_new_entersubop(aTHX_ gv, sibl);
12455 else if (!(o->op_flags & OPf_KIDS))
12456 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12461 S_io_hints(aTHX_ o);
12466 Perl_ck_bitop(pTHX_ OP *o)
12468 PERL_ARGS_ASSERT_CK_BITOP;
12470 o->op_private = (U8)(PL_hints & HINT_INTEGER);
12472 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12473 && OP_IS_INFIX_BIT(o->op_type))
12475 const OP * const left = cBINOPo->op_first;
12476 const OP * const right = OpSIBLING(left);
12477 if ((OP_IS_NUMCOMPARE(left->op_type) &&
12478 (left->op_flags & OPf_PARENS) == 0) ||
12479 (OP_IS_NUMCOMPARE(right->op_type) &&
12480 (right->op_flags & OPf_PARENS) == 0))
12481 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12482 "Possible precedence problem on bitwise %s operator",
12483 o->op_type == OP_BIT_OR
12484 ||o->op_type == OP_NBIT_OR ? "|"
12485 : o->op_type == OP_BIT_AND
12486 ||o->op_type == OP_NBIT_AND ? "&"
12487 : o->op_type == OP_BIT_XOR
12488 ||o->op_type == OP_NBIT_XOR ? "^"
12489 : o->op_type == OP_SBIT_OR ? "|."
12490 : o->op_type == OP_SBIT_AND ? "&." : "^."
12496 PERL_STATIC_INLINE bool
12497 is_dollar_bracket(pTHX_ const OP * const o)
12500 PERL_UNUSED_CONTEXT;
12501 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12502 && (kid = cUNOPx(o)->op_first)
12503 && kid->op_type == OP_GV
12504 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12507 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12510 Perl_ck_cmp(pTHX_ OP *o)
12516 OP *indexop, *constop, *start;
12520 PERL_ARGS_ASSERT_CK_CMP;
12522 is_eq = ( o->op_type == OP_EQ
12523 || o->op_type == OP_NE
12524 || o->op_type == OP_I_EQ
12525 || o->op_type == OP_I_NE);
12527 if (!is_eq && ckWARN(WARN_SYNTAX)) {
12528 const OP *kid = cUNOPo->op_first;
12531 ( is_dollar_bracket(aTHX_ kid)
12532 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12534 || ( kid->op_type == OP_CONST
12535 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12539 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12540 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12543 /* convert (index(...) == -1) and variations into
12544 * (r)index/BOOL(,NEG)
12549 indexop = cUNOPo->op_first;
12550 constop = OpSIBLING(indexop);
12552 if (indexop->op_type == OP_CONST) {
12554 indexop = OpSIBLING(constop);
12559 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12562 /* ($lex = index(....)) == -1 */
12563 if (indexop->op_private & OPpTARGET_MY)
12566 if (constop->op_type != OP_CONST)
12569 sv = cSVOPx_sv(constop);
12570 if (!(sv && SvIOK_notUV(sv)))
12574 if (iv != -1 && iv != 0)
12578 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12579 if (!(iv0 ^ reverse))
12583 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12588 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12589 if (!(iv0 ^ reverse))
12593 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12598 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12604 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12610 indexop->op_flags &= ~OPf_PARENS;
12611 indexop->op_flags |= (o->op_flags & OPf_PARENS);
12612 indexop->op_private |= OPpTRUEBOOL;
12614 indexop->op_private |= OPpINDEX_BOOLNEG;
12615 /* cut out the index op and free the eq,const ops */
12616 (void)op_sibling_splice(o, start, 1, NULL);
12624 Perl_ck_concat(pTHX_ OP *o)
12626 const OP * const kid = cUNOPo->op_first;
12628 PERL_ARGS_ASSERT_CK_CONCAT;
12629 PERL_UNUSED_CONTEXT;
12631 /* reuse the padtmp returned by the concat child */
12632 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12633 !(kUNOP->op_first->op_flags & OPf_MOD))
12635 o->op_flags |= OPf_STACKED;
12636 o->op_private |= OPpCONCAT_NESTED;
12642 Perl_ck_spair(pTHX_ OP *o)
12646 PERL_ARGS_ASSERT_CK_SPAIR;
12648 if (o->op_flags & OPf_KIDS) {
12652 const OPCODE type = o->op_type;
12653 o = modkids(ck_fun(o), type);
12654 kid = cUNOPo->op_first;
12655 kidkid = kUNOP->op_first;
12656 newop = OpSIBLING(kidkid);
12658 const OPCODE type = newop->op_type;
12659 if (OpHAS_SIBLING(newop))
12661 if (o->op_type == OP_REFGEN
12662 && ( type == OP_RV2CV
12663 || ( !(newop->op_flags & OPf_PARENS)
12664 && ( type == OP_RV2AV || type == OP_PADAV
12665 || type == OP_RV2HV || type == OP_PADHV))))
12666 NOOP; /* OK (allow srefgen for \@a and \%h) */
12667 else if (OP_GIMME(newop,0) != G_SCALAR)
12670 /* excise first sibling */
12671 op_sibling_splice(kid, NULL, 1, NULL);
12674 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12675 * and OP_CHOMP into OP_SCHOMP */
12676 o->op_ppaddr = PL_ppaddr[++o->op_type];
12681 Perl_ck_delete(pTHX_ OP *o)
12683 PERL_ARGS_ASSERT_CK_DELETE;
12687 if (o->op_flags & OPf_KIDS) {
12688 OP * const kid = cUNOPo->op_first;
12689 switch (kid->op_type) {
12691 o->op_flags |= OPf_SPECIAL;
12694 o->op_private |= OPpSLICE;
12697 o->op_flags |= OPf_SPECIAL;
12702 o->op_flags |= OPf_SPECIAL;
12705 o->op_private |= OPpKVSLICE;
12708 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12709 "element or slice");
12711 if (kid->op_private & OPpLVAL_INTRO)
12712 o->op_private |= OPpLVAL_INTRO;
12719 Perl_ck_eof(pTHX_ OP *o)
12721 PERL_ARGS_ASSERT_CK_EOF;
12723 if (o->op_flags & OPf_KIDS) {
12725 if (cLISTOPo->op_first->op_type == OP_STUB) {
12727 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12732 kid = cLISTOPo->op_first;
12733 if (kid->op_type == OP_RV2GV)
12734 kid->op_private |= OPpALLOW_FAKE;
12741 Perl_ck_eval(pTHX_ OP *o)
12745 PERL_ARGS_ASSERT_CK_EVAL;
12747 PL_hints |= HINT_BLOCK_SCOPE;
12748 if (o->op_flags & OPf_KIDS) {
12749 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12752 if (o->op_type == OP_ENTERTRY) {
12755 /* cut whole sibling chain free from o */
12756 op_sibling_splice(o, NULL, -1, NULL);
12759 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12761 /* establish postfix order */
12762 enter->op_next = (OP*)enter;
12764 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12765 OpTYPE_set(o, OP_LEAVETRY);
12766 enter->op_other = o;
12771 S_set_haseval(aTHX);
12775 const U8 priv = o->op_private;
12777 /* the newUNOP will recursively call ck_eval(), which will handle
12778 * all the stuff at the end of this function, like adding
12781 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12783 o->op_targ = (PADOFFSET)PL_hints;
12784 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12785 if ((PL_hints & HINT_LOCALIZE_HH) != 0
12786 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12787 /* Store a copy of %^H that pp_entereval can pick up. */
12788 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12790 STOREFEATUREBITSHH(hh);
12791 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12792 /* append hhop to only child */
12793 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12795 o->op_private |= OPpEVAL_HAS_HH;
12797 if (!(o->op_private & OPpEVAL_BYTES)
12798 && FEATURE_UNIEVAL_IS_ENABLED)
12799 o->op_private |= OPpEVAL_UNICODE;
12804 Perl_ck_exec(pTHX_ OP *o)
12806 PERL_ARGS_ASSERT_CK_EXEC;
12808 if (o->op_flags & OPf_STACKED) {
12811 kid = OpSIBLING(cUNOPo->op_first);
12812 if (kid->op_type == OP_RV2GV)
12821 Perl_ck_exists(pTHX_ OP *o)
12823 PERL_ARGS_ASSERT_CK_EXISTS;
12826 if (o->op_flags & OPf_KIDS) {
12827 OP * const kid = cUNOPo->op_first;
12828 if (kid->op_type == OP_ENTERSUB) {
12829 (void) ref(kid, o->op_type);
12830 if (kid->op_type != OP_RV2CV
12831 && !(PL_parser && PL_parser->error_count))
12833 "exists argument is not a subroutine name");
12834 o->op_private |= OPpEXISTS_SUB;
12836 else if (kid->op_type == OP_AELEM)
12837 o->op_flags |= OPf_SPECIAL;
12838 else if (kid->op_type != OP_HELEM)
12839 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12840 "element or a subroutine");
12847 Perl_ck_rvconst(pTHX_ OP *o)
12850 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12852 PERL_ARGS_ASSERT_CK_RVCONST;
12854 if (o->op_type == OP_RV2HV)
12855 /* rv2hv steals the bottom bit for its own uses */
12856 o->op_private &= ~OPpARG1_MASK;
12858 o->op_private |= (PL_hints & HINT_STRICT_REFS);
12860 if (kid->op_type == OP_CONST) {
12863 SV * const kidsv = kid->op_sv;
12865 /* Is it a constant from cv_const_sv()? */
12866 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12869 if (SvTYPE(kidsv) == SVt_PVAV) return o;
12870 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12871 const char *badthing;
12872 switch (o->op_type) {
12874 badthing = "a SCALAR";
12877 badthing = "an ARRAY";
12880 badthing = "a HASH";
12888 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12889 SVfARG(kidsv), badthing);
12892 * This is a little tricky. We only want to add the symbol if we
12893 * didn't add it in the lexer. Otherwise we get duplicate strict
12894 * warnings. But if we didn't add it in the lexer, we must at
12895 * least pretend like we wanted to add it even if it existed before,
12896 * or we get possible typo warnings. OPpCONST_ENTERED says
12897 * whether the lexer already added THIS instance of this symbol.
12899 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12900 gv = gv_fetchsv(kidsv,
12901 o->op_type == OP_RV2CV
12902 && o->op_private & OPpMAY_RETURN_CONSTANT
12904 : iscv | !(kid->op_private & OPpCONST_ENTERED),
12907 : o->op_type == OP_RV2SV
12909 : o->op_type == OP_RV2AV
12911 : o->op_type == OP_RV2HV
12918 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12919 && SvTYPE(SvRV(gv)) != SVt_PVCV)
12920 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12922 OpTYPE_set(kid, OP_GV);
12923 SvREFCNT_dec(kid->op_sv);
12924 #ifdef USE_ITHREADS
12925 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12926 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12927 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12928 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12929 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12931 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12933 kid->op_private = 0;
12934 /* FAKE globs in the symbol table cause weird bugs (#77810) */
12942 Perl_ck_ftst(pTHX_ OP *o)
12945 const I32 type = o->op_type;
12947 PERL_ARGS_ASSERT_CK_FTST;
12949 if (o->op_flags & OPf_REF) {
12952 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12953 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12954 const OPCODE kidtype = kid->op_type;
12956 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12957 && !kid->op_folded) {
12958 OP * const newop = newGVOP(type, OPf_REF,
12959 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12964 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12965 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12967 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12968 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12969 array_passed_to_stat, name);
12972 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12973 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12976 scalar((OP *) kid);
12977 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12978 o->op_private |= OPpFT_ACCESS;
12979 if (OP_IS_FILETEST(type)
12980 && OP_IS_FILETEST(kidtype)
12982 o->op_private |= OPpFT_STACKED;
12983 kid->op_private |= OPpFT_STACKING;
12984 if (kidtype == OP_FTTTY && (
12985 !(kid->op_private & OPpFT_STACKED)
12986 || kid->op_private & OPpFT_AFTER_t
12988 o->op_private |= OPpFT_AFTER_t;
12993 if (type == OP_FTTTY)
12994 o = newGVOP(type, OPf_REF, PL_stdingv);
12996 o = newUNOP(type, 0, newDEFSVOP());
13002 Perl_ck_fun(pTHX_ OP *o)
13004 const int type = o->op_type;
13005 I32 oa = PL_opargs[type] >> OASHIFT;
13007 PERL_ARGS_ASSERT_CK_FUN;
13009 if (o->op_flags & OPf_STACKED) {
13010 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
13011 oa &= ~OA_OPTIONAL;
13013 return no_fh_allowed(o);
13016 if (o->op_flags & OPf_KIDS) {
13017 OP *prev_kid = NULL;
13018 OP *kid = cLISTOPo->op_first;
13020 bool seen_optional = FALSE;
13022 if (kid->op_type == OP_PUSHMARK ||
13023 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
13026 kid = OpSIBLING(kid);
13028 if (kid && kid->op_type == OP_COREARGS) {
13029 bool optional = FALSE;
13032 if (oa & OA_OPTIONAL) optional = TRUE;
13035 if (optional) o->op_private |= numargs;
13040 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
13041 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
13042 kid = newDEFSVOP();
13043 /* append kid to chain */
13044 op_sibling_splice(o, prev_kid, 0, kid);
13046 seen_optional = TRUE;
13053 /* list seen where single (scalar) arg expected? */
13054 if (numargs == 1 && !(oa >> 4)
13055 && kid->op_type == OP_LIST && type != OP_SCALAR)
13057 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13059 if (type != OP_DELETE) scalar(kid);
13070 if ((type == OP_PUSH || type == OP_UNSHIFT)
13071 && !OpHAS_SIBLING(kid))
13072 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
13073 "Useless use of %s with no values",
13076 if (kid->op_type == OP_CONST
13077 && ( !SvROK(cSVOPx_sv(kid))
13078 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
13080 bad_type_pv(numargs, "array", o, kid);
13081 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
13082 || kid->op_type == OP_RV2GV) {
13083 bad_type_pv(1, "array", o, kid);
13085 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
13086 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
13087 PL_op_desc[type]), 0);
13090 op_lvalue(kid, type);
13094 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
13095 bad_type_pv(numargs, "hash", o, kid);
13096 op_lvalue(kid, type);
13100 /* replace kid with newop in chain */
13102 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
13103 newop->op_next = newop;
13108 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
13109 if (kid->op_type == OP_CONST &&
13110 (kid->op_private & OPpCONST_BARE))
13112 OP * const newop = newGVOP(OP_GV, 0,
13113 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
13114 /* replace kid with newop in chain */
13115 op_sibling_splice(o, prev_kid, 1, newop);
13119 else if (kid->op_type == OP_READLINE) {
13120 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
13121 bad_type_pv(numargs, "HANDLE", o, kid);
13124 I32 flags = OPf_SPECIAL;
13126 PADOFFSET targ = 0;
13128 /* is this op a FH constructor? */
13129 if (is_handle_constructor(o,numargs)) {
13130 const char *name = NULL;
13133 bool want_dollar = TRUE;
13136 /* Set a flag to tell rv2gv to vivify
13137 * need to "prove" flag does not mean something
13138 * else already - NI-S 1999/05/07
13141 if (kid->op_type == OP_PADSV) {
13143 = PAD_COMPNAME_SV(kid->op_targ);
13144 name = PadnamePV (pn);
13145 len = PadnameLEN(pn);
13146 name_utf8 = PadnameUTF8(pn);
13148 else if (kid->op_type == OP_RV2SV
13149 && kUNOP->op_first->op_type == OP_GV)
13151 GV * const gv = cGVOPx_gv(kUNOP->op_first);
13153 len = GvNAMELEN(gv);
13154 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
13156 else if (kid->op_type == OP_AELEM
13157 || kid->op_type == OP_HELEM)
13160 OP *op = ((BINOP*)kid)->op_first;
13164 const char * const a =
13165 kid->op_type == OP_AELEM ?
13167 if (((op->op_type == OP_RV2AV) ||
13168 (op->op_type == OP_RV2HV)) &&
13169 (firstop = ((UNOP*)op)->op_first) &&
13170 (firstop->op_type == OP_GV)) {
13171 /* packagevar $a[] or $h{} */
13172 GV * const gv = cGVOPx_gv(firstop);
13175 Perl_newSVpvf(aTHX_
13180 else if (op->op_type == OP_PADAV
13181 || op->op_type == OP_PADHV) {
13182 /* lexicalvar $a[] or $h{} */
13183 const char * const padname =
13184 PAD_COMPNAME_PV(op->op_targ);
13187 Perl_newSVpvf(aTHX_
13193 name = SvPV_const(tmpstr, len);
13194 name_utf8 = SvUTF8(tmpstr);
13195 sv_2mortal(tmpstr);
13199 name = "__ANONIO__";
13201 want_dollar = FALSE;
13203 op_lvalue(kid, type);
13207 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
13208 namesv = PAD_SVl(targ);
13209 if (want_dollar && *name != '$')
13210 sv_setpvs(namesv, "$");
13213 sv_catpvn(namesv, name, len);
13214 if ( name_utf8 ) SvUTF8_on(namesv);
13218 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
13220 kid->op_targ = targ;
13221 kid->op_private |= priv;
13227 if ((type == OP_UNDEF || type == OP_POS)
13228 && numargs == 1 && !(oa >> 4)
13229 && kid->op_type == OP_LIST)
13230 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13231 op_lvalue(scalar(kid), type);
13236 kid = OpSIBLING(kid);
13238 /* FIXME - should the numargs or-ing move after the too many
13239 * arguments check? */
13240 o->op_private |= numargs;
13242 return too_many_arguments_pv(o,OP_DESC(o), 0);
13245 else if (PL_opargs[type] & OA_DEFGV) {
13246 /* Ordering of these two is important to keep f_map.t passing. */
13248 return newUNOP(type, 0, newDEFSVOP());
13252 while (oa & OA_OPTIONAL)
13254 if (oa && oa != OA_LIST)
13255 return too_few_arguments_pv(o,OP_DESC(o), 0);
13261 Perl_ck_glob(pTHX_ OP *o)
13265 PERL_ARGS_ASSERT_CK_GLOB;
13268 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13269 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13271 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13275 * \ null - const(wildcard)
13280 * \ mark - glob - rv2cv
13281 * | \ gv(CORE::GLOBAL::glob)
13283 * \ null - const(wildcard)
13285 o->op_flags |= OPf_SPECIAL;
13286 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13287 o = S_new_entersubop(aTHX_ gv, o);
13288 o = newUNOP(OP_NULL, 0, o);
13289 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13292 else o->op_flags &= ~OPf_SPECIAL;
13293 #if !defined(PERL_EXTERNAL_GLOB)
13294 if (!PL_globhook) {
13296 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13297 newSVpvs("File::Glob"), NULL, NULL, NULL);
13300 #endif /* !PERL_EXTERNAL_GLOB */
13301 gv = (GV *)newSV(0);
13302 gv_init(gv, 0, "", 0, 0);
13304 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13305 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13311 Perl_ck_grep(pTHX_ OP *o)
13315 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13317 PERL_ARGS_ASSERT_CK_GREP;
13319 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13321 if (o->op_flags & OPf_STACKED) {
13322 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13323 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13324 return no_fh_allowed(o);
13325 o->op_flags &= ~OPf_STACKED;
13327 kid = OpSIBLING(cLISTOPo->op_first);
13328 if (type == OP_MAPWHILE)
13333 if (PL_parser && PL_parser->error_count)
13335 kid = OpSIBLING(cLISTOPo->op_first);
13336 if (kid->op_type != OP_NULL)
13337 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13338 kid = kUNOP->op_first;
13340 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13341 kid->op_next = (OP*)gwop;
13342 o->op_private = gwop->op_private = 0;
13343 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13345 kid = OpSIBLING(cLISTOPo->op_first);
13346 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13347 op_lvalue(kid, OP_GREPSTART);
13353 Perl_ck_index(pTHX_ OP *o)
13355 PERL_ARGS_ASSERT_CK_INDEX;
13357 if (o->op_flags & OPf_KIDS) {
13358 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13360 kid = OpSIBLING(kid); /* get past "big" */
13361 if (kid && kid->op_type == OP_CONST) {
13362 const bool save_taint = TAINT_get;
13363 SV *sv = kSVOP->op_sv;
13364 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13365 && SvOK(sv) && !SvROK(sv))
13368 sv_copypv(sv, kSVOP->op_sv);
13369 SvREFCNT_dec_NN(kSVOP->op_sv);
13372 if (SvOK(sv)) fbm_compile(sv, 0);
13373 TAINT_set(save_taint);
13374 #ifdef NO_TAINT_SUPPORT
13375 PERL_UNUSED_VAR(save_taint);
13383 Perl_ck_lfun(pTHX_ OP *o)
13385 const OPCODE type = o->op_type;
13387 PERL_ARGS_ASSERT_CK_LFUN;
13389 return modkids(ck_fun(o), type);
13393 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
13395 PERL_ARGS_ASSERT_CK_DEFINED;
13397 if ((o->op_flags & OPf_KIDS)) {
13398 switch (cUNOPo->op_first->op_type) {
13401 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13402 " (Maybe you should just omit the defined()?)");
13403 NOT_REACHED; /* NOTREACHED */
13407 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13408 " (Maybe you should just omit the defined()?)");
13409 NOT_REACHED; /* NOTREACHED */
13420 Perl_ck_readline(pTHX_ OP *o)
13422 PERL_ARGS_ASSERT_CK_READLINE;
13424 if (o->op_flags & OPf_KIDS) {
13425 OP *kid = cLISTOPo->op_first;
13426 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13431 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13439 Perl_ck_rfun(pTHX_ OP *o)
13441 const OPCODE type = o->op_type;
13443 PERL_ARGS_ASSERT_CK_RFUN;
13445 return refkids(ck_fun(o), type);
13449 Perl_ck_listiob(pTHX_ OP *o)
13453 PERL_ARGS_ASSERT_CK_LISTIOB;
13455 kid = cLISTOPo->op_first;
13457 o = force_list(o, 1);
13458 kid = cLISTOPo->op_first;
13460 if (kid->op_type == OP_PUSHMARK)
13461 kid = OpSIBLING(kid);
13462 if (kid && o->op_flags & OPf_STACKED)
13463 kid = OpSIBLING(kid);
13464 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
13465 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13466 && !kid->op_folded) {
13467 o->op_flags |= OPf_STACKED; /* make it a filehandle */
13469 /* replace old const op with new OP_RV2GV parent */
13470 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13471 OP_RV2GV, OPf_REF);
13472 kid = OpSIBLING(kid);
13477 op_append_elem(o->op_type, o, newDEFSVOP());
13479 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13480 return listkids(o);
13484 Perl_ck_smartmatch(pTHX_ OP *o)
13487 PERL_ARGS_ASSERT_CK_SMARTMATCH;
13488 if (0 == (o->op_flags & OPf_SPECIAL)) {
13489 OP *first = cBINOPo->op_first;
13490 OP *second = OpSIBLING(first);
13492 /* Implicitly take a reference to an array or hash */
13494 /* remove the original two siblings, then add back the
13495 * (possibly different) first and second sibs.
13497 op_sibling_splice(o, NULL, 1, NULL);
13498 op_sibling_splice(o, NULL, 1, NULL);
13499 first = ref_array_or_hash(first);
13500 second = ref_array_or_hash(second);
13501 op_sibling_splice(o, NULL, 0, second);
13502 op_sibling_splice(o, NULL, 0, first);
13504 /* Implicitly take a reference to a regular expression */
13505 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13506 OpTYPE_set(first, OP_QR);
13508 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13509 OpTYPE_set(second, OP_QR);
13518 S_maybe_targlex(pTHX_ OP *o)
13520 OP * const kid = cLISTOPo->op_first;
13521 /* has a disposable target? */
13522 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13523 && !(kid->op_flags & OPf_STACKED)
13524 /* Cannot steal the second time! */
13525 && !(kid->op_private & OPpTARGET_MY)
13528 OP * const kkid = OpSIBLING(kid);
13530 /* Can just relocate the target. */
13531 if (kkid && kkid->op_type == OP_PADSV
13532 && (!(kkid->op_private & OPpLVAL_INTRO)
13533 || kkid->op_private & OPpPAD_STATE))
13535 kid->op_targ = kkid->op_targ;
13537 /* Now we do not need PADSV and SASSIGN.
13538 * Detach kid and free the rest. */
13539 op_sibling_splice(o, NULL, 1, NULL);
13541 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
13549 Perl_ck_sassign(pTHX_ OP *o)
13552 OP * const kid = cBINOPo->op_first;
13554 PERL_ARGS_ASSERT_CK_SASSIGN;
13556 if (OpHAS_SIBLING(kid)) {
13557 OP *kkid = OpSIBLING(kid);
13558 /* For state variable assignment with attributes, kkid is a list op
13559 whose op_last is a padsv. */
13560 if ((kkid->op_type == OP_PADSV ||
13561 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13562 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13565 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13566 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13567 return S_newONCEOP(aTHX_ o, kkid);
13570 return S_maybe_targlex(aTHX_ o);
13575 Perl_ck_match(pTHX_ OP *o)
13577 PERL_UNUSED_CONTEXT;
13578 PERL_ARGS_ASSERT_CK_MATCH;
13584 Perl_ck_method(pTHX_ OP *o)
13586 SV *sv, *methsv, *rclass;
13587 const char* method;
13590 STRLEN len, nsplit = 0, i;
13592 OP * const kid = cUNOPo->op_first;
13594 PERL_ARGS_ASSERT_CK_METHOD;
13595 if (kid->op_type != OP_CONST) return o;
13599 /* replace ' with :: */
13600 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13601 SvEND(sv) - SvPVX(sv) )))
13604 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13607 method = SvPVX_const(sv);
13609 utf8 = SvUTF8(sv) ? -1 : 1;
13611 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13616 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13618 if (!nsplit) { /* $proto->method() */
13620 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13623 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13625 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13628 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13629 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13630 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13631 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13633 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13634 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13636 #ifdef USE_ITHREADS
13637 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13639 cMETHOPx(new_op)->op_rclass_sv = rclass;
13646 Perl_ck_null(pTHX_ OP *o)
13648 PERL_ARGS_ASSERT_CK_NULL;
13649 PERL_UNUSED_CONTEXT;
13654 Perl_ck_open(pTHX_ OP *o)
13656 PERL_ARGS_ASSERT_CK_OPEN;
13658 S_io_hints(aTHX_ o);
13660 /* In case of three-arg dup open remove strictness
13661 * from the last arg if it is a bareword. */
13662 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13663 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
13667 if ((last->op_type == OP_CONST) && /* The bareword. */
13668 (last->op_private & OPpCONST_BARE) &&
13669 (last->op_private & OPpCONST_STRICT) &&
13670 (oa = OpSIBLING(first)) && /* The fh. */
13671 (oa = OpSIBLING(oa)) && /* The mode. */
13672 (oa->op_type == OP_CONST) &&
13673 SvPOK(((SVOP*)oa)->op_sv) &&
13674 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
13675 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
13676 (last == OpSIBLING(oa))) /* The bareword. */
13677 last->op_private &= ~OPpCONST_STRICT;
13683 Perl_ck_prototype(pTHX_ OP *o)
13685 PERL_ARGS_ASSERT_CK_PROTOTYPE;
13686 if (!(o->op_flags & OPf_KIDS)) {
13688 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13694 Perl_ck_refassign(pTHX_ OP *o)
13696 OP * const right = cLISTOPo->op_first;
13697 OP * const left = OpSIBLING(right);
13698 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13701 PERL_ARGS_ASSERT_CK_REFASSIGN;
13703 assert (left->op_type == OP_SREFGEN);
13706 /* we use OPpPAD_STATE in refassign to mean either of those things,
13707 * and the code assumes the two flags occupy the same bit position
13708 * in the various ops below */
13709 assert(OPpPAD_STATE == OPpOUR_INTRO);
13711 switch (varop->op_type) {
13713 o->op_private |= OPpLVREF_AV;
13716 o->op_private |= OPpLVREF_HV;
13720 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13721 o->op_targ = varop->op_targ;
13722 varop->op_targ = 0;
13723 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13727 o->op_private |= OPpLVREF_AV;
13729 NOT_REACHED; /* NOTREACHED */
13731 o->op_private |= OPpLVREF_HV;
13735 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13736 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13738 /* Point varop to its GV kid, detached. */
13739 varop = op_sibling_splice(varop, NULL, -1, NULL);
13743 OP * const kidparent =
13744 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13745 OP * const kid = cUNOPx(kidparent)->op_first;
13746 o->op_private |= OPpLVREF_CV;
13747 if (kid->op_type == OP_GV) {
13748 SV *sv = (SV*)cGVOPx_gv(kid);
13750 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13751 /* a CVREF here confuses pp_refassign, so make sure
13753 CV *const cv = (CV*)SvRV(sv);
13754 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
13755 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13756 assert(SvTYPE(sv) == SVt_PVGV);
13758 goto detach_and_stack;
13760 if (kid->op_type != OP_PADCV) goto bad;
13761 o->op_targ = kid->op_targ;
13767 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13768 o->op_private |= OPpLVREF_ELEM;
13771 /* Detach varop. */
13772 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13776 /* diag_listed_as: Can't modify reference to %s in %s assignment */
13777 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13782 if (!FEATURE_REFALIASING_IS_ENABLED)
13784 "Experimental aliasing via reference not enabled");
13785 Perl_ck_warner_d(aTHX_
13786 packWARN(WARN_EXPERIMENTAL__REFALIASING),
13787 "Aliasing via reference is experimental");
13789 o->op_flags |= OPf_STACKED;
13790 op_sibling_splice(o, right, 1, varop);
13793 o->op_flags &=~ OPf_STACKED;
13794 op_sibling_splice(o, right, 1, NULL);
13801 Perl_ck_repeat(pTHX_ OP *o)
13803 PERL_ARGS_ASSERT_CK_REPEAT;
13805 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13807 o->op_private |= OPpREPEAT_DOLIST;
13808 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13809 kids = force_list(kids, 1); /* promote it to a list */
13810 op_sibling_splice(o, NULL, 0, kids); /* and add back */
13818 Perl_ck_require(pTHX_ OP *o)
13822 PERL_ARGS_ASSERT_CK_REQUIRE;
13824 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
13825 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13829 if (kid->op_type == OP_CONST) {
13830 SV * const sv = kid->op_sv;
13831 U32 const was_readonly = SvREADONLY(sv);
13832 if (kid->op_private & OPpCONST_BARE) {
13837 if (was_readonly) {
13838 SvREADONLY_off(sv);
13841 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13846 /* treat ::foo::bar as foo::bar */
13847 if (len >= 2 && s[0] == ':' && s[1] == ':')
13848 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13850 DIE(aTHX_ "Bareword in require maps to empty filename");
13852 for (; s < end; s++) {
13853 if (*s == ':' && s[1] == ':') {
13855 Move(s+2, s+1, end - s - 1, char);
13859 SvEND_set(sv, end);
13860 sv_catpvs(sv, ".pm");
13861 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13862 hek = share_hek(SvPVX(sv),
13863 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13865 sv_sethek(sv, hek);
13867 SvFLAGS(sv) |= was_readonly;
13869 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13872 if (SvREFCNT(sv) > 1) {
13873 kid->op_sv = newSVpvn_share(
13874 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13875 SvREFCNT_dec_NN(sv);
13880 if (was_readonly) SvREADONLY_off(sv);
13881 PERL_HASH(hash, s, len);
13883 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13885 sv_sethek(sv, hek);
13887 SvFLAGS(sv) |= was_readonly;
13893 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13894 /* handle override, if any */
13895 && (gv = gv_override("require", 7))) {
13897 if (o->op_flags & OPf_KIDS) {
13898 kid = cUNOPo->op_first;
13899 op_sibling_splice(o, NULL, -1, NULL);
13902 kid = newDEFSVOP();
13905 newop = S_new_entersubop(aTHX_ gv, kid);
13913 Perl_ck_return(pTHX_ OP *o)
13917 PERL_ARGS_ASSERT_CK_RETURN;
13919 kid = OpSIBLING(cLISTOPo->op_first);
13920 if (PL_compcv && CvLVALUE(PL_compcv)) {
13921 for (; kid; kid = OpSIBLING(kid))
13922 op_lvalue(kid, OP_LEAVESUBLV);
13929 Perl_ck_select(pTHX_ OP *o)
13934 PERL_ARGS_ASSERT_CK_SELECT;
13936 if (o->op_flags & OPf_KIDS) {
13937 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13938 if (kid && OpHAS_SIBLING(kid)) {
13939 OpTYPE_set(o, OP_SSELECT);
13941 return fold_constants(op_integerize(op_std_init(o)));
13945 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13946 if (kid && kid->op_type == OP_RV2GV)
13947 kid->op_private &= ~HINT_STRICT_REFS;
13952 Perl_ck_shift(pTHX_ OP *o)
13954 const I32 type = o->op_type;
13956 PERL_ARGS_ASSERT_CK_SHIFT;
13958 if (!(o->op_flags & OPf_KIDS)) {
13961 if (!CvUNIQUE(PL_compcv)) {
13962 o->op_flags |= OPf_SPECIAL;
13966 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13968 return newUNOP(type, 0, scalar(argop));
13970 return scalar(ck_fun(o));
13974 Perl_ck_sort(pTHX_ OP *o)
13978 HV * const hinthv =
13979 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
13982 PERL_ARGS_ASSERT_CK_SORT;
13985 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
13987 const I32 sorthints = (I32)SvIV(*svp);
13988 if ((sorthints & HINT_SORT_STABLE) != 0)
13989 o->op_private |= OPpSORT_STABLE;
13990 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
13991 o->op_private |= OPpSORT_UNSTABLE;
13995 if (o->op_flags & OPf_STACKED)
13997 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13999 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
14000 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
14002 /* if the first arg is a code block, process it and mark sort as
14004 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
14006 if (kid->op_type == OP_LEAVE)
14007 op_null(kid); /* wipe out leave */
14008 /* Prevent execution from escaping out of the sort block. */
14011 /* provide scalar context for comparison function/block */
14012 kid = scalar(firstkid);
14013 kid->op_next = kid;
14014 o->op_flags |= OPf_SPECIAL;
14016 else if (kid->op_type == OP_CONST
14017 && kid->op_private & OPpCONST_BARE) {
14021 const char * const name = SvPV(kSVOP_sv, len);
14023 assert (len < 256);
14024 Copy(name, tmpbuf+1, len, char);
14025 off = pad_findmy_pvn(tmpbuf, len+1, 0);
14026 if (off != NOT_IN_PAD) {
14027 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
14029 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
14030 sv_catpvs(fq, "::");
14031 sv_catsv(fq, kSVOP_sv);
14032 SvREFCNT_dec_NN(kSVOP_sv);
14036 OP * const padop = newOP(OP_PADCV, 0);
14037 padop->op_targ = off;
14038 /* replace the const op with the pad op */
14039 op_sibling_splice(firstkid, NULL, 1, padop);
14045 firstkid = OpSIBLING(firstkid);
14048 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
14049 /* provide list context for arguments */
14052 op_lvalue(kid, OP_GREPSTART);
14058 /* for sort { X } ..., where X is one of
14059 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
14060 * elide the second child of the sort (the one containing X),
14061 * and set these flags as appropriate
14065 * Also, check and warn on lexical $a, $b.
14069 S_simplify_sort(pTHX_ OP *o)
14071 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
14075 const char *gvname;
14078 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
14080 kid = kUNOP->op_first; /* get past null */
14081 if (!(have_scopeop = kid->op_type == OP_SCOPE)
14082 && kid->op_type != OP_LEAVE)
14084 kid = kLISTOP->op_last; /* get past scope */
14085 switch(kid->op_type) {
14089 if (!have_scopeop) goto padkids;
14094 k = kid; /* remember this node*/
14095 if (kBINOP->op_first->op_type != OP_RV2SV
14096 || kBINOP->op_last ->op_type != OP_RV2SV)
14099 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
14100 then used in a comparison. This catches most, but not
14101 all cases. For instance, it catches
14102 sort { my($a); $a <=> $b }
14104 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
14105 (although why you'd do that is anyone's guess).
14109 if (!ckWARN(WARN_SYNTAX)) return;
14110 kid = kBINOP->op_first;
14112 if (kid->op_type == OP_PADSV) {
14113 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
14114 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
14115 && ( PadnamePV(name)[1] == 'a'
14116 || PadnamePV(name)[1] == 'b' ))
14117 /* diag_listed_as: "my %s" used in sort comparison */
14118 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14119 "\"%s %s\" used in sort comparison",
14120 PadnameIsSTATE(name)
14125 } while ((kid = OpSIBLING(kid)));
14128 kid = kBINOP->op_first; /* get past cmp */
14129 if (kUNOP->op_first->op_type != OP_GV)
14131 kid = kUNOP->op_first; /* get past rv2sv */
14133 if (GvSTASH(gv) != PL_curstash)
14135 gvname = GvNAME(gv);
14136 if (*gvname == 'a' && gvname[1] == '\0')
14138 else if (*gvname == 'b' && gvname[1] == '\0')
14143 kid = k; /* back to cmp */
14144 /* already checked above that it is rv2sv */
14145 kid = kBINOP->op_last; /* down to 2nd arg */
14146 if (kUNOP->op_first->op_type != OP_GV)
14148 kid = kUNOP->op_first; /* get past rv2sv */
14150 if (GvSTASH(gv) != PL_curstash)
14152 gvname = GvNAME(gv);
14154 ? !(*gvname == 'a' && gvname[1] == '\0')
14155 : !(*gvname == 'b' && gvname[1] == '\0'))
14157 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
14159 o->op_private |= OPpSORT_DESCEND;
14160 if (k->op_type == OP_NCMP)
14161 o->op_private |= OPpSORT_NUMERIC;
14162 if (k->op_type == OP_I_NCMP)
14163 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
14164 kid = OpSIBLING(cLISTOPo->op_first);
14165 /* cut out and delete old block (second sibling) */
14166 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
14171 Perl_ck_split(pTHX_ OP *o)
14177 PERL_ARGS_ASSERT_CK_SPLIT;
14179 assert(o->op_type == OP_LIST);
14181 if (o->op_flags & OPf_STACKED)
14182 return no_fh_allowed(o);
14184 kid = cLISTOPo->op_first;
14185 /* delete leading NULL node, then add a CONST if no other nodes */
14186 assert(kid->op_type == OP_NULL);
14187 op_sibling_splice(o, NULL, 1,
14188 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
14190 kid = cLISTOPo->op_first;
14192 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
14193 /* remove match expression, and replace with new optree with
14194 * a match op at its head */
14195 op_sibling_splice(o, NULL, 1, NULL);
14196 /* pmruntime will handle split " " behavior with flag==2 */
14197 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
14198 op_sibling_splice(o, NULL, 0, kid);
14201 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
14203 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
14204 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
14205 "Use of /g modifier is meaningless in split");
14208 /* eliminate the split op, and move the match op (plus any children)
14209 * into its place, then convert the match op into a split op. i.e.
14211 * SPLIT MATCH SPLIT(ex-MATCH)
14213 * MATCH - A - B - C => R - A - B - C => R - A - B - C
14219 * (R, if it exists, will be a regcomp op)
14222 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14223 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14224 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14225 OpTYPE_set(kid, OP_SPLIT);
14226 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
14227 kid->op_private = o->op_private;
14230 kid = sibs; /* kid is now the string arg of the split */
14233 kid = newDEFSVOP();
14234 op_append_elem(OP_SPLIT, o, kid);
14238 kid = OpSIBLING(kid);
14240 kid = newSVOP(OP_CONST, 0, newSViv(0));
14241 op_append_elem(OP_SPLIT, o, kid);
14242 o->op_private |= OPpSPLIT_IMPLIM;
14246 if (OpHAS_SIBLING(kid))
14247 return too_many_arguments_pv(o,OP_DESC(o), 0);
14253 Perl_ck_stringify(pTHX_ OP *o)
14255 OP * const kid = OpSIBLING(cUNOPo->op_first);
14256 PERL_ARGS_ASSERT_CK_STRINGIFY;
14257 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14258 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
14259 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
14260 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14262 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14270 Perl_ck_join(pTHX_ OP *o)
14272 OP * const kid = OpSIBLING(cLISTOPo->op_first);
14274 PERL_ARGS_ASSERT_CK_JOIN;
14276 if (kid && kid->op_type == OP_MATCH) {
14277 if (ckWARN(WARN_SYNTAX)) {
14278 const REGEXP *re = PM_GETRE(kPMOP);
14280 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14281 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14282 : newSVpvs_flags( "STRING", SVs_TEMP );
14283 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14284 "/%" SVf "/ should probably be written as \"%" SVf "\"",
14285 SVfARG(msg), SVfARG(msg));
14289 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14290 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14291 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14292 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14294 const OP * const bairn = OpSIBLING(kid); /* the list */
14295 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14296 && OP_GIMME(bairn,0) == G_SCALAR)
14298 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14299 op_sibling_splice(o, kid, 1, NULL));
14309 =for apidoc rv2cv_op_cv
14311 Examines an op, which is expected to identify a subroutine at runtime,
14312 and attempts to determine at compile time which subroutine it identifies.
14313 This is normally used during Perl compilation to determine whether
14314 a prototype can be applied to a function call. C<cvop> is the op
14315 being considered, normally an C<rv2cv> op. A pointer to the identified
14316 subroutine is returned, if it could be determined statically, and a null
14317 pointer is returned if it was not possible to determine statically.
14319 Currently, the subroutine can be identified statically if the RV that the
14320 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14321 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
14322 suitable if the constant value must be an RV pointing to a CV. Details of
14323 this process may change in future versions of Perl. If the C<rv2cv> op
14324 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14325 the subroutine statically: this flag is used to suppress compile-time
14326 magic on a subroutine call, forcing it to use default runtime behaviour.
14328 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14329 of a GV reference is modified. If a GV was examined and its CV slot was
14330 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14331 If the op is not optimised away, and the CV slot is later populated with
14332 a subroutine having a prototype, that flag eventually triggers the warning
14333 "called too early to check prototype".
14335 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14336 of returning a pointer to the subroutine it returns a pointer to the
14337 GV giving the most appropriate name for the subroutine in this context.
14338 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14339 (C<CvANON>) subroutine that is referenced through a GV it will be the
14340 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
14341 A null pointer is returned as usual if there is no statically-determinable
14344 =for apidoc Amnh||OPpEARLY_CV
14345 =for apidoc Amnh||OPpENTERSUB_AMPER
14346 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14347 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14352 /* shared by toke.c:yylex */
14354 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14356 PADNAME *name = PAD_COMPNAME(off);
14357 CV *compcv = PL_compcv;
14358 while (PadnameOUTER(name)) {
14359 assert(PARENT_PAD_INDEX(name));
14360 compcv = CvOUTSIDE(compcv);
14361 name = PadlistNAMESARRAY(CvPADLIST(compcv))
14362 [off = PARENT_PAD_INDEX(name)];
14364 assert(!PadnameIsOUR(name));
14365 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14366 return PadnamePROTOCV(name);
14368 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14372 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14377 PERL_ARGS_ASSERT_RV2CV_OP_CV;
14378 if (flags & ~RV2CVOPCV_FLAG_MASK)
14379 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14380 if (cvop->op_type != OP_RV2CV)
14382 if (cvop->op_private & OPpENTERSUB_AMPER)
14384 if (!(cvop->op_flags & OPf_KIDS))
14386 rvop = cUNOPx(cvop)->op_first;
14387 switch (rvop->op_type) {
14389 gv = cGVOPx_gv(rvop);
14391 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14392 cv = MUTABLE_CV(SvRV(gv));
14396 if (flags & RV2CVOPCV_RETURN_STUB)
14402 if (flags & RV2CVOPCV_MARK_EARLY)
14403 rvop->op_private |= OPpEARLY_CV;
14408 SV *rv = cSVOPx_sv(rvop);
14411 cv = (CV*)SvRV(rv);
14415 cv = find_lexical_cv(rvop->op_targ);
14420 } NOT_REACHED; /* NOTREACHED */
14422 if (SvTYPE((SV*)cv) != SVt_PVCV)
14424 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14425 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14429 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14430 if (CvLEXICAL(cv) || CvNAMED(cv))
14432 if (!CvANON(cv) || !gv)
14442 =for apidoc ck_entersub_args_list
14444 Performs the default fixup of the arguments part of an C<entersub>
14445 op tree. This consists of applying list context to each of the
14446 argument ops. This is the standard treatment used on a call marked
14447 with C<&>, or a method call, or a call through a subroutine reference,
14448 or any other call where the callee can't be identified at compile time,
14449 or a call where the callee has no prototype.
14455 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14459 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14461 aop = cUNOPx(entersubop)->op_first;
14462 if (!OpHAS_SIBLING(aop))
14463 aop = cUNOPx(aop)->op_first;
14464 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14465 /* skip the extra attributes->import() call implicitly added in
14466 * something like foo(my $x : bar)
14468 if ( aop->op_type == OP_ENTERSUB
14469 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14473 op_lvalue(aop, OP_ENTERSUB);
14479 =for apidoc ck_entersub_args_proto
14481 Performs the fixup of the arguments part of an C<entersub> op tree
14482 based on a subroutine prototype. This makes various modifications to
14483 the argument ops, from applying context up to inserting C<refgen> ops,
14484 and checking the number and syntactic types of arguments, as directed by
14485 the prototype. This is the standard treatment used on a subroutine call,
14486 not marked with C<&>, where the callee can be identified at compile time
14487 and has a prototype.
14489 C<protosv> supplies the subroutine prototype to be applied to the call.
14490 It may be a normal defined scalar, of which the string value will be used.
14491 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14492 that has been cast to C<SV*>) which has a prototype. The prototype
14493 supplied, in whichever form, does not need to match the actual callee
14494 referenced by the op tree.
14496 If the argument ops disagree with the prototype, for example by having
14497 an unacceptable number of arguments, a valid op tree is returned anyway.
14498 The error is reflected in the parser state, normally resulting in a single
14499 exception at the top level of parsing which covers all the compilation
14500 errors that occurred. In the error message, the callee is referred to
14501 by the name defined by the C<namegv> parameter.
14507 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14510 const char *proto, *proto_end;
14511 OP *aop, *prev, *cvop, *parent;
14514 I32 contextclass = 0;
14515 const char *e = NULL;
14516 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14517 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14518 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14519 "flags=%lx", (unsigned long) SvFLAGS(protosv));
14520 if (SvTYPE(protosv) == SVt_PVCV)
14521 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14522 else proto = SvPV(protosv, proto_len);
14523 proto = S_strip_spaces(aTHX_ proto, &proto_len);
14524 proto_end = proto + proto_len;
14525 parent = entersubop;
14526 aop = cUNOPx(entersubop)->op_first;
14527 if (!OpHAS_SIBLING(aop)) {
14529 aop = cUNOPx(aop)->op_first;
14532 aop = OpSIBLING(aop);
14533 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14534 while (aop != cvop) {
14537 if (proto >= proto_end)
14539 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14540 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14541 SVfARG(namesv)), SvUTF8(namesv));
14551 /* _ must be at the end */
14552 if (proto[1] && !memCHRs(";@%", proto[1]))
14568 if ( o3->op_type != OP_UNDEF
14569 && (o3->op_type != OP_SREFGEN
14570 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14572 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14574 bad_type_gv(arg, namegv, o3,
14575 arg == 1 ? "block or sub {}" : "sub {}");
14578 /* '*' allows any scalar type, including bareword */
14581 if (o3->op_type == OP_RV2GV)
14582 goto wrapref; /* autoconvert GLOB -> GLOBref */
14583 else if (o3->op_type == OP_CONST)
14584 o3->op_private &= ~OPpCONST_STRICT;
14590 if (o3->op_type == OP_RV2AV ||
14591 o3->op_type == OP_PADAV ||
14592 o3->op_type == OP_RV2HV ||
14593 o3->op_type == OP_PADHV
14599 case '[': case ']':
14606 switch (*proto++) {
14608 if (contextclass++ == 0) {
14609 e = (char *) memchr(proto, ']', proto_end - proto);
14610 if (!e || e == proto)
14618 if (contextclass) {
14619 const char *p = proto;
14620 const char *const end = proto;
14622 while (*--p != '[')
14623 /* \[$] accepts any scalar lvalue */
14625 && Perl_op_lvalue_flags(aTHX_
14627 OP_READ, /* not entersub */
14630 bad_type_gv(arg, namegv, o3,
14631 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14636 if (o3->op_type == OP_RV2GV)
14639 bad_type_gv(arg, namegv, o3, "symbol");
14642 if (o3->op_type == OP_ENTERSUB
14643 && !(o3->op_flags & OPf_STACKED))
14646 bad_type_gv(arg, namegv, o3, "subroutine");
14649 if (o3->op_type == OP_RV2SV ||
14650 o3->op_type == OP_PADSV ||
14651 o3->op_type == OP_HELEM ||
14652 o3->op_type == OP_AELEM)
14654 if (!contextclass) {
14655 /* \$ accepts any scalar lvalue */
14656 if (Perl_op_lvalue_flags(aTHX_
14658 OP_READ, /* not entersub */
14661 bad_type_gv(arg, namegv, o3, "scalar");
14665 if (o3->op_type == OP_RV2AV ||
14666 o3->op_type == OP_PADAV)
14668 o3->op_flags &=~ OPf_PARENS;
14672 bad_type_gv(arg, namegv, o3, "array");
14675 if (o3->op_type == OP_RV2HV ||
14676 o3->op_type == OP_PADHV)
14678 o3->op_flags &=~ OPf_PARENS;
14682 bad_type_gv(arg, namegv, o3, "hash");
14685 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14687 if (contextclass && e) {
14692 default: goto oops;
14702 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14703 SVfARG(cv_name((CV *)namegv, NULL, 0)),
14708 op_lvalue(aop, OP_ENTERSUB);
14710 aop = OpSIBLING(aop);
14712 if (aop == cvop && *proto == '_') {
14713 /* generate an access to $_ */
14714 op_sibling_splice(parent, prev, 0, newDEFSVOP());
14716 if (!optional && proto_end > proto &&
14717 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14719 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14720 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14721 SVfARG(namesv)), SvUTF8(namesv));
14727 =for apidoc ck_entersub_args_proto_or_list
14729 Performs the fixup of the arguments part of an C<entersub> op tree either
14730 based on a subroutine prototype or using default list-context processing.
14731 This is the standard treatment used on a subroutine call, not marked
14732 with C<&>, where the callee can be identified at compile time.
14734 C<protosv> supplies the subroutine prototype to be applied to the call,
14735 or indicates that there is no prototype. It may be a normal scalar,
14736 in which case if it is defined then the string value will be used
14737 as a prototype, and if it is undefined then there is no prototype.
14738 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14739 that has been cast to C<SV*>), of which the prototype will be used if it
14740 has one. The prototype (or lack thereof) supplied, in whichever form,
14741 does not need to match the actual callee referenced by the op tree.
14743 If the argument ops disagree with the prototype, for example by having
14744 an unacceptable number of arguments, a valid op tree is returned anyway.
14745 The error is reflected in the parser state, normally resulting in a single
14746 exception at the top level of parsing which covers all the compilation
14747 errors that occurred. In the error message, the callee is referred to
14748 by the name defined by the C<namegv> parameter.
14754 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14755 GV *namegv, SV *protosv)
14757 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14758 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14759 return ck_entersub_args_proto(entersubop, namegv, protosv);
14761 return ck_entersub_args_list(entersubop);
14765 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14767 IV cvflags = SvIVX(protosv);
14768 int opnum = cvflags & 0xffff;
14769 OP *aop = cUNOPx(entersubop)->op_first;
14771 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14775 if (!OpHAS_SIBLING(aop))
14776 aop = cUNOPx(aop)->op_first;
14777 aop = OpSIBLING(aop);
14778 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14780 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14781 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14782 SVfARG(namesv)), SvUTF8(namesv));
14785 op_free(entersubop);
14786 switch(cvflags >> 16) {
14787 case 'F': return newSVOP(OP_CONST, 0,
14788 newSVpv(CopFILE(PL_curcop),0));
14789 case 'L': return newSVOP(
14791 Perl_newSVpvf(aTHX_
14792 "%" IVdf, (IV)CopLINE(PL_curcop)
14795 case 'P': return newSVOP(OP_CONST, 0,
14797 ? newSVhek(HvNAME_HEK(PL_curstash))
14802 NOT_REACHED; /* NOTREACHED */
14805 OP *prev, *cvop, *first, *parent;
14808 parent = entersubop;
14809 if (!OpHAS_SIBLING(aop)) {
14811 aop = cUNOPx(aop)->op_first;
14814 first = prev = aop;
14815 aop = OpSIBLING(aop);
14816 /* find last sibling */
14818 OpHAS_SIBLING(cvop);
14819 prev = cvop, cvop = OpSIBLING(cvop))
14821 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14822 /* Usually, OPf_SPECIAL on an op with no args means that it had
14823 * parens, but these have their own meaning for that flag: */
14824 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14825 && opnum != OP_DELETE && opnum != OP_EXISTS)
14826 flags |= OPf_SPECIAL;
14827 /* excise cvop from end of sibling chain */
14828 op_sibling_splice(parent, prev, 1, NULL);
14830 if (aop == cvop) aop = NULL;
14832 /* detach remaining siblings from the first sibling, then
14833 * dispose of original optree */
14836 op_sibling_splice(parent, first, -1, NULL);
14837 op_free(entersubop);
14839 if (cvflags == (OP_ENTEREVAL | (1<<16)))
14840 flags |= OPpEVAL_BYTES <<8;
14842 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14844 case OA_BASEOP_OR_UNOP:
14845 case OA_FILESTATOP:
14847 return newOP(opnum,flags); /* zero args */
14849 return newUNOP(opnum,flags,aop); /* one arg */
14850 /* too many args */
14857 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14858 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14859 SVfARG(namesv)), SvUTF8(namesv));
14861 nextop = OpSIBLING(aop);
14867 return opnum == OP_RUNCV
14868 ? newPVOP(OP_RUNCV,0,NULL)
14871 return op_convert_list(opnum,0,aop);
14874 NOT_REACHED; /* NOTREACHED */
14879 =for apidoc cv_get_call_checker_flags
14881 Retrieves the function that will be used to fix up a call to C<cv>.
14882 Specifically, the function is applied to an C<entersub> op tree for a
14883 subroutine call, not marked with C<&>, where the callee can be identified
14884 at compile time as C<cv>.
14886 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14887 for it is returned in C<*ckobj_p>, and control flags are returned in
14888 C<*ckflags_p>. The function is intended to be called in this manner:
14890 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14892 In this call, C<entersubop> is a pointer to the C<entersub> op,
14893 which may be replaced by the check function, and C<namegv> supplies
14894 the name that should be used by the check function to refer
14895 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14896 It is permitted to apply the check function in non-standard situations,
14897 such as to a call to a different subroutine or to a method call.
14899 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
14900 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14901 instead, anything that can be used as the first argument to L</cv_name>.
14902 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14903 check function requires C<namegv> to be a genuine GV.
14905 By default, the check function is
14906 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14907 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14908 flag is clear. This implements standard prototype processing. It can
14909 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14911 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14912 indicates that the caller only knows about the genuine GV version of
14913 C<namegv>, and accordingly the corresponding bit will always be set in
14914 C<*ckflags_p>, regardless of the check function's recorded requirements.
14915 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14916 indicates the caller knows about the possibility of passing something
14917 other than a GV as C<namegv>, and accordingly the corresponding bit may
14918 be either set or clear in C<*ckflags_p>, indicating the check function's
14919 recorded requirements.
14921 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14922 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14923 (for which see above). All other bits should be clear.
14925 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14927 =for apidoc cv_get_call_checker
14929 The original form of L</cv_get_call_checker_flags>, which does not return
14930 checker flags. When using a checker function returned by this function,
14931 it is only safe to call it with a genuine GV as its C<namegv> argument.
14937 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14938 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14941 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14942 PERL_UNUSED_CONTEXT;
14943 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14945 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14946 *ckobj_p = callmg->mg_obj;
14947 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14949 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14950 *ckobj_p = (SV*)cv;
14951 *ckflags_p = gflags & MGf_REQUIRE_GV;
14956 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14959 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14960 PERL_UNUSED_CONTEXT;
14961 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14966 =for apidoc cv_set_call_checker_flags
14968 Sets the function that will be used to fix up a call to C<cv>.
14969 Specifically, the function is applied to an C<entersub> op tree for a
14970 subroutine call, not marked with C<&>, where the callee can be identified
14971 at compile time as C<cv>.
14973 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14974 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14975 The function should be defined like this:
14977 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14979 It is intended to be called in this manner:
14981 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14983 In this call, C<entersubop> is a pointer to the C<entersub> op,
14984 which may be replaced by the check function, and C<namegv> supplies
14985 the name that should be used by the check function to refer
14986 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14987 It is permitted to apply the check function in non-standard situations,
14988 such as to a call to a different subroutine or to a method call.
14990 C<namegv> may not actually be a GV. For efficiency, perl may pass a
14991 CV or other SV instead. Whatever is passed can be used as the first
14992 argument to L</cv_name>. You can force perl to pass a GV by including
14993 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14995 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14996 bit currently has a defined meaning (for which see above). All other
14997 bits should be clear.
14999 The current setting for a particular CV can be retrieved by
15000 L</cv_get_call_checker_flags>.
15002 =for apidoc cv_set_call_checker
15004 The original form of L</cv_set_call_checker_flags>, which passes it the
15005 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
15006 of that flag setting is that the check function is guaranteed to get a
15007 genuine GV as its C<namegv> argument.
15013 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
15015 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
15016 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
15020 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
15021 SV *ckobj, U32 ckflags)
15023 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
15024 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
15025 if (SvMAGICAL((SV*)cv))
15026 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
15029 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
15030 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
15032 if (callmg->mg_flags & MGf_REFCOUNTED) {
15033 SvREFCNT_dec(callmg->mg_obj);
15034 callmg->mg_flags &= ~MGf_REFCOUNTED;
15036 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
15037 callmg->mg_obj = ckobj;
15038 if (ckobj != (SV*)cv) {
15039 SvREFCNT_inc_simple_void_NN(ckobj);
15040 callmg->mg_flags |= MGf_REFCOUNTED;
15042 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
15043 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
15048 S_entersub_alloc_targ(pTHX_ OP * const o)
15050 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
15051 o->op_private |= OPpENTERSUB_HASTARG;
15055 Perl_ck_subr(pTHX_ OP *o)
15060 SV **const_class = NULL;
15062 PERL_ARGS_ASSERT_CK_SUBR;
15064 aop = cUNOPx(o)->op_first;
15065 if (!OpHAS_SIBLING(aop))
15066 aop = cUNOPx(aop)->op_first;
15067 aop = OpSIBLING(aop);
15068 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
15069 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
15070 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
15072 o->op_private &= ~1;
15073 o->op_private |= (PL_hints & HINT_STRICT_REFS);
15074 if (PERLDB_SUB && PL_curstash != PL_debstash)
15075 o->op_private |= OPpENTERSUB_DB;
15076 switch (cvop->op_type) {
15078 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
15082 case OP_METHOD_NAMED:
15083 case OP_METHOD_SUPER:
15084 case OP_METHOD_REDIR:
15085 case OP_METHOD_REDIR_SUPER:
15086 o->op_flags |= OPf_REF;
15087 if (aop->op_type == OP_CONST) {
15088 aop->op_private &= ~OPpCONST_STRICT;
15089 const_class = &cSVOPx(aop)->op_sv;
15091 else if (aop->op_type == OP_LIST) {
15092 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
15093 if (sib && sib->op_type == OP_CONST) {
15094 sib->op_private &= ~OPpCONST_STRICT;
15095 const_class = &cSVOPx(sib)->op_sv;
15098 /* make class name a shared cow string to speedup method calls */
15099 /* constant string might be replaced with object, f.e. bigint */
15100 if (const_class && SvPOK(*const_class)) {
15102 const char* str = SvPV(*const_class, len);
15104 SV* const shared = newSVpvn_share(
15105 str, SvUTF8(*const_class)
15106 ? -(SSize_t)len : (SSize_t)len,
15109 if (SvREADONLY(*const_class))
15110 SvREADONLY_on(shared);
15111 SvREFCNT_dec(*const_class);
15112 *const_class = shared;
15119 S_entersub_alloc_targ(aTHX_ o);
15120 return ck_entersub_args_list(o);
15122 Perl_call_checker ckfun;
15125 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
15126 if (CvISXSUB(cv) || !CvROOT(cv))
15127 S_entersub_alloc_targ(aTHX_ o);
15129 /* The original call checker API guarantees that a GV will
15130 be provided with the right name. So, if the old API was
15131 used (or the REQUIRE_GV flag was passed), we have to reify
15132 the CV’s GV, unless this is an anonymous sub. This is not
15133 ideal for lexical subs, as its stringification will include
15134 the package. But it is the best we can do. */
15135 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
15136 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
15139 else namegv = MUTABLE_GV(cv);
15140 /* After a syntax error in a lexical sub, the cv that
15141 rv2cv_op_cv returns may be a nameless stub. */
15142 if (!namegv) return ck_entersub_args_list(o);
15145 return ckfun(aTHX_ o, namegv, ckobj);
15150 Perl_ck_svconst(pTHX_ OP *o)
15152 SV * const sv = cSVOPo->op_sv;
15153 PERL_ARGS_ASSERT_CK_SVCONST;
15154 PERL_UNUSED_CONTEXT;
15155 #ifdef PERL_COPY_ON_WRITE
15156 /* Since the read-only flag may be used to protect a string buffer, we
15157 cannot do copy-on-write with existing read-only scalars that are not
15158 already copy-on-write scalars. To allow $_ = "hello" to do COW with
15159 that constant, mark the constant as COWable here, if it is not
15160 already read-only. */
15161 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
15164 # ifdef PERL_DEBUG_READONLY_COW
15174 Perl_ck_trunc(pTHX_ OP *o)
15176 PERL_ARGS_ASSERT_CK_TRUNC;
15178 if (o->op_flags & OPf_KIDS) {
15179 SVOP *kid = (SVOP*)cUNOPo->op_first;
15181 if (kid->op_type == OP_NULL)
15182 kid = (SVOP*)OpSIBLING(kid);
15183 if (kid && kid->op_type == OP_CONST &&
15184 (kid->op_private & OPpCONST_BARE) &&
15187 o->op_flags |= OPf_SPECIAL;
15188 kid->op_private &= ~OPpCONST_STRICT;
15195 Perl_ck_substr(pTHX_ OP *o)
15197 PERL_ARGS_ASSERT_CK_SUBSTR;
15200 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15201 OP *kid = cLISTOPo->op_first;
15203 if (kid->op_type == OP_NULL)
15204 kid = OpSIBLING(kid);
15206 /* Historically, substr(delete $foo{bar},...) has been allowed
15207 with 4-arg substr. Keep it working by applying entersub
15209 op_lvalue(kid, OP_ENTERSUB);
15216 Perl_ck_tell(pTHX_ OP *o)
15218 PERL_ARGS_ASSERT_CK_TELL;
15220 if (o->op_flags & OPf_KIDS) {
15221 OP *kid = cLISTOPo->op_first;
15222 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15223 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15229 Perl_ck_each(pTHX_ OP *o)
15232 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15233 const unsigned orig_type = o->op_type;
15235 PERL_ARGS_ASSERT_CK_EACH;
15238 switch (kid->op_type) {
15244 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15245 : orig_type == OP_KEYS ? OP_AKEYS
15249 if (kid->op_private == OPpCONST_BARE
15250 || !SvROK(cSVOPx_sv(kid))
15251 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15252 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
15257 qerror(Perl_mess(aTHX_
15258 "Experimental %s on scalar is now forbidden",
15259 PL_op_desc[orig_type]));
15261 bad_type_pv(1, "hash or array", o, kid);
15269 Perl_ck_length(pTHX_ OP *o)
15271 PERL_ARGS_ASSERT_CK_LENGTH;
15275 if (ckWARN(WARN_SYNTAX)) {
15276 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15280 const bool hash = kid->op_type == OP_PADHV
15281 || kid->op_type == OP_RV2HV;
15282 switch (kid->op_type) {
15287 name = S_op_varname(aTHX_ kid);
15293 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15294 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15296 SVfARG(name), hash ? "keys " : "", SVfARG(name)
15299 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15300 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15301 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15303 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15304 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15305 "length() used on @array (did you mean \"scalar(@array)\"?)");
15314 Perl_ck_isa(pTHX_ OP *o)
15316 OP *classop = cBINOPo->op_last;
15318 PERL_ARGS_ASSERT_CK_ISA;
15320 /* Convert barename into PV */
15321 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15322 /* TODO: Optionally convert package to raw HV here */
15323 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15331 ---------------------------------------------------------
15333 Common vars in list assignment
15335 There now follows some enums and static functions for detecting
15336 common variables in list assignments. Here is a little essay I wrote
15337 for myself when trying to get my head around this. DAPM.
15341 First some random observations:
15343 * If a lexical var is an alias of something else, e.g.
15344 for my $x ($lex, $pkg, $a[0]) {...}
15345 then the act of aliasing will increase the reference count of the SV
15347 * If a package var is an alias of something else, it may still have a
15348 reference count of 1, depending on how the alias was created, e.g.
15349 in *a = *b, $a may have a refcount of 1 since the GP is shared
15350 with a single GvSV pointer to the SV. So If it's an alias of another
15351 package var, then RC may be 1; if it's an alias of another scalar, e.g.
15352 a lexical var or an array element, then it will have RC > 1.
15354 * There are many ways to create a package alias; ultimately, XS code
15355 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
15356 run-time tracing mechanisms are unlikely to be able to catch all cases.
15358 * When the LHS is all my declarations, the same vars can't appear directly
15359 on the RHS, but they can indirectly via closures, aliasing and lvalue
15360 subs. But those techniques all involve an increase in the lexical
15361 scalar's ref count.
15363 * When the LHS is all lexical vars (but not necessarily my declarations),
15364 it is possible for the same lexicals to appear directly on the RHS, and
15365 without an increased ref count, since the stack isn't refcounted.
15366 This case can be detected at compile time by scanning for common lex
15367 vars with PL_generation.
15369 * lvalue subs defeat common var detection, but they do at least
15370 return vars with a temporary ref count increment. Also, you can't
15371 tell at compile time whether a sub call is lvalue.
15376 A: There are a few circumstances where there definitely can't be any
15379 LHS empty: () = (...);
15380 RHS empty: (....) = ();
15381 RHS contains only constants or other 'can't possibly be shared'
15382 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
15383 i.e. they only contain ops not marked as dangerous, whose children
15384 are also not dangerous;
15386 LHS contains a single scalar element: e.g. ($x) = (....); because
15387 after $x has been modified, it won't be used again on the RHS;
15388 RHS contains a single element with no aggregate on LHS: e.g.
15389 ($a,$b,$c) = ($x); again, once $a has been modified, its value
15390 won't be used again.
15392 B: If LHS are all 'my' lexical var declarations (or safe ops, which
15395 my ($a, $b, @c) = ...;
15397 Due to closure and goto tricks, these vars may already have content.
15398 For the same reason, an element on the RHS may be a lexical or package
15399 alias of one of the vars on the left, or share common elements, for
15402 my ($x,$y) = f(); # $x and $y on both sides
15403 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
15408 my @a = @$ra; # elements of @a on both sides
15409 sub f { @a = 1..4; \@a }
15412 First, just consider scalar vars on LHS:
15414 RHS is safe only if (A), or in addition,
15415 * contains only lexical *scalar* vars, where neither side's
15416 lexicals have been flagged as aliases
15418 If RHS is not safe, then it's always legal to check LHS vars for
15419 RC==1, since the only RHS aliases will always be associated
15422 Note that in particular, RHS is not safe if:
15424 * it contains package scalar vars; e.g.:
15427 my ($x, $y) = (2, $x_alias);
15428 sub f { $x = 1; *x_alias = \$x; }
15430 * It contains other general elements, such as flattened or
15431 * spliced or single array or hash elements, e.g.
15434 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
15438 use feature 'refaliasing';
15439 \($a[0], $a[1]) = \($y,$x);
15442 It doesn't matter if the array/hash is lexical or package.
15444 * it contains a function call that happens to be an lvalue
15445 sub which returns one or more of the above, e.g.
15456 (so a sub call on the RHS should be treated the same
15457 as having a package var on the RHS).
15459 * any other "dangerous" thing, such an op or built-in that
15460 returns one of the above, e.g. pp_preinc
15463 If RHS is not safe, what we can do however is at compile time flag
15464 that the LHS are all my declarations, and at run time check whether
15465 all the LHS have RC == 1, and if so skip the full scan.
15467 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
15469 Here the issue is whether there can be elements of @a on the RHS
15470 which will get prematurely freed when @a is cleared prior to
15471 assignment. This is only a problem if the aliasing mechanism
15472 is one which doesn't increase the refcount - only if RC == 1
15473 will the RHS element be prematurely freed.
15475 Because the array/hash is being INTROed, it or its elements
15476 can't directly appear on the RHS:
15478 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
15480 but can indirectly, e.g.:
15484 sub f { @a = 1..3; \@a }
15486 So if the RHS isn't safe as defined by (A), we must always
15487 mortalise and bump the ref count of any remaining RHS elements
15488 when assigning to a non-empty LHS aggregate.
15490 Lexical scalars on the RHS aren't safe if they've been involved in
15493 use feature 'refaliasing';
15496 \(my $lex) = \$pkg;
15497 my @a = ($lex,3); # equivalent to ($a[0],3)
15504 Similarly with lexical arrays and hashes on the RHS:
15518 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
15519 my $a; ($a, my $b) = (....);
15521 The difference between (B) and (C) is that it is now physically
15522 possible for the LHS vars to appear on the RHS too, where they
15523 are not reference counted; but in this case, the compile-time
15524 PL_generation sweep will detect such common vars.
15526 So the rules for (C) differ from (B) in that if common vars are
15527 detected, the runtime "test RC==1" optimisation can no longer be used,
15528 and a full mark and sweep is required
15530 D: As (C), but in addition the LHS may contain package vars.
15532 Since package vars can be aliased without a corresponding refcount
15533 increase, all bets are off. It's only safe if (A). E.g.
15535 my ($x, $y) = (1,2);
15537 for $x_alias ($x) {
15538 ($x_alias, $y) = (3, $x); # whoops
15541 Ditto for LHS aggregate package vars.
15543 E: Any other dangerous ops on LHS, e.g.
15544 (f(), $a[0], @$r) = (...);
15546 this is similar to (E) in that all bets are off. In addition, it's
15547 impossible to determine at compile time whether the LHS
15548 contains a scalar or an aggregate, e.g.
15550 sub f : lvalue { @a }
15553 * ---------------------------------------------------------
15557 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
15558 * that at least one of the things flagged was seen.
15562 AAS_MY_SCALAR = 0x001, /* my $scalar */
15563 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
15564 AAS_LEX_SCALAR = 0x004, /* $lexical */
15565 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
15566 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
15567 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
15568 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
15569 AAS_DANGEROUS = 0x080, /* an op (other than the above)
15570 that's flagged OA_DANGEROUS */
15571 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
15572 not in any of the categories above */
15573 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
15578 /* helper function for S_aassign_scan().
15579 * check a PAD-related op for commonality and/or set its generation number.
15580 * Returns a boolean indicating whether its shared */
15583 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
15585 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
15586 /* lexical used in aliasing */
15590 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
15592 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
15599 Helper function for OPpASSIGN_COMMON* detection in rpeep().
15600 It scans the left or right hand subtree of the aassign op, and returns a
15601 set of flags indicating what sorts of things it found there.
15602 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
15603 set PL_generation on lexical vars; if the latter, we see if
15604 PL_generation matches.
15605 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
15606 This fn will increment it by the number seen. It's not intended to
15607 be an accurate count (especially as many ops can push a variable
15608 number of SVs onto the stack); rather it's used as to test whether there
15609 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
15613 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
15616 OP *effective_top_op = o;
15620 bool top = o == effective_top_op;
15622 OP* next_kid = NULL;
15624 /* first, look for a solitary @_ on the RHS */
15627 && (o->op_flags & OPf_KIDS)
15628 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
15630 OP *kid = cUNOPo->op_first;
15631 if ( ( kid->op_type == OP_PUSHMARK
15632 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
15633 && ((kid = OpSIBLING(kid)))
15634 && !OpHAS_SIBLING(kid)
15635 && kid->op_type == OP_RV2AV
15636 && !(kid->op_flags & OPf_REF)
15637 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15638 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
15639 && ((kid = cUNOPx(kid)->op_first))
15640 && kid->op_type == OP_GV
15641 && cGVOPx_gv(kid) == PL_defgv
15646 switch (o->op_type) {
15649 all_flags |= AAS_PKG_SCALAR;
15655 /* if !top, could be e.g. @a[0,1] */
15656 all_flags |= (top && (o->op_flags & OPf_REF))
15657 ? ((o->op_private & OPpLVAL_INTRO)
15658 ? AAS_MY_AGG : AAS_LEX_AGG)
15664 int comm = S_aassign_padcheck(aTHX_ o, rhs)
15665 ? AAS_LEX_SCALAR_COMM : 0;
15667 all_flags |= (o->op_private & OPpLVAL_INTRO)
15668 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
15676 if (cUNOPx(o)->op_first->op_type != OP_GV)
15677 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
15679 /* if !top, could be e.g. @a[0,1] */
15680 else if (top && (o->op_flags & OPf_REF))
15681 all_flags |= AAS_PKG_AGG;
15683 all_flags |= AAS_DANGEROUS;
15688 if (cUNOPx(o)->op_first->op_type != OP_GV) {
15690 all_flags |= AAS_DANGEROUS; /* ${expr} */
15693 all_flags |= AAS_PKG_SCALAR; /* $pkg */
15697 if (o->op_private & OPpSPLIT_ASSIGN) {
15698 /* the assign in @a = split() has been optimised away
15699 * and the @a attached directly to the split op
15700 * Treat the array as appearing on the RHS, i.e.
15701 * ... = (@a = split)
15706 if (o->op_flags & OPf_STACKED) {
15707 /* @{expr} = split() - the array expression is tacked
15708 * on as an extra child to split - process kid */
15709 next_kid = cLISTOPo->op_last;
15713 /* ... else array is directly attached to split op */
15715 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
15716 ? ((o->op_private & OPpLVAL_INTRO)
15717 ? AAS_MY_AGG : AAS_LEX_AGG)
15722 /* other args of split can't be returned */
15723 all_flags |= AAS_SAFE_SCALAR;
15727 /* undef counts as a scalar on the RHS:
15728 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
15729 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
15733 flags = AAS_SAFE_SCALAR;
15738 /* these are all no-ops; they don't push a potentially common SV
15739 * onto the stack, so they are neither AAS_DANGEROUS nor
15740 * AAS_SAFE_SCALAR */
15743 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
15748 /* these do nothing, but may have children */
15752 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
15754 flags = AAS_DANGEROUS;
15758 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
15759 && (o->op_private & OPpTARGET_MY))
15762 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
15763 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
15767 /* if its an unrecognised, non-dangerous op, assume that it
15768 * is the cause of at least one safe scalar */
15770 flags = AAS_SAFE_SCALAR;
15774 all_flags |= flags;
15776 /* by default, process all kids next
15777 * XXX this assumes that all other ops are "transparent" - i.e. that
15778 * they can return some of their children. While this true for e.g.
15779 * sort and grep, it's not true for e.g. map. We really need a
15780 * 'transparent' flag added to regen/opcodes
15782 if (o->op_flags & OPf_KIDS) {
15783 next_kid = cUNOPo->op_first;
15784 /* these ops do nothing but may have children; but their
15785 * children should also be treated as top-level */
15786 if ( o == effective_top_op
15787 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
15789 effective_top_op = next_kid;
15793 /* If next_kid is set, someone in the code above wanted us to process
15794 * that kid and all its remaining siblings. Otherwise, work our way
15795 * back up the tree */
15797 while (!next_kid) {
15799 return all_flags; /* at top; no parents/siblings to try */
15800 if (OpHAS_SIBLING(o)) {
15801 next_kid = o->op_sibparent;
15802 if (o == effective_top_op)
15803 effective_top_op = next_kid;
15806 if (o == effective_top_op)
15807 effective_top_op = o->op_sibparent;
15808 o = o->op_sibparent; /* try parent's next sibling */
15817 /* Check for in place reverse and sort assignments like "@a = reverse @a"
15818 and modify the optree to make them work inplace */
15821 S_inplace_aassign(pTHX_ OP *o) {
15823 OP *modop, *modop_pushmark;
15825 OP *oleft, *oleft_pushmark;
15827 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
15829 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
15831 assert(cUNOPo->op_first->op_type == OP_NULL);
15832 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
15833 assert(modop_pushmark->op_type == OP_PUSHMARK);
15834 modop = OpSIBLING(modop_pushmark);
15836 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
15839 /* no other operation except sort/reverse */
15840 if (OpHAS_SIBLING(modop))
15843 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
15844 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
15846 if (modop->op_flags & OPf_STACKED) {
15847 /* skip sort subroutine/block */
15848 assert(oright->op_type == OP_NULL);
15849 oright = OpSIBLING(oright);
15852 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
15853 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
15854 assert(oleft_pushmark->op_type == OP_PUSHMARK);
15855 oleft = OpSIBLING(oleft_pushmark);
15857 /* Check the lhs is an array */
15859 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
15860 || OpHAS_SIBLING(oleft)
15861 || (oleft->op_private & OPpLVAL_INTRO)
15865 /* Only one thing on the rhs */
15866 if (OpHAS_SIBLING(oright))
15869 /* check the array is the same on both sides */
15870 if (oleft->op_type == OP_RV2AV) {
15871 if (oright->op_type != OP_RV2AV
15872 || !cUNOPx(oright)->op_first
15873 || cUNOPx(oright)->op_first->op_type != OP_GV
15874 || cUNOPx(oleft )->op_first->op_type != OP_GV
15875 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15876 cGVOPx_gv(cUNOPx(oright)->op_first)
15880 else if (oright->op_type != OP_PADAV
15881 || oright->op_targ != oleft->op_targ
15885 /* This actually is an inplace assignment */
15887 modop->op_private |= OPpSORT_INPLACE;
15889 /* transfer MODishness etc from LHS arg to RHS arg */
15890 oright->op_flags = oleft->op_flags;
15892 /* remove the aassign op and the lhs */
15894 op_null(oleft_pushmark);
15895 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15896 op_null(cUNOPx(oleft)->op_first);
15902 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
15903 * that potentially represent a series of one or more aggregate derefs
15904 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
15905 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
15906 * additional ops left in too).
15908 * The caller will have already verified that the first few ops in the
15909 * chain following 'start' indicate a multideref candidate, and will have
15910 * set 'orig_o' to the point further on in the chain where the first index
15911 * expression (if any) begins. 'orig_action' specifies what type of
15912 * beginning has already been determined by the ops between start..orig_o
15913 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
15915 * 'hints' contains any hints flags that need adding (currently just
15916 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
15920 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
15924 UNOP_AUX_item *arg_buf = NULL;
15925 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
15926 int index_skip = -1; /* don't output index arg on this action */
15928 /* similar to regex compiling, do two passes; the first pass
15929 * determines whether the op chain is convertible and calculates the
15930 * buffer size; the second pass populates the buffer and makes any
15931 * changes necessary to ops (such as moving consts to the pad on
15932 * threaded builds).
15934 * NB: for things like Coverity, note that both passes take the same
15935 * path through the logic tree (except for 'if (pass)' bits), since
15936 * both passes are following the same op_next chain; and in
15937 * particular, if it would return early on the second pass, it would
15938 * already have returned early on the first pass.
15940 for (pass = 0; pass < 2; pass++) {
15942 UV action = orig_action;
15943 OP *first_elem_op = NULL; /* first seen aelem/helem */
15944 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
15945 int action_count = 0; /* number of actions seen so far */
15946 int action_ix = 0; /* action_count % (actions per IV) */
15947 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
15948 bool is_last = FALSE; /* no more derefs to follow */
15949 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
15950 UV action_word = 0; /* all actions so far */
15951 UNOP_AUX_item *arg = arg_buf;
15952 UNOP_AUX_item *action_ptr = arg_buf;
15954 arg++; /* reserve slot for first action word */
15957 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
15958 case MDEREF_HV_gvhv_helem:
15959 next_is_hash = TRUE;
15961 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
15962 case MDEREF_AV_gvav_aelem:
15964 #ifdef USE_ITHREADS
15965 arg->pad_offset = cPADOPx(start)->op_padix;
15966 /* stop it being swiped when nulled */
15967 cPADOPx(start)->op_padix = 0;
15969 arg->sv = cSVOPx(start)->op_sv;
15970 cSVOPx(start)->op_sv = NULL;
15976 case MDEREF_HV_padhv_helem:
15977 case MDEREF_HV_padsv_vivify_rv2hv_helem:
15978 next_is_hash = TRUE;
15980 case MDEREF_AV_padav_aelem:
15981 case MDEREF_AV_padsv_vivify_rv2av_aelem:
15983 arg->pad_offset = start->op_targ;
15984 /* we skip setting op_targ = 0 for now, since the intact
15985 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
15986 reset_start_targ = TRUE;
15991 case MDEREF_HV_pop_rv2hv_helem:
15992 next_is_hash = TRUE;
15994 case MDEREF_AV_pop_rv2av_aelem:
15998 NOT_REACHED; /* NOTREACHED */
16003 /* look for another (rv2av/hv; get index;
16004 * aelem/helem/exists/delele) sequence */
16009 UV index_type = MDEREF_INDEX_none;
16011 if (action_count) {
16012 /* if this is not the first lookup, consume the rv2av/hv */
16014 /* for N levels of aggregate lookup, we normally expect
16015 * that the first N-1 [ah]elem ops will be flagged as
16016 * /DEREF (so they autovivifiy if necessary), and the last
16017 * lookup op not to be.
16018 * For other things (like @{$h{k1}{k2}}) extra scope or
16019 * leave ops can appear, so abandon the effort in that
16021 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
16024 /* rv2av or rv2hv sKR/1 */
16026 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16027 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16028 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16031 /* at this point, we wouldn't expect any of these
16032 * possible private flags:
16033 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
16034 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
16036 ASSUME(!(o->op_private &
16037 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
16039 hints = (o->op_private & OPpHINT_STRICT_REFS);
16041 /* make sure the type of the previous /DEREF matches the
16042 * type of the next lookup */
16043 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
16046 action = next_is_hash
16047 ? MDEREF_HV_vivify_rv2hv_helem
16048 : MDEREF_AV_vivify_rv2av_aelem;
16052 /* if this is the second pass, and we're at the depth where
16053 * previously we encountered a non-simple index expression,
16054 * stop processing the index at this point */
16055 if (action_count != index_skip) {
16057 /* look for one or more simple ops that return an array
16058 * index or hash key */
16060 switch (o->op_type) {
16062 /* it may be a lexical var index */
16063 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
16064 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16065 ASSUME(!(o->op_private &
16066 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16068 if ( OP_GIMME(o,0) == G_SCALAR
16069 && !(o->op_flags & (OPf_REF|OPf_MOD))
16070 && o->op_private == 0)
16073 arg->pad_offset = o->op_targ;
16075 index_type = MDEREF_INDEX_padsv;
16081 if (next_is_hash) {
16082 /* it's a constant hash index */
16083 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
16084 /* "use constant foo => FOO; $h{+foo}" for
16085 * some weird FOO, can leave you with constants
16086 * that aren't simple strings. It's not worth
16087 * the extra hassle for those edge cases */
16092 OP * helem_op = o->op_next;
16094 ASSUME( helem_op->op_type == OP_HELEM
16095 || helem_op->op_type == OP_NULL
16097 if (helem_op->op_type == OP_HELEM) {
16098 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
16099 if ( helem_op->op_private & OPpLVAL_INTRO
16100 || rop->op_type != OP_RV2HV
16104 /* on first pass just check; on second pass
16106 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
16111 #ifdef USE_ITHREADS
16112 /* Relocate sv to the pad for thread safety */
16113 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
16114 arg->pad_offset = o->op_targ;
16117 arg->sv = cSVOPx_sv(o);
16122 /* it's a constant array index */
16124 SV *ix_sv = cSVOPo->op_sv;
16129 if ( action_count == 0
16132 && ( action == MDEREF_AV_padav_aelem
16133 || action == MDEREF_AV_gvav_aelem)
16135 maybe_aelemfast = TRUE;
16139 SvREFCNT_dec_NN(cSVOPo->op_sv);
16143 /* we've taken ownership of the SV */
16144 cSVOPo->op_sv = NULL;
16146 index_type = MDEREF_INDEX_const;
16151 /* it may be a package var index */
16153 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
16154 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
16155 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
16156 || o->op_private != 0
16161 if (kid->op_type != OP_RV2SV)
16164 ASSUME(!(kid->op_flags &
16165 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
16166 |OPf_SPECIAL|OPf_PARENS)));
16167 ASSUME(!(kid->op_private &
16169 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
16170 |OPpDEREF|OPpLVAL_INTRO)));
16171 if( (kid->op_flags &~ OPf_PARENS)
16172 != (OPf_WANT_SCALAR|OPf_KIDS)
16173 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
16178 #ifdef USE_ITHREADS
16179 arg->pad_offset = cPADOPx(o)->op_padix;
16180 /* stop it being swiped when nulled */
16181 cPADOPx(o)->op_padix = 0;
16183 arg->sv = cSVOPx(o)->op_sv;
16184 cSVOPo->op_sv = NULL;
16188 index_type = MDEREF_INDEX_gvsv;
16193 } /* action_count != index_skip */
16195 action |= index_type;
16198 /* at this point we have either:
16199 * * detected what looks like a simple index expression,
16200 * and expect the next op to be an [ah]elem, or
16201 * an nulled [ah]elem followed by a delete or exists;
16202 * * found a more complex expression, so something other
16203 * than the above follows.
16206 /* possibly an optimised away [ah]elem (where op_next is
16207 * exists or delete) */
16208 if (o->op_type == OP_NULL)
16211 /* at this point we're looking for an OP_AELEM, OP_HELEM,
16212 * OP_EXISTS or OP_DELETE */
16214 /* if a custom array/hash access checker is in scope,
16215 * abandon optimisation attempt */
16216 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16217 && PL_check[o->op_type] != Perl_ck_null)
16219 /* similarly for customised exists and delete */
16220 if ( (o->op_type == OP_EXISTS)
16221 && PL_check[o->op_type] != Perl_ck_exists)
16223 if ( (o->op_type == OP_DELETE)
16224 && PL_check[o->op_type] != Perl_ck_delete)
16227 if ( o->op_type != OP_AELEM
16228 || (o->op_private &
16229 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
16231 maybe_aelemfast = FALSE;
16233 /* look for aelem/helem/exists/delete. If it's not the last elem
16234 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
16235 * flags; if it's the last, then it mustn't have
16236 * OPpDEREF_AV/HV, but may have lots of other flags, like
16237 * OPpLVAL_INTRO etc
16240 if ( index_type == MDEREF_INDEX_none
16241 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
16242 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
16246 /* we have aelem/helem/exists/delete with valid simple index */
16248 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16249 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
16250 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
16252 /* This doesn't make much sense but is legal:
16253 * @{ local $x[0][0] } = 1
16254 * Since scope exit will undo the autovivification,
16255 * don't bother in the first place. The OP_LEAVE
16256 * assertion is in case there are other cases of both
16257 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
16258 * exit that would undo the local - in which case this
16259 * block of code would need rethinking.
16261 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
16263 OP *n = o->op_next;
16264 while (n && ( n->op_type == OP_NULL
16265 || n->op_type == OP_LIST
16266 || n->op_type == OP_SCALAR))
16268 assert(n && n->op_type == OP_LEAVE);
16270 o->op_private &= ~OPpDEREF;
16275 ASSUME(!(o->op_flags &
16276 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
16277 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
16279 ok = (o->op_flags &~ OPf_PARENS)
16280 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
16281 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
16283 else if (o->op_type == OP_EXISTS) {
16284 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16285 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16286 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
16287 ok = !(o->op_private & ~OPpARG1_MASK);
16289 else if (o->op_type == OP_DELETE) {
16290 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16291 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16292 ASSUME(!(o->op_private &
16293 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
16294 /* don't handle slices or 'local delete'; the latter
16295 * is fairly rare, and has a complex runtime */
16296 ok = !(o->op_private & ~OPpARG1_MASK);
16297 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
16298 /* skip handling run-tome error */
16299 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
16302 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
16303 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
16304 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
16305 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
16306 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
16307 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
16312 if (!first_elem_op)
16316 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
16321 action |= MDEREF_FLAG_last;
16325 /* at this point we have something that started
16326 * promisingly enough (with rv2av or whatever), but failed
16327 * to find a simple index followed by an
16328 * aelem/helem/exists/delete. If this is the first action,
16329 * give up; but if we've already seen at least one
16330 * aelem/helem, then keep them and add a new action with
16331 * MDEREF_INDEX_none, which causes it to do the vivify
16332 * from the end of the previous lookup, and do the deref,
16333 * but stop at that point. So $a[0][expr] will do one
16334 * av_fetch, vivify and deref, then continue executing at
16339 index_skip = action_count;
16340 action |= MDEREF_FLAG_last;
16341 if (index_type != MDEREF_INDEX_none)
16345 action_word |= (action << (action_ix * MDEREF_SHIFT));
16348 /* if there's no space for the next action, reserve a new slot
16349 * for it *before* we start adding args for that action */
16350 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
16352 action_ptr->uv = action_word;
16358 } /* while !is_last */
16363 /* slot reserved for next action word not now needed */
16366 action_ptr->uv = action_word;
16372 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
16373 if (index_skip == -1) {
16374 mderef->op_flags = o->op_flags
16375 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
16376 if (o->op_type == OP_EXISTS)
16377 mderef->op_private = OPpMULTIDEREF_EXISTS;
16378 else if (o->op_type == OP_DELETE)
16379 mderef->op_private = OPpMULTIDEREF_DELETE;
16381 mderef->op_private = o->op_private
16382 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
16384 /* accumulate strictness from every level (although I don't think
16385 * they can actually vary) */
16386 mderef->op_private |= hints;
16388 /* integrate the new multideref op into the optree and the
16391 * In general an op like aelem or helem has two child
16392 * sub-trees: the aggregate expression (a_expr) and the
16393 * index expression (i_expr):
16399 * The a_expr returns an AV or HV, while the i-expr returns an
16400 * index. In general a multideref replaces most or all of a
16401 * multi-level tree, e.g.
16417 * With multideref, all the i_exprs will be simple vars or
16418 * constants, except that i_expr1 may be arbitrary in the case
16419 * of MDEREF_INDEX_none.
16421 * The bottom-most a_expr will be either:
16422 * 1) a simple var (so padXv or gv+rv2Xv);
16423 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
16424 * so a simple var with an extra rv2Xv;
16425 * 3) or an arbitrary expression.
16427 * 'start', the first op in the execution chain, will point to
16428 * 1),2): the padXv or gv op;
16429 * 3): the rv2Xv which forms the last op in the a_expr
16430 * execution chain, and the top-most op in the a_expr
16433 * For all cases, the 'start' node is no longer required,
16434 * but we can't free it since one or more external nodes
16435 * may point to it. E.g. consider
16436 * $h{foo} = $a ? $b : $c
16437 * Here, both the op_next and op_other branches of the
16438 * cond_expr point to the gv[*h] of the hash expression, so
16439 * we can't free the 'start' op.
16441 * For expr->[...], we need to save the subtree containing the
16442 * expression; for the other cases, we just need to save the
16444 * So in all cases, we null the start op and keep it around by
16445 * making it the child of the multideref op; for the expr->
16446 * case, the expr will be a subtree of the start node.
16448 * So in the simple 1,2 case the optree above changes to
16454 * ex-gv (or ex-padxv)
16456 * with the op_next chain being
16458 * -> ex-gv -> multideref -> op-following-ex-exists ->
16460 * In the 3 case, we have
16473 * -> rest-of-a_expr subtree ->
16474 * ex-rv2xv -> multideref -> op-following-ex-exists ->
16477 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
16478 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
16479 * multideref attached as the child, e.g.
16485 * ex-rv2av - i_expr1
16493 /* if we free this op, don't free the pad entry */
16494 if (reset_start_targ)
16495 start->op_targ = 0;
16498 /* Cut the bit we need to save out of the tree and attach to
16499 * the multideref op, then free the rest of the tree */
16501 /* find parent of node to be detached (for use by splice) */
16503 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
16504 || orig_action == MDEREF_HV_pop_rv2hv_helem)
16506 /* there is an arbitrary expression preceding us, e.g.
16507 * expr->[..]? so we need to save the 'expr' subtree */
16508 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
16509 p = cUNOPx(p)->op_first;
16510 ASSUME( start->op_type == OP_RV2AV
16511 || start->op_type == OP_RV2HV);
16514 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
16515 * above for exists/delete. */
16516 while ( (p->op_flags & OPf_KIDS)
16517 && cUNOPx(p)->op_first != start
16519 p = cUNOPx(p)->op_first;
16521 ASSUME(cUNOPx(p)->op_first == start);
16523 /* detach from main tree, and re-attach under the multideref */
16524 op_sibling_splice(mderef, NULL, 0,
16525 op_sibling_splice(p, NULL, 1, NULL));
16528 start->op_next = mderef;
16530 mderef->op_next = index_skip == -1 ? o->op_next : o;
16532 /* excise and free the original tree, and replace with
16533 * the multideref op */
16534 p = op_sibling_splice(top_op, NULL, -1, mderef);
16543 Size_t size = arg - arg_buf;
16545 if (maybe_aelemfast && action_count == 1)
16548 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
16549 sizeof(UNOP_AUX_item) * (size + 1));
16550 /* for dumping etc: store the length in a hidden first slot;
16551 * we set the op_aux pointer to the second slot */
16552 arg_buf->uv = size;
16555 } /* for (pass = ...) */
16558 /* See if the ops following o are such that o will always be executed in
16559 * boolean context: that is, the SV which o pushes onto the stack will
16560 * only ever be consumed by later ops via SvTRUE(sv) or similar.
16561 * If so, set a suitable private flag on o. Normally this will be
16562 * bool_flag; but see below why maybe_flag is needed too.
16564 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
16565 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
16566 * already be taken, so you'll have to give that op two different flags.
16568 * More explanation of 'maybe_flag' and 'safe_and' parameters.
16569 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
16570 * those underlying ops) short-circuit, which means that rather than
16571 * necessarily returning a truth value, they may return the LH argument,
16572 * which may not be boolean. For example in $x = (keys %h || -1), keys
16573 * should return a key count rather than a boolean, even though its
16574 * sort-of being used in boolean context.
16576 * So we only consider such logical ops to provide boolean context to
16577 * their LH argument if they themselves are in void or boolean context.
16578 * However, sometimes the context isn't known until run-time. In this
16579 * case the op is marked with the maybe_flag flag it.
16581 * Consider the following.
16583 * sub f { ....; if (%h) { .... } }
16585 * This is actually compiled as
16587 * sub f { ....; %h && do { .... } }
16589 * Here we won't know until runtime whether the final statement (and hence
16590 * the &&) is in void context and so is safe to return a boolean value.
16591 * So mark o with maybe_flag rather than the bool_flag.
16592 * Note that there is cost associated with determining context at runtime
16593 * (e.g. a call to block_gimme()), so it may not be worth setting (at
16594 * compile time) and testing (at runtime) maybe_flag if the scalar verses
16595 * boolean costs savings are marginal.
16597 * However, we can do slightly better with && (compared to || and //):
16598 * this op only returns its LH argument when that argument is false. In
16599 * this case, as long as the op promises to return a false value which is
16600 * valid in both boolean and scalar contexts, we can mark an op consumed
16601 * by && with bool_flag rather than maybe_flag.
16602 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
16603 * than &PL_sv_no for a false result in boolean context, then it's safe. An
16604 * op which promises to handle this case is indicated by setting safe_and
16609 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
16614 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
16616 /* OPpTARGET_MY and boolean context probably don't mix well.
16617 * If someone finds a valid use case, maybe add an extra flag to this
16618 * function which indicates its safe to do so for this op? */
16619 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
16620 && (o->op_private & OPpTARGET_MY)));
16625 switch (lop->op_type) {
16630 /* these two consume the stack argument in the scalar case,
16631 * and treat it as a boolean in the non linenumber case */
16634 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
16635 || (lop->op_private & OPpFLIP_LINENUM))
16641 /* these never leave the original value on the stack */
16650 /* OR DOR and AND evaluate their arg as a boolean, but then may
16651 * leave the original scalar value on the stack when following the
16652 * op_next route. If not in void context, we need to ensure
16653 * that whatever follows consumes the arg only in boolean context
16665 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
16669 else if (!(lop->op_flags & OPf_WANT)) {
16670 /* unknown context - decide at runtime */
16682 lop = lop->op_next;
16685 o->op_private |= flag;
16690 /* mechanism for deferring recursion in rpeep() */
16692 #define MAX_DEFERRED 4
16696 if (defer_ix == (MAX_DEFERRED-1)) { \
16697 OP **defer = defer_queue[defer_base]; \
16698 CALL_RPEEP(*defer); \
16699 S_prune_chain_head(defer); \
16700 defer_base = (defer_base + 1) % MAX_DEFERRED; \
16703 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
16706 #define IS_AND_OP(o) (o->op_type == OP_AND)
16707 #define IS_OR_OP(o) (o->op_type == OP_OR)
16710 /* A peephole optimizer. We visit the ops in the order they're to execute.
16711 * See the comments at the top of this file for more details about when
16712 * peep() is called */
16715 Perl_rpeep(pTHX_ OP *o)
16719 OP* oldoldop = NULL;
16720 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
16721 int defer_base = 0;
16724 if (!o || o->op_opt)
16727 assert(o->op_type != OP_FREED);
16731 SAVEVPTR(PL_curcop);
16732 for (;; o = o->op_next) {
16733 if (o && o->op_opt)
16736 while (defer_ix >= 0) {
16738 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
16739 CALL_RPEEP(*defer);
16740 S_prune_chain_head(defer);
16747 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
16748 assert(!oldoldop || oldoldop->op_next == oldop);
16749 assert(!oldop || oldop->op_next == o);
16751 /* By default, this op has now been optimised. A couple of cases below
16752 clear this again. */
16756 /* look for a series of 1 or more aggregate derefs, e.g.
16757 * $a[1]{foo}[$i]{$k}
16758 * and replace with a single OP_MULTIDEREF op.
16759 * Each index must be either a const, or a simple variable,
16761 * First, look for likely combinations of starting ops,
16762 * corresponding to (global and lexical variants of)
16764 * $r->[...] $r->{...}
16765 * (preceding expression)->[...]
16766 * (preceding expression)->{...}
16767 * and if so, call maybe_multideref() to do a full inspection
16768 * of the op chain and if appropriate, replace with an
16776 switch (o2->op_type) {
16778 /* $pkg[..] : gv[*pkg]
16779 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
16781 /* Fail if there are new op flag combinations that we're
16782 * not aware of, rather than:
16783 * * silently failing to optimise, or
16784 * * silently optimising the flag away.
16785 * If this ASSUME starts failing, examine what new flag
16786 * has been added to the op, and decide whether the
16787 * optimisation should still occur with that flag, then
16788 * update the code accordingly. This applies to all the
16789 * other ASSUMEs in the block of code too.
16791 ASSUME(!(o2->op_flags &
16792 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
16793 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
16797 if (o2->op_type == OP_RV2AV) {
16798 action = MDEREF_AV_gvav_aelem;
16802 if (o2->op_type == OP_RV2HV) {
16803 action = MDEREF_HV_gvhv_helem;
16807 if (o2->op_type != OP_RV2SV)
16810 /* at this point we've seen gv,rv2sv, so the only valid
16811 * construct left is $pkg->[] or $pkg->{} */
16813 ASSUME(!(o2->op_flags & OPf_STACKED));
16814 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16815 != (OPf_WANT_SCALAR|OPf_MOD))
16818 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
16819 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
16820 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
16822 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
16823 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
16827 if (o2->op_type == OP_RV2AV) {
16828 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
16831 if (o2->op_type == OP_RV2HV) {
16832 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
16838 /* $lex->[...]: padsv[$lex] sM/DREFAV */
16840 ASSUME(!(o2->op_flags &
16841 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
16842 if ((o2->op_flags &
16843 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16844 != (OPf_WANT_SCALAR|OPf_MOD))
16847 ASSUME(!(o2->op_private &
16848 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16849 /* skip if state or intro, or not a deref */
16850 if ( o2->op_private != OPpDEREF_AV
16851 && o2->op_private != OPpDEREF_HV)
16855 if (o2->op_type == OP_RV2AV) {
16856 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
16859 if (o2->op_type == OP_RV2HV) {
16860 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
16867 /* $lex[..]: padav[@lex:1,2] sR *
16868 * or $lex{..}: padhv[%lex:1,2] sR */
16869 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
16870 OPf_REF|OPf_SPECIAL)));
16871 if ((o2->op_flags &
16872 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16873 != (OPf_WANT_SCALAR|OPf_REF))
16875 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
16877 /* OPf_PARENS isn't currently used in this case;
16878 * if that changes, let us know! */
16879 ASSUME(!(o2->op_flags & OPf_PARENS));
16881 /* at this point, we wouldn't expect any of the remaining
16882 * possible private flags:
16883 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
16884 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
16886 * OPpSLICEWARNING shouldn't affect runtime
16888 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
16890 action = o2->op_type == OP_PADAV
16891 ? MDEREF_AV_padav_aelem
16892 : MDEREF_HV_padhv_helem;
16894 S_maybe_multideref(aTHX_ o, o2, action, 0);
16900 action = o2->op_type == OP_RV2AV
16901 ? MDEREF_AV_pop_rv2av_aelem
16902 : MDEREF_HV_pop_rv2hv_helem;
16905 /* (expr)->[...]: rv2av sKR/1;
16906 * (expr)->{...}: rv2hv sKR/1; */
16908 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
16910 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16911 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
16912 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16915 /* at this point, we wouldn't expect any of these
16916 * possible private flags:
16917 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
16918 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
16920 ASSUME(!(o2->op_private &
16921 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
16923 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
16927 S_maybe_multideref(aTHX_ o, o2, action, hints);
16936 switch (o->op_type) {
16938 PL_curcop = ((COP*)o); /* for warnings */
16941 PL_curcop = ((COP*)o); /* for warnings */
16943 /* Optimise a "return ..." at the end of a sub to just be "...".
16944 * This saves 2 ops. Before:
16945 * 1 <;> nextstate(main 1 -e:1) v ->2
16946 * 4 <@> return K ->5
16947 * 2 <0> pushmark s ->3
16948 * - <1> ex-rv2sv sK/1 ->4
16949 * 3 <#> gvsv[*cat] s ->4
16952 * - <@> return K ->-
16953 * - <0> pushmark s ->2
16954 * - <1> ex-rv2sv sK/1 ->-
16955 * 2 <$> gvsv(*cat) s ->3
16958 OP *next = o->op_next;
16959 OP *sibling = OpSIBLING(o);
16960 if ( OP_TYPE_IS(next, OP_PUSHMARK)
16961 && OP_TYPE_IS(sibling, OP_RETURN)
16962 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
16963 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
16964 ||OP_TYPE_IS(sibling->op_next->op_next,
16966 && cUNOPx(sibling)->op_first == next
16967 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
16970 /* Look through the PUSHMARK's siblings for one that
16971 * points to the RETURN */
16972 OP *top = OpSIBLING(next);
16973 while (top && top->op_next) {
16974 if (top->op_next == sibling) {
16975 top->op_next = sibling->op_next;
16976 o->op_next = next->op_next;
16979 top = OpSIBLING(top);
16984 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
16986 * This latter form is then suitable for conversion into padrange
16987 * later on. Convert:
16989 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
16993 * nextstate1 -> listop -> nextstate3
16995 * pushmark -> padop1 -> padop2
16997 if (o->op_next && (
16998 o->op_next->op_type == OP_PADSV
16999 || o->op_next->op_type == OP_PADAV
17000 || o->op_next->op_type == OP_PADHV
17002 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
17003 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
17004 && o->op_next->op_next->op_next && (
17005 o->op_next->op_next->op_next->op_type == OP_PADSV
17006 || o->op_next->op_next->op_next->op_type == OP_PADAV
17007 || o->op_next->op_next->op_next->op_type == OP_PADHV
17009 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
17010 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
17011 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
17012 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
17014 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
17017 ns2 = pad1->op_next;
17018 pad2 = ns2->op_next;
17019 ns3 = pad2->op_next;
17021 /* we assume here that the op_next chain is the same as
17022 * the op_sibling chain */
17023 assert(OpSIBLING(o) == pad1);
17024 assert(OpSIBLING(pad1) == ns2);
17025 assert(OpSIBLING(ns2) == pad2);
17026 assert(OpSIBLING(pad2) == ns3);
17028 /* excise and delete ns2 */
17029 op_sibling_splice(NULL, pad1, 1, NULL);
17032 /* excise pad1 and pad2 */
17033 op_sibling_splice(NULL, o, 2, NULL);
17035 /* create new listop, with children consisting of:
17036 * a new pushmark, pad1, pad2. */
17037 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
17038 newop->op_flags |= OPf_PARENS;
17039 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17041 /* insert newop between o and ns3 */
17042 op_sibling_splice(NULL, o, 0, newop);
17044 /*fixup op_next chain */
17045 newpm = cUNOPx(newop)->op_first; /* pushmark */
17046 o ->op_next = newpm;
17047 newpm->op_next = pad1;
17048 pad1 ->op_next = pad2;
17049 pad2 ->op_next = newop; /* listop */
17050 newop->op_next = ns3;
17052 /* Ensure pushmark has this flag if padops do */
17053 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
17054 newpm->op_flags |= OPf_MOD;
17060 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
17061 to carry two labels. For now, take the easier option, and skip
17062 this optimisation if the first NEXTSTATE has a label. */
17063 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
17064 OP *nextop = o->op_next;
17066 switch (nextop->op_type) {
17071 nextop = nextop->op_next;
17077 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
17080 oldop->op_next = nextop;
17082 /* Skip (old)oldop assignment since the current oldop's
17083 op_next already points to the next op. */
17090 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
17091 if (o->op_next->op_private & OPpTARGET_MY) {
17092 if (o->op_flags & OPf_STACKED) /* chained concats */
17093 break; /* ignore_optimization */
17095 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
17096 o->op_targ = o->op_next->op_targ;
17097 o->op_next->op_targ = 0;
17098 o->op_private |= OPpTARGET_MY;
17101 op_null(o->op_next);
17105 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
17106 break; /* Scalar stub must produce undef. List stub is noop */
17110 if (o->op_targ == OP_NEXTSTATE
17111 || o->op_targ == OP_DBSTATE)
17113 PL_curcop = ((COP*)o);
17115 /* XXX: We avoid setting op_seq here to prevent later calls
17116 to rpeep() from mistakenly concluding that optimisation
17117 has already occurred. This doesn't fix the real problem,
17118 though (See 20010220.007 (#5874)). AMS 20010719 */
17119 /* op_seq functionality is now replaced by op_opt */
17127 oldop->op_next = o->op_next;
17141 convert repeat into a stub with no kids.
17143 if (o->op_next->op_type == OP_CONST
17144 || ( o->op_next->op_type == OP_PADSV
17145 && !(o->op_next->op_private & OPpLVAL_INTRO))
17146 || ( o->op_next->op_type == OP_GV
17147 && o->op_next->op_next->op_type == OP_RV2SV
17148 && !(o->op_next->op_next->op_private
17149 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
17151 const OP *kid = o->op_next->op_next;
17152 if (o->op_next->op_type == OP_GV)
17153 kid = kid->op_next;
17154 /* kid is now the ex-list. */
17155 if (kid->op_type == OP_NULL
17156 && (kid = kid->op_next)->op_type == OP_CONST
17157 /* kid is now the repeat count. */
17158 && kid->op_next->op_type == OP_REPEAT
17159 && kid->op_next->op_private & OPpREPEAT_DOLIST
17160 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
17161 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
17164 o = kid->op_next; /* repeat */
17165 oldop->op_next = o;
17166 op_free(cBINOPo->op_first);
17167 op_free(cBINOPo->op_last );
17168 o->op_flags &=~ OPf_KIDS;
17169 /* stub is a baseop; repeat is a binop */
17170 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
17171 OpTYPE_set(o, OP_STUB);
17177 /* Convert a series of PAD ops for my vars plus support into a
17178 * single padrange op. Basically
17180 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
17182 * becomes, depending on circumstances, one of
17184 * padrange ----------------------------------> (list) -> rest
17185 * padrange --------------------------------------------> rest
17187 * where all the pad indexes are sequential and of the same type
17189 * We convert the pushmark into a padrange op, then skip
17190 * any other pad ops, and possibly some trailing ops.
17191 * Note that we don't null() the skipped ops, to make it
17192 * easier for Deparse to undo this optimisation (and none of
17193 * the skipped ops are holding any resourses). It also makes
17194 * it easier for find_uninit_var(), as it can just ignore
17195 * padrange, and examine the original pad ops.
17199 OP *followop = NULL; /* the op that will follow the padrange op */
17202 PADOFFSET base = 0; /* init only to stop compiler whining */
17203 bool gvoid = 0; /* init only to stop compiler whining */
17204 bool defav = 0; /* seen (...) = @_ */
17205 bool reuse = 0; /* reuse an existing padrange op */
17207 /* look for a pushmark -> gv[_] -> rv2av */
17212 if ( p->op_type == OP_GV
17213 && cGVOPx_gv(p) == PL_defgv
17214 && (rv2av = p->op_next)
17215 && rv2av->op_type == OP_RV2AV
17216 && !(rv2av->op_flags & OPf_REF)
17217 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
17218 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
17220 q = rv2av->op_next;
17221 if (q->op_type == OP_NULL)
17223 if (q->op_type == OP_PUSHMARK) {
17233 /* scan for PAD ops */
17235 for (p = p->op_next; p; p = p->op_next) {
17236 if (p->op_type == OP_NULL)
17239 if (( p->op_type != OP_PADSV
17240 && p->op_type != OP_PADAV
17241 && p->op_type != OP_PADHV
17243 /* any private flag other than INTRO? e.g. STATE */
17244 || (p->op_private & ~OPpLVAL_INTRO)
17248 /* let $a[N] potentially be optimised into AELEMFAST_LEX
17250 if ( p->op_type == OP_PADAV
17252 && p->op_next->op_type == OP_CONST
17253 && p->op_next->op_next
17254 && p->op_next->op_next->op_type == OP_AELEM
17258 /* for 1st padop, note what type it is and the range
17259 * start; for the others, check that it's the same type
17260 * and that the targs are contiguous */
17262 intro = (p->op_private & OPpLVAL_INTRO);
17264 gvoid = OP_GIMME(p,0) == G_VOID;
17267 if ((p->op_private & OPpLVAL_INTRO) != intro)
17269 /* Note that you'd normally expect targs to be
17270 * contiguous in my($a,$b,$c), but that's not the case
17271 * when external modules start doing things, e.g.
17272 * Function::Parameters */
17273 if (p->op_targ != base + count)
17275 assert(p->op_targ == base + count);
17276 /* Either all the padops or none of the padops should
17277 be in void context. Since we only do the optimisa-
17278 tion for av/hv when the aggregate itself is pushed
17279 on to the stack (one item), there is no need to dis-
17280 tinguish list from scalar context. */
17281 if (gvoid != (OP_GIMME(p,0) == G_VOID))
17285 /* for AV, HV, only when we're not flattening */
17286 if ( p->op_type != OP_PADSV
17288 && !(p->op_flags & OPf_REF)
17292 if (count >= OPpPADRANGE_COUNTMASK)
17295 /* there's a biggest base we can fit into a
17296 * SAVEt_CLEARPADRANGE in pp_padrange.
17297 * (The sizeof() stuff will be constant-folded, and is
17298 * intended to avoid getting "comparison is always false"
17299 * compiler warnings. See the comments above
17300 * MEM_WRAP_CHECK for more explanation on why we do this
17301 * in a weird way to avoid compiler warnings.)
17304 && (8*sizeof(base) >
17305 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
17307 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17309 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17313 /* Success! We've got another valid pad op to optimise away */
17315 followop = p->op_next;
17318 if (count < 1 || (count == 1 && !defav))
17321 /* pp_padrange in specifically compile-time void context
17322 * skips pushing a mark and lexicals; in all other contexts
17323 * (including unknown till runtime) it pushes a mark and the
17324 * lexicals. We must be very careful then, that the ops we
17325 * optimise away would have exactly the same effect as the
17327 * In particular in void context, we can only optimise to
17328 * a padrange if we see the complete sequence
17329 * pushmark, pad*v, ...., list
17330 * which has the net effect of leaving the markstack as it
17331 * was. Not pushing onto the stack (whereas padsv does touch
17332 * the stack) makes no difference in void context.
17336 if (followop->op_type == OP_LIST
17337 && OP_GIMME(followop,0) == G_VOID
17340 followop = followop->op_next; /* skip OP_LIST */
17342 /* consolidate two successive my(...);'s */
17345 && oldoldop->op_type == OP_PADRANGE
17346 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
17347 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
17348 && !(oldoldop->op_flags & OPf_SPECIAL)
17351 assert(oldoldop->op_next == oldop);
17352 assert( oldop->op_type == OP_NEXTSTATE
17353 || oldop->op_type == OP_DBSTATE);
17354 assert(oldop->op_next == o);
17357 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
17359 /* Do not assume pad offsets for $c and $d are con-
17364 if ( oldoldop->op_targ + old_count == base
17365 && old_count < OPpPADRANGE_COUNTMASK - count) {
17366 base = oldoldop->op_targ;
17367 count += old_count;
17372 /* if there's any immediately following singleton
17373 * my var's; then swallow them and the associated
17375 * my ($a,$b); my $c; my $d;
17377 * my ($a,$b,$c,$d);
17380 while ( ((p = followop->op_next))
17381 && ( p->op_type == OP_PADSV
17382 || p->op_type == OP_PADAV
17383 || p->op_type == OP_PADHV)
17384 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
17385 && (p->op_private & OPpLVAL_INTRO) == intro
17386 && !(p->op_private & ~OPpLVAL_INTRO)
17388 && ( p->op_next->op_type == OP_NEXTSTATE
17389 || p->op_next->op_type == OP_DBSTATE)
17390 && count < OPpPADRANGE_COUNTMASK
17391 && base + count == p->op_targ
17394 followop = p->op_next;
17402 assert(oldoldop->op_type == OP_PADRANGE);
17403 oldoldop->op_next = followop;
17404 oldoldop->op_private = (intro | count);
17410 /* Convert the pushmark into a padrange.
17411 * To make Deparse easier, we guarantee that a padrange was
17412 * *always* formerly a pushmark */
17413 assert(o->op_type == OP_PUSHMARK);
17414 o->op_next = followop;
17415 OpTYPE_set(o, OP_PADRANGE);
17417 /* bit 7: INTRO; bit 6..0: count */
17418 o->op_private = (intro | count);
17419 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
17420 | gvoid * OPf_WANT_VOID
17421 | (defav ? OPf_SPECIAL : 0));
17427 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17428 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17433 /*'keys %h' in void or scalar context: skip the OP_KEYS
17434 * and perform the functionality directly in the RV2HV/PADHV
17437 if (o->op_flags & OPf_REF) {
17438 OP *k = o->op_next;
17439 U8 want = (k->op_flags & OPf_WANT);
17441 && k->op_type == OP_KEYS
17442 && ( want == OPf_WANT_VOID
17443 || want == OPf_WANT_SCALAR)
17444 && !(k->op_private & OPpMAYBE_LVSUB)
17445 && !(k->op_flags & OPf_MOD)
17447 o->op_next = k->op_next;
17448 o->op_flags &= ~(OPf_REF|OPf_WANT);
17449 o->op_flags |= want;
17450 o->op_private |= (o->op_type == OP_PADHV ?
17451 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
17452 /* for keys(%lex), hold onto the OP_KEYS's targ
17453 * since padhv doesn't have its own targ to return
17455 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
17460 /* see if %h is used in boolean context */
17461 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17462 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17465 if (o->op_type != OP_PADHV)
17469 if ( o->op_type == OP_PADAV
17470 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17472 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17475 /* Skip over state($x) in void context. */
17476 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
17477 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
17479 oldop->op_next = o->op_next;
17480 goto redo_nextstate;
17482 if (o->op_type != OP_PADAV)
17486 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
17487 OP* const pop = (o->op_type == OP_PADAV) ?
17488 o->op_next : o->op_next->op_next;
17490 if (pop && pop->op_type == OP_CONST &&
17491 ((PL_op = pop->op_next)) &&
17492 pop->op_next->op_type == OP_AELEM &&
17493 !(pop->op_next->op_private &
17494 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
17495 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
17498 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
17499 no_bareword_allowed(pop);
17500 if (o->op_type == OP_GV)
17501 op_null(o->op_next);
17502 op_null(pop->op_next);
17504 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
17505 o->op_next = pop->op_next->op_next;
17506 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
17507 o->op_private = (U8)i;
17508 if (o->op_type == OP_GV) {
17511 o->op_type = OP_AELEMFAST;
17514 o->op_type = OP_AELEMFAST_LEX;
17516 if (o->op_type != OP_GV)
17520 /* Remove $foo from the op_next chain in void context. */
17522 && ( o->op_next->op_type == OP_RV2SV
17523 || o->op_next->op_type == OP_RV2AV
17524 || o->op_next->op_type == OP_RV2HV )
17525 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17526 && !(o->op_next->op_private & OPpLVAL_INTRO))
17528 oldop->op_next = o->op_next->op_next;
17529 /* Reprocess the previous op if it is a nextstate, to
17530 allow double-nextstate optimisation. */
17532 if (oldop->op_type == OP_NEXTSTATE) {
17539 o = oldop->op_next;
17542 else if (o->op_next->op_type == OP_RV2SV) {
17543 if (!(o->op_next->op_private & OPpDEREF)) {
17544 op_null(o->op_next);
17545 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
17547 o->op_next = o->op_next->op_next;
17548 OpTYPE_set(o, OP_GVSV);
17551 else if (o->op_next->op_type == OP_READLINE
17552 && o->op_next->op_next->op_type == OP_CONCAT
17553 && (o->op_next->op_next->op_flags & OPf_STACKED))
17555 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
17556 OpTYPE_set(o, OP_RCATLINE);
17557 o->op_flags |= OPf_STACKED;
17558 op_null(o->op_next->op_next);
17559 op_null(o->op_next);
17570 case OP_CMPCHAIN_AND:
17571 while (cLOGOP->op_other->op_type == OP_NULL)
17572 cLOGOP->op_other = cLOGOP->op_other->op_next;
17573 while (o->op_next && ( o->op_type == o->op_next->op_type
17574 || o->op_next->op_type == OP_NULL))
17575 o->op_next = o->op_next->op_next;
17577 /* If we're an OR and our next is an AND in void context, we'll
17578 follow its op_other on short circuit, same for reverse.
17579 We can't do this with OP_DOR since if it's true, its return
17580 value is the underlying value which must be evaluated
17584 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
17585 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
17587 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17589 o->op_next = ((LOGOP*)o->op_next)->op_other;
17591 DEFER(cLOGOP->op_other);
17596 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17597 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17606 case OP_ARGDEFELEM:
17607 while (cLOGOP->op_other->op_type == OP_NULL)
17608 cLOGOP->op_other = cLOGOP->op_other->op_next;
17609 DEFER(cLOGOP->op_other);
17614 while (cLOOP->op_redoop->op_type == OP_NULL)
17615 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
17616 while (cLOOP->op_nextop->op_type == OP_NULL)
17617 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
17618 while (cLOOP->op_lastop->op_type == OP_NULL)
17619 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
17620 /* a while(1) loop doesn't have an op_next that escapes the
17621 * loop, so we have to explicitly follow the op_lastop to
17622 * process the rest of the code */
17623 DEFER(cLOOP->op_lastop);
17627 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
17628 DEFER(cLOGOPo->op_other);
17632 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17633 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17634 assert(!(cPMOP->op_pmflags & PMf_ONCE));
17635 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
17636 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
17637 cPMOP->op_pmstashstartu.op_pmreplstart
17638 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
17639 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
17645 if (o->op_flags & OPf_SPECIAL) {
17646 /* first arg is a code block */
17647 OP * const nullop = OpSIBLING(cLISTOP->op_first);
17648 OP * kid = cUNOPx(nullop)->op_first;
17650 assert(nullop->op_type == OP_NULL);
17651 assert(kid->op_type == OP_SCOPE
17652 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
17653 /* since OP_SORT doesn't have a handy op_other-style
17654 * field that can point directly to the start of the code
17655 * block, store it in the otherwise-unused op_next field
17656 * of the top-level OP_NULL. This will be quicker at
17657 * run-time, and it will also allow us to remove leading
17658 * OP_NULLs by just messing with op_nexts without
17659 * altering the basic op_first/op_sibling layout. */
17660 kid = kLISTOP->op_first;
17662 (kid->op_type == OP_NULL
17663 && ( kid->op_targ == OP_NEXTSTATE
17664 || kid->op_targ == OP_DBSTATE ))
17665 || kid->op_type == OP_STUB
17666 || kid->op_type == OP_ENTER
17667 || (PL_parser && PL_parser->error_count));
17668 nullop->op_next = kid->op_next;
17669 DEFER(nullop->op_next);
17672 /* check that RHS of sort is a single plain array */
17673 oright = cUNOPo->op_first;
17674 if (!oright || oright->op_type != OP_PUSHMARK)
17677 if (o->op_private & OPpSORT_INPLACE)
17680 /* reverse sort ... can be optimised. */
17681 if (!OpHAS_SIBLING(cUNOPo)) {
17682 /* Nothing follows us on the list. */
17683 OP * const reverse = o->op_next;
17685 if (reverse->op_type == OP_REVERSE &&
17686 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
17687 OP * const pushmark = cUNOPx(reverse)->op_first;
17688 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
17689 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
17690 /* reverse -> pushmark -> sort */
17691 o->op_private |= OPpSORT_REVERSE;
17693 pushmark->op_next = oright->op_next;
17703 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
17705 LISTOP *enter, *exlist;
17707 if (o->op_private & OPpSORT_INPLACE)
17710 enter = (LISTOP *) o->op_next;
17713 if (enter->op_type == OP_NULL) {
17714 enter = (LISTOP *) enter->op_next;
17718 /* for $a (...) will have OP_GV then OP_RV2GV here.
17719 for (...) just has an OP_GV. */
17720 if (enter->op_type == OP_GV) {
17721 gvop = (OP *) enter;
17722 enter = (LISTOP *) enter->op_next;
17725 if (enter->op_type == OP_RV2GV) {
17726 enter = (LISTOP *) enter->op_next;
17732 if (enter->op_type != OP_ENTERITER)
17735 iter = enter->op_next;
17736 if (!iter || iter->op_type != OP_ITER)
17739 expushmark = enter->op_first;
17740 if (!expushmark || expushmark->op_type != OP_NULL
17741 || expushmark->op_targ != OP_PUSHMARK)
17744 exlist = (LISTOP *) OpSIBLING(expushmark);
17745 if (!exlist || exlist->op_type != OP_NULL
17746 || exlist->op_targ != OP_LIST)
17749 if (exlist->op_last != o) {
17750 /* Mmm. Was expecting to point back to this op. */
17753 theirmark = exlist->op_first;
17754 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
17757 if (OpSIBLING(theirmark) != o) {
17758 /* There's something between the mark and the reverse, eg
17759 for (1, reverse (...))
17764 ourmark = ((LISTOP *)o)->op_first;
17765 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
17768 ourlast = ((LISTOP *)o)->op_last;
17769 if (!ourlast || ourlast->op_next != o)
17772 rv2av = OpSIBLING(ourmark);
17773 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
17774 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
17775 /* We're just reversing a single array. */
17776 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
17777 enter->op_flags |= OPf_STACKED;
17780 /* We don't have control over who points to theirmark, so sacrifice
17782 theirmark->op_next = ourmark->op_next;
17783 theirmark->op_flags = ourmark->op_flags;
17784 ourlast->op_next = gvop ? gvop : (OP *) enter;
17787 enter->op_private |= OPpITER_REVERSED;
17788 iter->op_private |= OPpITER_REVERSED;
17792 o = oldop->op_next;
17794 NOT_REACHED; /* NOTREACHED */
17800 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
17801 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
17806 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
17807 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
17810 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
17812 sv = newRV((SV *)PL_compcv);
17816 OpTYPE_set(o, OP_CONST);
17817 o->op_flags |= OPf_SPECIAL;
17818 cSVOPo->op_sv = sv;
17823 if (OP_GIMME(o,0) == G_VOID
17824 || ( o->op_next->op_type == OP_LINESEQ
17825 && ( o->op_next->op_next->op_type == OP_LEAVESUB
17826 || ( o->op_next->op_next->op_type == OP_RETURN
17827 && !CvLVALUE(PL_compcv)))))
17829 OP *right = cBINOP->op_first;
17848 OP *left = OpSIBLING(right);
17849 if (left->op_type == OP_SUBSTR
17850 && (left->op_private & 7) < 4) {
17852 /* cut out right */
17853 op_sibling_splice(o, NULL, 1, NULL);
17854 /* and insert it as second child of OP_SUBSTR */
17855 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
17857 left->op_private |= OPpSUBSTR_REPL_FIRST;
17859 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17866 int l, r, lr, lscalars, rscalars;
17868 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
17869 Note that we do this now rather than in newASSIGNOP(),
17870 since only by now are aliased lexicals flagged as such
17872 See the essay "Common vars in list assignment" above for
17873 the full details of the rationale behind all the conditions
17876 PL_generation sorcery:
17877 To detect whether there are common vars, the global var
17878 PL_generation is incremented for each assign op we scan.
17879 Then we run through all the lexical variables on the LHS,
17880 of the assignment, setting a spare slot in each of them to
17881 PL_generation. Then we scan the RHS, and if any lexicals
17882 already have that value, we know we've got commonality.
17883 Also, if the generation number is already set to
17884 PERL_INT_MAX, then the variable is involved in aliasing, so
17885 we also have potential commonality in that case.
17891 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
17894 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
17898 /* After looking for things which are *always* safe, this main
17899 * if/else chain selects primarily based on the type of the
17900 * LHS, gradually working its way down from the more dangerous
17901 * to the more restrictive and thus safer cases */
17903 if ( !l /* () = ....; */
17904 || !r /* .... = (); */
17905 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
17906 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
17907 || (lscalars < 2) /* ($x, undef) = ... */
17909 NOOP; /* always safe */
17911 else if (l & AAS_DANGEROUS) {
17912 /* always dangerous */
17913 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17914 o->op_private |= OPpASSIGN_COMMON_AGG;
17916 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
17917 /* package vars are always dangerous - too many
17918 * aliasing possibilities */
17919 if (l & AAS_PKG_SCALAR)
17920 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17921 if (l & AAS_PKG_AGG)
17922 o->op_private |= OPpASSIGN_COMMON_AGG;
17924 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
17925 |AAS_LEX_SCALAR|AAS_LEX_AGG))
17927 /* LHS contains only lexicals and safe ops */
17929 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
17930 o->op_private |= OPpASSIGN_COMMON_AGG;
17932 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
17933 if (lr & AAS_LEX_SCALAR_COMM)
17934 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17935 else if ( !(l & AAS_LEX_SCALAR)
17936 && (r & AAS_DEFAV))
17940 * as scalar-safe for performance reasons.
17941 * (it will still have been marked _AGG if necessary */
17944 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
17945 /* if there are only lexicals on the LHS and no
17946 * common ones on the RHS, then we assume that the
17947 * only way those lexicals could also get
17948 * on the RHS is via some sort of dereffing or
17951 * ($lex, $x) = (1, $$r)
17952 * and in this case we assume the var must have
17953 * a bumped ref count. So if its ref count is 1,
17954 * it must only be on the LHS.
17956 o->op_private |= OPpASSIGN_COMMON_RC1;
17961 * may have to handle aggregate on LHS, but we can't
17962 * have common scalars. */
17965 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
17967 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17968 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
17973 /* see if ref() is used in boolean context */
17974 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17975 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17979 /* see if the op is used in known boolean context,
17980 * but not if OA_TARGLEX optimisation is enabled */
17981 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17982 && !(o->op_private & OPpTARGET_MY)
17984 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17988 /* see if the op is used in known boolean context */
17989 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17990 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17994 Perl_cpeep_t cpeep =
17995 XopENTRYCUSTOM(o, xop_peep);
17997 cpeep(aTHX_ o, oldop);
18002 /* did we just null the current op? If so, re-process it to handle
18003 * eliding "empty" ops from the chain */
18004 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
18017 Perl_peep(pTHX_ OP *o)
18023 =head1 Custom Operators
18025 =for apidoc Perl_custom_op_xop
18026 Return the XOP structure for a given custom op. This macro should be
18027 considered internal to C<OP_NAME> and the other access macros: use them instead.
18028 This macro does call a function. Prior
18029 to 5.19.6, this was implemented as a
18036 /* use PERL_MAGIC_ext to call a function to free the xop structure when
18037 * freeing PL_custom_ops */
18040 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
18044 PERL_UNUSED_ARG(mg);
18045 xop = INT2PTR(XOP *, SvIV(sv));
18046 Safefree(xop->xop_name);
18047 Safefree(xop->xop_desc);
18053 static const MGVTBL custom_op_register_vtbl = {
18058 custom_op_register_free, /* free */
18068 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
18074 static const XOP xop_null = { 0, 0, 0, 0, 0 };
18076 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
18077 assert(o->op_type == OP_CUSTOM);
18079 /* This is wrong. It assumes a function pointer can be cast to IV,
18080 * which isn't guaranteed, but this is what the old custom OP code
18081 * did. In principle it should be safer to Copy the bytes of the
18082 * pointer into a PV: since the new interface is hidden behind
18083 * functions, this can be changed later if necessary. */
18084 /* Change custom_op_xop if this ever happens */
18085 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
18088 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18090 /* See if the op isn't registered, but its name *is* registered.
18091 * That implies someone is using the pre-5.14 API,where only name and
18092 * description could be registered. If so, fake up a real
18094 * We only check for an existing name, and assume no one will have
18095 * just registered a desc */
18096 if (!he && PL_custom_op_names &&
18097 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
18102 /* XXX does all this need to be shared mem? */
18103 Newxz(xop, 1, XOP);
18104 pv = SvPV(HeVAL(he), l);
18105 XopENTRY_set(xop, xop_name, savepvn(pv, l));
18106 if (PL_custom_op_descs &&
18107 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
18109 pv = SvPV(HeVAL(he), l);
18110 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
18112 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
18113 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18114 /* add magic to the SV so that the xop struct (pointed to by
18115 * SvIV(sv)) is freed. Normally a static xop is registered, but
18116 * for this backcompat hack, we've alloced one */
18117 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
18118 &custom_op_register_vtbl, NULL, 0);
18123 xop = (XOP *)&xop_null;
18125 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
18129 if(field == XOPe_xop_ptr) {
18132 const U32 flags = XopFLAGS(xop);
18133 if(flags & field) {
18135 case XOPe_xop_name:
18136 any.xop_name = xop->xop_name;
18138 case XOPe_xop_desc:
18139 any.xop_desc = xop->xop_desc;
18141 case XOPe_xop_class:
18142 any.xop_class = xop->xop_class;
18144 case XOPe_xop_peep:
18145 any.xop_peep = xop->xop_peep;
18148 NOT_REACHED; /* NOTREACHED */
18153 case XOPe_xop_name:
18154 any.xop_name = XOPd_xop_name;
18156 case XOPe_xop_desc:
18157 any.xop_desc = XOPd_xop_desc;
18159 case XOPe_xop_class:
18160 any.xop_class = XOPd_xop_class;
18162 case XOPe_xop_peep:
18163 any.xop_peep = XOPd_xop_peep;
18166 NOT_REACHED; /* NOTREACHED */
18171 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
18172 * op.c: In function 'Perl_custom_op_get_field':
18173 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
18174 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
18175 * expands to assert(0), which expands to ((0) ? (void)0 :
18176 * __assert(...)), and gcc doesn't know that __assert can never return. */
18182 =for apidoc custom_op_register
18183 Register a custom op. See L<perlguts/"Custom Operators">.
18189 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
18193 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
18195 /* see the comment in custom_op_xop */
18196 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
18198 if (!PL_custom_ops)
18199 PL_custom_ops = newHV();
18201 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
18202 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
18207 =for apidoc core_prototype
18209 This function assigns the prototype of the named core function to C<sv>, or
18210 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
18211 C<NULL> if the core function has no prototype. C<code> is a code as returned
18212 by C<keyword()>. It must not be equal to 0.
18218 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
18221 int i = 0, n = 0, seen_question = 0, defgv = 0;
18223 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
18224 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
18225 bool nullret = FALSE;
18227 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
18231 if (!sv) sv = sv_newmortal();
18233 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
18235 switch (code < 0 ? -code : code) {
18236 case KEY_and : case KEY_chop: case KEY_chomp:
18237 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
18238 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
18239 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
18240 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
18241 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
18242 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
18243 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
18244 case KEY_x : case KEY_xor :
18245 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
18246 case KEY_glob: retsetpvs("_;", OP_GLOB);
18247 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
18248 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
18249 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
18250 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
18251 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
18253 case KEY_evalbytes:
18254 name = "entereval"; break;
18262 while (i < MAXO) { /* The slow way. */
18263 if (strEQ(name, PL_op_name[i])
18264 || strEQ(name, PL_op_desc[i]))
18266 if (nullret) { assert(opnum); *opnum = i; return NULL; }
18273 defgv = PL_opargs[i] & OA_DEFGV;
18274 oa = PL_opargs[i] >> OASHIFT;
18276 if (oa & OA_OPTIONAL && !seen_question && (
18277 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
18282 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
18283 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
18284 /* But globs are already references (kinda) */
18285 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
18289 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
18290 && !scalar_mod_type(NULL, i)) {
18295 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
18299 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
18300 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
18301 str[n-1] = '_'; defgv = 0;
18305 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
18307 sv_setpvn(sv, str, n - 1);
18308 if (opnum) *opnum = i;
18313 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
18316 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
18317 newSVOP(OP_COREARGS,0,coreargssv);
18320 PERL_ARGS_ASSERT_CORESUB_OP;
18324 return op_append_elem(OP_LINESEQ,
18327 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
18334 o = newUNOP(OP_AVHVSWITCH,0,argop);
18335 o->op_private = opnum-OP_EACH;
18337 case OP_SELECT: /* which represents OP_SSELECT as well */
18342 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
18343 newSVOP(OP_CONST, 0, newSVuv(1))
18345 coresub_op(newSVuv((UV)OP_SSELECT), 0,
18347 coresub_op(coreargssv, 0, OP_SELECT)
18351 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
18353 return op_append_elem(
18356 opnum == OP_WANTARRAY || opnum == OP_RUNCV
18357 ? OPpOFFBYONE << 8 : 0)
18359 case OA_BASEOP_OR_UNOP:
18360 if (opnum == OP_ENTEREVAL) {
18361 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
18362 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
18364 else o = newUNOP(opnum,0,argop);
18365 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
18368 if (is_handle_constructor(o, 1))
18369 argop->op_private |= OPpCOREARGS_DEREF1;
18370 if (scalar_mod_type(NULL, opnum))
18371 argop->op_private |= OPpCOREARGS_SCALARMOD;
18375 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
18376 if (is_handle_constructor(o, 2))
18377 argop->op_private |= OPpCOREARGS_DEREF2;
18378 if (opnum == OP_SUBSTR) {
18379 o->op_private |= OPpMAYBE_LVSUB;
18388 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
18389 SV * const *new_const_svp)
18391 const char *hvname;
18392 bool is_const = !!CvCONST(old_cv);
18393 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
18395 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
18397 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
18399 /* They are 2 constant subroutines generated from
18400 the same constant. This probably means that
18401 they are really the "same" proxy subroutine
18402 instantiated in 2 places. Most likely this is
18403 when a constant is exported twice. Don't warn.
18406 (ckWARN(WARN_REDEFINE)
18408 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
18409 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
18410 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
18411 strEQ(hvname, "autouse"))
18415 && ckWARN_d(WARN_REDEFINE)
18416 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
18419 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
18421 ? "Constant subroutine %" SVf " redefined"
18422 : "Subroutine %" SVf " redefined",
18427 =head1 Hook manipulation
18429 These functions provide convenient and thread-safe means of manipulating
18436 =for apidoc wrap_op_checker
18438 Puts a C function into the chain of check functions for a specified op
18439 type. This is the preferred way to manipulate the L</PL_check> array.
18440 C<opcode> specifies which type of op is to be affected. C<new_checker>
18441 is a pointer to the C function that is to be added to that opcode's
18442 check chain, and C<old_checker_p> points to the storage location where a
18443 pointer to the next function in the chain will be stored. The value of
18444 C<new_checker> is written into the L</PL_check> array, while the value
18445 previously stored there is written to C<*old_checker_p>.
18447 L</PL_check> is global to an entire process, and a module wishing to
18448 hook op checking may find itself invoked more than once per process,
18449 typically in different threads. To handle that situation, this function
18450 is idempotent. The location C<*old_checker_p> must initially (once
18451 per process) contain a null pointer. A C variable of static duration
18452 (declared at file scope, typically also marked C<static> to give
18453 it internal linkage) will be implicitly initialised appropriately,
18454 if it does not have an explicit initialiser. This function will only
18455 actually modify the check chain if it finds C<*old_checker_p> to be null.
18456 This function is also thread safe on the small scale. It uses appropriate
18457 locking to avoid race conditions in accessing L</PL_check>.
18459 When this function is called, the function referenced by C<new_checker>
18460 must be ready to be called, except for C<*old_checker_p> being unfilled.
18461 In a threading situation, C<new_checker> may be called immediately,
18462 even before this function has returned. C<*old_checker_p> will always
18463 be appropriately set before C<new_checker> is called. If C<new_checker>
18464 decides not to do anything special with an op that it is given (which
18465 is the usual case for most uses of op check hooking), it must chain the
18466 check function referenced by C<*old_checker_p>.
18468 Taken all together, XS code to hook an op checker should typically look
18469 something like this:
18471 static Perl_check_t nxck_frob;
18472 static OP *myck_frob(pTHX_ OP *op) {
18474 op = nxck_frob(aTHX_ op);
18479 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
18481 If you want to influence compilation of calls to a specific subroutine,
18482 then use L</cv_set_call_checker_flags> rather than hooking checking of
18483 all C<entersub> ops.
18489 Perl_wrap_op_checker(pTHX_ Optype opcode,
18490 Perl_check_t new_checker, Perl_check_t *old_checker_p)
18494 PERL_UNUSED_CONTEXT;
18495 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
18496 if (*old_checker_p) return;
18497 OP_CHECK_MUTEX_LOCK;
18498 if (!*old_checker_p) {
18499 *old_checker_p = PL_check[opcode];
18500 PL_check[opcode] = new_checker;
18502 OP_CHECK_MUTEX_UNLOCK;
18507 /* Efficient sub that returns a constant scalar value. */
18509 const_sv_xsub(pTHX_ CV* cv)
18512 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
18513 PERL_UNUSED_ARG(items);
18523 const_av_xsub(pTHX_ CV* cv)
18526 AV * const av = MUTABLE_AV(XSANY.any_ptr);
18534 if (SvRMAGICAL(av))
18535 Perl_croak(aTHX_ "Magical list constants are not supported");
18536 if (GIMME_V != G_ARRAY) {
18538 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
18541 EXTEND(SP, AvFILLp(av)+1);
18542 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
18543 XSRETURN(AvFILLp(av)+1);
18546 /* Copy an existing cop->cop_warnings field.
18547 * If it's one of the standard addresses, just re-use the address.
18548 * This is the e implementation for the DUP_WARNINGS() macro
18552 Perl_dup_warnings(pTHX_ STRLEN* warnings)
18555 STRLEN *new_warnings;
18557 if (warnings == NULL || specialWARN(warnings))
18560 size = sizeof(*warnings) + *warnings;
18562 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
18563 Copy(warnings, new_warnings, size, char);
18564 return new_warnings;
18568 * ex: set ts=8 sts=4 sw=4 et: