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"
168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
174 /* remove any leading "empty" ops from the op_next chain whose first
175 * node's address is stored in op_p. Store the updated address of the
176 * first node in op_p.
180 S_prune_chain_head(OP** op_p)
183 && ( (*op_p)->op_type == OP_NULL
184 || (*op_p)->op_type == OP_SCOPE
185 || (*op_p)->op_type == OP_SCALAR
186 || (*op_p)->op_type == OP_LINESEQ)
188 *op_p = (*op_p)->op_next;
192 /* See the explanatory comments above struct opslab in op.h. */
194 #ifdef PERL_DEBUG_READONLY_OPS
195 # define PERL_SLAB_SIZE 128
196 # define PERL_MAX_SLAB_SIZE 4096
197 # include <sys/mman.h>
200 #ifndef PERL_SLAB_SIZE
201 # define PERL_SLAB_SIZE 64
203 #ifndef PERL_MAX_SLAB_SIZE
204 # define PERL_MAX_SLAB_SIZE 2048
207 /* rounds up to nearest pointer */
208 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
209 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
211 /* requires double parens and aTHX_ */
212 #define DEBUG_S_warn(args) \
214 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
218 /* malloc a new op slab (suitable for attaching to PL_compcv).
219 * sz is in units of pointers */
222 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
226 /* opslot_offset is only U16 */
227 assert(sz < U16_MAX);
229 #ifdef PERL_DEBUG_READONLY_OPS
230 slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
231 PROT_READ|PROT_WRITE,
232 MAP_ANON|MAP_PRIVATE, -1, 0);
233 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
234 (unsigned long) sz, slab));
235 if (slab == MAP_FAILED) {
236 perror("mmap failed");
240 slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
242 slab->opslab_size = (U16)sz;
245 /* The context is unused in non-Windows */
248 slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
249 slab->opslab_head = head ? head : slab;
250 DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
251 (unsigned int)slab->opslab_size, (void*)slab,
252 (void*)(slab->opslab_head)));
257 /* Returns a sz-sized block of memory (suitable for holding an op) from
258 * a free slot in the chain of op slabs attached to PL_compcv.
259 * Allocates a new slab if necessary.
260 * if PL_compcv isn't compiling, malloc() instead.
264 Perl_Slab_Alloc(pTHX_ size_t sz)
266 OPSLAB *head_slab; /* first slab in the chain */
272 /* We only allocate ops from the slab during subroutine compilation.
273 We find the slab via PL_compcv, hence that must be non-NULL. It could
274 also be pointing to a subroutine which is now fully set up (CvROOT()
275 pointing to the top of the optree for that sub), or a subroutine
276 which isn't using the slab allocator. If our sanity checks aren't met,
277 don't use a slab, but allocate the OP directly from the heap. */
278 if (!PL_compcv || CvROOT(PL_compcv)
279 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
281 o = (OP*)PerlMemShared_calloc(1, sz);
285 /* While the subroutine is under construction, the slabs are accessed via
286 CvSTART(), to avoid needing to expand PVCV by one pointer for something
287 unneeded at runtime. Once a subroutine is constructed, the slabs are
288 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
289 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
291 if (!CvSTART(PL_compcv)) {
293 (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
294 CvSLABBED_on(PL_compcv);
295 head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
297 else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
299 opsz = SIZE_TO_PSIZE(sz);
300 sz = opsz + OPSLOT_HEADER_P;
302 /* The slabs maintain a free list of OPs. In particular, constant folding
303 will free up OPs, so it makes sense to re-use them where possible. A
304 freed up slot is used in preference to a new allocation. */
305 if (head_slab->opslab_freed) {
306 OP **too = &head_slab->opslab_freed;
308 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p, head slab %p",
310 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
313 while (o && OpSLOT(o)->opslot_size < sz) {
314 DEBUG_S_warn((aTHX_ "Alas! too small"));
315 o = *(too = &o->op_next);
316 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
320 Zero(o, opsz, I32 *);
326 #define INIT_OPSLOT(s) \
327 slot->opslot_offset = DIFF(slab2, slot) ; \
328 slot->opslot_size = s; \
329 slab2->opslab_free_space -= s; \
330 o = &slot->opslot_op; \
333 /* The partially-filled slab is next in the chain. */
334 slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
335 if (slab2->opslab_free_space < sz) {
336 /* Remaining space is too small. */
337 /* If we can fit a BASEOP, add it to the free chain, so as not
339 if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
340 slot = &slab2->opslab_slots;
341 INIT_OPSLOT(slab2->opslab_free_space);
342 o->op_type = OP_FREED;
343 o->op_next = head_slab->opslab_freed;
344 head_slab->opslab_freed = o;
347 /* Create a new slab. Make this one twice as big. */
348 slab2 = S_new_slab(aTHX_ head_slab,
349 slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2
351 : slab2->opslab_size * 2);
352 slab2->opslab_next = head_slab->opslab_next;
353 head_slab->opslab_next = slab2;
355 assert(slab2->opslab_size >= sz);
357 /* Create a new op slot */
359 ((I32 **)&slab2->opslab_slots
360 + slab2->opslab_free_space - sz);
361 assert(slot >= &slab2->opslab_slots);
363 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
364 (void*)o, (void*)slab2, (void*)head_slab));
367 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
368 assert(!o->op_moresib);
369 assert(!o->op_sibparent);
376 #ifdef PERL_DEBUG_READONLY_OPS
378 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
380 PERL_ARGS_ASSERT_SLAB_TO_RO;
382 if (slab->opslab_readonly) return;
383 slab->opslab_readonly = 1;
384 for (; slab; slab = slab->opslab_next) {
385 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
386 (unsigned long) slab->opslab_size, slab));*/
387 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
388 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
389 (unsigned long)slab->opslab_size, errno);
394 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
398 PERL_ARGS_ASSERT_SLAB_TO_RW;
400 if (!slab->opslab_readonly) return;
402 for (; slab2; slab2 = slab2->opslab_next) {
403 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
404 (unsigned long) size, slab2));*/
405 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
406 PROT_READ|PROT_WRITE)) {
407 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
408 (unsigned long)slab2->opslab_size, errno);
411 slab->opslab_readonly = 0;
415 # define Slab_to_rw(op) NOOP
418 /* This cannot possibly be right, but it was copied from the old slab
419 allocator, to which it was originally added, without explanation, in
422 # define PerlMemShared PerlMem
425 /* make freed ops die if they're inadvertently executed */
430 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
435 /* Return the block of memory used by an op to the free list of
436 * the OP slab associated with that op.
440 Perl_Slab_Free(pTHX_ void *op)
442 OP * const o = (OP *)op;
445 PERL_ARGS_ASSERT_SLAB_FREE;
448 o->op_ppaddr = S_pp_freed;
451 if (!o->op_slabbed) {
453 PerlMemShared_free(op);
458 /* If this op is already freed, our refcount will get screwy. */
459 assert(o->op_type != OP_FREED);
460 o->op_type = OP_FREED;
461 o->op_next = slab->opslab_freed;
462 slab->opslab_freed = o;
463 DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p",
465 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
467 OpslabREFCNT_dec_padok(slab);
471 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
473 const bool havepad = !!PL_comppad;
474 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
477 PAD_SAVE_SETNULLPAD();
483 /* Free a chain of OP slabs. Should only be called after all ops contained
484 * in it have been freed. At this point, its reference count should be 1,
485 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
486 * and just directly calls opslab_free().
487 * (Note that the reference count which PL_compcv held on the slab should
488 * have been removed once compilation of the sub was complete).
494 Perl_opslab_free(pTHX_ OPSLAB *slab)
497 PERL_ARGS_ASSERT_OPSLAB_FREE;
499 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
500 assert(slab->opslab_refcnt == 1);
502 slab2 = slab->opslab_next;
504 slab->opslab_refcnt = ~(size_t)0;
506 #ifdef PERL_DEBUG_READONLY_OPS
507 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
509 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
510 perror("munmap failed");
514 PerlMemShared_free(slab);
520 /* like opslab_free(), but first calls op_free() on any ops in the slab
521 * not marked as OP_FREED
525 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
529 size_t savestack_count = 0;
531 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
534 OPSLOT *slot = (OPSLOT*)
535 ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
536 OPSLOT *end = (OPSLOT*)
537 ((I32**)slab2 + slab2->opslab_size);
539 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
541 if (slot->opslot_op.op_type != OP_FREED
542 && !(slot->opslot_op.op_savefree
548 assert(slot->opslot_op.op_slabbed);
549 op_free(&slot->opslot_op);
550 if (slab->opslab_refcnt == 1) goto free;
553 } while ((slab2 = slab2->opslab_next));
554 /* > 1 because the CV still holds a reference count. */
555 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
557 assert(savestack_count == slab->opslab_refcnt-1);
559 /* Remove the CV’s reference count. */
560 slab->opslab_refcnt--;
567 #ifdef PERL_DEBUG_READONLY_OPS
569 Perl_op_refcnt_inc(pTHX_ OP *o)
572 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
573 if (slab && slab->opslab_readonly) {
586 Perl_op_refcnt_dec(pTHX_ OP *o)
589 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
591 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
593 if (slab && slab->opslab_readonly) {
595 result = --o->op_targ;
598 result = --o->op_targ;
604 * In the following definition, the ", (OP*)0" is just to make the compiler
605 * think the expression is of the right type: croak actually does a Siglongjmp.
607 #define CHECKOP(type,o) \
608 ((PL_op_mask && PL_op_mask[type]) \
609 ? ( op_free((OP*)o), \
610 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
612 : PL_check[type](aTHX_ (OP*)o))
614 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
616 #define OpTYPE_set(o,type) \
618 o->op_type = (OPCODE)type; \
619 o->op_ppaddr = PL_ppaddr[type]; \
623 S_no_fh_allowed(pTHX_ OP *o)
625 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
627 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
633 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
635 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
636 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
641 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
643 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
645 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
650 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
652 PERL_ARGS_ASSERT_BAD_TYPE_PV;
654 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
655 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
658 /* remove flags var, its unused in all callers, move to to right end since gv
659 and kid are always the same */
661 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
663 SV * const namesv = cv_name((CV *)gv, NULL, 0);
664 PERL_ARGS_ASSERT_BAD_TYPE_GV;
666 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
667 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
671 S_no_bareword_allowed(pTHX_ OP *o)
673 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
675 qerror(Perl_mess(aTHX_
676 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
678 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
681 /* "register" allocation */
684 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
687 const bool is_our = (PL_parser->in_my == KEY_our);
689 PERL_ARGS_ASSERT_ALLOCMY;
691 if (flags & ~SVf_UTF8)
692 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
695 /* complain about "my $<special_var>" etc etc */
699 || ( (flags & SVf_UTF8)
700 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
701 || (name[1] == '_' && len > 2)))
703 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
705 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
706 /* diag_listed_as: Can't use global %s in "%s" */
707 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
708 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
709 PL_parser->in_my == KEY_state ? "state" : "my"));
711 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
712 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
716 /* allocate a spare slot and store the name in that slot */
718 off = pad_add_name_pvn(name, len,
719 (is_our ? padadd_OUR :
720 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
721 PL_parser->in_my_stash,
723 /* $_ is always in main::, even with our */
724 ? (PL_curstash && !memEQs(name,len,"$_")
730 /* anon sub prototypes contains state vars should always be cloned,
731 * otherwise the state var would be shared between anon subs */
733 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
734 CvCLONE_on(PL_compcv);
740 =head1 Optree Manipulation Functions
742 =for apidoc alloccopstash
744 Available only under threaded builds, this function allocates an entry in
745 C<PL_stashpad> for the stash passed to it.
752 Perl_alloccopstash(pTHX_ HV *hv)
754 PADOFFSET off = 0, o = 1;
755 bool found_slot = FALSE;
757 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
759 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
761 for (; o < PL_stashpadmax; ++o) {
762 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
763 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
764 found_slot = TRUE, off = o;
767 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
768 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
769 off = PL_stashpadmax;
770 PL_stashpadmax += 10;
773 PL_stashpad[PL_stashpadix = off] = hv;
778 /* free the body of an op without examining its contents.
779 * Always use this rather than FreeOp directly */
782 S_op_destroy(pTHX_ OP *o)
792 Free an op and its children. Only use this when an op is no longer linked
799 Perl_op_free(pTHX_ OP *o)
805 bool went_up = FALSE; /* whether we reached the current node by
806 following the parent pointer from a child, and
807 so have already seen this node */
809 if (!o || o->op_type == OP_FREED)
812 if (o->op_private & OPpREFCOUNTED) {
813 /* if base of tree is refcounted, just decrement */
814 switch (o->op_type) {
824 refcnt = OpREFCNT_dec(o);
827 /* Need to find and remove any pattern match ops from
828 * the list we maintain for reset(). */
829 find_and_forget_pmops(o);
842 /* free child ops before ourself, (then free ourself "on the
845 if (!went_up && o->op_flags & OPf_KIDS) {
846 next_op = cUNOPo->op_first;
850 /* find the next node to visit, *then* free the current node
851 * (can't rely on o->op_* fields being valid after o has been
854 /* The next node to visit will be either the sibling, or the
855 * parent if no siblings left, or NULL if we've worked our way
856 * back up to the top node in the tree */
857 next_op = (o == top_op) ? NULL : o->op_sibparent;
858 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
860 /* Now process the current node */
862 /* Though ops may be freed twice, freeing the op after its slab is a
864 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
865 /* During the forced freeing of ops after compilation failure, kidops
866 may be freed before their parents. */
867 if (!o || o->op_type == OP_FREED)
872 /* an op should only ever acquire op_private flags that we know about.
873 * If this fails, you may need to fix something in regen/op_private.
874 * Don't bother testing if:
875 * * the op_ppaddr doesn't match the op; someone may have
876 * overridden the op and be doing strange things with it;
877 * * we've errored, as op flags are often left in an
878 * inconsistent state then. Note that an error when
879 * compiling the main program leaves PL_parser NULL, so
880 * we can't spot faults in the main code, only
881 * evaled/required code */
883 if ( o->op_ppaddr == PL_ppaddr[type]
885 && !PL_parser->error_count)
887 assert(!(o->op_private & ~PL_op_private_valid[type]));
892 /* Call the op_free hook if it has been set. Do it now so that it's called
893 * at the right time for refcounted ops, but still before all of the kids
898 type = (OPCODE)o->op_targ;
901 Slab_to_rw(OpSLAB(o));
903 /* COP* is not cleared by op_clear() so that we may track line
904 * numbers etc even after null() */
905 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
917 /* S_op_clear_gv(): free a GV attached to an OP */
921 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
923 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
927 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
928 || o->op_type == OP_MULTIDEREF)
931 ? ((GV*)PAD_SVl(*ixp)) : NULL;
933 ? (GV*)(*svp) : NULL;
935 /* It's possible during global destruction that the GV is freed
936 before the optree. Whilst the SvREFCNT_inc is happy to bump from
937 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
938 will trigger an assertion failure, because the entry to sv_clear
939 checks that the scalar is not already freed. A check of for
940 !SvIS_FREED(gv) turns out to be invalid, because during global
941 destruction the reference count can be forced down to zero
942 (with SVf_BREAK set). In which case raising to 1 and then
943 dropping to 0 triggers cleanup before it should happen. I
944 *think* that this might actually be a general, systematic,
945 weakness of the whole idea of SVf_BREAK, in that code *is*
946 allowed to raise and lower references during global destruction,
947 so any *valid* code that happens to do this during global
948 destruction might well trigger premature cleanup. */
949 bool still_valid = gv && SvREFCNT(gv);
952 SvREFCNT_inc_simple_void(gv);
955 pad_swipe(*ixp, TRUE);
963 int try_downgrade = SvREFCNT(gv) == 2;
966 gv_try_downgrade(gv);
972 Perl_op_clear(pTHX_ OP *o)
977 PERL_ARGS_ASSERT_OP_CLEAR;
979 switch (o->op_type) {
980 case OP_NULL: /* Was holding old type, if any. */
983 case OP_ENTEREVAL: /* Was holding hints. */
984 case OP_ARGDEFELEM: /* Was holding signature index. */
988 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
995 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
997 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1000 case OP_METHOD_REDIR:
1001 case OP_METHOD_REDIR_SUPER:
1003 if (cMETHOPx(o)->op_rclass_targ) {
1004 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1005 cMETHOPx(o)->op_rclass_targ = 0;
1008 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1009 cMETHOPx(o)->op_rclass_sv = NULL;
1012 case OP_METHOD_NAMED:
1013 case OP_METHOD_SUPER:
1014 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1015 cMETHOPx(o)->op_u.op_meth_sv = NULL;
1018 pad_swipe(o->op_targ, 1);
1025 SvREFCNT_dec(cSVOPo->op_sv);
1026 cSVOPo->op_sv = NULL;
1029 Even if op_clear does a pad_free for the target of the op,
1030 pad_free doesn't actually remove the sv that exists in the pad;
1031 instead it lives on. This results in that it could be reused as
1032 a target later on when the pad was reallocated.
1035 pad_swipe(o->op_targ,1);
1045 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1050 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1051 && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1054 if (cPADOPo->op_padix > 0) {
1055 pad_swipe(cPADOPo->op_padix, TRUE);
1056 cPADOPo->op_padix = 0;
1059 SvREFCNT_dec(cSVOPo->op_sv);
1060 cSVOPo->op_sv = NULL;
1064 PerlMemShared_free(cPVOPo->op_pv);
1065 cPVOPo->op_pv = NULL;
1069 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1073 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1074 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1076 if (o->op_private & OPpSPLIT_LEX)
1077 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1080 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1082 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1089 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1090 op_free(cPMOPo->op_code_list);
1091 cPMOPo->op_code_list = NULL;
1092 forget_pmop(cPMOPo);
1093 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1094 /* we use the same protection as the "SAFE" version of the PM_ macros
1095 * here since sv_clean_all might release some PMOPs
1096 * after PL_regex_padav has been cleared
1097 * and the clearing of PL_regex_padav needs to
1098 * happen before sv_clean_all
1101 if(PL_regex_pad) { /* We could be in destruction */
1102 const IV offset = (cPMOPo)->op_pmoffset;
1103 ReREFCNT_dec(PM_GETRE(cPMOPo));
1104 PL_regex_pad[offset] = &PL_sv_undef;
1105 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1109 ReREFCNT_dec(PM_GETRE(cPMOPo));
1110 PM_SETRE(cPMOPo, NULL);
1116 PerlMemShared_free(cUNOP_AUXo->op_aux);
1119 case OP_MULTICONCAT:
1121 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1122 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1123 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1124 * utf8 shared strings */
1125 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1126 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1128 PerlMemShared_free(p1);
1130 PerlMemShared_free(p2);
1131 PerlMemShared_free(aux);
1137 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1138 UV actions = items->uv;
1140 bool is_hash = FALSE;
1143 switch (actions & MDEREF_ACTION_MASK) {
1146 actions = (++items)->uv;
1149 case MDEREF_HV_padhv_helem:
1152 case MDEREF_AV_padav_aelem:
1153 pad_free((++items)->pad_offset);
1156 case MDEREF_HV_gvhv_helem:
1159 case MDEREF_AV_gvav_aelem:
1161 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1163 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1167 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1170 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1172 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1174 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1176 goto do_vivify_rv2xv_elem;
1178 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1181 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1182 pad_free((++items)->pad_offset);
1183 goto do_vivify_rv2xv_elem;
1185 case MDEREF_HV_pop_rv2hv_helem:
1186 case MDEREF_HV_vivify_rv2hv_helem:
1189 do_vivify_rv2xv_elem:
1190 case MDEREF_AV_pop_rv2av_aelem:
1191 case MDEREF_AV_vivify_rv2av_aelem:
1193 switch (actions & MDEREF_INDEX_MASK) {
1194 case MDEREF_INDEX_none:
1197 case MDEREF_INDEX_const:
1201 pad_swipe((++items)->pad_offset, 1);
1203 SvREFCNT_dec((++items)->sv);
1209 case MDEREF_INDEX_padsv:
1210 pad_free((++items)->pad_offset);
1212 case MDEREF_INDEX_gvsv:
1214 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1216 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1221 if (actions & MDEREF_FLAG_last)
1234 actions >>= MDEREF_SHIFT;
1237 /* start of malloc is at op_aux[-1], where the length is
1239 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1244 if (o->op_targ > 0) {
1245 pad_free(o->op_targ);
1251 S_cop_free(pTHX_ COP* cop)
1253 PERL_ARGS_ASSERT_COP_FREE;
1256 if (! specialWARN(cop->cop_warnings))
1257 PerlMemShared_free(cop->cop_warnings);
1258 cophh_free(CopHINTHASH_get(cop));
1259 if (PL_curcop == cop)
1264 S_forget_pmop(pTHX_ PMOP *const o)
1266 HV * const pmstash = PmopSTASH(o);
1268 PERL_ARGS_ASSERT_FORGET_PMOP;
1270 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1271 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1273 PMOP **const array = (PMOP**) mg->mg_ptr;
1274 U32 count = mg->mg_len / sizeof(PMOP**);
1278 if (array[i] == o) {
1279 /* Found it. Move the entry at the end to overwrite it. */
1280 array[i] = array[--count];
1281 mg->mg_len = count * sizeof(PMOP**);
1282 /* Could realloc smaller at this point always, but probably
1283 not worth it. Probably worth free()ing if we're the
1286 Safefree(mg->mg_ptr);
1300 S_find_and_forget_pmops(pTHX_ OP *o)
1304 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1307 switch (o->op_type) {
1312 forget_pmop((PMOP*)o);
1315 if (o->op_flags & OPf_KIDS) {
1316 o = cUNOPo->op_first;
1322 return; /* at top; no parents/siblings to try */
1323 if (OpHAS_SIBLING(o)) {
1324 o = o->op_sibparent; /* process next sibling */
1327 o = o->op_sibparent; /*try parent's next sibling */
1336 Neutralizes an op when it is no longer needed, but is still linked to from
1343 Perl_op_null(pTHX_ OP *o)
1347 PERL_ARGS_ASSERT_OP_NULL;
1349 if (o->op_type == OP_NULL)
1352 o->op_targ = o->op_type;
1353 OpTYPE_set(o, OP_NULL);
1357 Perl_op_refcnt_lock(pTHX)
1358 PERL_TSA_ACQUIRE(PL_op_mutex)
1363 PERL_UNUSED_CONTEXT;
1368 Perl_op_refcnt_unlock(pTHX)
1369 PERL_TSA_RELEASE(PL_op_mutex)
1374 PERL_UNUSED_CONTEXT;
1380 =for apidoc op_sibling_splice
1382 A general function for editing the structure of an existing chain of
1383 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1384 you to delete zero or more sequential nodes, replacing them with zero or
1385 more different nodes. Performs the necessary op_first/op_last
1386 housekeeping on the parent node and op_sibling manipulation on the
1387 children. The last deleted node will be marked as as the last node by
1388 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1390 Note that op_next is not manipulated, and nodes are not freed; that is the
1391 responsibility of the caller. It also won't create a new list op for an
1392 empty list etc; use higher-level functions like op_append_elem() for that.
1394 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1395 the splicing doesn't affect the first or last op in the chain.
1397 C<start> is the node preceding the first node to be spliced. Node(s)
1398 following it will be deleted, and ops will be inserted after it. If it is
1399 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1402 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1403 If -1 or greater than or equal to the number of remaining kids, all
1404 remaining kids are deleted.
1406 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1407 If C<NULL>, no nodes are inserted.
1409 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1414 action before after returns
1415 ------ ----- ----- -------
1418 splice(P, A, 2, X-Y-Z) | | B-C
1422 splice(P, NULL, 1, X-Y) | | A
1426 splice(P, NULL, 3, NULL) | | A-B-C
1430 splice(P, B, 0, X-Y) | | NULL
1434 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1435 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1441 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1445 OP *last_del = NULL;
1446 OP *last_ins = NULL;
1449 first = OpSIBLING(start);
1453 first = cLISTOPx(parent)->op_first;
1455 assert(del_count >= -1);
1457 if (del_count && first) {
1459 while (--del_count && OpHAS_SIBLING(last_del))
1460 last_del = OpSIBLING(last_del);
1461 rest = OpSIBLING(last_del);
1462 OpLASTSIB_set(last_del, NULL);
1469 while (OpHAS_SIBLING(last_ins))
1470 last_ins = OpSIBLING(last_ins);
1471 OpMAYBESIB_set(last_ins, rest, NULL);
1477 OpMAYBESIB_set(start, insert, NULL);
1481 cLISTOPx(parent)->op_first = insert;
1483 parent->op_flags |= OPf_KIDS;
1485 parent->op_flags &= ~OPf_KIDS;
1489 /* update op_last etc */
1496 /* ought to use OP_CLASS(parent) here, but that can't handle
1497 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1499 type = parent->op_type;
1500 if (type == OP_CUSTOM) {
1502 type = XopENTRYCUSTOM(parent, xop_class);
1505 if (type == OP_NULL)
1506 type = parent->op_targ;
1507 type = PL_opargs[type] & OA_CLASS_MASK;
1510 lastop = last_ins ? last_ins : start ? start : NULL;
1511 if ( type == OA_BINOP
1512 || type == OA_LISTOP
1516 cLISTOPx(parent)->op_last = lastop;
1519 OpLASTSIB_set(lastop, parent);
1521 return last_del ? first : NULL;
1524 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1528 =for apidoc op_parent
1530 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1536 Perl_op_parent(OP *o)
1538 PERL_ARGS_ASSERT_OP_PARENT;
1539 while (OpHAS_SIBLING(o))
1541 return o->op_sibparent;
1544 /* replace the sibling following start with a new UNOP, which becomes
1545 * the parent of the original sibling; e.g.
1547 * op_sibling_newUNOP(P, A, unop-args...)
1555 * where U is the new UNOP.
1557 * parent and start args are the same as for op_sibling_splice();
1558 * type and flags args are as newUNOP().
1560 * Returns the new UNOP.
1564 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1568 kid = op_sibling_splice(parent, start, 1, NULL);
1569 newop = newUNOP(type, flags, kid);
1570 op_sibling_splice(parent, start, 0, newop);
1575 /* lowest-level newLOGOP-style function - just allocates and populates
1576 * the struct. Higher-level stuff should be done by S_new_logop() /
1577 * newLOGOP(). This function exists mainly to avoid op_first assignment
1578 * being spread throughout this file.
1582 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1587 NewOp(1101, logop, 1, LOGOP);
1588 OpTYPE_set(logop, type);
1589 logop->op_first = first;
1590 logop->op_other = other;
1592 logop->op_flags = OPf_KIDS;
1593 while (kid && OpHAS_SIBLING(kid))
1594 kid = OpSIBLING(kid);
1596 OpLASTSIB_set(kid, (OP*)logop);
1601 /* Contextualizers */
1604 =for apidoc op_contextualize
1606 Applies a syntactic context to an op tree representing an expression.
1607 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1608 or C<G_VOID> to specify the context to apply. The modified op tree
1615 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1617 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1619 case G_SCALAR: return scalar(o);
1620 case G_ARRAY: return list(o);
1621 case G_VOID: return scalarvoid(o);
1623 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1630 =for apidoc op_linklist
1631 This function is the implementation of the L</LINKLIST> macro. It should
1632 not be called directly.
1639 Perl_op_linklist(pTHX_ OP *o)
1646 PERL_ARGS_ASSERT_OP_LINKLIST;
1649 /* Descend down the tree looking for any unprocessed subtrees to
1652 if (o->op_flags & OPf_KIDS) {
1653 o = cUNOPo->op_first;
1656 o->op_next = o; /* leaf node; link to self initially */
1659 /* if we're at the top level, there either weren't any children
1660 * to process, or we've worked our way back to the top. */
1664 /* o is now processed. Next, process any sibling subtrees */
1666 if (OpHAS_SIBLING(o)) {
1671 /* Done all the subtrees at this level. Go back up a level and
1672 * link the parent in with all its (processed) children.
1675 o = o->op_sibparent;
1676 assert(!o->op_next);
1677 prevp = &(o->op_next);
1678 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1680 *prevp = kid->op_next;
1681 prevp = &(kid->op_next);
1682 kid = OpSIBLING(kid);
1690 S_scalarkids(pTHX_ OP *o)
1692 if (o && o->op_flags & OPf_KIDS) {
1694 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1701 S_scalarboolean(pTHX_ OP *o)
1703 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1705 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1706 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1707 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1708 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1709 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1710 if (ckWARN(WARN_SYNTAX)) {
1711 const line_t oldline = CopLINE(PL_curcop);
1713 if (PL_parser && PL_parser->copline != NOLINE) {
1714 /* This ensures that warnings are reported at the first line
1715 of the conditional, not the last. */
1716 CopLINE_set(PL_curcop, PL_parser->copline);
1718 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1719 CopLINE_set(PL_curcop, oldline);
1726 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1729 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1730 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1732 const char funny = o->op_type == OP_PADAV
1733 || o->op_type == OP_RV2AV ? '@' : '%';
1734 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1736 if (cUNOPo->op_first->op_type != OP_GV
1737 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1739 return varname(gv, funny, 0, NULL, 0, subscript_type);
1742 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1747 S_op_varname(pTHX_ const OP *o)
1749 return S_op_varname_subscript(aTHX_ o, 1);
1753 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1754 { /* or not so pretty :-) */
1755 if (o->op_type == OP_CONST) {
1757 if (SvPOK(*retsv)) {
1759 *retsv = sv_newmortal();
1760 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1761 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1763 else if (!SvOK(*retsv))
1766 else *retpv = "...";
1770 S_scalar_slice_warning(pTHX_ const OP *o)
1773 const bool h = o->op_type == OP_HSLICE
1774 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1780 SV *keysv = NULL; /* just to silence compiler warnings */
1781 const char *key = NULL;
1783 if (!(o->op_private & OPpSLICEWARNING))
1785 if (PL_parser && PL_parser->error_count)
1786 /* This warning can be nonsensical when there is a syntax error. */
1789 kid = cLISTOPo->op_first;
1790 kid = OpSIBLING(kid); /* get past pushmark */
1791 /* weed out false positives: any ops that can return lists */
1792 switch (kid->op_type) {
1818 /* Don't warn if we have a nulled list either. */
1819 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1822 assert(OpSIBLING(kid));
1823 name = S_op_varname(aTHX_ OpSIBLING(kid));
1824 if (!name) /* XS module fiddling with the op tree */
1826 S_op_pretty(aTHX_ kid, &keysv, &key);
1827 assert(SvPOK(name));
1828 sv_chop(name,SvPVX(name)+1);
1830 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1831 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1832 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1834 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1835 lbrack, key, rbrack);
1837 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1838 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1839 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1841 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1842 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1847 /* apply scalar context to the o subtree */
1850 Perl_scalar(pTHX_ OP *o)
1855 OP *next_kid = NULL; /* what op (if any) to process next */
1858 /* assumes no premature commitment */
1859 if (!o || (PL_parser && PL_parser->error_count)
1860 || (o->op_flags & OPf_WANT)
1861 || o->op_type == OP_RETURN)
1866 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1868 switch (o->op_type) {
1870 scalar(cBINOPo->op_first);
1871 /* convert what initially looked like a list repeat into a
1872 * scalar repeat, e.g. $s = (1) x $n
1874 if (o->op_private & OPpREPEAT_DOLIST) {
1875 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1876 assert(kid->op_type == OP_PUSHMARK);
1877 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1878 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1879 o->op_private &=~ OPpREPEAT_DOLIST;
1887 /* impose scalar context on everything except the condition */
1888 next_kid = OpSIBLING(cUNOPo->op_first);
1892 if (o->op_flags & OPf_KIDS)
1893 next_kid = cUNOPo->op_first; /* do all kids */
1896 /* the children of these ops are usually a list of statements,
1897 * except the leaves, whose first child is a corresponding enter
1902 kid = cLISTOPo->op_first;
1906 kid = cLISTOPo->op_first;
1908 kid = OpSIBLING(kid);
1911 OP *sib = OpSIBLING(kid);
1912 /* Apply void context to all kids except the last, which
1913 * is scalar (ignoring a trailing ex-nextstate in determining
1914 * if it's the last kid). E.g.
1915 * $scalar = do { void; void; scalar }
1916 * Except that 'when's are always scalar, e.g.
1917 * $scalar = do { given(..) {
1918 * when (..) { scalar }
1919 * when (..) { scalar }
1924 || ( !OpHAS_SIBLING(sib)
1925 && sib->op_type == OP_NULL
1926 && ( sib->op_targ == OP_NEXTSTATE
1927 || sib->op_targ == OP_DBSTATE )
1931 /* tail call optimise calling scalar() on the last kid */
1935 else if (kid->op_type == OP_LEAVEWHEN)
1941 NOT_REACHED; /* NOTREACHED */
1945 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1951 /* Warn about scalar context */
1952 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1953 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1956 const char *key = NULL;
1958 /* This warning can be nonsensical when there is a syntax error. */
1959 if (PL_parser && PL_parser->error_count)
1962 if (!ckWARN(WARN_SYNTAX)) break;
1964 kid = cLISTOPo->op_first;
1965 kid = OpSIBLING(kid); /* get past pushmark */
1966 assert(OpSIBLING(kid));
1967 name = S_op_varname(aTHX_ OpSIBLING(kid));
1968 if (!name) /* XS module fiddling with the op tree */
1970 S_op_pretty(aTHX_ kid, &keysv, &key);
1971 assert(SvPOK(name));
1972 sv_chop(name,SvPVX(name)+1);
1974 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1975 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1976 "%%%" SVf "%c%s%c in scalar context better written "
1977 "as $%" SVf "%c%s%c",
1978 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1979 lbrack, key, rbrack);
1981 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1982 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1983 "%%%" SVf "%c%" SVf "%c in scalar context better "
1984 "written as $%" SVf "%c%" SVf "%c",
1985 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1986 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1990 /* If next_kid is set, someone in the code above wanted us to process
1991 * that kid and all its remaining siblings. Otherwise, work our way
1992 * back up the tree */
1996 return top_op; /* at top; no parents/siblings to try */
1997 if (OpHAS_SIBLING(o))
1998 next_kid = o->op_sibparent;
2000 o = o->op_sibparent; /*try parent's next sibling */
2001 switch (o->op_type) {
2007 /* should really restore PL_curcop to its old value, but
2008 * setting it to PL_compiling is better than do nothing */
2009 PL_curcop = &PL_compiling;
2018 /* apply void context to the optree arg */
2021 Perl_scalarvoid(pTHX_ OP *arg)
2028 PERL_ARGS_ASSERT_SCALARVOID;
2032 SV *useless_sv = NULL;
2033 const char* useless = NULL;
2034 OP * next_kid = NULL;
2036 if (o->op_type == OP_NEXTSTATE
2037 || o->op_type == OP_DBSTATE
2038 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2039 || o->op_targ == OP_DBSTATE)))
2040 PL_curcop = (COP*)o; /* for warning below */
2042 /* assumes no premature commitment */
2043 want = o->op_flags & OPf_WANT;
2044 if ((want && want != OPf_WANT_SCALAR)
2045 || (PL_parser && PL_parser->error_count)
2046 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2051 if ((o->op_private & OPpTARGET_MY)
2052 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2054 /* newASSIGNOP has already applied scalar context, which we
2055 leave, as if this op is inside SASSIGN. */
2059 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2061 switch (o->op_type) {
2063 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2067 if (o->op_flags & OPf_STACKED)
2069 if (o->op_type == OP_REPEAT)
2070 scalar(cBINOPo->op_first);
2073 if ((o->op_flags & OPf_STACKED) &&
2074 !(o->op_private & OPpCONCAT_NESTED))
2078 if (o->op_private == 4)
2113 case OP_GETSOCKNAME:
2114 case OP_GETPEERNAME:
2119 case OP_GETPRIORITY:
2144 useless = OP_DESC(o);
2154 case OP_AELEMFAST_LEX:
2158 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2159 /* Otherwise it's "Useless use of grep iterator" */
2160 useless = OP_DESC(o);
2164 if (!(o->op_private & OPpSPLIT_ASSIGN))
2165 useless = OP_DESC(o);
2169 kid = cUNOPo->op_first;
2170 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2171 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2174 useless = "negative pattern binding (!~)";
2178 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2179 useless = "non-destructive substitution (s///r)";
2183 useless = "non-destructive transliteration (tr///r)";
2190 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2191 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2192 useless = "a variable";
2197 if (cSVOPo->op_private & OPpCONST_STRICT)
2198 no_bareword_allowed(o);
2200 if (ckWARN(WARN_VOID)) {
2202 /* don't warn on optimised away booleans, eg
2203 * use constant Foo, 5; Foo || print; */
2204 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2206 /* the constants 0 and 1 are permitted as they are
2207 conventionally used as dummies in constructs like
2208 1 while some_condition_with_side_effects; */
2209 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2211 else if (SvPOK(sv)) {
2212 SV * const dsv = newSVpvs("");
2214 = Perl_newSVpvf(aTHX_
2216 pv_pretty(dsv, SvPVX_const(sv),
2217 SvCUR(sv), 32, NULL, NULL,
2219 | PERL_PV_ESCAPE_NOCLEAR
2220 | PERL_PV_ESCAPE_UNI_DETECT));
2221 SvREFCNT_dec_NN(dsv);
2223 else if (SvOK(sv)) {
2224 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2227 useless = "a constant (undef)";
2230 op_null(o); /* don't execute or even remember it */
2234 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2238 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2242 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2246 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2251 UNOP *refgen, *rv2cv;
2254 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2257 rv2gv = ((BINOP *)o)->op_last;
2258 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2261 refgen = (UNOP *)((BINOP *)o)->op_first;
2263 if (!refgen || (refgen->op_type != OP_REFGEN
2264 && refgen->op_type != OP_SREFGEN))
2267 exlist = (LISTOP *)refgen->op_first;
2268 if (!exlist || exlist->op_type != OP_NULL
2269 || exlist->op_targ != OP_LIST)
2272 if (exlist->op_first->op_type != OP_PUSHMARK
2273 && exlist->op_first != exlist->op_last)
2276 rv2cv = (UNOP*)exlist->op_last;
2278 if (rv2cv->op_type != OP_RV2CV)
2281 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2282 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2283 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2285 o->op_private |= OPpASSIGN_CV_TO_GV;
2286 rv2gv->op_private |= OPpDONT_INIT_GV;
2287 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2299 kid = cLOGOPo->op_first;
2300 if (kid->op_type == OP_NOT
2301 && (kid->op_flags & OPf_KIDS)) {
2302 if (o->op_type == OP_AND) {
2303 OpTYPE_set(o, OP_OR);
2305 OpTYPE_set(o, OP_AND);
2315 next_kid = OpSIBLING(cUNOPo->op_first);
2319 if (o->op_flags & OPf_STACKED)
2326 if (!(o->op_flags & OPf_KIDS))
2337 next_kid = cLISTOPo->op_first;
2340 /* If the first kid after pushmark is something that the padrange
2341 optimisation would reject, then null the list and the pushmark.
2343 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2344 && ( !(kid = OpSIBLING(kid))
2345 || ( kid->op_type != OP_PADSV
2346 && kid->op_type != OP_PADAV
2347 && kid->op_type != OP_PADHV)
2348 || kid->op_private & ~OPpLVAL_INTRO
2349 || !(kid = OpSIBLING(kid))
2350 || ( kid->op_type != OP_PADSV
2351 && kid->op_type != OP_PADAV
2352 && kid->op_type != OP_PADHV)
2353 || kid->op_private & ~OPpLVAL_INTRO)
2355 op_null(cUNOPo->op_first); /* NULL the pushmark */
2356 op_null(o); /* NULL the list */
2368 /* mortalise it, in case warnings are fatal. */
2369 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2370 "Useless use of %" SVf " in void context",
2371 SVfARG(sv_2mortal(useless_sv)));
2374 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2375 "Useless use of %s in void context",
2380 /* if a kid hasn't been nominated to process, continue with the
2381 * next sibling, or if no siblings left, go back to the parent's
2382 * siblings and so on
2386 return arg; /* at top; no parents/siblings to try */
2387 if (OpHAS_SIBLING(o))
2388 next_kid = o->op_sibparent;
2390 o = o->op_sibparent; /*try parent's next sibling */
2400 S_listkids(pTHX_ OP *o)
2402 if (o && o->op_flags & OPf_KIDS) {
2404 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2411 /* apply list context to the o subtree */
2414 Perl_list(pTHX_ OP *o)
2419 OP *next_kid = NULL; /* what op (if any) to process next */
2423 /* assumes no premature commitment */
2424 if (!o || (o->op_flags & OPf_WANT)
2425 || (PL_parser && PL_parser->error_count)
2426 || o->op_type == OP_RETURN)
2431 if ((o->op_private & OPpTARGET_MY)
2432 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2434 goto do_next; /* As if inside SASSIGN */
2437 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2439 switch (o->op_type) {
2441 if (o->op_private & OPpREPEAT_DOLIST
2442 && !(o->op_flags & OPf_STACKED))
2444 list(cBINOPo->op_first);
2445 kid = cBINOPo->op_last;
2446 /* optimise away (.....) x 1 */
2447 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2448 && SvIVX(kSVOP_sv) == 1)
2450 op_null(o); /* repeat */
2451 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2453 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2461 /* impose list context on everything except the condition */
2462 next_kid = OpSIBLING(cUNOPo->op_first);
2466 if (!(o->op_flags & OPf_KIDS))
2468 /* possibly flatten 1..10 into a constant array */
2469 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2470 list(cBINOPo->op_first);
2471 gen_constant_list(o);
2474 next_kid = cUNOPo->op_first; /* do all kids */
2478 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2479 op_null(cUNOPo->op_first); /* NULL the pushmark */
2480 op_null(o); /* NULL the list */
2482 if (o->op_flags & OPf_KIDS)
2483 next_kid = cUNOPo->op_first; /* do all kids */
2486 /* the children of these ops are usually a list of statements,
2487 * except the leaves, whose first child is a corresponding enter
2491 kid = cLISTOPo->op_first;
2495 kid = cLISTOPo->op_first;
2497 kid = OpSIBLING(kid);
2500 OP *sib = OpSIBLING(kid);
2501 /* Apply void context to all kids except the last, which
2503 * @a = do { void; void; list }
2504 * Except that 'when's are always list context, e.g.
2505 * @a = do { given(..) {
2506 * when (..) { list }
2507 * when (..) { list }
2512 /* tail call optimise calling list() on the last kid */
2516 else if (kid->op_type == OP_LEAVEWHEN)
2522 NOT_REACHED; /* NOTREACHED */
2527 /* If next_kid is set, someone in the code above wanted us to process
2528 * that kid and all its remaining siblings. Otherwise, work our way
2529 * back up the tree */
2533 return top_op; /* at top; no parents/siblings to try */
2534 if (OpHAS_SIBLING(o))
2535 next_kid = o->op_sibparent;
2537 o = o->op_sibparent; /*try parent's next sibling */
2538 switch (o->op_type) {
2544 /* should really restore PL_curcop to its old value, but
2545 * setting it to PL_compiling is better than do nothing */
2546 PL_curcop = &PL_compiling;
2558 S_scalarseq(pTHX_ OP *o)
2561 const OPCODE type = o->op_type;
2563 if (type == OP_LINESEQ || type == OP_SCOPE ||
2564 type == OP_LEAVE || type == OP_LEAVETRY)
2567 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2568 if ((sib = OpSIBLING(kid))
2569 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2570 || ( sib->op_targ != OP_NEXTSTATE
2571 && sib->op_targ != OP_DBSTATE )))
2576 PL_curcop = &PL_compiling;
2578 o->op_flags &= ~OPf_PARENS;
2579 if (PL_hints & HINT_BLOCK_SCOPE)
2580 o->op_flags |= OPf_PARENS;
2583 o = newOP(OP_STUB, 0);
2588 S_modkids(pTHX_ OP *o, I32 type)
2590 if (o && o->op_flags & OPf_KIDS) {
2592 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2593 op_lvalue(kid, type);
2599 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2600 * const fields. Also, convert CONST keys to HEK-in-SVs.
2601 * rop is the op that retrieves the hash;
2602 * key_op is the first key
2603 * real if false, only check (and possibly croak); don't update op
2607 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2613 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2615 if (rop->op_first->op_type == OP_PADSV)
2616 /* @$hash{qw(keys here)} */
2617 rop = (UNOP*)rop->op_first;
2619 /* @{$hash}{qw(keys here)} */
2620 if (rop->op_first->op_type == OP_SCOPE
2621 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2623 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2630 lexname = NULL; /* just to silence compiler warnings */
2631 fields = NULL; /* just to silence compiler warnings */
2635 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2636 SvPAD_TYPED(lexname))
2637 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2638 && isGV(*fields) && GvHV(*fields);
2640 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2642 if (key_op->op_type != OP_CONST)
2644 svp = cSVOPx_svp(key_op);
2646 /* make sure it's not a bareword under strict subs */
2647 if (key_op->op_private & OPpCONST_BARE &&
2648 key_op->op_private & OPpCONST_STRICT)
2650 no_bareword_allowed((OP*)key_op);
2653 /* Make the CONST have a shared SV */
2654 if ( !SvIsCOW_shared_hash(sv = *svp)
2655 && SvTYPE(sv) < SVt_PVMG
2661 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2662 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2663 SvREFCNT_dec_NN(sv);
2668 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2670 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2671 "in variable %" PNf " of type %" HEKf,
2672 SVfARG(*svp), PNfARG(lexname),
2673 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2678 /* info returned by S_sprintf_is_multiconcatable() */
2680 struct sprintf_ismc_info {
2681 SSize_t nargs; /* num of args to sprintf (not including the format) */
2682 char *start; /* start of raw format string */
2683 char *end; /* bytes after end of raw format string */
2684 STRLEN total_len; /* total length (in bytes) of format string, not
2685 including '%s' and half of '%%' */
2686 STRLEN variant; /* number of bytes by which total_len_p would grow
2687 if upgraded to utf8 */
2688 bool utf8; /* whether the format is utf8 */
2692 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2693 * i.e. its format argument is a const string with only '%s' and '%%'
2694 * formats, and the number of args is known, e.g.
2695 * sprintf "a=%s f=%s", $a[0], scalar(f());
2697 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2699 * If successful, the sprintf_ismc_info struct pointed to by info will be
2704 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2706 OP *pm, *constop, *kid;
2709 SSize_t nargs, nformats;
2710 STRLEN cur, total_len, variant;
2713 /* if sprintf's behaviour changes, die here so that someone
2714 * can decide whether to enhance this function or skip optimising
2715 * under those new circumstances */
2716 assert(!(o->op_flags & OPf_STACKED));
2717 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2718 assert(!(o->op_private & ~OPpARG4_MASK));
2720 pm = cUNOPo->op_first;
2721 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2723 constop = OpSIBLING(pm);
2724 if (!constop || constop->op_type != OP_CONST)
2726 sv = cSVOPx_sv(constop);
2727 if (SvMAGICAL(sv) || !SvPOK(sv))
2733 /* Scan format for %% and %s and work out how many %s there are.
2734 * Abandon if other format types are found.
2741 for (p = s; p < e; p++) {
2744 if (!UTF8_IS_INVARIANT(*p))
2750 return FALSE; /* lone % at end gives "Invalid conversion" */
2759 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2762 utf8 = cBOOL(SvUTF8(sv));
2766 /* scan args; they must all be in scalar cxt */
2769 kid = OpSIBLING(constop);
2772 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2775 kid = OpSIBLING(kid);
2778 if (nargs != nformats)
2779 return FALSE; /* e.g. sprintf("%s%s", $a); */
2782 info->nargs = nargs;
2785 info->total_len = total_len;
2786 info->variant = variant;
2794 /* S_maybe_multiconcat():
2796 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2797 * convert it (and its children) into an OP_MULTICONCAT. See the code
2798 * comments just before pp_multiconcat() for the full details of what
2799 * OP_MULTICONCAT supports.
2801 * Basically we're looking for an optree with a chain of OP_CONCATS down
2802 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2803 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2811 * STRINGIFY -- PADSV[$x]
2814 * ex-PUSHMARK -- CONCAT/S
2816 * CONCAT/S -- PADSV[$d]
2818 * CONCAT -- CONST["-"]
2820 * PADSV[$a] -- PADSV[$b]
2822 * Note that at this stage the OP_SASSIGN may have already been optimised
2823 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2827 S_maybe_multiconcat(pTHX_ OP *o)
2830 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2831 OP *topop; /* the top-most op in the concat tree (often equals o,
2832 unless there are assign/stringify ops above it */
2833 OP *parentop; /* the parent op of topop (or itself if no parent) */
2834 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2835 OP *targetop; /* the op corresponding to target=... or target.=... */
2836 OP *stringop; /* the OP_STRINGIFY op, if any */
2837 OP *nextop; /* used for recreating the op_next chain without consts */
2838 OP *kid; /* general-purpose op pointer */
2840 UNOP_AUX_item *lenp;
2841 char *const_str, *p;
2842 struct sprintf_ismc_info sprintf_info;
2844 /* store info about each arg in args[];
2845 * toparg is the highest used slot; argp is a general
2846 * pointer to args[] slots */
2848 void *p; /* initially points to const sv (or null for op);
2849 later, set to SvPV(constsv), with ... */
2850 STRLEN len; /* ... len set to SvPV(..., len) */
2851 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2855 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2858 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2859 the last-processed arg will the LHS of one,
2860 as args are processed in reverse order */
2861 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2862 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2863 U8 flags = 0; /* what will become the op_flags and ... */
2864 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2865 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2866 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2867 bool prev_was_const = FALSE; /* previous arg was a const */
2869 /* -----------------------------------------------------------------
2872 * Examine the optree non-destructively to determine whether it's
2873 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2874 * information about the optree in args[].
2884 assert( o->op_type == OP_SASSIGN
2885 || o->op_type == OP_CONCAT
2886 || o->op_type == OP_SPRINTF
2887 || o->op_type == OP_STRINGIFY);
2889 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2891 /* first see if, at the top of the tree, there is an assign,
2892 * append and/or stringify */
2894 if (topop->op_type == OP_SASSIGN) {
2896 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2898 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2900 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2903 topop = cBINOPo->op_first;
2904 targetop = OpSIBLING(topop);
2905 if (!targetop) /* probably some sort of syntax error */
2908 else if ( topop->op_type == OP_CONCAT
2909 && (topop->op_flags & OPf_STACKED)
2910 && (!(topop->op_private & OPpCONCAT_NESTED))
2915 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2916 * decide what to do about it */
2917 assert(!(o->op_private & OPpTARGET_MY));
2919 /* barf on unknown flags */
2920 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2921 private_flags |= OPpMULTICONCAT_APPEND;
2922 targetop = cBINOPo->op_first;
2924 topop = OpSIBLING(targetop);
2926 /* $x .= <FOO> gets optimised to rcatline instead */
2927 if (topop->op_type == OP_READLINE)
2932 /* Can targetop (the LHS) if it's a padsv, be be optimised
2933 * away and use OPpTARGET_MY instead?
2935 if ( (targetop->op_type == OP_PADSV)
2936 && !(targetop->op_private & OPpDEREF)
2937 && !(targetop->op_private & OPpPAD_STATE)
2938 /* we don't support 'my $x .= ...' */
2939 && ( o->op_type == OP_SASSIGN
2940 || !(targetop->op_private & OPpLVAL_INTRO))
2945 if (topop->op_type == OP_STRINGIFY) {
2946 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2950 /* barf on unknown flags */
2951 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2953 if ((topop->op_private & OPpTARGET_MY)) {
2954 if (o->op_type == OP_SASSIGN)
2955 return; /* can't have two assigns */
2959 private_flags |= OPpMULTICONCAT_STRINGIFY;
2961 topop = cBINOPx(topop)->op_first;
2962 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2963 topop = OpSIBLING(topop);
2966 if (topop->op_type == OP_SPRINTF) {
2967 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2969 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2970 nargs = sprintf_info.nargs;
2971 total_len = sprintf_info.total_len;
2972 variant = sprintf_info.variant;
2973 utf8 = sprintf_info.utf8;
2975 private_flags |= OPpMULTICONCAT_FAKE;
2977 /* we have an sprintf op rather than a concat optree.
2978 * Skip most of the code below which is associated with
2979 * processing that optree. We also skip phase 2, determining
2980 * whether its cost effective to optimise, since for sprintf,
2981 * multiconcat is *always* faster */
2984 /* note that even if the sprintf itself isn't multiconcatable,
2985 * the expression as a whole may be, e.g. in
2986 * $x .= sprintf("%d",...)
2987 * the sprintf op will be left as-is, but the concat/S op may
2988 * be upgraded to multiconcat
2991 else if (topop->op_type == OP_CONCAT) {
2992 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2995 if ((topop->op_private & OPpTARGET_MY)) {
2996 if (o->op_type == OP_SASSIGN || targmyop)
2997 return; /* can't have two assigns */
3002 /* Is it safe to convert a sassign/stringify/concat op into
3004 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
3005 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
3006 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3007 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
3008 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
3009 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3010 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
3011 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3013 /* Now scan the down the tree looking for a series of
3014 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3015 * stacked). For example this tree:
3020 * CONCAT/STACKED -- EXPR5
3022 * CONCAT/STACKED -- EXPR4
3028 * corresponds to an expression like
3030 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3032 * Record info about each EXPR in args[]: in particular, whether it is
3033 * a stringifiable OP_CONST and if so what the const sv is.
3035 * The reason why the last concat can't be STACKED is the difference
3038 * ((($a .= $a) .= $a) .= $a) .= $a
3041 * $a . $a . $a . $a . $a
3043 * The main difference between the optrees for those two constructs
3044 * is the presence of the last STACKED. As well as modifying $a,
3045 * the former sees the changed $a between each concat, so if $s is
3046 * initially 'a', the first returns 'a' x 16, while the latter returns
3047 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3057 if ( kid->op_type == OP_CONCAT
3061 k1 = cUNOPx(kid)->op_first;
3063 /* shouldn't happen except maybe after compile err? */
3067 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3068 if (kid->op_private & OPpTARGET_MY)
3071 stacked_last = (kid->op_flags & OPf_STACKED);
3083 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3084 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3086 /* At least two spare slots are needed to decompose both
3087 * concat args. If there are no slots left, continue to
3088 * examine the rest of the optree, but don't push new values
3089 * on args[]. If the optree as a whole is legal for conversion
3090 * (in particular that the last concat isn't STACKED), then
3091 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3092 * can be converted into an OP_MULTICONCAT now, with the first
3093 * child of that op being the remainder of the optree -
3094 * which may itself later be converted to a multiconcat op
3098 /* the last arg is the rest of the optree */
3103 else if ( argop->op_type == OP_CONST
3104 && ((sv = cSVOPx_sv(argop)))
3105 /* defer stringification until runtime of 'constant'
3106 * things that might stringify variantly, e.g. the radix
3107 * point of NVs, or overloaded RVs */
3108 && (SvPOK(sv) || SvIOK(sv))
3109 && (!SvGMAGICAL(sv))
3112 utf8 |= cBOOL(SvUTF8(sv));
3115 /* this const may be demoted back to a plain arg later;
3116 * make sure we have enough arg slots left */
3118 prev_was_const = !prev_was_const;
3123 prev_was_const = FALSE;
3133 return; /* we don't support ((A.=B).=C)...) */
3135 /* look for two adjacent consts and don't fold them together:
3138 * $o->concat("a")->concat("b")
3141 * (but $o .= "a" . "b" should still fold)
3144 bool seen_nonconst = FALSE;
3145 for (argp = toparg; argp >= args; argp--) {
3146 if (argp->p == NULL) {
3147 seen_nonconst = TRUE;
3153 /* both previous and current arg were constants;
3154 * leave the current OP_CONST as-is */
3162 /* -----------------------------------------------------------------
3165 * At this point we have determined that the optree *can* be converted
3166 * into a multiconcat. Having gathered all the evidence, we now decide
3167 * whether it *should*.
3171 /* we need at least one concat action, e.g.:
3177 * otherwise we could be doing something like $x = "foo", which
3178 * if treated as as a concat, would fail to COW.
3180 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3183 /* Benchmarking seems to indicate that we gain if:
3184 * * we optimise at least two actions into a single multiconcat
3185 * (e.g concat+concat, sassign+concat);
3186 * * or if we can eliminate at least 1 OP_CONST;
3187 * * or if we can eliminate a padsv via OPpTARGET_MY
3191 /* eliminated at least one OP_CONST */
3193 /* eliminated an OP_SASSIGN */
3194 || o->op_type == OP_SASSIGN
3195 /* eliminated an OP_PADSV */
3196 || (!targmyop && is_targable)
3198 /* definitely a net gain to optimise */
3201 /* ... if not, what else? */
3203 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3204 * multiconcat is faster (due to not creating a temporary copy of
3205 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3211 && topop->op_type == OP_CONCAT
3213 PADOFFSET t = targmyop->op_targ;
3214 OP *k1 = cBINOPx(topop)->op_first;
3215 OP *k2 = cBINOPx(topop)->op_last;
3216 if ( k2->op_type == OP_PADSV
3218 && ( k1->op_type != OP_PADSV
3219 || k1->op_targ != t)
3224 /* need at least two concats */
3225 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3230 /* -----------------------------------------------------------------
3233 * At this point the optree has been verified as ok to be optimised
3234 * into an OP_MULTICONCAT. Now start changing things.
3239 /* stringify all const args and determine utf8ness */
3242 for (argp = args; argp <= toparg; argp++) {
3243 SV *sv = (SV*)argp->p;
3245 continue; /* not a const op */
3246 if (utf8 && !SvUTF8(sv))
3247 sv_utf8_upgrade_nomg(sv);
3248 argp->p = SvPV_nomg(sv, argp->len);
3249 total_len += argp->len;
3251 /* see if any strings would grow if converted to utf8 */
3253 variant += variant_under_utf8_count((U8 *) argp->p,
3254 (U8 *) argp->p + argp->len);
3258 /* create and populate aux struct */
3262 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3263 sizeof(UNOP_AUX_item)
3265 PERL_MULTICONCAT_HEADER_SIZE
3266 + ((nargs + 1) * (variant ? 2 : 1))
3269 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3271 /* Extract all the non-const expressions from the concat tree then
3272 * dispose of the old tree, e.g. convert the tree from this:
3276 * STRINGIFY -- TARGET
3278 * ex-PUSHMARK -- CONCAT
3293 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3295 * except that if EXPRi is an OP_CONST, it's discarded.
3297 * During the conversion process, EXPR ops are stripped from the tree
3298 * and unshifted onto o. Finally, any of o's remaining original
3299 * childen are discarded and o is converted into an OP_MULTICONCAT.
3301 * In this middle of this, o may contain both: unshifted args on the
3302 * left, and some remaining original args on the right. lastkidop
3303 * is set to point to the right-most unshifted arg to delineate
3304 * between the two sets.
3309 /* create a copy of the format with the %'s removed, and record
3310 * the sizes of the const string segments in the aux struct */
3312 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3314 p = sprintf_info.start;
3317 for (; p < sprintf_info.end; p++) {
3321 (lenp++)->ssize = q - oldq;
3328 lenp->ssize = q - oldq;
3329 assert((STRLEN)(q - const_str) == total_len);
3331 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3332 * may or may not be topop) The pushmark and const ops need to be
3333 * kept in case they're an op_next entry point.
3335 lastkidop = cLISTOPx(topop)->op_last;
3336 kid = cUNOPx(topop)->op_first; /* pushmark */
3338 op_null(OpSIBLING(kid)); /* const */
3340 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3341 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3342 lastkidop->op_next = o;
3347 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3351 /* Concatenate all const strings into const_str.
3352 * Note that args[] contains the RHS args in reverse order, so
3353 * we scan args[] from top to bottom to get constant strings
3356 for (argp = toparg; argp >= args; argp--) {
3358 /* not a const op */
3359 (++lenp)->ssize = -1;
3361 STRLEN l = argp->len;
3362 Copy(argp->p, p, l, char);
3364 if (lenp->ssize == -1)
3375 for (argp = args; argp <= toparg; argp++) {
3376 /* only keep non-const args, except keep the first-in-next-chain
3377 * arg no matter what it is (but nulled if OP_CONST), because it
3378 * may be the entry point to this subtree from the previous
3381 bool last = (argp == toparg);
3384 /* set prev to the sibling *before* the arg to be cut out,
3385 * e.g. when cutting EXPR:
3390 * prev= CONCAT -- EXPR
3393 if (argp == args && kid->op_type != OP_CONCAT) {
3394 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3395 * so the expression to be cut isn't kid->op_last but
3398 /* find the op before kid */
3400 o2 = cUNOPx(parentop)->op_first;
3401 while (o2 && o2 != kid) {
3409 else if (kid == o && lastkidop)
3410 prev = last ? lastkidop : OpSIBLING(lastkidop);
3412 prev = last ? NULL : cUNOPx(kid)->op_first;
3414 if (!argp->p || last) {
3416 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3417 /* and unshift to front of o */
3418 op_sibling_splice(o, NULL, 0, aop);
3419 /* record the right-most op added to o: later we will
3420 * free anything to the right of it */
3423 aop->op_next = nextop;
3426 /* null the const at start of op_next chain */
3430 nextop = prev->op_next;
3433 /* the last two arguments are both attached to the same concat op */
3434 if (argp < toparg - 1)
3439 /* Populate the aux struct */
3441 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3442 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3443 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3444 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3445 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3447 /* if variant > 0, calculate a variant const string and lengths where
3448 * the utf8 version of the string will take 'variant' more bytes than
3452 char *p = const_str;
3453 STRLEN ulen = total_len + variant;
3454 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3455 UNOP_AUX_item *ulens = lens + (nargs + 1);
3456 char *up = (char*)PerlMemShared_malloc(ulen);
3459 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3460 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3462 for (n = 0; n < (nargs + 1); n++) {
3464 char * orig_up = up;
3465 for (i = (lens++)->ssize; i > 0; i--) {
3467 append_utf8_from_native_byte(c, (U8**)&up);
3469 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3474 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3475 * that op's first child - an ex-PUSHMARK - because the op_next of
3476 * the previous op may point to it (i.e. it's the entry point for
3481 ? op_sibling_splice(o, lastkidop, 1, NULL)
3482 : op_sibling_splice(stringop, NULL, 1, NULL);
3483 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3484 op_sibling_splice(o, NULL, 0, pmop);
3491 * target .= A.B.C...
3497 if (o->op_type == OP_SASSIGN) {
3498 /* Move the target subtree from being the last of o's children
3499 * to being the last of o's preserved children.
3500 * Note the difference between 'target = ...' and 'target .= ...':
3501 * for the former, target is executed last; for the latter,
3504 kid = OpSIBLING(lastkidop);
3505 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3506 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3507 lastkidop->op_next = kid->op_next;
3508 lastkidop = targetop;
3511 /* Move the target subtree from being the first of o's
3512 * original children to being the first of *all* o's children.
3515 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3516 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3519 /* if the RHS of .= doesn't contain a concat (e.g.
3520 * $x .= "foo"), it gets missed by the "strip ops from the
3521 * tree and add to o" loop earlier */
3522 assert(topop->op_type != OP_CONCAT);
3524 /* in e.g. $x .= "$y", move the $y expression
3525 * from being a child of OP_STRINGIFY to being the
3526 * second child of the OP_CONCAT
3528 assert(cUNOPx(stringop)->op_first == topop);
3529 op_sibling_splice(stringop, NULL, 1, NULL);
3530 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3532 assert(topop == OpSIBLING(cBINOPo->op_first));
3541 * my $lex = A.B.C...
3544 * The original padsv op is kept but nulled in case it's the
3545 * entry point for the optree (which it will be for
3548 private_flags |= OPpTARGET_MY;
3549 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3550 o->op_targ = targetop->op_targ;
3551 targetop->op_targ = 0;
3555 flags |= OPf_STACKED;
3557 else if (targmyop) {
3558 private_flags |= OPpTARGET_MY;
3559 if (o != targmyop) {
3560 o->op_targ = targmyop->op_targ;
3561 targmyop->op_targ = 0;
3565 /* detach the emaciated husk of the sprintf/concat optree and free it */
3567 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3573 /* and convert o into a multiconcat */
3575 o->op_flags = (flags|OPf_KIDS|stacked_last
3576 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3577 o->op_private = private_flags;
3578 o->op_type = OP_MULTICONCAT;
3579 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3580 cUNOP_AUXo->op_aux = aux;
3584 /* do all the final processing on an optree (e.g. running the peephole
3585 * optimiser on it), then attach it to cv (if cv is non-null)
3589 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3593 /* XXX for some reason, evals, require and main optrees are
3594 * never attached to their CV; instead they just hang off
3595 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3596 * and get manually freed when appropriate */
3598 startp = &CvSTART(cv);
3600 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3603 optree->op_private |= OPpREFCOUNTED;
3604 OpREFCNT_set(optree, 1);
3605 optimize_optree(optree);
3607 finalize_optree(optree);
3608 S_prune_chain_head(startp);
3611 /* now that optimizer has done its work, adjust pad values */
3612 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3613 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3619 =for apidoc optimize_optree
3621 This function applies some optimisations to the optree in top-down order.
3622 It is called before the peephole optimizer, which processes ops in
3623 execution order. Note that finalize_optree() also does a top-down scan,
3624 but is called *after* the peephole optimizer.
3630 Perl_optimize_optree(pTHX_ OP* o)
3632 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3635 SAVEVPTR(PL_curcop);
3643 /* helper for optimize_optree() which optimises one op then recurses
3644 * to optimise any children.
3648 S_optimize_op(pTHX_ OP* o)
3652 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3655 OP * next_kid = NULL;
3657 assert(o->op_type != OP_FREED);
3659 switch (o->op_type) {
3662 PL_curcop = ((COP*)o); /* for warnings */
3670 S_maybe_multiconcat(aTHX_ o);
3674 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3675 /* we can't assume that op_pmreplroot->op_sibparent == o
3676 * and that it is thus possible to walk back up the tree
3677 * past op_pmreplroot. So, although we try to avoid
3678 * recursing through op trees, do it here. After all,
3679 * there are unlikely to be many nested s///e's within
3680 * the replacement part of a s///e.
3682 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3690 if (o->op_flags & OPf_KIDS)
3691 next_kid = cUNOPo->op_first;
3693 /* if a kid hasn't been nominated to process, continue with the
3694 * next sibling, or if no siblings left, go back to the parent's
3695 * siblings and so on
3699 return; /* at top; no parents/siblings to try */
3700 if (OpHAS_SIBLING(o))
3701 next_kid = o->op_sibparent;
3703 o = o->op_sibparent; /*try parent's next sibling */
3706 /* this label not yet used. Goto here if any code above sets
3716 =for apidoc finalize_optree
3718 This function finalizes the optree. Should be called directly after
3719 the complete optree is built. It does some additional
3720 checking which can't be done in the normal C<ck_>xxx functions and makes
3721 the tree thread-safe.
3726 Perl_finalize_optree(pTHX_ OP* o)
3728 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3731 SAVEVPTR(PL_curcop);
3739 /* Relocate sv to the pad for thread safety.
3740 * Despite being a "constant", the SV is written to,
3741 * for reference counts, sv_upgrade() etc. */
3742 PERL_STATIC_INLINE void
3743 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3746 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3748 ix = pad_alloc(OP_CONST, SVf_READONLY);
3749 SvREFCNT_dec(PAD_SVl(ix));
3750 PAD_SETSV(ix, *svp);
3751 /* XXX I don't know how this isn't readonly already. */
3752 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3759 =for apidoc traverse_op_tree
3761 Return the next op in a depth-first traversal of the op tree,
3762 returning NULL when the traversal is complete.
3764 The initial call must supply the root of the tree as both top and o.
3766 For now it's static, but it may be exposed to the API in the future.
3772 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3775 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3777 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3778 return cUNOPo->op_first;
3780 else if ((sib = OpSIBLING(o))) {
3784 OP *parent = o->op_sibparent;
3785 assert(!(o->op_moresib));
3786 while (parent && parent != top) {
3787 OP *sib = OpSIBLING(parent);
3790 parent = parent->op_sibparent;
3798 S_finalize_op(pTHX_ OP* o)
3801 PERL_ARGS_ASSERT_FINALIZE_OP;
3804 assert(o->op_type != OP_FREED);
3806 switch (o->op_type) {
3809 PL_curcop = ((COP*)o); /* for warnings */
3812 if (OpHAS_SIBLING(o)) {
3813 OP *sib = OpSIBLING(o);
3814 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3815 && ckWARN(WARN_EXEC)
3816 && OpHAS_SIBLING(sib))
3818 const OPCODE type = OpSIBLING(sib)->op_type;
3819 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3820 const line_t oldline = CopLINE(PL_curcop);
3821 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3822 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3823 "Statement unlikely to be reached");
3824 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3825 "\t(Maybe you meant system() when you said exec()?)\n");
3826 CopLINE_set(PL_curcop, oldline);
3833 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3834 GV * const gv = cGVOPo_gv;
3835 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3836 /* XXX could check prototype here instead of just carping */
3837 SV * const sv = sv_newmortal();
3838 gv_efullname3(sv, gv, NULL);
3839 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3840 "%" SVf "() called too early to check prototype",
3847 if (cSVOPo->op_private & OPpCONST_STRICT)
3848 no_bareword_allowed(o);
3852 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3857 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3858 case OP_METHOD_NAMED:
3859 case OP_METHOD_SUPER:
3860 case OP_METHOD_REDIR:
3861 case OP_METHOD_REDIR_SUPER:
3862 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3871 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3874 rop = (UNOP*)((BINOP*)o)->op_first;
3879 S_scalar_slice_warning(aTHX_ o);
3883 kid = OpSIBLING(cLISTOPo->op_first);
3884 if (/* I bet there's always a pushmark... */
3885 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3886 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3891 key_op = (SVOP*)(kid->op_type == OP_CONST
3893 : OpSIBLING(kLISTOP->op_first));
3895 rop = (UNOP*)((LISTOP*)o)->op_last;
3898 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3900 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3904 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3908 S_scalar_slice_warning(aTHX_ o);
3912 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3913 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3921 if (o->op_flags & OPf_KIDS) {
3924 /* check that op_last points to the last sibling, and that
3925 * the last op_sibling/op_sibparent field points back to the
3926 * parent, and that the only ops with KIDS are those which are
3927 * entitled to them */
3928 U32 type = o->op_type;
3932 if (type == OP_NULL) {
3934 /* ck_glob creates a null UNOP with ex-type GLOB
3935 * (which is a list op. So pretend it wasn't a listop */
3936 if (type == OP_GLOB)
3939 family = PL_opargs[type] & OA_CLASS_MASK;
3941 has_last = ( family == OA_BINOP
3942 || family == OA_LISTOP
3943 || family == OA_PMOP
3944 || family == OA_LOOP
3946 assert( has_last /* has op_first and op_last, or ...
3947 ... has (or may have) op_first: */
3948 || family == OA_UNOP
3949 || family == OA_UNOP_AUX
3950 || family == OA_LOGOP
3951 || family == OA_BASEOP_OR_UNOP
3952 || family == OA_FILESTATOP
3953 || family == OA_LOOPEXOP
3954 || family == OA_METHOP
3955 || type == OP_CUSTOM
3956 || type == OP_NULL /* new_logop does this */
3959 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3960 if (!OpHAS_SIBLING(kid)) {
3962 assert(kid == cLISTOPo->op_last);
3963 assert(kid->op_sibparent == o);
3968 } while (( o = traverse_op_tree(top, o)) != NULL);
3972 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3975 PadnameLVALUE_on(pn);
3976 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3978 /* RT #127786: cv can be NULL due to an eval within the DB package
3979 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3980 * unless they contain an eval, but calling eval within DB
3981 * pretends the eval was done in the caller's scope.
3985 assert(CvPADLIST(cv));
3987 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3988 assert(PadnameLEN(pn));
3989 PadnameLVALUE_on(pn);
3994 S_vivifies(const OPCODE type)
3997 case OP_RV2AV: case OP_ASLICE:
3998 case OP_RV2HV: case OP_KVASLICE:
3999 case OP_RV2SV: case OP_HSLICE:
4000 case OP_AELEMFAST: case OP_KVHSLICE:
4009 /* apply lvalue reference (aliasing) context to the optree o.
4012 * o would be the list ($x,$y) and type would be OP_AASSIGN.
4013 * It may descend and apply this to children too, for example in
4014 * \( $cond ? $x, $y) = (...)
4018 S_lvref(pTHX_ OP *o, I32 type)
4025 switch (o->op_type) {
4027 o = OpSIBLING(cUNOPo->op_first);
4034 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4035 o->op_flags |= OPf_STACKED;
4036 if (o->op_flags & OPf_PARENS) {
4037 if (o->op_private & OPpLVAL_INTRO) {
4038 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4039 "localized parenthesized array in list assignment"));
4043 OpTYPE_set(o, OP_LVAVREF);
4044 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4045 o->op_flags |= OPf_MOD|OPf_REF;
4048 o->op_private |= OPpLVREF_AV;
4052 kid = cUNOPo->op_first;
4053 if (kid->op_type == OP_NULL)
4054 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4056 o->op_private = OPpLVREF_CV;
4057 if (kid->op_type == OP_GV)
4058 o->op_flags |= OPf_STACKED;
4059 else if (kid->op_type == OP_PADCV) {
4060 o->op_targ = kid->op_targ;
4062 op_free(cUNOPo->op_first);
4063 cUNOPo->op_first = NULL;
4064 o->op_flags &=~ OPf_KIDS;
4070 if (o->op_flags & OPf_PARENS) {
4072 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4073 "parenthesized hash in list assignment"));
4076 o->op_private |= OPpLVREF_HV;
4080 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4081 o->op_flags |= OPf_STACKED;
4085 if (o->op_flags & OPf_PARENS) goto parenhash;
4086 o->op_private |= OPpLVREF_HV;
4089 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4093 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4094 if (o->op_flags & OPf_PARENS) goto slurpy;
4095 o->op_private |= OPpLVREF_AV;
4100 o->op_private |= OPpLVREF_ELEM;
4101 o->op_flags |= OPf_STACKED;
4106 OpTYPE_set(o, OP_LVREFSLICE);
4107 o->op_private &= OPpLVAL_INTRO;
4111 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4113 else if (!(o->op_flags & OPf_KIDS))
4116 /* the code formerly only recursed into the first child of
4117 * a non ex-list OP_NULL. if we ever encounter such a null op with
4118 * more than one child, need to decide whether its ok to process
4119 * *all* its kids or not */
4120 assert(o->op_targ == OP_LIST
4121 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4124 o = cLISTOPo->op_first;
4128 if (o->op_flags & OPf_PARENS)
4133 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4134 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4135 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4142 OpTYPE_set(o, OP_LVREF);
4144 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4145 if (type == OP_ENTERLOOP)
4146 o->op_private |= OPpLVREF_ITER;
4151 return; /* at top; no parents/siblings to try */
4152 if (OpHAS_SIBLING(o)) {
4153 o = o->op_sibparent;
4156 o = o->op_sibparent; /*try parent's next sibling */
4162 PERL_STATIC_INLINE bool
4163 S_potential_mod_type(I32 type)
4165 /* Types that only potentially result in modification. */
4166 return type == OP_GREPSTART || type == OP_ENTERSUB
4167 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4172 =for apidoc op_lvalue
4174 Propagate lvalue ("modifiable") context to an op and its children.
4175 C<type> represents the context type, roughly based on the type of op that
4176 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4177 because it has no op type of its own (it is signalled by a flag on
4180 This function detects things that can't be modified, such as C<$x+1>, and
4181 generates errors for them. For example, C<$x+1 = 2> would cause it to be
4182 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4184 It also flags things that need to behave specially in an lvalue context,
4185 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4189 Perl_op_lvalue_flags() is a non-API lower-level interface to
4190 op_lvalue(). The flags param has these bits:
4191 OP_LVALUE_NO_CROAK: return rather than croaking on error
4196 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4201 if (!o || (PL_parser && PL_parser->error_count))
4206 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4208 OP *next_kid = NULL;
4210 if ((o->op_private & OPpTARGET_MY)
4211 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4216 /* elements of a list might be in void context because the list is
4217 in scalar context or because they are attribute sub calls */
4218 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4221 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4223 switch (o->op_type) {
4229 if ((o->op_flags & OPf_PARENS))
4234 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4235 !(o->op_flags & OPf_STACKED)) {
4236 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4237 assert(cUNOPo->op_first->op_type == OP_NULL);
4238 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4241 else { /* lvalue subroutine call */
4242 o->op_private |= OPpLVAL_INTRO;
4243 PL_modcount = RETURN_UNLIMITED_NUMBER;
4244 if (S_potential_mod_type(type)) {
4245 o->op_private |= OPpENTERSUB_INARGS;
4248 else { /* Compile-time error message: */
4249 OP *kid = cUNOPo->op_first;
4254 if (kid->op_type != OP_PUSHMARK) {
4255 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4257 "panic: unexpected lvalue entersub "
4258 "args: type/targ %ld:%" UVuf,
4259 (long)kid->op_type, (UV)kid->op_targ);
4260 kid = kLISTOP->op_first;
4262 while (OpHAS_SIBLING(kid))
4263 kid = OpSIBLING(kid);
4264 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4265 break; /* Postpone until runtime */
4268 kid = kUNOP->op_first;
4269 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4270 kid = kUNOP->op_first;
4271 if (kid->op_type == OP_NULL)
4273 "Unexpected constant lvalue entersub "
4274 "entry via type/targ %ld:%" UVuf,
4275 (long)kid->op_type, (UV)kid->op_targ);
4276 if (kid->op_type != OP_GV) {
4283 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4284 ? MUTABLE_CV(SvRV(gv))
4290 if (flags & OP_LVALUE_NO_CROAK)
4293 namesv = cv_name(cv, NULL, 0);
4294 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4295 "subroutine call of &%" SVf " in %s",
4296 SVfARG(namesv), PL_op_desc[type]),
4304 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4305 /* grep, foreach, subcalls, refgen */
4306 if (S_potential_mod_type(type))
4308 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4309 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4312 type ? PL_op_desc[type] : "local"));
4325 case OP_RIGHT_SHIFT:
4334 if (!(o->op_flags & OPf_STACKED))
4340 if (o->op_flags & OPf_STACKED) {
4344 if (!(o->op_private & OPpREPEAT_DOLIST))
4347 const I32 mods = PL_modcount;
4348 /* we recurse rather than iterate here because we need to
4349 * calculate and use the delta applied to PL_modcount by the
4350 * first child. So in something like
4351 * ($x, ($y) x 3) = split;
4352 * split knows that 4 elements are wanted
4354 modkids(cBINOPo->op_first, type);
4355 if (type != OP_AASSIGN)
4357 kid = cBINOPo->op_last;
4358 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4359 const IV iv = SvIV(kSVOP_sv);
4360 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4362 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4365 PL_modcount = RETURN_UNLIMITED_NUMBER;
4371 next_kid = OpSIBLING(cUNOPo->op_first);
4376 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4377 PL_modcount = RETURN_UNLIMITED_NUMBER;
4378 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4379 fiable since some contexts need to know. */
4380 o->op_flags |= OPf_MOD;
4385 if (scalar_mod_type(o, type))
4387 ref(cUNOPo->op_first, o->op_type);
4394 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4395 if (type == OP_LEAVESUBLV && (
4396 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4397 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4399 o->op_private |= OPpMAYBE_LVSUB;
4403 PL_modcount = RETURN_UNLIMITED_NUMBER;
4409 if (type == OP_LEAVESUBLV)
4410 o->op_private |= OPpMAYBE_LVSUB;
4414 if (type == OP_LEAVESUBLV
4415 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4416 o->op_private |= OPpMAYBE_LVSUB;
4420 PL_hints |= HINT_BLOCK_SCOPE;
4421 if (type == OP_LEAVESUBLV)
4422 o->op_private |= OPpMAYBE_LVSUB;
4427 ref(cUNOPo->op_first, o->op_type);
4431 PL_hints |= HINT_BLOCK_SCOPE;
4441 case OP_AELEMFAST_LEX:
4448 PL_modcount = RETURN_UNLIMITED_NUMBER;
4449 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4451 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4452 fiable since some contexts need to know. */
4453 o->op_flags |= OPf_MOD;
4456 if (scalar_mod_type(o, type))
4458 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4459 && type == OP_LEAVESUBLV)
4460 o->op_private |= OPpMAYBE_LVSUB;
4464 if (!type) /* local() */
4465 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4466 PNfARG(PAD_COMPNAME(o->op_targ)));
4467 if (!(o->op_private & OPpLVAL_INTRO)
4468 || ( type != OP_SASSIGN && type != OP_AASSIGN
4469 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4470 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4478 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4482 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4488 if (type == OP_LEAVESUBLV)
4489 o->op_private |= OPpMAYBE_LVSUB;
4490 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4491 /* we recurse rather than iterate here because the child
4492 * needs to be processed with a different 'type' parameter */
4494 /* substr and vec */
4495 /* If this op is in merely potential (non-fatal) modifiable
4496 context, then apply OP_ENTERSUB context to
4497 the kid op (to avoid croaking). Other-
4498 wise pass this op’s own type so the correct op is mentioned
4499 in error messages. */
4500 op_lvalue(OpSIBLING(cBINOPo->op_first),
4501 S_potential_mod_type(type)
4509 ref(cBINOPo->op_first, o->op_type);
4510 if (type == OP_ENTERSUB &&
4511 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4512 o->op_private |= OPpLVAL_DEFER;
4513 if (type == OP_LEAVESUBLV)
4514 o->op_private |= OPpMAYBE_LVSUB;
4521 o->op_private |= OPpLVALUE;
4527 if (o->op_flags & OPf_KIDS)
4528 next_kid = cLISTOPo->op_last;
4533 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4535 else if (!(o->op_flags & OPf_KIDS))
4538 if (o->op_targ != OP_LIST) {
4539 OP *sib = OpSIBLING(cLISTOPo->op_first);
4540 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4547 * compared with things like OP_MATCH which have the argument
4553 * so handle specially to correctly get "Can't modify" croaks etc
4556 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4558 /* this should trigger a "Can't modify transliteration" err */
4559 op_lvalue(sib, type);
4561 next_kid = cBINOPo->op_first;
4562 /* we assume OP_NULLs which aren't ex-list have no more than 2
4563 * children. If this assumption is wrong, increase the scan
4565 assert( !OpHAS_SIBLING(next_kid)
4566 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4572 next_kid = cLISTOPo->op_first;
4580 if (type == OP_LEAVESUBLV
4581 || !S_vivifies(cLOGOPo->op_first->op_type))
4582 next_kid = cLOGOPo->op_first;
4583 else if (type == OP_LEAVESUBLV
4584 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4585 next_kid = OpSIBLING(cLOGOPo->op_first);
4589 if (type == OP_NULL) { /* local */
4591 if (!FEATURE_MYREF_IS_ENABLED)
4592 Perl_croak(aTHX_ "The experimental declared_refs "
4593 "feature is not enabled");
4594 Perl_ck_warner_d(aTHX_
4595 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4596 "Declaring references is experimental");
4597 next_kid = cUNOPo->op_first;
4600 if (type != OP_AASSIGN && type != OP_SASSIGN
4601 && type != OP_ENTERLOOP)
4603 /* Don’t bother applying lvalue context to the ex-list. */
4604 kid = cUNOPx(cUNOPo->op_first)->op_first;
4605 assert (!OpHAS_SIBLING(kid));
4608 if (type == OP_NULL) /* local */
4610 if (type != OP_AASSIGN) goto nomod;
4611 kid = cUNOPo->op_first;
4614 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4615 S_lvref(aTHX_ kid, type);
4616 if (!PL_parser || PL_parser->error_count == ec) {
4617 if (!FEATURE_REFALIASING_IS_ENABLED)
4619 "Experimental aliasing via reference not enabled");
4620 Perl_ck_warner_d(aTHX_
4621 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4622 "Aliasing via reference is experimental");
4625 if (o->op_type == OP_REFGEN)
4626 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4631 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4632 /* This is actually @array = split. */
4633 PL_modcount = RETURN_UNLIMITED_NUMBER;
4639 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4643 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4644 their argument is a filehandle; thus \stat(".") should not set
4646 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4649 if (type != OP_LEAVESUBLV)
4650 o->op_flags |= OPf_MOD;
4652 if (type == OP_AASSIGN || type == OP_SASSIGN)
4653 o->op_flags |= OPf_SPECIAL
4654 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4655 else if (!type) { /* local() */
4658 o->op_private |= OPpLVAL_INTRO;
4659 o->op_flags &= ~OPf_SPECIAL;
4660 PL_hints |= HINT_BLOCK_SCOPE;
4665 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4666 "Useless localization of %s", OP_DESC(o));
4669 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4670 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4671 o->op_flags |= OPf_REF;
4676 return top_op; /* at top; no parents/siblings to try */
4677 if (OpHAS_SIBLING(o)) {
4678 next_kid = o->op_sibparent;
4679 if (!OpHAS_SIBLING(next_kid)) {
4680 /* a few node types don't recurse into their second child */
4681 OP *parent = next_kid->op_sibparent;
4682 I32 ptype = parent->op_type;
4683 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
4684 || ( (ptype == OP_AND || ptype == OP_OR)
4685 && (type != OP_LEAVESUBLV
4686 && S_vivifies(next_kid->op_type))
4689 /*try parent's next sibling */
4696 o = o->op_sibparent; /*try parent's next sibling */
4707 S_scalar_mod_type(const OP *o, I32 type)
4712 if (o && o->op_type == OP_RV2GV)
4736 case OP_RIGHT_SHIFT:
4765 S_is_handle_constructor(const OP *o, I32 numargs)
4767 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4769 switch (o->op_type) {
4777 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4790 S_refkids(pTHX_ OP *o, I32 type)
4792 if (o && o->op_flags & OPf_KIDS) {
4794 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4801 /* Apply reference (autovivification) context to the subtree at o.
4803 * push @{expression}, ....;
4804 * o will be the head of 'expression' and type will be OP_RV2AV.
4805 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4807 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4808 * set_op_ref is true.
4810 * Also calls scalar(o).
4814 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4819 PERL_ARGS_ASSERT_DOREF;
4821 if (PL_parser && PL_parser->error_count)
4825 switch (o->op_type) {
4827 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4828 !(o->op_flags & OPf_STACKED)) {
4829 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4830 assert(cUNOPo->op_first->op_type == OP_NULL);
4831 /* disable pushmark */
4832 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4833 o->op_flags |= OPf_SPECIAL;
4835 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4836 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4837 : type == OP_RV2HV ? OPpDEREF_HV
4839 o->op_flags |= OPf_MOD;
4845 o = OpSIBLING(cUNOPo->op_first);
4849 if (type == OP_DEFINED)
4850 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4853 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4854 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4855 : type == OP_RV2HV ? OPpDEREF_HV
4857 o->op_flags |= OPf_MOD;
4859 if (o->op_flags & OPf_KIDS) {
4861 o = cUNOPo->op_first;
4869 o->op_flags |= OPf_REF;
4872 if (type == OP_DEFINED)
4873 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4875 o = cUNOPo->op_first;
4881 o->op_flags |= OPf_REF;
4886 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4888 o = cBINOPo->op_first;
4893 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4894 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4895 : type == OP_RV2HV ? OPpDEREF_HV
4897 o->op_flags |= OPf_MOD;
4900 o = cBINOPo->op_first;
4909 if (!(o->op_flags & OPf_KIDS))
4911 o = cLISTOPo->op_last;
4920 return scalar(top_op); /* at top; no parents/siblings to try */
4921 if (OpHAS_SIBLING(o)) {
4922 o = o->op_sibparent;
4923 /* Normally skip all siblings and go straight to the parent;
4924 * the only op that requires two children to be processed
4925 * is OP_COND_EXPR */
4926 if (!OpHAS_SIBLING(o)
4927 && o->op_sibparent->op_type == OP_COND_EXPR)
4931 o = o->op_sibparent; /*try parent's next sibling */
4938 S_dup_attrlist(pTHX_ OP *o)
4942 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4944 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4945 * where the first kid is OP_PUSHMARK and the remaining ones
4946 * are OP_CONST. We need to push the OP_CONST values.
4948 if (o->op_type == OP_CONST)
4949 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4951 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4953 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4954 if (o->op_type == OP_CONST)
4955 rop = op_append_elem(OP_LIST, rop,
4956 newSVOP(OP_CONST, o->op_flags,
4957 SvREFCNT_inc_NN(cSVOPo->op_sv)));
4964 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4966 PERL_ARGS_ASSERT_APPLY_ATTRS;
4968 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4970 /* fake up C<use attributes $pkg,$rv,@attrs> */
4972 #define ATTRSMODULE "attributes"
4973 #define ATTRSMODULE_PM "attributes.pm"
4976 aTHX_ PERL_LOADMOD_IMPORT_OPS,
4977 newSVpvs(ATTRSMODULE),
4979 op_prepend_elem(OP_LIST,
4980 newSVOP(OP_CONST, 0, stashsv),
4981 op_prepend_elem(OP_LIST,
4982 newSVOP(OP_CONST, 0,
4984 dup_attrlist(attrs))));
4989 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4991 OP *pack, *imop, *arg;
4992 SV *meth, *stashsv, **svp;
4994 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4999 assert(target->op_type == OP_PADSV ||
5000 target->op_type == OP_PADHV ||
5001 target->op_type == OP_PADAV);
5003 /* Ensure that attributes.pm is loaded. */
5004 /* Don't force the C<use> if we don't need it. */
5005 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
5006 if (svp && *svp != &PL_sv_undef)
5007 NOOP; /* already in %INC */
5009 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5010 newSVpvs(ATTRSMODULE), NULL);
5012 /* Need package name for method call. */
5013 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
5015 /* Build up the real arg-list. */
5016 stashsv = newSVhek(HvNAME_HEK(stash));
5018 arg = newOP(OP_PADSV, 0);
5019 arg->op_targ = target->op_targ;
5020 arg = op_prepend_elem(OP_LIST,
5021 newSVOP(OP_CONST, 0, stashsv),
5022 op_prepend_elem(OP_LIST,
5023 newUNOP(OP_REFGEN, 0,
5025 dup_attrlist(attrs)));
5027 /* Fake up a method call to import */
5028 meth = newSVpvs_share("import");
5029 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
5030 op_append_elem(OP_LIST,
5031 op_prepend_elem(OP_LIST, pack, arg),
5032 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5034 /* Combine the ops. */
5035 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
5039 =notfor apidoc apply_attrs_string
5041 Attempts to apply a list of attributes specified by the C<attrstr> and
5042 C<len> arguments to the subroutine identified by the C<cv> argument which
5043 is expected to be associated with the package identified by the C<stashpv>
5044 argument (see L<attributes>). It gets this wrong, though, in that it
5045 does not correctly identify the boundaries of the individual attribute
5046 specifications within C<attrstr>. This is not really intended for the
5047 public API, but has to be listed here for systems such as AIX which
5048 need an explicit export list for symbols. (It's called from XS code
5049 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
5050 to respect attribute syntax properly would be welcome.
5056 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
5057 const char *attrstr, STRLEN len)
5061 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
5064 len = strlen(attrstr);
5068 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
5070 const char * const sstr = attrstr;
5071 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
5072 attrs = op_append_elem(OP_LIST, attrs,
5073 newSVOP(OP_CONST, 0,
5074 newSVpvn(sstr, attrstr-sstr)));
5078 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5079 newSVpvs(ATTRSMODULE),
5080 NULL, op_prepend_elem(OP_LIST,
5081 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5082 op_prepend_elem(OP_LIST,
5083 newSVOP(OP_CONST, 0,
5084 newRV(MUTABLE_SV(cv))),
5089 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5092 OP *new_proto = NULL;
5097 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5103 if (o->op_type == OP_CONST) {
5104 pv = SvPV(cSVOPo_sv, pvlen);
5105 if (memBEGINs(pv, pvlen, "prototype(")) {
5106 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5107 SV ** const tmpo = cSVOPx_svp(o);
5108 SvREFCNT_dec(cSVOPo_sv);
5113 } else if (o->op_type == OP_LIST) {
5115 assert(o->op_flags & OPf_KIDS);
5116 lasto = cLISTOPo->op_first;
5117 assert(lasto->op_type == OP_PUSHMARK);
5118 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5119 if (o->op_type == OP_CONST) {
5120 pv = SvPV(cSVOPo_sv, pvlen);
5121 if (memBEGINs(pv, pvlen, "prototype(")) {
5122 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5123 SV ** const tmpo = cSVOPx_svp(o);
5124 SvREFCNT_dec(cSVOPo_sv);
5126 if (new_proto && ckWARN(WARN_MISC)) {
5128 const char * newp = SvPV(cSVOPo_sv, new_len);
5129 Perl_warner(aTHX_ packWARN(WARN_MISC),
5130 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5131 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5137 /* excise new_proto from the list */
5138 op_sibling_splice(*attrs, lasto, 1, NULL);
5145 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5146 would get pulled in with no real need */
5147 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5156 svname = sv_newmortal();
5157 gv_efullname3(svname, name, NULL);
5159 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5160 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5162 svname = (SV *)name;
5163 if (ckWARN(WARN_ILLEGALPROTO))
5164 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5166 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5167 STRLEN old_len, new_len;
5168 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5169 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5171 if (curstash && svname == (SV *)name
5172 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5173 svname = sv_2mortal(newSVsv(PL_curstname));
5174 sv_catpvs(svname, "::");
5175 sv_catsv(svname, (SV *)name);
5178 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5179 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5181 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5182 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5192 S_cant_declare(pTHX_ OP *o)
5194 if (o->op_type == OP_NULL
5195 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5196 o = cUNOPo->op_first;
5197 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5198 o->op_type == OP_NULL
5199 && o->op_flags & OPf_SPECIAL
5202 PL_parser->in_my == KEY_our ? "our" :
5203 PL_parser->in_my == KEY_state ? "state" :
5208 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5211 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5213 PERL_ARGS_ASSERT_MY_KID;
5215 if (!o || (PL_parser && PL_parser->error_count))
5220 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5222 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5223 my_kid(kid, attrs, imopsp);
5225 } else if (type == OP_UNDEF || type == OP_STUB) {
5227 } else if (type == OP_RV2SV || /* "our" declaration */
5230 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5231 S_cant_declare(aTHX_ o);
5233 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5235 PL_parser->in_my = FALSE;
5236 PL_parser->in_my_stash = NULL;
5237 apply_attrs(GvSTASH(gv),
5238 (type == OP_RV2SV ? GvSVn(gv) :
5239 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5240 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5243 o->op_private |= OPpOUR_INTRO;
5246 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5247 if (!FEATURE_MYREF_IS_ENABLED)
5248 Perl_croak(aTHX_ "The experimental declared_refs "
5249 "feature is not enabled");
5250 Perl_ck_warner_d(aTHX_
5251 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5252 "Declaring references is experimental");
5253 /* Kid is a nulled OP_LIST, handled above. */
5254 my_kid(cUNOPo->op_first, attrs, imopsp);
5257 else if (type != OP_PADSV &&
5260 type != OP_PUSHMARK)
5262 S_cant_declare(aTHX_ o);
5265 else if (attrs && type != OP_PUSHMARK) {
5269 PL_parser->in_my = FALSE;
5270 PL_parser->in_my_stash = NULL;
5272 /* check for C<my Dog $spot> when deciding package */
5273 stash = PAD_COMPNAME_TYPE(o->op_targ);
5275 stash = PL_curstash;
5276 apply_attrs_my(stash, o, attrs, imopsp);
5278 o->op_flags |= OPf_MOD;
5279 o->op_private |= OPpLVAL_INTRO;
5281 o->op_private |= OPpPAD_STATE;
5286 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5289 int maybe_scalar = 0;
5291 PERL_ARGS_ASSERT_MY_ATTRS;
5293 /* [perl #17376]: this appears to be premature, and results in code such as
5294 C< our(%x); > executing in list mode rather than void mode */
5296 if (o->op_flags & OPf_PARENS)
5306 o = my_kid(o, attrs, &rops);
5308 if (maybe_scalar && o->op_type == OP_PADSV) {
5309 o = scalar(op_append_list(OP_LIST, rops, o));
5310 o->op_private |= OPpLVAL_INTRO;
5313 /* The listop in rops might have a pushmark at the beginning,
5314 which will mess up list assignment. */
5315 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5316 if (rops->op_type == OP_LIST &&
5317 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5319 OP * const pushmark = lrops->op_first;
5320 /* excise pushmark */
5321 op_sibling_splice(rops, NULL, 1, NULL);
5324 o = op_append_list(OP_LIST, o, rops);
5327 PL_parser->in_my = FALSE;
5328 PL_parser->in_my_stash = NULL;
5333 Perl_sawparens(pTHX_ OP *o)
5335 PERL_UNUSED_CONTEXT;
5337 o->op_flags |= OPf_PARENS;
5342 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5346 const OPCODE ltype = left->op_type;
5347 const OPCODE rtype = right->op_type;
5349 PERL_ARGS_ASSERT_BIND_MATCH;
5351 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5352 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5354 const char * const desc
5356 rtype == OP_SUBST || rtype == OP_TRANS
5357 || rtype == OP_TRANSR
5359 ? (int)rtype : OP_MATCH];
5360 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5362 S_op_varname(aTHX_ left);
5364 Perl_warner(aTHX_ packWARN(WARN_MISC),
5365 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5366 desc, SVfARG(name), SVfARG(name));
5368 const char * const sample = (isary
5369 ? "@array" : "%hash");
5370 Perl_warner(aTHX_ packWARN(WARN_MISC),
5371 "Applying %s to %s will act on scalar(%s)",
5372 desc, sample, sample);
5376 if (rtype == OP_CONST &&
5377 cSVOPx(right)->op_private & OPpCONST_BARE &&
5378 cSVOPx(right)->op_private & OPpCONST_STRICT)
5380 no_bareword_allowed(right);
5383 /* !~ doesn't make sense with /r, so error on it for now */
5384 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5386 /* diag_listed_as: Using !~ with %s doesn't make sense */
5387 yyerror("Using !~ with s///r doesn't make sense");
5388 if (rtype == OP_TRANSR && type == OP_NOT)
5389 /* diag_listed_as: Using !~ with %s doesn't make sense */
5390 yyerror("Using !~ with tr///r doesn't make sense");
5392 ismatchop = (rtype == OP_MATCH ||
5393 rtype == OP_SUBST ||
5394 rtype == OP_TRANS || rtype == OP_TRANSR)
5395 && !(right->op_flags & OPf_SPECIAL);
5396 if (ismatchop && right->op_private & OPpTARGET_MY) {
5398 right->op_private &= ~OPpTARGET_MY;
5400 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5401 if (left->op_type == OP_PADSV
5402 && !(left->op_private & OPpLVAL_INTRO))
5404 right->op_targ = left->op_targ;
5409 right->op_flags |= OPf_STACKED;
5410 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5411 ! (rtype == OP_TRANS &&
5412 right->op_private & OPpTRANS_IDENTICAL) &&
5413 ! (rtype == OP_SUBST &&
5414 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5415 left = op_lvalue(left, rtype);
5416 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5417 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5419 o = op_prepend_elem(rtype, scalar(left), right);
5422 return newUNOP(OP_NOT, 0, scalar(o));
5426 return bind_match(type, left,
5427 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5431 Perl_invert(pTHX_ OP *o)
5435 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5439 =for apidoc op_scope
5441 Wraps up an op tree with some additional ops so that at runtime a dynamic
5442 scope will be created. The original ops run in the new dynamic scope,
5443 and then, provided that they exit normally, the scope will be unwound.
5444 The additional ops used to create and unwind the dynamic scope will
5445 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5446 instead if the ops are simple enough to not need the full dynamic scope
5453 Perl_op_scope(pTHX_ OP *o)
5457 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5458 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5459 OpTYPE_set(o, OP_LEAVE);
5461 else if (o->op_type == OP_LINESEQ) {
5463 OpTYPE_set(o, OP_SCOPE);
5464 kid = ((LISTOP*)o)->op_first;
5465 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5468 /* The following deals with things like 'do {1 for 1}' */
5469 kid = OpSIBLING(kid);
5471 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5476 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5482 Perl_op_unscope(pTHX_ OP *o)
5484 if (o && o->op_type == OP_LINESEQ) {
5485 OP *kid = cLISTOPo->op_first;
5486 for(; kid; kid = OpSIBLING(kid))
5487 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5494 =for apidoc block_start
5496 Handles compile-time scope entry.
5497 Arranges for hints to be restored on block
5498 exit and also handles pad sequence numbers to make lexical variables scope
5499 right. Returns a savestack index for use with C<block_end>.
5505 Perl_block_start(pTHX_ int full)
5507 const int retval = PL_savestack_ix;
5509 PL_compiling.cop_seq = PL_cop_seqmax;
5511 pad_block_start(full);
5513 PL_hints &= ~HINT_BLOCK_SCOPE;
5514 SAVECOMPILEWARNINGS();
5515 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5516 SAVEI32(PL_compiling.cop_seq);
5517 PL_compiling.cop_seq = 0;
5519 CALL_BLOCK_HOOKS(bhk_start, full);
5525 =for apidoc block_end
5527 Handles compile-time scope exit. C<floor>
5528 is the savestack index returned by
5529 C<block_start>, and C<seq> is the body of the block. Returns the block,
5536 Perl_block_end(pTHX_ I32 floor, OP *seq)
5538 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5539 OP* retval = scalarseq(seq);
5542 /* XXX Is the null PL_parser check necessary here? */
5543 assert(PL_parser); /* Let’s find out under debugging builds. */
5544 if (PL_parser && PL_parser->parsed_sub) {
5545 o = newSTATEOP(0, NULL, NULL);
5547 retval = op_append_elem(OP_LINESEQ, retval, o);
5550 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5554 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5558 /* pad_leavemy has created a sequence of introcv ops for all my
5559 subs declared in the block. We have to replicate that list with
5560 clonecv ops, to deal with this situation:
5565 sub s1 { state sub foo { \&s2 } }
5568 Originally, I was going to have introcv clone the CV and turn
5569 off the stale flag. Since &s1 is declared before &s2, the
5570 introcv op for &s1 is executed (on sub entry) before the one for
5571 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5572 cloned, since it is a state sub) closes over &s2 and expects
5573 to see it in its outer CV’s pad. If the introcv op clones &s1,
5574 then &s2 is still marked stale. Since &s1 is not active, and
5575 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5576 ble will not stay shared’ warning. Because it is the same stub
5577 that will be used when the introcv op for &s2 is executed, clos-
5578 ing over it is safe. Hence, we have to turn off the stale flag
5579 on all lexical subs in the block before we clone any of them.
5580 Hence, having introcv clone the sub cannot work. So we create a
5581 list of ops like this:
5605 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5606 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5607 for (;; kid = OpSIBLING(kid)) {
5608 OP *newkid = newOP(OP_CLONECV, 0);
5609 newkid->op_targ = kid->op_targ;
5610 o = op_append_elem(OP_LINESEQ, o, newkid);
5611 if (kid == last) break;
5613 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5616 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5622 =head1 Compile-time scope hooks
5624 =for apidoc blockhook_register
5626 Register a set of hooks to be called when the Perl lexical scope changes
5627 at compile time. See L<perlguts/"Compile-time scope hooks">.
5633 Perl_blockhook_register(pTHX_ BHK *hk)
5635 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5637 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5641 Perl_newPROG(pTHX_ OP *o)
5645 PERL_ARGS_ASSERT_NEWPROG;
5652 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5653 ((PL_in_eval & EVAL_KEEPERR)
5654 ? OPf_SPECIAL : 0), o);
5657 assert(CxTYPE(cx) == CXt_EVAL);
5659 if ((cx->blk_gimme & G_WANT) == G_VOID)
5660 scalarvoid(PL_eval_root);
5661 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5664 scalar(PL_eval_root);
5666 start = op_linklist(PL_eval_root);
5667 PL_eval_root->op_next = 0;
5668 i = PL_savestack_ix;
5671 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5673 PL_savestack_ix = i;
5676 if (o->op_type == OP_STUB) {
5677 /* This block is entered if nothing is compiled for the main
5678 program. This will be the case for an genuinely empty main
5679 program, or one which only has BEGIN blocks etc, so already
5682 Historically (5.000) the guard above was !o. However, commit
5683 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5684 c71fccf11fde0068, changed perly.y so that newPROG() is now
5685 called with the output of block_end(), which returns a new
5686 OP_STUB for the case of an empty optree. ByteLoader (and
5687 maybe other things) also take this path, because they set up
5688 PL_main_start and PL_main_root directly, without generating an
5691 If the parsing the main program aborts (due to parse errors,
5692 or due to BEGIN or similar calling exit), then newPROG()
5693 isn't even called, and hence this code path and its cleanups
5694 are skipped. This shouldn't make a make a difference:
5695 * a non-zero return from perl_parse is a failure, and
5696 perl_destruct() should be called immediately.
5697 * however, if exit(0) is called during the parse, then
5698 perl_parse() returns 0, and perl_run() is called. As
5699 PL_main_start will be NULL, perl_run() will return
5700 promptly, and the exit code will remain 0.
5703 PL_comppad_name = 0;
5705 S_op_destroy(aTHX_ o);
5708 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5709 PL_curcop = &PL_compiling;
5710 start = LINKLIST(PL_main_root);
5711 PL_main_root->op_next = 0;
5712 S_process_optree(aTHX_ NULL, PL_main_root, start);
5713 if (!PL_parser->error_count)
5714 /* on error, leave CV slabbed so that ops left lying around
5715 * will eb cleaned up. Else unslab */
5716 cv_forget_slab(PL_compcv);
5719 /* Register with debugger */
5721 CV * const cv = get_cvs("DB::postponed", 0);
5725 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5727 call_sv(MUTABLE_SV(cv), G_DISCARD);
5734 Perl_localize(pTHX_ OP *o, I32 lex)
5736 PERL_ARGS_ASSERT_LOCALIZE;
5738 if (o->op_flags & OPf_PARENS)
5739 /* [perl #17376]: this appears to be premature, and results in code such as
5740 C< our(%x); > executing in list mode rather than void mode */
5747 if ( PL_parser->bufptr > PL_parser->oldbufptr
5748 && PL_parser->bufptr[-1] == ','
5749 && ckWARN(WARN_PARENTHESIS))
5751 char *s = PL_parser->bufptr;
5754 /* some heuristics to detect a potential error */
5755 while (*s && (strchr(", \t\n", *s)))
5759 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5761 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5764 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5766 while (*s && (strchr(", \t\n", *s)))
5772 if (sigil && (*s == ';' || *s == '=')) {
5773 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5774 "Parentheses missing around \"%s\" list",
5776 ? (PL_parser->in_my == KEY_our
5778 : PL_parser->in_my == KEY_state
5788 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5789 PL_parser->in_my = FALSE;
5790 PL_parser->in_my_stash = NULL;
5795 Perl_jmaybe(pTHX_ OP *o)
5797 PERL_ARGS_ASSERT_JMAYBE;
5799 if (o->op_type == OP_LIST) {
5801 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5802 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5807 PERL_STATIC_INLINE OP *
5808 S_op_std_init(pTHX_ OP *o)
5810 I32 type = o->op_type;
5812 PERL_ARGS_ASSERT_OP_STD_INIT;
5814 if (PL_opargs[type] & OA_RETSCALAR)
5816 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5817 o->op_targ = pad_alloc(type, SVs_PADTMP);
5822 PERL_STATIC_INLINE OP *
5823 S_op_integerize(pTHX_ OP *o)
5825 I32 type = o->op_type;
5827 PERL_ARGS_ASSERT_OP_INTEGERIZE;
5829 /* integerize op. */
5830 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5833 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5836 if (type == OP_NEGATE)
5837 /* XXX might want a ck_negate() for this */
5838 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5843 /* This function exists solely to provide a scope to limit
5844 setjmp/longjmp() messing with auto variables.
5846 PERL_STATIC_INLINE int
5847 S_fold_constants_eval(pTHX) {
5863 S_fold_constants(pTHX_ OP *const o)
5868 I32 type = o->op_type;
5873 SV * const oldwarnhook = PL_warnhook;
5874 SV * const olddiehook = PL_diehook;
5876 U8 oldwarn = PL_dowarn;
5879 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5881 if (!(PL_opargs[type] & OA_FOLDCONST))
5890 #ifdef USE_LOCALE_CTYPE
5891 if (IN_LC_COMPILETIME(LC_CTYPE))
5900 #ifdef USE_LOCALE_COLLATE
5901 if (IN_LC_COMPILETIME(LC_COLLATE))
5906 /* XXX what about the numeric ops? */
5907 #ifdef USE_LOCALE_NUMERIC
5908 if (IN_LC_COMPILETIME(LC_NUMERIC))
5913 if (!OpHAS_SIBLING(cLISTOPo->op_first)
5914 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5917 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5918 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5920 const char *s = SvPVX_const(sv);
5921 while (s < SvEND(sv)) {
5922 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5929 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5932 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5933 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5937 if (PL_parser && PL_parser->error_count)
5938 goto nope; /* Don't try to run w/ errors */
5940 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5941 switch (curop->op_type) {
5943 if ( (curop->op_private & OPpCONST_BARE)
5944 && (curop->op_private & OPpCONST_STRICT)) {
5945 no_bareword_allowed(curop);
5953 /* Foldable; move to next op in list */
5957 /* No other op types are considered foldable */
5962 curop = LINKLIST(o);
5963 old_next = o->op_next;
5967 old_cxix = cxstack_ix;
5968 create_eval_scope(NULL, G_FAKINGEVAL);
5970 /* Verify that we don't need to save it: */
5971 assert(PL_curcop == &PL_compiling);
5972 StructCopy(&PL_compiling, ¬_compiling, COP);
5973 PL_curcop = ¬_compiling;
5974 /* The above ensures that we run with all the correct hints of the
5975 currently compiling COP, but that IN_PERL_RUNTIME is true. */
5976 assert(IN_PERL_RUNTIME);
5977 PL_warnhook = PERL_WARNHOOK_FATAL;
5980 /* Effective $^W=1. */
5981 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5982 PL_dowarn |= G_WARN_ON;
5984 ret = S_fold_constants_eval(aTHX);
5988 sv = *(PL_stack_sp--);
5989 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
5990 pad_swipe(o->op_targ, FALSE);
5992 else if (SvTEMP(sv)) { /* grab mortal temp? */
5993 SvREFCNT_inc_simple_void(sv);
5996 else { assert(SvIMMORTAL(sv)); }
5999 /* Something tried to die. Abandon constant folding. */
6000 /* Pretend the error never happened. */
6002 o->op_next = old_next;
6005 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
6006 PL_warnhook = oldwarnhook;
6007 PL_diehook = olddiehook;
6008 /* XXX note that this croak may fail as we've already blown away
6009 * the stack - eg any nested evals */
6010 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6012 PL_dowarn = oldwarn;
6013 PL_warnhook = oldwarnhook;
6014 PL_diehook = olddiehook;
6015 PL_curcop = &PL_compiling;
6017 /* if we croaked, depending on how we croaked the eval scope
6018 * may or may not have already been popped */
6019 if (cxstack_ix > old_cxix) {
6020 assert(cxstack_ix == old_cxix + 1);
6021 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6022 delete_eval_scope();
6027 /* OP_STRINGIFY and constant folding are used to implement qq.
6028 Here the constant folding is an implementation detail that we
6029 want to hide. If the stringify op is itself already marked
6030 folded, however, then it is actually a folded join. */
6031 is_stringify = type == OP_STRINGIFY && !o->op_folded;
6036 else if (!SvIMMORTAL(sv)) {
6040 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6041 if (!is_stringify) newop->op_folded = 1;
6048 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6049 * the constant value being an AV holding the flattened range.
6053 S_gen_constant_list(pTHX_ OP *o)
6056 OP *curop, *old_next;
6057 SV * const oldwarnhook = PL_warnhook;
6058 SV * const olddiehook = PL_diehook;
6060 U8 oldwarn = PL_dowarn;
6070 if (PL_parser && PL_parser->error_count)
6071 return; /* Don't attempt to run with errors */
6073 curop = LINKLIST(o);
6074 old_next = o->op_next;
6076 op_was_null = o->op_type == OP_NULL;
6077 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6078 o->op_type = OP_CUSTOM;
6081 o->op_type = OP_NULL;
6082 S_prune_chain_head(&curop);
6085 old_cxix = cxstack_ix;
6086 create_eval_scope(NULL, G_FAKINGEVAL);
6088 old_curcop = PL_curcop;
6089 StructCopy(old_curcop, ¬_compiling, COP);
6090 PL_curcop = ¬_compiling;
6091 /* The above ensures that we run with all the correct hints of the
6092 current COP, but that IN_PERL_RUNTIME is true. */
6093 assert(IN_PERL_RUNTIME);
6094 PL_warnhook = PERL_WARNHOOK_FATAL;
6098 /* Effective $^W=1. */
6099 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6100 PL_dowarn |= G_WARN_ON;
6104 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6105 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6107 Perl_pp_pushmark(aTHX);
6110 assert (!(curop->op_flags & OPf_SPECIAL));
6111 assert(curop->op_type == OP_RANGE);
6112 Perl_pp_anonlist(aTHX);
6116 o->op_next = old_next;
6120 PL_warnhook = oldwarnhook;
6121 PL_diehook = olddiehook;
6122 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6127 PL_dowarn = oldwarn;
6128 PL_warnhook = oldwarnhook;
6129 PL_diehook = olddiehook;
6130 PL_curcop = old_curcop;
6132 if (cxstack_ix > old_cxix) {
6133 assert(cxstack_ix == old_cxix + 1);
6134 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6135 delete_eval_scope();
6140 OpTYPE_set(o, OP_RV2AV);
6141 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6142 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6143 o->op_opt = 0; /* needs to be revisited in rpeep() */
6144 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6146 /* replace subtree with an OP_CONST */
6147 curop = ((UNOP*)o)->op_first;
6148 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6151 if (AvFILLp(av) != -1)
6152 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6155 SvREADONLY_on(*svp);
6163 =head1 Optree Manipulation Functions
6166 /* List constructors */
6169 =for apidoc op_append_elem
6171 Append an item to the list of ops contained directly within a list-type
6172 op, returning the lengthened list. C<first> is the list-type op,
6173 and C<last> is the op to append to the list. C<optype> specifies the
6174 intended opcode for the list. If C<first> is not already a list of the
6175 right type, it will be upgraded into one. If either C<first> or C<last>
6176 is null, the other is returned unchanged.
6182 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6190 if (first->op_type != (unsigned)type
6191 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6193 return newLISTOP(type, 0, first, last);
6196 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6197 first->op_flags |= OPf_KIDS;
6202 =for apidoc op_append_list
6204 Concatenate the lists of ops contained directly within two list-type ops,
6205 returning the combined list. C<first> and C<last> are the list-type ops
6206 to concatenate. C<optype> specifies the intended opcode for the list.
6207 If either C<first> or C<last> is not already a list of the right type,
6208 it will be upgraded into one. If either C<first> or C<last> is null,
6209 the other is returned unchanged.
6215 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6223 if (first->op_type != (unsigned)type)
6224 return op_prepend_elem(type, first, last);
6226 if (last->op_type != (unsigned)type)
6227 return op_append_elem(type, first, last);
6229 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6230 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6231 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6232 first->op_flags |= (last->op_flags & OPf_KIDS);
6234 S_op_destroy(aTHX_ last);
6240 =for apidoc op_prepend_elem
6242 Prepend an item to the list of ops contained directly within a list-type
6243 op, returning the lengthened list. C<first> is the op to prepend to the
6244 list, and C<last> is the list-type op. C<optype> specifies the intended
6245 opcode for the list. If C<last> is not already a list of the right type,
6246 it will be upgraded into one. If either C<first> or C<last> is null,
6247 the other is returned unchanged.
6253 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6261 if (last->op_type == (unsigned)type) {
6262 if (type == OP_LIST) { /* already a PUSHMARK there */
6263 /* insert 'first' after pushmark */
6264 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6265 if (!(first->op_flags & OPf_PARENS))
6266 last->op_flags &= ~OPf_PARENS;
6269 op_sibling_splice(last, NULL, 0, first);
6270 last->op_flags |= OPf_KIDS;
6274 return newLISTOP(type, 0, first, last);
6278 =for apidoc op_convert_list
6280 Converts C<o> into a list op if it is not one already, and then converts it
6281 into the specified C<type>, calling its check function, allocating a target if
6282 it needs one, and folding constants.
6284 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6285 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6286 C<op_convert_list> to make it the right type.
6292 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6295 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6296 if (!o || o->op_type != OP_LIST)
6297 o = force_list(o, 0);
6300 o->op_flags &= ~OPf_WANT;
6301 o->op_private &= ~OPpLVAL_INTRO;
6304 if (!(PL_opargs[type] & OA_MARK))
6305 op_null(cLISTOPo->op_first);
6307 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6308 if (kid2 && kid2->op_type == OP_COREARGS) {
6309 op_null(cLISTOPo->op_first);
6310 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6314 if (type != OP_SPLIT)
6315 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6316 * ck_split() create a real PMOP and leave the op's type as listop
6317 * for now. Otherwise op_free() etc will crash.
6319 OpTYPE_set(o, type);
6321 o->op_flags |= flags;
6322 if (flags & OPf_FOLDED)
6325 o = CHECKOP(type, o);
6326 if (o->op_type != (unsigned)type)
6329 return fold_constants(op_integerize(op_std_init(o)));
6336 =head1 Optree construction
6338 =for apidoc newNULLLIST
6340 Constructs, checks, and returns a new C<stub> op, which represents an
6341 empty list expression.
6347 Perl_newNULLLIST(pTHX)
6349 return newOP(OP_STUB, 0);
6352 /* promote o and any siblings to be a list if its not already; i.e.
6360 * pushmark - o - A - B
6362 * If nullit it true, the list op is nulled.
6366 S_force_list(pTHX_ OP *o, bool nullit)
6368 if (!o || o->op_type != OP_LIST) {
6371 /* manually detach any siblings then add them back later */
6372 rest = OpSIBLING(o);
6373 OpLASTSIB_set(o, NULL);
6375 o = newLISTOP(OP_LIST, 0, o, NULL);
6377 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6385 =for apidoc newLISTOP
6387 Constructs, checks, and returns an op of any list type. C<type> is
6388 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6389 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6390 supply up to two ops to be direct children of the list op; they are
6391 consumed by this function and become part of the constructed op tree.
6393 For most list operators, the check function expects all the kid ops to be
6394 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6395 appropriate. What you want to do in that case is create an op of type
6396 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6397 See L</op_convert_list> for more information.
6404 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6408 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6409 * pushmark is banned. So do it now while existing ops are in a
6410 * consistent state, in case they suddenly get freed */
6411 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6413 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6414 || type == OP_CUSTOM);
6416 NewOp(1101, listop, 1, LISTOP);
6417 OpTYPE_set(listop, type);
6420 listop->op_flags = (U8)flags;
6424 else if (!first && last)
6427 OpMORESIB_set(first, last);
6428 listop->op_first = first;
6429 listop->op_last = last;
6432 OpMORESIB_set(pushop, first);
6433 listop->op_first = pushop;
6434 listop->op_flags |= OPf_KIDS;
6436 listop->op_last = pushop;
6438 if (listop->op_last)
6439 OpLASTSIB_set(listop->op_last, (OP*)listop);
6441 return CHECKOP(type, listop);
6447 Constructs, checks, and returns an op of any base type (any type that
6448 has no extra fields). C<type> is the opcode. C<flags> gives the
6449 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6456 Perl_newOP(pTHX_ I32 type, I32 flags)
6461 if (type == -OP_ENTEREVAL) {
6462 type = OP_ENTEREVAL;
6463 flags |= OPpEVAL_BYTES<<8;
6466 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6467 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6468 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6469 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6471 NewOp(1101, o, 1, OP);
6472 OpTYPE_set(o, type);
6473 o->op_flags = (U8)flags;
6476 o->op_private = (U8)(0 | (flags >> 8));
6477 if (PL_opargs[type] & OA_RETSCALAR)
6479 if (PL_opargs[type] & OA_TARGET)
6480 o->op_targ = pad_alloc(type, SVs_PADTMP);
6481 return CHECKOP(type, o);
6487 Constructs, checks, and returns an op of any unary type. C<type> is
6488 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6489 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6490 bits, the eight bits of C<op_private>, except that the bit with value 1
6491 is automatically set. C<first> supplies an optional op to be the direct
6492 child of the unary op; it is consumed by this function and become part
6493 of the constructed op tree.
6499 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6504 if (type == -OP_ENTEREVAL) {
6505 type = OP_ENTEREVAL;
6506 flags |= OPpEVAL_BYTES<<8;
6509 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6510 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6511 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6512 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6513 || type == OP_SASSIGN
6514 || type == OP_ENTERTRY
6515 || type == OP_CUSTOM
6516 || type == OP_NULL );
6519 first = newOP(OP_STUB, 0);
6520 if (PL_opargs[type] & OA_MARK)
6521 first = force_list(first, 1);
6523 NewOp(1101, unop, 1, UNOP);
6524 OpTYPE_set(unop, type);
6525 unop->op_first = first;
6526 unop->op_flags = (U8)(flags | OPf_KIDS);
6527 unop->op_private = (U8)(1 | (flags >> 8));
6529 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6530 OpLASTSIB_set(first, (OP*)unop);
6532 unop = (UNOP*) CHECKOP(type, unop);
6536 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6540 =for apidoc newUNOP_AUX
6542 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6543 initialised to C<aux>
6549 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6554 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6555 || type == OP_CUSTOM);
6557 NewOp(1101, unop, 1, UNOP_AUX);
6558 unop->op_type = (OPCODE)type;
6559 unop->op_ppaddr = PL_ppaddr[type];
6560 unop->op_first = first;
6561 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6562 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6565 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6566 OpLASTSIB_set(first, (OP*)unop);
6568 unop = (UNOP_AUX*) CHECKOP(type, unop);
6570 return op_std_init((OP *) unop);
6574 =for apidoc newMETHOP
6576 Constructs, checks, and returns an op of method type with a method name
6577 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6578 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6579 and, shifted up eight bits, the eight bits of C<op_private>, except that
6580 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6581 op which evaluates method name; it is consumed by this function and
6582 become part of the constructed op tree.
6583 Supported optypes: C<OP_METHOD>.
6589 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6593 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6594 || type == OP_CUSTOM);
6596 NewOp(1101, methop, 1, METHOP);
6598 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6599 methop->op_flags = (U8)(flags | OPf_KIDS);
6600 methop->op_u.op_first = dynamic_meth;
6601 methop->op_private = (U8)(1 | (flags >> 8));
6603 if (!OpHAS_SIBLING(dynamic_meth))
6604 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6608 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6609 methop->op_u.op_meth_sv = const_meth;
6610 methop->op_private = (U8)(0 | (flags >> 8));
6611 methop->op_next = (OP*)methop;
6615 methop->op_rclass_targ = 0;
6617 methop->op_rclass_sv = NULL;
6620 OpTYPE_set(methop, type);
6621 return CHECKOP(type, methop);
6625 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6626 PERL_ARGS_ASSERT_NEWMETHOP;
6627 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6631 =for apidoc newMETHOP_named
6633 Constructs, checks, and returns an op of method type with a constant
6634 method name. C<type> is the opcode. C<flags> gives the eight bits of
6635 C<op_flags>, and, shifted up eight bits, the eight bits of
6636 C<op_private>. C<const_meth> supplies a constant method name;
6637 it must be a shared COW string.
6638 Supported optypes: C<OP_METHOD_NAMED>.
6644 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6645 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6646 return newMETHOP_internal(type, flags, NULL, const_meth);
6650 =for apidoc newBINOP
6652 Constructs, checks, and returns an op of any binary type. C<type>
6653 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6654 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6655 the eight bits of C<op_private>, except that the bit with value 1 or
6656 2 is automatically set as required. C<first> and C<last> supply up to
6657 two ops to be the direct children of the binary op; they are consumed
6658 by this function and become part of the constructed op tree.
6664 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6669 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6670 || type == OP_NULL || type == OP_CUSTOM);
6672 NewOp(1101, binop, 1, BINOP);
6675 first = newOP(OP_NULL, 0);
6677 OpTYPE_set(binop, type);
6678 binop->op_first = first;
6679 binop->op_flags = (U8)(flags | OPf_KIDS);
6682 binop->op_private = (U8)(1 | (flags >> 8));
6685 binop->op_private = (U8)(2 | (flags >> 8));
6686 OpMORESIB_set(first, last);
6689 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6690 OpLASTSIB_set(last, (OP*)binop);
6692 binop->op_last = OpSIBLING(binop->op_first);
6694 OpLASTSIB_set(binop->op_last, (OP*)binop);
6696 binop = (BINOP*)CHECKOP(type, binop);
6697 if (binop->op_next || binop->op_type != (OPCODE)type)
6700 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6703 /* Helper function for S_pmtrans(): comparison function to sort an array
6704 * of codepoint range pairs. Sorts by start point, or if equal, by end
6707 static int uvcompare(const void *a, const void *b)
6708 __attribute__nonnull__(1)
6709 __attribute__nonnull__(2)
6710 __attribute__pure__;
6711 static int uvcompare(const void *a, const void *b)
6713 if (*((const UV *)a) < (*(const UV *)b))
6715 if (*((const UV *)a) > (*(const UV *)b))
6717 if (*((const UV *)a+1) < (*(const UV *)b+1))
6719 if (*((const UV *)a+1) > (*(const UV *)b+1))
6724 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6725 * containing the search and replacement strings, assemble into
6726 * a translation table attached as o->op_pv.
6727 * Free expr and repl.
6728 * It expects the toker to have already set the
6729 * OPpTRANS_COMPLEMENT
6732 * flags as appropriate; this function may add
6735 * OPpTRANS_IDENTICAL
6741 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6743 SV * const tstr = ((SVOP*)expr)->op_sv;
6744 SV * const rstr = ((SVOP*)repl)->op_sv;
6747 const U8 *t = (U8*)SvPV_const(tstr, tlen);
6748 const U8 *r = (U8*)SvPV_const(rstr, rlen);
6752 SSize_t struct_size; /* malloced size of table struct */
6754 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6755 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6756 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6759 PERL_ARGS_ASSERT_PMTRANS;
6761 PL_hints |= HINT_BLOCK_SCOPE;
6764 o->op_private |= OPpTRANS_FROM_UTF;
6767 o->op_private |= OPpTRANS_TO_UTF;
6769 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6771 /* for utf8 translations, op_sv will be set to point to a swash
6772 * containing codepoint ranges. This is done by first assembling
6773 * a textual representation of the ranges in listsv then compiling
6774 * it using swash_init(). For more details of the textual format,
6775 * see L<perlunicode.pod/"User-Defined Character Properties"> .
6778 SV* const listsv = newSVpvs("# comment\n");
6780 const U8* tend = t + tlen;
6781 const U8* rend = r + rlen;
6797 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
6798 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
6801 const U32 flags = UTF8_ALLOW_DEFAULT;
6805 t = tsave = bytes_to_utf8(t, &len);
6808 if (!to_utf && rlen) {
6810 r = rsave = bytes_to_utf8(r, &len);
6814 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6815 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6820 * replace t/tlen/tend with a version that has the ranges
6823 U8 tmpbuf[UTF8_MAXBYTES+1];
6826 Newx(cp, 2*tlen, UV);
6828 transv = newSVpvs("");
6830 /* convert search string into array of (start,end) range
6831 * codepoint pairs stored in cp[]. Most "ranges" will start
6832 * and end at the same char */
6834 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6836 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6837 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6839 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6843 cp[2*i+1] = cp[2*i];
6848 /* sort the ranges */
6849 qsort(cp, i, 2*sizeof(UV), uvcompare);
6851 /* Create a utf8 string containing the complement of the
6852 * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6853 * then transv will contain the equivalent of:
6854 * join '', map chr, 0, ILLEGAL_UTF8_BYTE, A - 1,
6855 * B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6856 * D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6857 * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6860 for (j = 0; j < i; j++) {
6862 diff = val - nextmin;
6864 t = uvchr_to_utf8(tmpbuf,nextmin);
6865 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6867 U8 range_mark = ILLEGAL_UTF8_BYTE;
6868 t = uvchr_to_utf8(tmpbuf, val - 1);
6869 sv_catpvn(transv, (char *)&range_mark, 1);
6870 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6878 t = uvchr_to_utf8(tmpbuf,nextmin);
6879 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6881 U8 range_mark = ILLEGAL_UTF8_BYTE;
6882 sv_catpvn(transv, (char *)&range_mark, 1);
6884 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6885 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6886 t = (const U8*)SvPVX_const(transv);
6887 tlen = SvCUR(transv);
6891 else if (!rlen && !del) {
6892 r = t; rlen = tlen; rend = tend;
6896 if ((!rlen && !del) || t == r ||
6897 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6899 o->op_private |= OPpTRANS_IDENTICAL;
6903 /* extract char ranges from t and r and append them to listsv */
6905 while (t < tend || tfirst <= tlast) {
6906 /* see if we need more "t" chars */
6907 if (tfirst > tlast) {
6908 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6910 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6912 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6919 /* now see if we need more "r" chars */
6920 if (rfirst > rlast) {
6922 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6924 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6926 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6935 rfirst = rlast = 0xffffffff;
6939 /* now see which range will peter out first, if either. */
6940 tdiff = tlast - tfirst;
6941 rdiff = rlast - rfirst;
6942 tcount += tdiff + 1;
6943 rcount += rdiff + 1;
6950 if (rfirst == 0xffffffff) {
6951 diff = tdiff; /* oops, pretend rdiff is infinite */
6953 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6954 (long)tfirst, (long)tlast);
6956 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6960 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6961 (long)tfirst, (long)(tfirst + diff),
6964 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6965 (long)tfirst, (long)rfirst);
6967 if (rfirst + diff > max)
6968 max = rfirst + diff;
6970 grows = (tfirst < rfirst &&
6971 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6977 /* compile listsv into a swash and attach to o */
6985 else if (max > 0xff)
6990 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6992 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6993 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6994 PAD_SETSV(cPADOPo->op_padix, swash);
6996 SvREADONLY_on(swash);
6998 cSVOPo->op_sv = swash;
7000 SvREFCNT_dec(listsv);
7001 SvREFCNT_dec(transv);
7003 if (!del && havefinal && rlen)
7004 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
7005 newSVuv((UV)final), 0);
7014 else if (rlast == 0xffffffff)
7020 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
7021 * table. Entries with the value -1 indicate chars not to be
7022 * translated, while -2 indicates a search char without a
7023 * corresponding replacement char under /d.
7025 * Normally, the table has 256 slots. However, in the presence of
7026 * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
7027 * added, and if there are enough replacement chars to start pairing
7028 * with the \x{100},... search chars, then a larger (> 256) table
7031 * In addition, regardless of whether under /c, an extra slot at the
7032 * end is used to store the final repeating char, or -3 under an empty
7033 * replacement list, or -2 under /d; which makes the runtime code
7036 * The toker will have already expanded char ranges in t and r.
7039 /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
7040 * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
7041 * The OPtrans_map struct already contains one slot; hence the -1.
7043 struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
7044 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7046 cPVOPo->op_pv = (char*)tbl;
7051 /* in this branch, j is a count of 'consumed' (i.e. paired off
7052 * with a search char) replacement chars (so j <= rlen always)
7054 for (i = 0; i < tlen; i++)
7055 tbl->map[t[i]] = -1;
7057 for (i = 0, j = 0; i < 256; i++) {
7063 tbl->map[i] = r[j-1];
7065 tbl->map[i] = (short)i;
7068 tbl->map[i] = r[j++];
7070 if ( tbl->map[i] >= 0
7071 && UVCHR_IS_INVARIANT((UV)i)
7072 && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
7082 /* More replacement chars than search chars:
7083 * store excess replacement chars at end of main table.
7086 struct_size += excess;
7087 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
7088 struct_size + excess * sizeof(short));
7089 tbl->size += excess;
7090 cPVOPo->op_pv = (char*)tbl;
7092 for (i = 0; i < excess; i++)
7093 tbl->map[i + 256] = r[j+i];
7096 /* no more replacement chars than search chars */
7097 if (!rlen && !del && !squash)
7098 o->op_private |= OPpTRANS_IDENTICAL;
7101 tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
7104 if (!rlen && !del) {
7107 o->op_private |= OPpTRANS_IDENTICAL;
7109 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
7110 o->op_private |= OPpTRANS_IDENTICAL;
7113 for (i = 0; i < 256; i++)
7115 for (i = 0, j = 0; i < tlen; i++,j++) {
7118 if (tbl->map[t[i]] == -1)
7119 tbl->map[t[i]] = -2;
7124 if (tbl->map[t[i]] == -1) {
7125 if ( UVCHR_IS_INVARIANT(t[i])
7126 && ! UVCHR_IS_INVARIANT(r[j]))
7128 tbl->map[t[i]] = r[j];
7131 tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
7134 /* both non-utf8 and utf8 code paths end up here */
7137 if(del && rlen == tlen) {
7138 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
7139 } else if(rlen > tlen && !complement) {
7140 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
7144 o->op_private |= OPpTRANS_GROWS;
7155 Constructs, checks, and returns an op of any pattern matching type.
7156 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
7157 and, shifted up eight bits, the eight bits of C<op_private>.
7163 Perl_newPMOP(pTHX_ I32 type, I32 flags)
7168 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
7169 || type == OP_CUSTOM);
7171 NewOp(1101, pmop, 1, PMOP);
7172 OpTYPE_set(pmop, type);
7173 pmop->op_flags = (U8)flags;
7174 pmop->op_private = (U8)(0 | (flags >> 8));
7175 if (PL_opargs[type] & OA_RETSCALAR)
7178 if (PL_hints & HINT_RE_TAINT)
7179 pmop->op_pmflags |= PMf_RETAINT;
7180 #ifdef USE_LOCALE_CTYPE
7181 if (IN_LC_COMPILETIME(LC_CTYPE)) {
7182 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
7187 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
7189 if (PL_hints & HINT_RE_FLAGS) {
7190 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7191 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
7193 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
7194 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7195 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
7197 if (reflags && SvOK(reflags)) {
7198 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
7204 assert(SvPOK(PL_regex_pad[0]));
7205 if (SvCUR(PL_regex_pad[0])) {
7206 /* Pop off the "packed" IV from the end. */
7207 SV *const repointer_list = PL_regex_pad[0];
7208 const char *p = SvEND(repointer_list) - sizeof(IV);
7209 const IV offset = *((IV*)p);
7211 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
7213 SvEND_set(repointer_list, p);
7215 pmop->op_pmoffset = offset;
7216 /* This slot should be free, so assert this: */
7217 assert(PL_regex_pad[offset] == &PL_sv_undef);
7219 SV * const repointer = &PL_sv_undef;
7220 av_push(PL_regex_padav, repointer);
7221 pmop->op_pmoffset = av_tindex(PL_regex_padav);
7222 PL_regex_pad = AvARRAY(PL_regex_padav);
7226 return CHECKOP(type, pmop);
7234 /* Any pad names in scope are potentially lvalues. */
7235 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
7236 PADNAME *pn = PAD_COMPNAME_SV(i);
7237 if (!pn || !PadnameLEN(pn))
7239 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
7240 S_mark_padname_lvalue(aTHX_ pn);
7244 /* Given some sort of match op o, and an expression expr containing a
7245 * pattern, either compile expr into a regex and attach it to o (if it's
7246 * constant), or convert expr into a runtime regcomp op sequence (if it's
7249 * Flags currently has 2 bits of meaning:
7250 * 1: isreg indicates that the pattern is part of a regex construct, eg
7251 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
7252 * split "pattern", which aren't. In the former case, expr will be a list
7253 * if the pattern contains more than one term (eg /a$b/).
7254 * 2: The pattern is for a split.
7256 * When the pattern has been compiled within a new anon CV (for
7257 * qr/(?{...})/ ), then floor indicates the savestack level just before
7258 * the new sub was created
7262 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
7266 I32 repl_has_vars = 0;
7267 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
7268 bool is_compiletime;
7270 bool isreg = cBOOL(flags & 1);
7271 bool is_split = cBOOL(flags & 2);
7273 PERL_ARGS_ASSERT_PMRUNTIME;
7276 return pmtrans(o, expr, repl);
7279 /* find whether we have any runtime or code elements;
7280 * at the same time, temporarily set the op_next of each DO block;
7281 * then when we LINKLIST, this will cause the DO blocks to be excluded
7282 * from the op_next chain (and from having LINKLIST recursively
7283 * applied to them). We fix up the DOs specially later */
7287 if (expr->op_type == OP_LIST) {
7289 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7290 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
7292 assert(!o->op_next);
7293 if (UNLIKELY(!OpHAS_SIBLING(o))) {
7294 assert(PL_parser && PL_parser->error_count);
7295 /* This can happen with qr/ (?{(^{})/. Just fake up
7296 the op we were expecting to see, to avoid crashing
7298 op_sibling_splice(expr, o, 0,
7299 newSVOP(OP_CONST, 0, &PL_sv_no));
7301 o->op_next = OpSIBLING(o);
7303 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
7307 else if (expr->op_type != OP_CONST)
7312 /* fix up DO blocks; treat each one as a separate little sub;
7313 * also, mark any arrays as LIST/REF */
7315 if (expr->op_type == OP_LIST) {
7317 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7319 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
7320 assert( !(o->op_flags & OPf_WANT));
7321 /* push the array rather than its contents. The regex
7322 * engine will retrieve and join the elements later */
7323 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
7327 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
7329 o->op_next = NULL; /* undo temporary hack from above */
7332 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
7333 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
7335 assert(leaveop->op_first->op_type == OP_ENTER);
7336 assert(OpHAS_SIBLING(leaveop->op_first));
7337 o->op_next = OpSIBLING(leaveop->op_first);
7339 assert(leaveop->op_flags & OPf_KIDS);
7340 assert(leaveop->op_last->op_next == (OP*)leaveop);
7341 leaveop->op_next = NULL; /* stop on last op */
7342 op_null((OP*)leaveop);
7346 OP *scope = cLISTOPo->op_first;
7347 assert(scope->op_type == OP_SCOPE);
7348 assert(scope->op_flags & OPf_KIDS);
7349 scope->op_next = NULL; /* stop on last op */
7353 /* XXX optimize_optree() must be called on o before
7354 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7355 * currently cope with a peephole-optimised optree.
7356 * Calling optimize_optree() here ensures that condition
7357 * is met, but may mean optimize_optree() is applied
7358 * to the same optree later (where hopefully it won't do any
7359 * harm as it can't convert an op to multiconcat if it's
7360 * already been converted */
7363 /* have to peep the DOs individually as we've removed it from
7364 * the op_next chain */
7366 S_prune_chain_head(&(o->op_next));
7368 /* runtime finalizes as part of finalizing whole tree */
7372 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7373 assert( !(expr->op_flags & OPf_WANT));
7374 /* push the array rather than its contents. The regex
7375 * engine will retrieve and join the elements later */
7376 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7379 PL_hints |= HINT_BLOCK_SCOPE;
7381 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7383 if (is_compiletime) {
7384 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7385 regexp_engine const *eng = current_re_engine();
7388 /* make engine handle split ' ' specially */
7389 pm->op_pmflags |= PMf_SPLIT;
7390 rx_flags |= RXf_SPLIT;
7393 if (!has_code || !eng->op_comp) {
7394 /* compile-time simple constant pattern */
7396 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7397 /* whoops! we guessed that a qr// had a code block, but we
7398 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7399 * that isn't required now. Note that we have to be pretty
7400 * confident that nothing used that CV's pad while the
7401 * regex was parsed, except maybe op targets for \Q etc.
7402 * If there were any op targets, though, they should have
7403 * been stolen by constant folding.
7407 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7408 while (++i <= AvFILLp(PL_comppad)) {
7409 # ifdef USE_PAD_RESET
7410 /* under USE_PAD_RESET, pad swipe replaces a swiped
7411 * folded constant with a fresh padtmp */
7412 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7414 assert(!PL_curpad[i]);
7418 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7419 * outer CV (the one whose slab holds the pm op). The
7420 * inner CV (which holds expr) will be freed later, once
7421 * all the entries on the parse stack have been popped on
7422 * return from this function. Which is why its safe to
7423 * call op_free(expr) below.
7426 pm->op_pmflags &= ~PMf_HAS_CV;
7429 /* Skip compiling if parser found an error for this pattern */
7430 if (pm->op_pmflags & PMf_HAS_ERROR) {
7436 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7437 rx_flags, pm->op_pmflags)
7438 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7439 rx_flags, pm->op_pmflags)
7444 /* compile-time pattern that includes literal code blocks */
7448 /* Skip compiling if parser found an error for this pattern */
7449 if (pm->op_pmflags & PMf_HAS_ERROR) {
7453 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7456 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7459 if (pm->op_pmflags & PMf_HAS_CV) {
7461 /* this QR op (and the anon sub we embed it in) is never
7462 * actually executed. It's just a placeholder where we can
7463 * squirrel away expr in op_code_list without the peephole
7464 * optimiser etc processing it for a second time */
7465 OP *qr = newPMOP(OP_QR, 0);
7466 ((PMOP*)qr)->op_code_list = expr;
7468 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7469 SvREFCNT_inc_simple_void(PL_compcv);
7470 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7471 ReANY(re)->qr_anoncv = cv;
7473 /* attach the anon CV to the pad so that
7474 * pad_fixup_inner_anons() can find it */
7475 (void)pad_add_anon(cv, o->op_type);
7476 SvREFCNT_inc_simple_void(cv);
7479 pm->op_code_list = expr;
7484 /* runtime pattern: build chain of regcomp etc ops */
7486 PADOFFSET cv_targ = 0;
7488 reglist = isreg && expr->op_type == OP_LIST;
7493 pm->op_code_list = expr;
7494 /* don't free op_code_list; its ops are embedded elsewhere too */
7495 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7499 /* make engine handle split ' ' specially */
7500 pm->op_pmflags |= PMf_SPLIT;
7502 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7503 * to allow its op_next to be pointed past the regcomp and
7504 * preceding stacking ops;
7505 * OP_REGCRESET is there to reset taint before executing the
7507 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7508 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7510 if (pm->op_pmflags & PMf_HAS_CV) {
7511 /* we have a runtime qr with literal code. This means
7512 * that the qr// has been wrapped in a new CV, which
7513 * means that runtime consts, vars etc will have been compiled
7514 * against a new pad. So... we need to execute those ops
7515 * within the environment of the new CV. So wrap them in a call
7516 * to a new anon sub. i.e. for
7520 * we build an anon sub that looks like
7522 * sub { "a", $b, '(?{...})' }
7524 * and call it, passing the returned list to regcomp.
7525 * Or to put it another way, the list of ops that get executed
7529 * ------ -------------------
7530 * pushmark (for regcomp)
7531 * pushmark (for entersub)
7535 * regcreset regcreset
7537 * const("a") const("a")
7539 * const("(?{...})") const("(?{...})")
7544 SvREFCNT_inc_simple_void(PL_compcv);
7545 CvLVALUE_on(PL_compcv);
7546 /* these lines are just an unrolled newANONATTRSUB */
7547 expr = newSVOP(OP_ANONCODE, 0,
7548 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7549 cv_targ = expr->op_targ;
7550 expr = newUNOP(OP_REFGEN, 0, expr);
7552 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7555 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7556 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7557 | (reglist ? OPf_STACKED : 0);
7558 rcop->op_targ = cv_targ;
7560 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
7561 if (PL_hints & HINT_RE_EVAL)
7562 S_set_haseval(aTHX);
7564 /* establish postfix order */
7565 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7567 rcop->op_next = expr;
7568 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7571 rcop->op_next = LINKLIST(expr);
7572 expr->op_next = (OP*)rcop;
7575 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7581 /* If we are looking at s//.../e with a single statement, get past
7582 the implicit do{}. */
7583 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7584 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7585 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7588 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7589 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7590 && !OpHAS_SIBLING(sib))
7593 if (curop->op_type == OP_CONST)
7595 else if (( (curop->op_type == OP_RV2SV ||
7596 curop->op_type == OP_RV2AV ||
7597 curop->op_type == OP_RV2HV ||
7598 curop->op_type == OP_RV2GV)
7599 && cUNOPx(curop)->op_first
7600 && cUNOPx(curop)->op_first->op_type == OP_GV )
7601 || curop->op_type == OP_PADSV
7602 || curop->op_type == OP_PADAV
7603 || curop->op_type == OP_PADHV
7604 || curop->op_type == OP_PADANY) {
7612 || !RX_PRELEN(PM_GETRE(pm))
7613 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7615 pm->op_pmflags |= PMf_CONST; /* const for long enough */
7616 op_prepend_elem(o->op_type, scalar(repl), o);
7619 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7620 rcop->op_private = 1;
7622 /* establish postfix order */
7623 rcop->op_next = LINKLIST(repl);
7624 repl->op_next = (OP*)rcop;
7626 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7627 assert(!(pm->op_pmflags & PMf_ONCE));
7628 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7639 Constructs, checks, and returns an op of any type that involves an
7640 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
7641 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
7642 takes ownership of one reference to it.
7648 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7653 PERL_ARGS_ASSERT_NEWSVOP;
7655 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7656 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7657 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7658 || type == OP_CUSTOM);
7660 NewOp(1101, svop, 1, SVOP);
7661 OpTYPE_set(svop, type);
7663 svop->op_next = (OP*)svop;
7664 svop->op_flags = (U8)flags;
7665 svop->op_private = (U8)(0 | (flags >> 8));
7666 if (PL_opargs[type] & OA_RETSCALAR)
7668 if (PL_opargs[type] & OA_TARGET)
7669 svop->op_targ = pad_alloc(type, SVs_PADTMP);
7670 return CHECKOP(type, svop);
7674 =for apidoc newDEFSVOP
7676 Constructs and returns an op to access C<$_>.
7682 Perl_newDEFSVOP(pTHX)
7684 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7690 =for apidoc newPADOP
7692 Constructs, checks, and returns an op of any type that involves a
7693 reference to a pad element. C<type> is the opcode. C<flags> gives the
7694 eight bits of C<op_flags>. A pad slot is automatically allocated, and
7695 is populated with C<sv>; this function takes ownership of one reference
7698 This function only exists if Perl has been compiled to use ithreads.
7704 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7709 PERL_ARGS_ASSERT_NEWPADOP;
7711 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7712 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7713 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7714 || type == OP_CUSTOM);
7716 NewOp(1101, padop, 1, PADOP);
7717 OpTYPE_set(padop, type);
7719 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7720 SvREFCNT_dec(PAD_SVl(padop->op_padix));
7721 PAD_SETSV(padop->op_padix, sv);
7723 padop->op_next = (OP*)padop;
7724 padop->op_flags = (U8)flags;
7725 if (PL_opargs[type] & OA_RETSCALAR)
7727 if (PL_opargs[type] & OA_TARGET)
7728 padop->op_targ = pad_alloc(type, SVs_PADTMP);
7729 return CHECKOP(type, padop);
7732 #endif /* USE_ITHREADS */
7737 Constructs, checks, and returns an op of any type that involves an
7738 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
7739 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
7740 reference; calling this function does not transfer ownership of any
7747 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7749 PERL_ARGS_ASSERT_NEWGVOP;
7752 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7754 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7761 Constructs, checks, and returns an op of any type that involves an
7762 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
7763 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
7764 Depending on the op type, the memory referenced by C<pv> may be freed
7765 when the op is destroyed. If the op is of a freeing type, C<pv> must
7766 have been allocated using C<PerlMemShared_malloc>.
7772 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7775 const bool utf8 = cBOOL(flags & SVf_UTF8);
7780 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7781 || type == OP_RUNCV || type == OP_CUSTOM
7782 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7784 NewOp(1101, pvop, 1, PVOP);
7785 OpTYPE_set(pvop, type);
7787 pvop->op_next = (OP*)pvop;
7788 pvop->op_flags = (U8)flags;
7789 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7790 if (PL_opargs[type] & OA_RETSCALAR)
7792 if (PL_opargs[type] & OA_TARGET)
7793 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7794 return CHECKOP(type, pvop);
7798 Perl_package(pTHX_ OP *o)
7800 SV *const sv = cSVOPo->op_sv;
7802 PERL_ARGS_ASSERT_PACKAGE;
7804 SAVEGENERICSV(PL_curstash);
7805 save_item(PL_curstname);
7807 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7809 sv_setsv(PL_curstname, sv);
7811 PL_hints |= HINT_BLOCK_SCOPE;
7812 PL_parser->copline = NOLINE;
7818 Perl_package_version( pTHX_ OP *v )
7820 U32 savehints = PL_hints;
7821 PERL_ARGS_ASSERT_PACKAGE_VERSION;
7822 PL_hints &= ~HINT_STRICT_VARS;
7823 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7824 PL_hints = savehints;
7829 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7834 SV *use_version = NULL;
7836 PERL_ARGS_ASSERT_UTILIZE;
7838 if (idop->op_type != OP_CONST)
7839 Perl_croak(aTHX_ "Module name must be constant");
7844 SV * const vesv = ((SVOP*)version)->op_sv;
7846 if (!arg && !SvNIOKp(vesv)) {
7853 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7854 Perl_croak(aTHX_ "Version number must be a constant number");
7856 /* Make copy of idop so we don't free it twice */
7857 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7859 /* Fake up a method call to VERSION */
7860 meth = newSVpvs_share("VERSION");
7861 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7862 op_append_elem(OP_LIST,
7863 op_prepend_elem(OP_LIST, pack, version),
7864 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7868 /* Fake up an import/unimport */
7869 if (arg && arg->op_type == OP_STUB) {
7870 imop = arg; /* no import on explicit () */
7872 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7873 imop = NULL; /* use 5.0; */
7875 use_version = ((SVOP*)idop)->op_sv;
7877 idop->op_private |= OPpCONST_NOVER;
7882 /* Make copy of idop so we don't free it twice */
7883 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7885 /* Fake up a method call to import/unimport */
7887 ? newSVpvs_share("import") : newSVpvs_share("unimport");
7888 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7889 op_append_elem(OP_LIST,
7890 op_prepend_elem(OP_LIST, pack, arg),
7891 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7895 /* Fake up the BEGIN {}, which does its thing immediately. */
7897 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7900 op_append_elem(OP_LINESEQ,
7901 op_append_elem(OP_LINESEQ,
7902 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7903 newSTATEOP(0, NULL, veop)),
7904 newSTATEOP(0, NULL, imop) ));
7908 * feature bundle that corresponds to the required version. */
7909 use_version = sv_2mortal(new_version(use_version));
7910 S_enable_feature_bundle(aTHX_ use_version);
7912 /* If a version >= 5.11.0 is requested, strictures are on by default! */
7913 if (vcmp(use_version,
7914 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7915 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7916 PL_hints |= HINT_STRICT_REFS;
7917 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7918 PL_hints |= HINT_STRICT_SUBS;
7919 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7920 PL_hints |= HINT_STRICT_VARS;
7922 /* otherwise they are off */
7924 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7925 PL_hints &= ~HINT_STRICT_REFS;
7926 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7927 PL_hints &= ~HINT_STRICT_SUBS;
7928 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7929 PL_hints &= ~HINT_STRICT_VARS;
7933 /* The "did you use incorrect case?" warning used to be here.
7934 * The problem is that on case-insensitive filesystems one
7935 * might get false positives for "use" (and "require"):
7936 * "use Strict" or "require CARP" will work. This causes
7937 * portability problems for the script: in case-strict
7938 * filesystems the script will stop working.
7940 * The "incorrect case" warning checked whether "use Foo"
7941 * imported "Foo" to your namespace, but that is wrong, too:
7942 * there is no requirement nor promise in the language that
7943 * a Foo.pm should or would contain anything in package "Foo".
7945 * There is very little Configure-wise that can be done, either:
7946 * the case-sensitivity of the build filesystem of Perl does not
7947 * help in guessing the case-sensitivity of the runtime environment.
7950 PL_hints |= HINT_BLOCK_SCOPE;
7951 PL_parser->copline = NOLINE;
7952 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7956 =head1 Embedding Functions
7958 =for apidoc load_module
7960 Loads the module whose name is pointed to by the string part of C<name>.
7961 Note that the actual module name, not its filename, should be given.
7962 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7963 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7964 trailing arguments can be used to specify arguments to the module's C<import()>
7965 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7966 on the flags. The flags argument is a bitwise-ORed collection of any of
7967 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7968 (or 0 for no flags).
7970 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7971 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7972 the trailing optional arguments may be omitted entirely. Otherwise, if
7973 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7974 exactly one C<OP*>, containing the op tree that produces the relevant import
7975 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7976 will be used as import arguments; and the list must be terminated with C<(SV*)
7977 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7978 set, the trailing C<NULL> pointer is needed even if no import arguments are
7979 desired. The reference count for each specified C<SV*> argument is
7980 decremented. In addition, the C<name> argument is modified.
7982 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7988 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7992 PERL_ARGS_ASSERT_LOAD_MODULE;
7994 va_start(args, ver);
7995 vload_module(flags, name, ver, &args);
7999 #ifdef PERL_IMPLICIT_CONTEXT
8001 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8005 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8006 va_start(args, ver);
8007 vload_module(flags, name, ver, &args);
8013 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8019 PERL_ARGS_ASSERT_VLOAD_MODULE;
8021 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8022 * that it has a PL_parser to play with while doing that, and also
8023 * that it doesn't mess with any existing parser, by creating a tmp
8024 * new parser with lex_start(). This won't actually be used for much,
8025 * since pp_require() will create another parser for the real work.
8026 * The ENTER/LEAVE pair protect callers from any side effects of use.
8028 * start_subparse() creates a new PL_compcv. This means that any ops
8029 * allocated below will be allocated from that CV's op slab, and so
8030 * will be automatically freed if the utilise() fails
8034 SAVEVPTR(PL_curcop);
8035 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8036 floor = start_subparse(FALSE, 0);
8038 modname = newSVOP(OP_CONST, 0, name);
8039 modname->op_private |= OPpCONST_BARE;
8041 veop = newSVOP(OP_CONST, 0, ver);
8045 if (flags & PERL_LOADMOD_NOIMPORT) {
8046 imop = sawparens(newNULLLIST());
8048 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8049 imop = va_arg(*args, OP*);
8054 sv = va_arg(*args, SV*);
8056 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8057 sv = va_arg(*args, SV*);
8061 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
8065 PERL_STATIC_INLINE OP *
8066 S_new_entersubop(pTHX_ GV *gv, OP *arg)
8068 return newUNOP(OP_ENTERSUB, OPf_STACKED,
8069 newLISTOP(OP_LIST, 0, arg,
8070 newUNOP(OP_RV2CV, 0,
8071 newGVOP(OP_GV, 0, gv))));
8075 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
8080 PERL_ARGS_ASSERT_DOFILE;
8082 if (!force_builtin && (gv = gv_override("do", 2))) {
8083 doop = S_new_entersubop(aTHX_ gv, term);
8086 doop = newUNOP(OP_DOFILE, 0, scalar(term));
8092 =head1 Optree construction
8094 =for apidoc newSLICEOP
8096 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
8097 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
8098 be set automatically, and, shifted up eight bits, the eight bits of
8099 C<op_private>, except that the bit with value 1 or 2 is automatically
8100 set as required. C<listval> and C<subscript> supply the parameters of
8101 the slice; they are consumed by this function and become part of the
8102 constructed op tree.
8108 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
8110 return newBINOP(OP_LSLICE, flags,
8111 list(force_list(subscript, 1)),
8112 list(force_list(listval, 1)) );
8115 #define ASSIGN_SCALAR 0
8116 #define ASSIGN_LIST 1
8117 #define ASSIGN_REF 2
8119 /* given the optree o on the LHS of an assignment, determine whether its:
8120 * ASSIGN_SCALAR $x = ...
8121 * ASSIGN_LIST ($x) = ...
8122 * ASSIGN_REF \$x = ...
8126 S_assignment_type(pTHX_ const OP *o)
8135 if (o->op_type == OP_SREFGEN)
8137 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
8138 type = kid->op_type;
8139 flags = o->op_flags | kid->op_flags;
8140 if (!(flags & OPf_PARENS)
8141 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
8142 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
8146 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
8147 o = cUNOPo->op_first;
8148 flags = o->op_flags;
8150 ret = ASSIGN_SCALAR;
8153 if (type == OP_COND_EXPR) {
8154 OP * const sib = OpSIBLING(cLOGOPo->op_first);
8155 const I32 t = assignment_type(sib);
8156 const I32 f = assignment_type(OpSIBLING(sib));
8158 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
8160 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
8161 yyerror("Assignment to both a list and a scalar");
8162 return ASSIGN_SCALAR;
8165 if (type == OP_LIST &&
8166 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
8167 o->op_private & OPpLVAL_INTRO)
8170 if (type == OP_LIST || flags & OPf_PARENS ||
8171 type == OP_RV2AV || type == OP_RV2HV ||
8172 type == OP_ASLICE || type == OP_HSLICE ||
8173 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
8176 if (type == OP_PADAV || type == OP_PADHV)
8179 if (type == OP_RV2SV)
8186 S_newONCEOP(pTHX_ OP *initop, OP *padop)
8189 const PADOFFSET target = padop->op_targ;
8190 OP *const other = newOP(OP_PADSV,
8192 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
8193 OP *const first = newOP(OP_NULL, 0);
8194 OP *const nullop = newCONDOP(0, first, initop, other);
8195 /* XXX targlex disabled for now; see ticket #124160
8196 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
8198 OP *const condop = first->op_next;
8200 OpTYPE_set(condop, OP_ONCE);
8201 other->op_targ = target;
8202 nullop->op_flags |= OPf_WANT_SCALAR;
8204 /* Store the initializedness of state vars in a separate
8207 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
8208 /* hijacking PADSTALE for uninitialized state variables */
8209 SvPADSTALE_on(PAD_SVl(condop->op_targ));
8215 =for apidoc newASSIGNOP
8217 Constructs, checks, and returns an assignment op. C<left> and C<right>
8218 supply the parameters of the assignment; they are consumed by this
8219 function and become part of the constructed op tree.
8221 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
8222 a suitable conditional optree is constructed. If C<optype> is the opcode
8223 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
8224 performs the binary operation and assigns the result to the left argument.
8225 Either way, if C<optype> is non-zero then C<flags> has no effect.
8227 If C<optype> is zero, then a plain scalar or list assignment is
8228 constructed. Which type of assignment it is is automatically determined.
8229 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8230 will be set automatically, and, shifted up eight bits, the eight bits
8231 of C<op_private>, except that the bit with value 1 or 2 is automatically
8238 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
8244 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
8245 right = scalar(right);
8246 return newLOGOP(optype, 0,
8247 op_lvalue(scalar(left), optype),
8248 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
8251 return newBINOP(optype, OPf_STACKED,
8252 op_lvalue(scalar(left), optype), scalar(right));
8256 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
8257 OP *state_var_op = NULL;
8258 static const char no_list_state[] = "Initialization of state variables"
8259 " in list currently forbidden";
8262 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
8263 left->op_private &= ~ OPpSLICEWARNING;
8266 left = op_lvalue(left, OP_AASSIGN);
8267 curop = list(force_list(left, 1));
8268 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
8269 o->op_private = (U8)(0 | (flags >> 8));
8271 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
8273 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
8274 if (!(left->op_flags & OPf_PARENS) &&
8275 lop->op_type == OP_PUSHMARK &&
8276 (vop = OpSIBLING(lop)) &&
8277 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
8278 !(vop->op_flags & OPf_PARENS) &&
8279 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
8280 (OPpLVAL_INTRO|OPpPAD_STATE) &&
8281 (eop = OpSIBLING(vop)) &&
8282 eop->op_type == OP_ENTERSUB &&
8283 !OpHAS_SIBLING(eop)) {
8287 if ((lop->op_type == OP_PADSV ||
8288 lop->op_type == OP_PADAV ||
8289 lop->op_type == OP_PADHV ||
8290 lop->op_type == OP_PADANY)
8291 && (lop->op_private & OPpPAD_STATE)
8293 yyerror(no_list_state);
8294 lop = OpSIBLING(lop);
8298 else if ( (left->op_private & OPpLVAL_INTRO)
8299 && (left->op_private & OPpPAD_STATE)
8300 && ( left->op_type == OP_PADSV
8301 || left->op_type == OP_PADAV
8302 || left->op_type == OP_PADHV
8303 || left->op_type == OP_PADANY)
8305 /* All single variable list context state assignments, hence
8315 if (left->op_flags & OPf_PARENS)
8316 yyerror(no_list_state);
8318 state_var_op = left;
8321 /* optimise @a = split(...) into:
8322 * @{expr}: split(..., @{expr}) (where @a is not flattened)
8323 * @a, my @a, local @a: split(...) (where @a is attached to
8324 * the split op itself)
8328 && right->op_type == OP_SPLIT
8329 /* don't do twice, e.g. @b = (@a = split) */
8330 && !(right->op_private & OPpSPLIT_ASSIGN))
8334 if ( ( left->op_type == OP_RV2AV
8335 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
8336 || left->op_type == OP_PADAV)
8338 /* @pkg or @lex or local @pkg' or 'my @lex' */
8342 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
8343 = cPADOPx(gvop)->op_padix;
8344 cPADOPx(gvop)->op_padix = 0; /* steal it */
8346 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
8347 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8348 cSVOPx(gvop)->op_sv = NULL; /* steal it */
8350 right->op_private |=
8351 left->op_private & OPpOUR_INTRO;
8354 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8355 left->op_targ = 0; /* steal it */
8356 right->op_private |= OPpSPLIT_LEX;
8358 right->op_private |= left->op_private & OPpLVAL_INTRO;
8361 tmpop = cUNOPo->op_first; /* to list (nulled) */
8362 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
8363 assert(OpSIBLING(tmpop) == right);
8364 assert(!OpHAS_SIBLING(right));
8365 /* detach the split subtreee from the o tree,
8366 * then free the residual o tree */
8367 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8368 op_free(o); /* blow off assign */
8369 right->op_private |= OPpSPLIT_ASSIGN;
8370 right->op_flags &= ~OPf_WANT;
8371 /* "I don't know and I don't care." */
8374 else if (left->op_type == OP_RV2AV) {
8377 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8378 assert(OpSIBLING(pushop) == left);
8379 /* Detach the array ... */
8380 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8381 /* ... and attach it to the split. */
8382 op_sibling_splice(right, cLISTOPx(right)->op_last,
8384 right->op_flags |= OPf_STACKED;
8385 /* Detach split and expunge aassign as above. */
8388 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8389 ((LISTOP*)right)->op_last->op_type == OP_CONST)
8391 /* convert split(...,0) to split(..., PL_modcount+1) */
8393 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8394 SV * const sv = *svp;
8395 if (SvIOK(sv) && SvIVX(sv) == 0)
8397 if (right->op_private & OPpSPLIT_IMPLIM) {
8398 /* our own SV, created in ck_split */
8400 sv_setiv(sv, PL_modcount+1);
8403 /* SV may belong to someone else */
8405 *svp = newSViv(PL_modcount+1);
8412 o = S_newONCEOP(aTHX_ o, state_var_op);
8415 if (assign_type == ASSIGN_REF)
8416 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8418 right = newOP(OP_UNDEF, 0);
8419 if (right->op_type == OP_READLINE) {
8420 right->op_flags |= OPf_STACKED;
8421 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8425 o = newBINOP(OP_SASSIGN, flags,
8426 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8432 =for apidoc newSTATEOP
8434 Constructs a state op (COP). The state op is normally a C<nextstate> op,
8435 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8436 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8437 If C<label> is non-null, it supplies the name of a label to attach to
8438 the state op; this function takes ownership of the memory pointed at by
8439 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
8442 If C<o> is null, the state op is returned. Otherwise the state op is
8443 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
8444 is consumed by this function and becomes part of the returned op tree.
8450 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8453 const U32 seq = intro_my();
8454 const U32 utf8 = flags & SVf_UTF8;
8457 PL_parser->parsed_sub = 0;
8461 NewOp(1101, cop, 1, COP);
8462 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8463 OpTYPE_set(cop, OP_DBSTATE);
8466 OpTYPE_set(cop, OP_NEXTSTATE);
8468 cop->op_flags = (U8)flags;
8469 CopHINTS_set(cop, PL_hints);
8471 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8473 cop->op_next = (OP*)cop;
8476 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8477 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8479 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8481 PL_hints |= HINT_BLOCK_SCOPE;
8482 /* It seems that we need to defer freeing this pointer, as other parts
8483 of the grammar end up wanting to copy it after this op has been
8488 if (PL_parser->preambling != NOLINE) {
8489 CopLINE_set(cop, PL_parser->preambling);
8490 PL_parser->copline = NOLINE;
8492 else if (PL_parser->copline == NOLINE)
8493 CopLINE_set(cop, CopLINE(PL_curcop));
8495 CopLINE_set(cop, PL_parser->copline);
8496 PL_parser->copline = NOLINE;
8499 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
8501 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8503 CopSTASH_set(cop, PL_curstash);
8505 if (cop->op_type == OP_DBSTATE) {
8506 /* this line can have a breakpoint - store the cop in IV */
8507 AV *av = CopFILEAVx(PL_curcop);
8509 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8510 if (svp && *svp != &PL_sv_undef ) {
8511 (void)SvIOK_on(*svp);
8512 SvIV_set(*svp, PTR2IV(cop));
8517 if (flags & OPf_SPECIAL)
8519 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8523 =for apidoc newLOGOP
8525 Constructs, checks, and returns a logical (flow control) op. C<type>
8526 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
8527 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8528 the eight bits of C<op_private>, except that the bit with value 1 is
8529 automatically set. C<first> supplies the expression controlling the
8530 flow, and C<other> supplies the side (alternate) chain of ops; they are
8531 consumed by this function and become part of the constructed op tree.
8537 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8539 PERL_ARGS_ASSERT_NEWLOGOP;
8541 return new_logop(type, flags, &first, &other);
8545 /* See if the optree o contains a single OP_CONST (plus possibly
8546 * surrounding enter/nextstate/null etc). If so, return it, else return
8551 S_search_const(pTHX_ OP *o)
8553 PERL_ARGS_ASSERT_SEARCH_CONST;
8556 switch (o->op_type) {
8560 if (o->op_flags & OPf_KIDS) {
8561 o = cUNOPo->op_first;
8570 if (!(o->op_flags & OPf_KIDS))
8572 kid = cLISTOPo->op_first;
8575 switch (kid->op_type) {
8579 kid = OpSIBLING(kid);
8582 if (kid != cLISTOPo->op_last)
8589 kid = cLISTOPo->op_last;
8601 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8609 int prepend_not = 0;
8611 PERL_ARGS_ASSERT_NEW_LOGOP;
8616 /* [perl #59802]: Warn about things like "return $a or $b", which
8617 is parsed as "(return $a) or $b" rather than "return ($a or
8618 $b)". NB: This also applies to xor, which is why we do it
8621 switch (first->op_type) {
8625 /* XXX: Perhaps we should emit a stronger warning for these.
8626 Even with the high-precedence operator they don't seem to do
8629 But until we do, fall through here.
8635 /* XXX: Currently we allow people to "shoot themselves in the
8636 foot" by explicitly writing "(return $a) or $b".
8638 Warn unless we are looking at the result from folding or if
8639 the programmer explicitly grouped the operators like this.
8640 The former can occur with e.g.
8642 use constant FEATURE => ( $] >= ... );
8643 sub { not FEATURE and return or do_stuff(); }
8645 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8646 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8647 "Possible precedence issue with control flow operator");
8648 /* XXX: Should we optimze this to "return $a;" (i.e. remove
8654 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8655 return newBINOP(type, flags, scalar(first), scalar(other));
8657 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8658 || type == OP_CUSTOM);
8660 scalarboolean(first);
8662 /* search for a constant op that could let us fold the test */
8663 if ((cstop = search_const(first))) {
8664 if (cstop->op_private & OPpCONST_STRICT)
8665 no_bareword_allowed(cstop);
8666 else if ((cstop->op_private & OPpCONST_BARE))
8667 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8668 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
8669 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8670 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8671 /* Elide the (constant) lhs, since it can't affect the outcome */
8673 if (other->op_type == OP_CONST)
8674 other->op_private |= OPpCONST_SHORTCIRCUIT;
8676 if (other->op_type == OP_LEAVE)
8677 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8678 else if (other->op_type == OP_MATCH
8679 || other->op_type == OP_SUBST
8680 || other->op_type == OP_TRANSR
8681 || other->op_type == OP_TRANS)
8682 /* Mark the op as being unbindable with =~ */
8683 other->op_flags |= OPf_SPECIAL;
8685 other->op_folded = 1;
8689 /* Elide the rhs, since the outcome is entirely determined by
8690 * the (constant) lhs */
8692 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8693 const OP *o2 = other;
8694 if ( ! (o2->op_type == OP_LIST
8695 && (( o2 = cUNOPx(o2)->op_first))
8696 && o2->op_type == OP_PUSHMARK
8697 && (( o2 = OpSIBLING(o2))) )
8700 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8701 || o2->op_type == OP_PADHV)
8702 && o2->op_private & OPpLVAL_INTRO
8703 && !(o2->op_private & OPpPAD_STATE))
8705 Perl_croak(aTHX_ "This use of my() in false conditional is "
8706 "no longer allowed");
8710 if (cstop->op_type == OP_CONST)
8711 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8716 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8717 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8719 const OP * const k1 = ((UNOP*)first)->op_first;
8720 const OP * const k2 = OpSIBLING(k1);
8722 switch (first->op_type)
8725 if (k2 && k2->op_type == OP_READLINE
8726 && (k2->op_flags & OPf_STACKED)
8727 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8729 warnop = k2->op_type;
8734 if (k1->op_type == OP_READDIR
8735 || k1->op_type == OP_GLOB
8736 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8737 || k1->op_type == OP_EACH
8738 || k1->op_type == OP_AEACH)
8740 warnop = ((k1->op_type == OP_NULL)
8741 ? (OPCODE)k1->op_targ : k1->op_type);
8746 const line_t oldline = CopLINE(PL_curcop);
8747 /* This ensures that warnings are reported at the first line
8748 of the construction, not the last. */
8749 CopLINE_set(PL_curcop, PL_parser->copline);
8750 Perl_warner(aTHX_ packWARN(WARN_MISC),
8751 "Value of %s%s can be \"0\"; test with defined()",
8753 ((warnop == OP_READLINE || warnop == OP_GLOB)
8754 ? " construct" : "() operator"));
8755 CopLINE_set(PL_curcop, oldline);
8759 /* optimize AND and OR ops that have NOTs as children */
8760 if (first->op_type == OP_NOT
8761 && (first->op_flags & OPf_KIDS)
8762 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8763 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8765 if (type == OP_AND || type == OP_OR) {
8771 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8773 prepend_not = 1; /* prepend a NOT op later */
8778 logop = alloc_LOGOP(type, first, LINKLIST(other));
8779 logop->op_flags |= (U8)flags;
8780 logop->op_private = (U8)(1 | (flags >> 8));
8782 /* establish postfix order */
8783 logop->op_next = LINKLIST(first);
8784 first->op_next = (OP*)logop;
8785 assert(!OpHAS_SIBLING(first));
8786 op_sibling_splice((OP*)logop, first, 0, other);
8788 CHECKOP(type,logop);
8790 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8791 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8799 =for apidoc newCONDOP
8801 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8802 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8803 will be set automatically, and, shifted up eight bits, the eight bits of
8804 C<op_private>, except that the bit with value 1 is automatically set.
8805 C<first> supplies the expression selecting between the two branches,
8806 and C<trueop> and C<falseop> supply the branches; they are consumed by
8807 this function and become part of the constructed op tree.
8813 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8821 PERL_ARGS_ASSERT_NEWCONDOP;
8824 return newLOGOP(OP_AND, 0, first, trueop);
8826 return newLOGOP(OP_OR, 0, first, falseop);
8828 scalarboolean(first);
8829 if ((cstop = search_const(first))) {
8830 /* Left or right arm of the conditional? */
8831 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8832 OP *live = left ? trueop : falseop;
8833 OP *const dead = left ? falseop : trueop;
8834 if (cstop->op_private & OPpCONST_BARE &&
8835 cstop->op_private & OPpCONST_STRICT) {
8836 no_bareword_allowed(cstop);
8840 if (live->op_type == OP_LEAVE)
8841 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8842 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8843 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8844 /* Mark the op as being unbindable with =~ */
8845 live->op_flags |= OPf_SPECIAL;
8846 live->op_folded = 1;
8849 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8850 logop->op_flags |= (U8)flags;
8851 logop->op_private = (U8)(1 | (flags >> 8));
8852 logop->op_next = LINKLIST(falseop);
8854 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8857 /* establish postfix order */
8858 start = LINKLIST(first);
8859 first->op_next = (OP*)logop;
8861 /* make first, trueop, falseop siblings */
8862 op_sibling_splice((OP*)logop, first, 0, trueop);
8863 op_sibling_splice((OP*)logop, trueop, 0, falseop);
8865 o = newUNOP(OP_NULL, 0, (OP*)logop);
8867 trueop->op_next = falseop->op_next = o;
8874 =for apidoc newRANGE
8876 Constructs and returns a C<range> op, with subordinate C<flip> and
8877 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
8878 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8879 for both the C<flip> and C<range> ops, except that the bit with value
8880 1 is automatically set. C<left> and C<right> supply the expressions
8881 controlling the endpoints of the range; they are consumed by this function
8882 and become part of the constructed op tree.
8888 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8896 PERL_ARGS_ASSERT_NEWRANGE;
8898 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8899 range->op_flags = OPf_KIDS;
8900 leftstart = LINKLIST(left);
8901 range->op_private = (U8)(1 | (flags >> 8));
8903 /* make left and right siblings */
8904 op_sibling_splice((OP*)range, left, 0, right);
8906 range->op_next = (OP*)range;
8907 flip = newUNOP(OP_FLIP, flags, (OP*)range);
8908 flop = newUNOP(OP_FLOP, 0, flip);
8909 o = newUNOP(OP_NULL, 0, flop);
8911 range->op_next = leftstart;
8913 left->op_next = flip;
8914 right->op_next = flop;
8917 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8918 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8920 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8921 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8922 SvPADTMP_on(PAD_SV(flip->op_targ));
8924 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8925 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8927 /* check barewords before they might be optimized aways */
8928 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8929 no_bareword_allowed(left);
8930 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8931 no_bareword_allowed(right);
8934 if (!flip->op_private || !flop->op_private)
8935 LINKLIST(o); /* blow off optimizer unless constant */
8941 =for apidoc newLOOPOP
8943 Constructs, checks, and returns an op tree expressing a loop. This is
8944 only a loop in the control flow through the op tree; it does not have
8945 the heavyweight loop structure that allows exiting the loop by C<last>
8946 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
8947 top-level op, except that some bits will be set automatically as required.
8948 C<expr> supplies the expression controlling loop iteration, and C<block>
8949 supplies the body of the loop; they are consumed by this function and
8950 become part of the constructed op tree. C<debuggable> is currently
8951 unused and should always be 1.
8957 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8961 const bool once = block && block->op_flags & OPf_SPECIAL &&
8962 block->op_type == OP_NULL;
8964 PERL_UNUSED_ARG(debuggable);
8968 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8969 || ( expr->op_type == OP_NOT
8970 && cUNOPx(expr)->op_first->op_type == OP_CONST
8971 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8974 /* Return the block now, so that S_new_logop does not try to
8978 return block; /* do {} while 0 does once */
8981 if (expr->op_type == OP_READLINE
8982 || expr->op_type == OP_READDIR
8983 || expr->op_type == OP_GLOB
8984 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8985 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8986 expr = newUNOP(OP_DEFINED, 0,
8987 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8988 } else if (expr->op_flags & OPf_KIDS) {
8989 const OP * const k1 = ((UNOP*)expr)->op_first;
8990 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8991 switch (expr->op_type) {
8993 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8994 && (k2->op_flags & OPf_STACKED)
8995 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8996 expr = newUNOP(OP_DEFINED, 0, expr);
9000 if (k1 && (k1->op_type == OP_READDIR
9001 || k1->op_type == OP_GLOB
9002 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9003 || k1->op_type == OP_EACH
9004 || k1->op_type == OP_AEACH))
9005 expr = newUNOP(OP_DEFINED, 0, expr);
9011 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9012 * op, in listop. This is wrong. [perl #27024] */
9014 block = newOP(OP_NULL, 0);
9015 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9016 o = new_logop(OP_AND, 0, &expr, &listop);
9023 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
9025 if (once && o != listop)
9027 assert(cUNOPo->op_first->op_type == OP_AND
9028 || cUNOPo->op_first->op_type == OP_OR);
9029 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
9033 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
9035 o->op_flags |= flags;
9037 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9042 =for apidoc newWHILEOP
9044 Constructs, checks, and returns an op tree expressing a C<while> loop.
9045 This is a heavyweight loop, with structure that allows exiting the loop
9046 by C<last> and suchlike.
9048 C<loop> is an optional preconstructed C<enterloop> op to use in the
9049 loop; if it is null then a suitable op will be constructed automatically.
9050 C<expr> supplies the loop's controlling expression. C<block> supplies the
9051 main body of the loop, and C<cont> optionally supplies a C<continue> block
9052 that operates as a second half of the body. All of these optree inputs
9053 are consumed by this function and become part of the constructed op tree.
9055 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9056 op and, shifted up eight bits, the eight bits of C<op_private> for
9057 the C<leaveloop> op, except that (in both cases) some bits will be set
9058 automatically. C<debuggable> is currently unused and should always be 1.
9059 C<has_my> can be supplied as true to force the
9060 loop body to be enclosed in its own scope.
9066 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9067 OP *expr, OP *block, OP *cont, I32 has_my)
9076 PERL_UNUSED_ARG(debuggable);
9079 if (expr->op_type == OP_READLINE
9080 || expr->op_type == OP_READDIR
9081 || expr->op_type == OP_GLOB
9082 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9083 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9084 expr = newUNOP(OP_DEFINED, 0,
9085 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9086 } else if (expr->op_flags & OPf_KIDS) {
9087 const OP * const k1 = ((UNOP*)expr)->op_first;
9088 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
9089 switch (expr->op_type) {
9091 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9092 && (k2->op_flags & OPf_STACKED)
9093 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9094 expr = newUNOP(OP_DEFINED, 0, expr);
9098 if (k1 && (k1->op_type == OP_READDIR
9099 || k1->op_type == OP_GLOB
9100 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9101 || k1->op_type == OP_EACH
9102 || k1->op_type == OP_AEACH))
9103 expr = newUNOP(OP_DEFINED, 0, expr);
9110 block = newOP(OP_NULL, 0);
9111 else if (cont || has_my) {
9112 block = op_scope(block);
9116 next = LINKLIST(cont);
9119 OP * const unstack = newOP(OP_UNSTACK, 0);
9122 cont = op_append_elem(OP_LINESEQ, cont, unstack);
9126 listop = op_append_list(OP_LINESEQ, block, cont);
9128 redo = LINKLIST(listop);
9132 o = new_logop(OP_AND, 0, &expr, &listop);
9133 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
9135 return expr; /* listop already freed by new_logop */
9138 ((LISTOP*)listop)->op_last->op_next =
9139 (o == listop ? redo : LINKLIST(o));
9145 NewOp(1101,loop,1,LOOP);
9146 OpTYPE_set(loop, OP_ENTERLOOP);
9147 loop->op_private = 0;
9148 loop->op_next = (OP*)loop;
9151 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
9153 loop->op_redoop = redo;
9154 loop->op_lastop = o;
9155 o->op_private |= loopflags;
9158 loop->op_nextop = next;
9160 loop->op_nextop = o;
9162 o->op_flags |= flags;
9163 o->op_private |= (flags >> 8);
9168 =for apidoc newFOROP
9170 Constructs, checks, and returns an op tree expressing a C<foreach>
9171 loop (iteration through a list of values). This is a heavyweight loop,
9172 with structure that allows exiting the loop by C<last> and suchlike.
9174 C<sv> optionally supplies the variable that will be aliased to each
9175 item in turn; if null, it defaults to C<$_>.
9176 C<expr> supplies the list of values to iterate over. C<block> supplies
9177 the main body of the loop, and C<cont> optionally supplies a C<continue>
9178 block that operates as a second half of the body. All of these optree
9179 inputs are consumed by this function and become part of the constructed
9182 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9183 op and, shifted up eight bits, the eight bits of C<op_private> for
9184 the C<leaveloop> op, except that (in both cases) some bits will be set
9191 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
9196 PADOFFSET padoff = 0;
9200 PERL_ARGS_ASSERT_NEWFOROP;
9203 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
9204 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
9205 OpTYPE_set(sv, OP_RV2GV);
9207 /* The op_type check is needed to prevent a possible segfault
9208 * if the loop variable is undeclared and 'strict vars' is in
9209 * effect. This is illegal but is nonetheless parsed, so we
9210 * may reach this point with an OP_CONST where we're expecting
9213 if (cUNOPx(sv)->op_first->op_type == OP_GV
9214 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
9215 iterpflags |= OPpITER_DEF;
9217 else if (sv->op_type == OP_PADSV) { /* private variable */
9218 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
9219 padoff = sv->op_targ;
9223 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9225 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
9228 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
9230 PADNAME * const pn = PAD_COMPNAME(padoff);
9231 const char * const name = PadnamePV(pn);
9233 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
9234 iterpflags |= OPpITER_DEF;
9238 sv = newGVOP(OP_GV, 0, PL_defgv);
9239 iterpflags |= OPpITER_DEF;
9242 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
9243 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
9244 iterflags |= OPf_STACKED;
9246 else if (expr->op_type == OP_NULL &&
9247 (expr->op_flags & OPf_KIDS) &&
9248 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
9250 /* Basically turn for($x..$y) into the same as for($x,$y), but we
9251 * set the STACKED flag to indicate that these values are to be
9252 * treated as min/max values by 'pp_enteriter'.
9254 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
9255 LOGOP* const range = (LOGOP*) flip->op_first;
9256 OP* const left = range->op_first;
9257 OP* const right = OpSIBLING(left);
9260 range->op_flags &= ~OPf_KIDS;
9261 /* detach range's children */
9262 op_sibling_splice((OP*)range, NULL, -1, NULL);
9264 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
9265 listop->op_first->op_next = range->op_next;
9266 left->op_next = range->op_other;
9267 right->op_next = (OP*)listop;
9268 listop->op_next = listop->op_first;
9271 expr = (OP*)(listop);
9273 iterflags |= OPf_STACKED;
9276 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
9279 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
9280 op_append_elem(OP_LIST, list(expr),
9282 assert(!loop->op_next);
9283 /* for my $x () sets OPpLVAL_INTRO;
9284 * for our $x () sets OPpOUR_INTRO */
9285 loop->op_private = (U8)iterpflags;
9287 /* upgrade loop from a LISTOP to a LOOPOP;
9288 * keep it in-place if there's space */
9289 if (loop->op_slabbed
9290 && OpSLOT(loop)->opslot_size
9291 < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
9293 /* no space; allocate new op */
9295 NewOp(1234,tmp,1,LOOP);
9296 Copy(loop,tmp,1,LISTOP);
9297 assert(loop->op_last->op_sibparent == (OP*)loop);
9298 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
9299 S_op_destroy(aTHX_ (OP*)loop);
9302 else if (!loop->op_slabbed)
9304 /* loop was malloc()ed */
9305 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
9306 OpLASTSIB_set(loop->op_last, (OP*)loop);
9308 loop->op_targ = padoff;
9309 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
9314 =for apidoc newLOOPEX
9316 Constructs, checks, and returns a loop-exiting op (such as C<goto>
9317 or C<last>). C<type> is the opcode. C<label> supplies the parameter
9318 determining the target of the op; it is consumed by this function and
9319 becomes part of the constructed op tree.
9325 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
9329 PERL_ARGS_ASSERT_NEWLOOPEX;
9331 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9332 || type == OP_CUSTOM);
9334 if (type != OP_GOTO) {
9335 /* "last()" means "last" */
9336 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9337 o = newOP(type, OPf_SPECIAL);
9341 /* Check whether it's going to be a goto &function */
9342 if (label->op_type == OP_ENTERSUB
9343 && !(label->op_flags & OPf_STACKED))
9344 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9347 /* Check for a constant argument */
9348 if (label->op_type == OP_CONST) {
9349 SV * const sv = ((SVOP *)label)->op_sv;
9351 const char *s = SvPV_const(sv,l);
9352 if (l == strlen(s)) {
9354 SvUTF8(((SVOP*)label)->op_sv),
9356 SvPV_nolen_const(((SVOP*)label)->op_sv)));
9360 /* If we have already created an op, we do not need the label. */
9363 else o = newUNOP(type, OPf_STACKED, label);
9365 PL_hints |= HINT_BLOCK_SCOPE;
9369 /* if the condition is a literal array or hash
9370 (or @{ ... } etc), make a reference to it.
9373 S_ref_array_or_hash(pTHX_ OP *cond)
9376 && (cond->op_type == OP_RV2AV
9377 || cond->op_type == OP_PADAV
9378 || cond->op_type == OP_RV2HV
9379 || cond->op_type == OP_PADHV))
9381 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9384 && (cond->op_type == OP_ASLICE
9385 || cond->op_type == OP_KVASLICE
9386 || cond->op_type == OP_HSLICE
9387 || cond->op_type == OP_KVHSLICE)) {
9389 /* anonlist now needs a list from this op, was previously used in
9391 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9392 cond->op_flags |= OPf_WANT_LIST;
9394 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9401 /* These construct the optree fragments representing given()
9404 entergiven and enterwhen are LOGOPs; the op_other pointer
9405 points up to the associated leave op. We need this so we
9406 can put it in the context and make break/continue work.
9407 (Also, of course, pp_enterwhen will jump straight to
9408 op_other if the match fails.)
9412 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9413 I32 enter_opcode, I32 leave_opcode,
9414 PADOFFSET entertarg)
9420 PERL_ARGS_ASSERT_NEWGIVWHENOP;
9421 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9423 enterop = alloc_LOGOP(enter_opcode, block, NULL);
9424 enterop->op_targ = 0;
9425 enterop->op_private = 0;
9427 o = newUNOP(leave_opcode, 0, (OP *) enterop);
9430 /* prepend cond if we have one */
9431 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9433 o->op_next = LINKLIST(cond);
9434 cond->op_next = (OP *) enterop;
9437 /* This is a default {} block */
9438 enterop->op_flags |= OPf_SPECIAL;
9439 o ->op_flags |= OPf_SPECIAL;
9441 o->op_next = (OP *) enterop;
9444 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9445 entergiven and enterwhen both
9448 enterop->op_next = LINKLIST(block);
9449 block->op_next = enterop->op_other = o;
9455 /* For the purposes of 'when(implied_smartmatch)'
9456 * versus 'when(boolean_expression)',
9457 * does this look like a boolean operation? For these purposes
9458 a boolean operation is:
9459 - a subroutine call [*]
9460 - a logical connective
9461 - a comparison operator
9462 - a filetest operator, with the exception of -s -M -A -C
9463 - defined(), exists() or eof()
9464 - /$re/ or $foo =~ /$re/
9466 [*] possibly surprising
9469 S_looks_like_bool(pTHX_ const OP *o)
9471 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9473 switch(o->op_type) {
9476 return looks_like_bool(cLOGOPo->op_first);
9480 OP* sibl = OpSIBLING(cLOGOPo->op_first);
9483 looks_like_bool(cLOGOPo->op_first)
9484 && looks_like_bool(sibl));
9490 o->op_flags & OPf_KIDS
9491 && looks_like_bool(cUNOPo->op_first));
9495 case OP_NOT: case OP_XOR:
9497 case OP_EQ: case OP_NE: case OP_LT:
9498 case OP_GT: case OP_LE: case OP_GE:
9500 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
9501 case OP_I_GT: case OP_I_LE: case OP_I_GE:
9503 case OP_SEQ: case OP_SNE: case OP_SLT:
9504 case OP_SGT: case OP_SLE: case OP_SGE:
9508 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
9509 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
9510 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
9511 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
9512 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
9513 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
9514 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
9515 case OP_FTTEXT: case OP_FTBINARY:
9517 case OP_DEFINED: case OP_EXISTS:
9518 case OP_MATCH: case OP_EOF:
9526 /* optimised-away (index() != -1) or similar comparison */
9527 if (o->op_private & OPpTRUEBOOL)
9532 /* Detect comparisons that have been optimized away */
9533 if (cSVOPo->op_sv == &PL_sv_yes
9534 || cSVOPo->op_sv == &PL_sv_no)
9547 =for apidoc newGIVENOP
9549 Constructs, checks, and returns an op tree expressing a C<given> block.
9550 C<cond> supplies the expression to whose value C<$_> will be locally
9551 aliased, and C<block> supplies the body of the C<given> construct; they
9552 are consumed by this function and become part of the constructed op tree.
9553 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9559 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9561 PERL_ARGS_ASSERT_NEWGIVENOP;
9562 PERL_UNUSED_ARG(defsv_off);
9565 return newGIVWHENOP(
9566 ref_array_or_hash(cond),
9568 OP_ENTERGIVEN, OP_LEAVEGIVEN,
9573 =for apidoc newWHENOP
9575 Constructs, checks, and returns an op tree expressing a C<when> block.
9576 C<cond> supplies the test expression, and C<block> supplies the block
9577 that will be executed if the test evaluates to true; they are consumed
9578 by this function and become part of the constructed op tree. C<cond>
9579 will be interpreted DWIMically, often as a comparison against C<$_>,
9580 and may be null to generate a C<default> block.
9586 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9588 const bool cond_llb = (!cond || looks_like_bool(cond));
9591 PERL_ARGS_ASSERT_NEWWHENOP;
9596 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9598 scalar(ref_array_or_hash(cond)));
9601 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9604 /* must not conflict with SVf_UTF8 */
9605 #define CV_CKPROTO_CURSTASH 0x1
9608 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9609 const STRLEN len, const U32 flags)
9611 SV *name = NULL, *msg;
9612 const char * cvp = SvROK(cv)
9613 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9614 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9617 STRLEN clen = CvPROTOLEN(cv), plen = len;
9619 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9621 if (p == NULL && cvp == NULL)
9624 if (!ckWARN_d(WARN_PROTOTYPE))
9628 p = S_strip_spaces(aTHX_ p, &plen);
9629 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9630 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9631 if (plen == clen && memEQ(cvp, p, plen))
9634 if (flags & SVf_UTF8) {
9635 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9639 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9645 msg = sv_newmortal();
9650 gv_efullname3(name = sv_newmortal(), gv, NULL);
9651 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9652 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9653 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9654 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9655 sv_catpvs(name, "::");
9657 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9658 assert (CvNAMED(SvRV_const(gv)));
9659 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9661 else sv_catsv(name, (SV *)gv);
9663 else name = (SV *)gv;
9665 sv_setpvs(msg, "Prototype mismatch:");
9667 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9669 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9670 UTF8fARG(SvUTF8(cv),clen,cvp)
9673 sv_catpvs(msg, ": none");
9674 sv_catpvs(msg, " vs ");
9676 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9678 sv_catpvs(msg, "none");
9679 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9682 static void const_sv_xsub(pTHX_ CV* cv);
9683 static void const_av_xsub(pTHX_ CV* cv);
9687 =head1 Optree Manipulation Functions
9689 =for apidoc cv_const_sv
9691 If C<cv> is a constant sub eligible for inlining, returns the constant
9692 value returned by the sub. Otherwise, returns C<NULL>.
9694 Constant subs can be created with C<newCONSTSUB> or as described in
9695 L<perlsub/"Constant Functions">.
9700 Perl_cv_const_sv(const CV *const cv)
9705 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9707 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9708 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9713 Perl_cv_const_sv_or_av(const CV * const cv)
9717 if (SvROK(cv)) return SvRV((SV *)cv);
9718 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9719 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9722 /* op_const_sv: examine an optree to determine whether it's in-lineable.
9723 * Can be called in 2 ways:
9726 * look for a single OP_CONST with attached value: return the value
9728 * allow_lex && !CvCONST(cv);
9730 * examine the clone prototype, and if contains only a single
9731 * OP_CONST, return the value; or if it contains a single PADSV ref-
9732 * erencing an outer lexical, turn on CvCONST to indicate the CV is
9733 * a candidate for "constizing" at clone time, and return NULL.
9737 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9745 for (; o; o = o->op_next) {
9746 const OPCODE type = o->op_type;
9748 if (type == OP_NEXTSTATE || type == OP_LINESEQ
9750 || type == OP_PUSHMARK)
9752 if (type == OP_DBSTATE)
9754 if (type == OP_LEAVESUB)
9758 if (type == OP_CONST && cSVOPo->op_sv)
9760 else if (type == OP_UNDEF && !o->op_private) {
9764 else if (allow_lex && type == OP_PADSV) {
9765 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9767 sv = &PL_sv_undef; /* an arbitrary non-null value */
9785 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9786 PADNAME * const name, SV ** const const_svp)
9792 if (CvFLAGS(PL_compcv)) {
9793 /* might have had built-in attrs applied */
9794 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9795 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9796 && ckWARN(WARN_MISC))
9798 /* protect against fatal warnings leaking compcv */
9799 SAVEFREESV(PL_compcv);
9800 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9801 SvREFCNT_inc_simple_void_NN(PL_compcv);
9804 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9805 & ~(CVf_LVALUE * pureperl));
9810 /* redundant check for speed: */
9811 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9812 const line_t oldline = CopLINE(PL_curcop);
9815 : sv_2mortal(newSVpvn_utf8(
9816 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9818 if (PL_parser && PL_parser->copline != NOLINE)
9819 /* This ensures that warnings are reported at the first
9820 line of a redefinition, not the last. */
9821 CopLINE_set(PL_curcop, PL_parser->copline);
9822 /* protect against fatal warnings leaking compcv */
9823 SAVEFREESV(PL_compcv);
9824 report_redefined_cv(namesv, cv, const_svp);
9825 SvREFCNT_inc_simple_void_NN(PL_compcv);
9826 CopLINE_set(PL_curcop, oldline);
9833 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9838 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9841 CV *compcv = PL_compcv;
9844 PADOFFSET pax = o->op_targ;
9845 CV *outcv = CvOUTSIDE(PL_compcv);
9848 bool reusable = FALSE;
9850 #ifdef PERL_DEBUG_READONLY_OPS
9851 OPSLAB *slab = NULL;
9854 PERL_ARGS_ASSERT_NEWMYSUB;
9856 PL_hints |= HINT_BLOCK_SCOPE;
9858 /* Find the pad slot for storing the new sub.
9859 We cannot use PL_comppad, as it is the pad owned by the new sub. We
9860 need to look in CvOUTSIDE and find the pad belonging to the enclos-
9861 ing sub. And then we need to dig deeper if this is a lexical from
9863 my sub foo; sub { sub foo { } }
9866 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9867 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9868 pax = PARENT_PAD_INDEX(name);
9869 outcv = CvOUTSIDE(outcv);
9874 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9875 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9876 spot = (CV **)svspot;
9878 if (!(PL_parser && PL_parser->error_count))
9879 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9882 assert(proto->op_type == OP_CONST);
9883 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9884 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9894 if (PL_parser && PL_parser->error_count) {
9896 SvREFCNT_dec(PL_compcv);
9901 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9903 svspot = (SV **)(spot = &clonee);
9905 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9908 assert (SvTYPE(*spot) == SVt_PVCV);
9910 hek = CvNAME_HEK(*spot);
9914 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9915 CvNAME_HEK_set(*spot, hek =
9918 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9922 CvLEXICAL_on(*spot);
9924 cv = PadnamePROTOCV(name);
9925 svspot = (SV **)(spot = &PadnamePROTOCV(name));
9929 /* This makes sub {}; work as expected. */
9930 if (block->op_type == OP_STUB) {
9931 const line_t l = PL_parser->copline;
9933 block = newSTATEOP(0, NULL, 0);
9934 PL_parser->copline = l;
9936 block = CvLVALUE(compcv)
9937 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9938 ? newUNOP(OP_LEAVESUBLV, 0,
9939 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9940 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9941 start = LINKLIST(block);
9943 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9944 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9952 const bool exists = CvROOT(cv) || CvXSUB(cv);
9954 /* if the subroutine doesn't exist and wasn't pre-declared
9955 * with a prototype, assume it will be AUTOLOADed,
9956 * skipping the prototype check
9958 if (exists || SvPOK(cv))
9959 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9961 /* already defined? */
9963 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9969 /* just a "sub foo;" when &foo is already defined */
9974 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9981 SvREFCNT_inc_simple_void_NN(const_sv);
9982 SvFLAGS(const_sv) |= SVs_PADTMP;
9984 assert(!CvROOT(cv) && !CvCONST(cv));
9988 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9989 CvFILE_set_from_cop(cv, PL_curcop);
9990 CvSTASH_set(cv, PL_curstash);
9993 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
9994 CvXSUBANY(cv).any_ptr = const_sv;
9995 CvXSUB(cv) = const_sv_xsub;
9999 CvFLAGS(cv) |= CvMETHOD(compcv);
10001 SvREFCNT_dec(compcv);
10006 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10007 determine whether this sub definition is in the same scope as its
10008 declaration. If this sub definition is inside an inner named pack-
10009 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10010 the package sub. So check PadnameOUTER(name) too.
10012 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10013 assert(!CvWEAKOUTSIDE(compcv));
10014 SvREFCNT_dec(CvOUTSIDE(compcv));
10015 CvWEAKOUTSIDE_on(compcv);
10017 /* XXX else do we have a circular reference? */
10019 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
10020 /* transfer PL_compcv to cv */
10022 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10023 cv_flags_t preserved_flags =
10024 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10025 PADLIST *const temp_padl = CvPADLIST(cv);
10026 CV *const temp_cv = CvOUTSIDE(cv);
10027 const cv_flags_t other_flags =
10028 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10029 OP * const cvstart = CvSTART(cv);
10033 CvFLAGS(compcv) | preserved_flags;
10034 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10035 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10036 CvPADLIST_set(cv, CvPADLIST(compcv));
10037 CvOUTSIDE(compcv) = temp_cv;
10038 CvPADLIST_set(compcv, temp_padl);
10039 CvSTART(cv) = CvSTART(compcv);
10040 CvSTART(compcv) = cvstart;
10041 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10042 CvFLAGS(compcv) |= other_flags;
10045 Safefree(CvFILE(cv));
10049 /* inner references to compcv must be fixed up ... */
10050 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10051 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10052 ++PL_sub_generation;
10055 /* Might have had built-in attributes applied -- propagate them. */
10056 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10058 /* ... before we throw it away */
10059 SvREFCNT_dec(compcv);
10060 PL_compcv = compcv = cv;
10069 if (!CvNAME_HEK(cv)) {
10070 if (hek) (void)share_hek_hek(hek);
10074 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10075 hek = share_hek(PadnamePV(name)+1,
10076 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10079 CvNAME_HEK_set(cv, hek);
10085 if (CvFILE(cv) && CvDYNFILE(cv))
10086 Safefree(CvFILE(cv));
10087 CvFILE_set_from_cop(cv, PL_curcop);
10088 CvSTASH_set(cv, PL_curstash);
10091 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10093 SvUTF8_on(MUTABLE_SV(cv));
10097 /* If we assign an optree to a PVCV, then we've defined a
10098 * subroutine that the debugger could be able to set a breakpoint
10099 * in, so signal to pp_entereval that it should not throw away any
10100 * saved lines at scope exit. */
10102 PL_breakable_sub_gen++;
10103 CvROOT(cv) = block;
10104 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10105 itself has a refcount. */
10107 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10108 #ifdef PERL_DEBUG_READONLY_OPS
10109 slab = (OPSLAB *)CvSTART(cv);
10111 S_process_optree(aTHX_ cv, block, start);
10116 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10117 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
10121 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10122 SV * const tmpstr = sv_newmortal();
10123 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10124 GV_ADDMULTI, SVt_PVHV);
10126 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10127 CopFILE(PL_curcop),
10129 (long)CopLINE(PL_curcop));
10130 if (HvNAME_HEK(PL_curstash)) {
10131 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
10132 sv_catpvs(tmpstr, "::");
10135 sv_setpvs(tmpstr, "__ANON__::");
10137 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
10138 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
10139 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10140 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10141 hv = GvHVn(db_postponed);
10142 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10143 CV * const pcv = GvCV(db_postponed);
10149 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10157 assert(CvDEPTH(outcv));
10159 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
10161 cv_clone_into(clonee, *spot);
10162 else *spot = cv_clone(clonee);
10163 SvREFCNT_dec_NN(clonee);
10167 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
10168 PADOFFSET depth = CvDEPTH(outcv);
10171 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
10173 *svspot = SvREFCNT_inc_simple_NN(cv);
10174 SvREFCNT_dec(oldcv);
10180 PL_parser->copline = NOLINE;
10181 LEAVE_SCOPE(floor);
10182 #ifdef PERL_DEBUG_READONLY_OPS
10191 =for apidoc newATTRSUB_x
10193 Construct a Perl subroutine, also performing some surrounding jobs.
10195 This function is expected to be called in a Perl compilation context,
10196 and some aspects of the subroutine are taken from global variables
10197 associated with compilation. In particular, C<PL_compcv> represents
10198 the subroutine that is currently being compiled. It must be non-null
10199 when this function is called, and some aspects of the subroutine being
10200 constructed are taken from it. The constructed subroutine may actually
10201 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
10203 If C<block> is null then the subroutine will have no body, and for the
10204 time being it will be an error to call it. This represents a forward
10205 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
10206 non-null then it provides the Perl code of the subroutine body, which
10207 will be executed when the subroutine is called. This body includes
10208 any argument unwrapping code resulting from a subroutine signature or
10209 similar. The pad use of the code must correspond to the pad attached
10210 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
10211 C<leavesublv> op; this function will add such an op. C<block> is consumed
10212 by this function and will become part of the constructed subroutine.
10214 C<proto> specifies the subroutine's prototype, unless one is supplied
10215 as an attribute (see below). If C<proto> is null, then the subroutine
10216 will not have a prototype. If C<proto> is non-null, it must point to a
10217 C<const> op whose value is a string, and the subroutine will have that
10218 string as its prototype. If a prototype is supplied as an attribute, the
10219 attribute takes precedence over C<proto>, but in that case C<proto> should
10220 preferably be null. In any case, C<proto> is consumed by this function.
10222 C<attrs> supplies attributes to be applied the subroutine. A handful of
10223 attributes take effect by built-in means, being applied to C<PL_compcv>
10224 immediately when seen. Other attributes are collected up and attached
10225 to the subroutine by this route. C<attrs> may be null to supply no
10226 attributes, or point to a C<const> op for a single attribute, or point
10227 to a C<list> op whose children apart from the C<pushmark> are C<const>
10228 ops for one or more attributes. Each C<const> op must be a string,
10229 giving the attribute name optionally followed by parenthesised arguments,
10230 in the manner in which attributes appear in Perl source. The attributes
10231 will be applied to the sub by this function. C<attrs> is consumed by
10234 If C<o_is_gv> is false and C<o> is null, then the subroutine will
10235 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
10236 must point to a C<const> op, which will be consumed by this function,
10237 and its string value supplies a name for the subroutine. The name may
10238 be qualified or unqualified, and if it is unqualified then a default
10239 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
10240 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
10241 by which the subroutine will be named.
10243 If there is already a subroutine of the specified name, then the new
10244 sub will either replace the existing one in the glob or be merged with
10245 the existing one. A warning may be generated about redefinition.
10247 If the subroutine has one of a few special names, such as C<BEGIN> or
10248 C<END>, then it will be claimed by the appropriate queue for automatic
10249 running of phase-related subroutines. In this case the relevant glob will
10250 be left not containing any subroutine, even if it did contain one before.
10251 In the case of C<BEGIN>, the subroutine will be executed and the reference
10252 to it disposed of before this function returns.
10254 The function returns a pointer to the constructed subroutine. If the sub
10255 is anonymous then ownership of one counted reference to the subroutine
10256 is transferred to the caller. If the sub is named then the caller does
10257 not get ownership of a reference. In most such cases, where the sub
10258 has a non-phase name, the sub will be alive at the point it is returned
10259 by virtue of being contained in the glob that names it. A phase-named
10260 subroutine will usually be alive by virtue of the reference owned by the
10261 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10262 been executed, will quite likely have been destroyed already by the
10263 time this function returns, making it erroneous for the caller to make
10264 any use of the returned pointer. It is the caller's responsibility to
10265 ensure that it knows which of these situations applies.
10270 /* _x = extended */
10272 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
10273 OP *block, bool o_is_gv)
10277 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10279 CV *cv = NULL; /* the previous CV with this name, if any */
10281 const bool ec = PL_parser && PL_parser->error_count;
10282 /* If the subroutine has no body, no attributes, and no builtin attributes
10283 then it's just a sub declaration, and we may be able to get away with
10284 storing with a placeholder scalar in the symbol table, rather than a
10285 full CV. If anything is present then it will take a full CV to
10287 const I32 gv_fetch_flags
10288 = ec ? GV_NOADD_NOINIT :
10289 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
10290 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
10292 const char * const name =
10293 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
10295 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
10296 bool evanescent = FALSE;
10298 #ifdef PERL_DEBUG_READONLY_OPS
10299 OPSLAB *slab = NULL;
10307 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
10308 hek and CvSTASH pointer together can imply the GV. If the name
10309 contains a package name, then GvSTASH(CvGV(cv)) may differ from
10310 CvSTASH, so forego the optimisation if we find any.
10311 Also, we may be called from load_module at run time, so
10312 PL_curstash (which sets CvSTASH) may not point to the stash the
10313 sub is stored in. */
10314 /* XXX This optimization is currently disabled for packages other
10315 than main, since there was too much CPAN breakage. */
10317 ec ? GV_NOADD_NOINIT
10318 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
10319 || PL_curstash != PL_defstash
10320 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
10322 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
10323 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
10325 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
10326 SV * const sv = sv_newmortal();
10327 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
10328 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10329 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10330 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
10332 } else if (PL_curstash) {
10333 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10336 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10342 move_proto_attr(&proto, &attrs, gv, 0);
10345 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10350 assert(proto->op_type == OP_CONST);
10351 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10352 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10368 SvREFCNT_dec(PL_compcv);
10373 if (name && block) {
10374 const char *s = (char *) my_memrchr(name, ':', namlen);
10375 s = s ? s+1 : name;
10376 if (strEQ(s, "BEGIN")) {
10377 if (PL_in_eval & EVAL_KEEPERR)
10378 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10380 SV * const errsv = ERRSV;
10381 /* force display of errors found but not reported */
10382 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10383 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10390 if (!block && SvTYPE(gv) != SVt_PVGV) {
10391 /* If we are not defining a new sub and the existing one is not a
10393 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10394 /* We are applying attributes to an existing sub, so we need it
10395 upgraded if it is a constant. */
10396 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10397 gv_init_pvn(gv, PL_curstash, name, namlen,
10398 SVf_UTF8 * name_is_utf8);
10400 else { /* Maybe prototype now, and had at maximum
10401 a prototype or const/sub ref before. */
10402 if (SvTYPE(gv) > SVt_NULL) {
10403 cv_ckproto_len_flags((const CV *)gv,
10404 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10410 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10412 SvUTF8_on(MUTABLE_SV(gv));
10415 sv_setiv(MUTABLE_SV(gv), -1);
10418 SvREFCNT_dec(PL_compcv);
10419 cv = PL_compcv = NULL;
10424 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10428 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10434 /* This makes sub {}; work as expected. */
10435 if (block->op_type == OP_STUB) {
10436 const line_t l = PL_parser->copline;
10438 block = newSTATEOP(0, NULL, 0);
10439 PL_parser->copline = l;
10441 block = CvLVALUE(PL_compcv)
10442 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10443 && (!isGV(gv) || !GvASSUMECV(gv)))
10444 ? newUNOP(OP_LEAVESUBLV, 0,
10445 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10446 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10447 start = LINKLIST(block);
10448 block->op_next = 0;
10449 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10451 S_op_const_sv(aTHX_ start, PL_compcv,
10452 cBOOL(CvCLONE(PL_compcv)));
10459 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10460 cv_ckproto_len_flags((const CV *)gv,
10461 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10462 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10464 /* All the other code for sub redefinition warnings expects the
10465 clobbered sub to be a CV. Instead of making all those code
10466 paths more complex, just inline the RV version here. */
10467 const line_t oldline = CopLINE(PL_curcop);
10468 assert(IN_PERL_COMPILETIME);
10469 if (PL_parser && PL_parser->copline != NOLINE)
10470 /* This ensures that warnings are reported at the first
10471 line of a redefinition, not the last. */
10472 CopLINE_set(PL_curcop, PL_parser->copline);
10473 /* protect against fatal warnings leaking compcv */
10474 SAVEFREESV(PL_compcv);
10476 if (ckWARN(WARN_REDEFINE)
10477 || ( ckWARN_d(WARN_REDEFINE)
10478 && ( !const_sv || SvRV(gv) == const_sv
10479 || sv_cmp(SvRV(gv), const_sv) ))) {
10481 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10482 "Constant subroutine %" SVf " redefined",
10483 SVfARG(cSVOPo->op_sv));
10486 SvREFCNT_inc_simple_void_NN(PL_compcv);
10487 CopLINE_set(PL_curcop, oldline);
10488 SvREFCNT_dec(SvRV(gv));
10493 const bool exists = CvROOT(cv) || CvXSUB(cv);
10495 /* if the subroutine doesn't exist and wasn't pre-declared
10496 * with a prototype, assume it will be AUTOLOADed,
10497 * skipping the prototype check
10499 if (exists || SvPOK(cv))
10500 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10501 /* already defined (or promised)? */
10502 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10503 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10509 /* just a "sub foo;" when &foo is already defined */
10510 SAVEFREESV(PL_compcv);
10517 SvREFCNT_inc_simple_void_NN(const_sv);
10518 SvFLAGS(const_sv) |= SVs_PADTMP;
10520 assert(!CvROOT(cv) && !CvCONST(cv));
10521 cv_forget_slab(cv);
10522 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10523 CvXSUBANY(cv).any_ptr = const_sv;
10524 CvXSUB(cv) = const_sv_xsub;
10528 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10531 if (isGV(gv) || CvMETHOD(PL_compcv)) {
10532 if (name && isGV(gv))
10533 GvCV_set(gv, NULL);
10534 cv = newCONSTSUB_flags(
10535 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10539 assert(SvREFCNT((SV*)cv) != 0);
10540 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10544 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10545 prepare_SV_for_RV((SV *)gv);
10546 SvOK_off((SV *)gv);
10549 SvRV_set(gv, const_sv);
10553 SvREFCNT_dec(PL_compcv);
10558 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10559 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10562 if (cv) { /* must reuse cv if autoloaded */
10563 /* transfer PL_compcv to cv */
10565 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10566 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10567 PADLIST *const temp_av = CvPADLIST(cv);
10568 CV *const temp_cv = CvOUTSIDE(cv);
10569 const cv_flags_t other_flags =
10570 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10571 OP * const cvstart = CvSTART(cv);
10575 assert(!CvCVGV_RC(cv));
10576 assert(CvGV(cv) == gv);
10581 PERL_HASH(hash, name, namlen);
10591 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10593 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10594 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10595 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10596 CvOUTSIDE(PL_compcv) = temp_cv;
10597 CvPADLIST_set(PL_compcv, temp_av);
10598 CvSTART(cv) = CvSTART(PL_compcv);
10599 CvSTART(PL_compcv) = cvstart;
10600 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10601 CvFLAGS(PL_compcv) |= other_flags;
10604 Safefree(CvFILE(cv));
10606 CvFILE_set_from_cop(cv, PL_curcop);
10607 CvSTASH_set(cv, PL_curstash);
10609 /* inner references to PL_compcv must be fixed up ... */
10610 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10611 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10612 ++PL_sub_generation;
10615 /* Might have had built-in attributes applied -- propagate them. */
10616 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10618 /* ... before we throw it away */
10619 SvREFCNT_dec(PL_compcv);
10624 if (name && isGV(gv)) {
10627 if (HvENAME_HEK(GvSTASH(gv)))
10628 /* sub Foo::bar { (shift)+1 } */
10629 gv_method_changed(gv);
10633 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10634 prepare_SV_for_RV((SV *)gv);
10635 SvOK_off((SV *)gv);
10638 SvRV_set(gv, (SV *)cv);
10639 if (HvENAME_HEK(PL_curstash))
10640 mro_method_changed_in(PL_curstash);
10644 assert(SvREFCNT((SV*)cv) != 0);
10646 if (!CvHASGV(cv)) {
10652 PERL_HASH(hash, name, namlen);
10653 CvNAME_HEK_set(cv, share_hek(name,
10659 CvFILE_set_from_cop(cv, PL_curcop);
10660 CvSTASH_set(cv, PL_curstash);
10664 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10666 SvUTF8_on(MUTABLE_SV(cv));
10670 /* If we assign an optree to a PVCV, then we've defined a
10671 * subroutine that the debugger could be able to set a breakpoint
10672 * in, so signal to pp_entereval that it should not throw away any
10673 * saved lines at scope exit. */
10675 PL_breakable_sub_gen++;
10676 CvROOT(cv) = block;
10677 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10678 itself has a refcount. */
10680 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10681 #ifdef PERL_DEBUG_READONLY_OPS
10682 slab = (OPSLAB *)CvSTART(cv);
10684 S_process_optree(aTHX_ cv, block, start);
10689 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10690 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10691 ? GvSTASH(CvGV(cv))
10695 apply_attrs(stash, MUTABLE_SV(cv), attrs);
10697 SvREFCNT_inc_simple_void_NN(cv);
10700 if (block && has_name) {
10701 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10702 SV * const tmpstr = cv_name(cv,NULL,0);
10703 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10704 GV_ADDMULTI, SVt_PVHV);
10706 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10707 CopFILE(PL_curcop),
10709 (long)CopLINE(PL_curcop));
10710 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10711 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10712 hv = GvHVn(db_postponed);
10713 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10714 CV * const pcv = GvCV(db_postponed);
10720 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10726 if (PL_parser && PL_parser->error_count)
10727 clear_special_blocks(name, gv, cv);
10730 process_special_blocks(floor, name, gv, cv);
10736 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10738 PL_parser->copline = NOLINE;
10739 LEAVE_SCOPE(floor);
10741 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10743 #ifdef PERL_DEBUG_READONLY_OPS
10747 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10748 pad_add_weakref(cv);
10754 S_clear_special_blocks(pTHX_ const char *const fullname,
10755 GV *const gv, CV *const cv) {
10759 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10761 colon = strrchr(fullname,':');
10762 name = colon ? colon + 1 : fullname;
10764 if ((*name == 'B' && strEQ(name, "BEGIN"))
10765 || (*name == 'E' && strEQ(name, "END"))
10766 || (*name == 'U' && strEQ(name, "UNITCHECK"))
10767 || (*name == 'C' && strEQ(name, "CHECK"))
10768 || (*name == 'I' && strEQ(name, "INIT"))) {
10773 GvCV_set(gv, NULL);
10774 SvREFCNT_dec_NN(MUTABLE_SV(cv));
10778 /* Returns true if the sub has been freed. */
10780 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10784 const char *const colon = strrchr(fullname,':');
10785 const char *const name = colon ? colon + 1 : fullname;
10787 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10789 if (*name == 'B') {
10790 if (strEQ(name, "BEGIN")) {
10791 const I32 oldscope = PL_scopestack_ix;
10794 if (floor) LEAVE_SCOPE(floor);
10796 PUSHSTACKi(PERLSI_REQUIRE);
10797 SAVECOPFILE(&PL_compiling);
10798 SAVECOPLINE(&PL_compiling);
10799 SAVEVPTR(PL_curcop);
10801 DEBUG_x( dump_sub(gv) );
10802 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10803 GvCV_set(gv,0); /* cv has been hijacked */
10804 call_list(oldscope, PL_beginav);
10808 return !PL_savebegin;
10813 if (*name == 'E') {
10814 if (strEQ(name, "END")) {
10815 DEBUG_x( dump_sub(gv) );
10816 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10819 } else if (*name == 'U') {
10820 if (strEQ(name, "UNITCHECK")) {
10821 /* It's never too late to run a unitcheck block */
10822 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10826 } else if (*name == 'C') {
10827 if (strEQ(name, "CHECK")) {
10829 /* diag_listed_as: Too late to run %s block */
10830 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10831 "Too late to run CHECK block");
10832 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10836 } else if (*name == 'I') {
10837 if (strEQ(name, "INIT")) {
10839 /* diag_listed_as: Too late to run %s block */
10840 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10841 "Too late to run INIT block");
10842 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10848 DEBUG_x( dump_sub(gv) );
10850 GvCV_set(gv,0); /* cv has been hijacked */
10856 =for apidoc newCONSTSUB
10858 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10859 rather than of counted length, and no flags are set. (This means that
10860 C<name> is always interpreted as Latin-1.)
10866 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10868 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10872 =for apidoc newCONSTSUB_flags
10874 Construct a constant subroutine, also performing some surrounding
10875 jobs. A scalar constant-valued subroutine is eligible for inlining
10876 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10877 123 }>>. Other kinds of constant subroutine have other treatment.
10879 The subroutine will have an empty prototype and will ignore any arguments
10880 when called. Its constant behaviour is determined by C<sv>. If C<sv>
10881 is null, the subroutine will yield an empty list. If C<sv> points to a
10882 scalar, the subroutine will always yield that scalar. If C<sv> points
10883 to an array, the subroutine will always yield a list of the elements of
10884 that array in list context, or the number of elements in the array in
10885 scalar context. This function takes ownership of one counted reference
10886 to the scalar or array, and will arrange for the object to live as long
10887 as the subroutine does. If C<sv> points to a scalar then the inlining
10888 assumes that the value of the scalar will never change, so the caller
10889 must ensure that the scalar is not subsequently written to. If C<sv>
10890 points to an array then no such assumption is made, so it is ostensibly
10891 safe to mutate the array or its elements, but whether this is really
10892 supported has not been determined.
10894 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10895 Other aspects of the subroutine will be left in their default state.
10896 The caller is free to mutate the subroutine beyond its initial state
10897 after this function has returned.
10899 If C<name> is null then the subroutine will be anonymous, with its
10900 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10901 subroutine will be named accordingly, referenced by the appropriate glob.
10902 C<name> is a string of length C<len> bytes giving a sigilless symbol
10903 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10904 otherwise. The name may be either qualified or unqualified. If the
10905 name is unqualified then it defaults to being in the stash specified by
10906 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10907 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10910 C<flags> should not have bits set other than C<SVf_UTF8>.
10912 If there is already a subroutine of the specified name, then the new sub
10913 will replace the existing one in the glob. A warning may be generated
10914 about the redefinition.
10916 If the subroutine has one of a few special names, such as C<BEGIN> or
10917 C<END>, then it will be claimed by the appropriate queue for automatic
10918 running of phase-related subroutines. In this case the relevant glob will
10919 be left not containing any subroutine, even if it did contain one before.
10920 Execution of the subroutine will likely be a no-op, unless C<sv> was
10921 a tied array or the caller modified the subroutine in some interesting
10922 way before it was executed. In the case of C<BEGIN>, the treatment is
10923 buggy: the sub will be executed when only half built, and may be deleted
10924 prematurely, possibly causing a crash.
10926 The function returns a pointer to the constructed subroutine. If the sub
10927 is anonymous then ownership of one counted reference to the subroutine
10928 is transferred to the caller. If the sub is named then the caller does
10929 not get ownership of a reference. In most such cases, where the sub
10930 has a non-phase name, the sub will be alive at the point it is returned
10931 by virtue of being contained in the glob that names it. A phase-named
10932 subroutine will usually be alive by virtue of the reference owned by
10933 the phase's automatic run queue. A C<BEGIN> subroutine may have been
10934 destroyed already by the time this function returns, but currently bugs
10935 occur in that case before the caller gets control. It is the caller's
10936 responsibility to ensure that it knows which of these situations applies.
10942 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10946 const char *const file = CopFILE(PL_curcop);
10950 if (IN_PERL_RUNTIME) {
10951 /* at runtime, it's not safe to manipulate PL_curcop: it may be
10952 * an op shared between threads. Use a non-shared COP for our
10954 SAVEVPTR(PL_curcop);
10955 SAVECOMPILEWARNINGS();
10956 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10957 PL_curcop = &PL_compiling;
10959 SAVECOPLINE(PL_curcop);
10960 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10963 PL_hints &= ~HINT_BLOCK_SCOPE;
10966 SAVEGENERICSV(PL_curstash);
10967 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10970 /* Protect sv against leakage caused by fatal warnings. */
10971 if (sv) SAVEFREESV(sv);
10973 /* file becomes the CvFILE. For an XS, it's usually static storage,
10974 and so doesn't get free()d. (It's expected to be from the C pre-
10975 processor __FILE__ directive). But we need a dynamically allocated one,
10976 and we need it to get freed. */
10977 cv = newXS_len_flags(name, len,
10978 sv && SvTYPE(sv) == SVt_PVAV
10981 file ? file : "", "",
10982 &sv, XS_DYNAMIC_FILENAME | flags);
10984 assert(SvREFCNT((SV*)cv) != 0);
10985 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10996 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
10997 static storage, as it is used directly as CvFILE(), without a copy being made.
11003 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11005 PERL_ARGS_ASSERT_NEWXS;
11006 return newXS_len_flags(
11007 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11012 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11013 const char *const filename, const char *const proto,
11016 PERL_ARGS_ASSERT_NEWXS_FLAGS;
11017 return newXS_len_flags(
11018 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11023 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11025 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11026 return newXS_len_flags(
11027 name, strlen(name), subaddr, NULL, NULL, NULL, 0
11032 =for apidoc newXS_len_flags
11034 Construct an XS subroutine, also performing some surrounding jobs.
11036 The subroutine will have the entry point C<subaddr>. It will have
11037 the prototype specified by the nul-terminated string C<proto>, or
11038 no prototype if C<proto> is null. The prototype string is copied;
11039 the caller can mutate the supplied string afterwards. If C<filename>
11040 is non-null, it must be a nul-terminated filename, and the subroutine
11041 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
11042 point directly to the supplied string, which must be static. If C<flags>
11043 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11046 Other aspects of the subroutine will be left in their default state.
11047 If anything else needs to be done to the subroutine for it to function
11048 correctly, it is the caller's responsibility to do that after this
11049 function has constructed it. However, beware of the subroutine
11050 potentially being destroyed before this function returns, as described
11053 If C<name> is null then the subroutine will be anonymous, with its
11054 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11055 subroutine will be named accordingly, referenced by the appropriate glob.
11056 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11057 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11058 The name may be either qualified or unqualified, with the stash defaulting
11059 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
11060 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11061 they have there, such as C<GV_ADDWARN>. The symbol is always added to
11062 the stash if necessary, with C<GV_ADDMULTI> semantics.
11064 If there is already a subroutine of the specified name, then the new sub
11065 will replace the existing one in the glob. A warning may be generated
11066 about the redefinition. If the old subroutine was C<CvCONST> then the
11067 decision about whether to warn is influenced by an expectation about
11068 whether the new subroutine will become a constant of similar value.
11069 That expectation is determined by C<const_svp>. (Note that the call to
11070 this function doesn't make the new subroutine C<CvCONST> in any case;
11071 that is left to the caller.) If C<const_svp> is null then it indicates
11072 that the new subroutine will not become a constant. If C<const_svp>
11073 is non-null then it indicates that the new subroutine will become a
11074 constant, and it points to an C<SV*> that provides the constant value
11075 that the subroutine will have.
11077 If the subroutine has one of a few special names, such as C<BEGIN> or
11078 C<END>, then it will be claimed by the appropriate queue for automatic
11079 running of phase-related subroutines. In this case the relevant glob will
11080 be left not containing any subroutine, even if it did contain one before.
11081 In the case of C<BEGIN>, the subroutine will be executed and the reference
11082 to it disposed of before this function returns, and also before its
11083 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
11084 constructed by this function to be ready for execution then the caller
11085 must prevent this happening by giving the subroutine a different name.
11087 The function returns a pointer to the constructed subroutine. If the sub
11088 is anonymous then ownership of one counted reference to the subroutine
11089 is transferred to the caller. If the sub is named then the caller does
11090 not get ownership of a reference. In most such cases, where the sub
11091 has a non-phase name, the sub will be alive at the point it is returned
11092 by virtue of being contained in the glob that names it. A phase-named
11093 subroutine will usually be alive by virtue of the reference owned by the
11094 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11095 been executed, will quite likely have been destroyed already by the
11096 time this function returns, making it erroneous for the caller to make
11097 any use of the returned pointer. It is the caller's responsibility to
11098 ensure that it knows which of these situations applies.
11104 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
11105 XSUBADDR_t subaddr, const char *const filename,
11106 const char *const proto, SV **const_svp,
11110 bool interleave = FALSE;
11111 bool evanescent = FALSE;
11113 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
11116 GV * const gv = gv_fetchpvn(
11117 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11118 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
11119 sizeof("__ANON__::__ANON__") - 1,
11120 GV_ADDMULTI | flags, SVt_PVCV);
11122 if ((cv = (name ? GvCV(gv) : NULL))) {
11124 /* just a cached method */
11128 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
11129 /* already defined (or promised) */
11130 /* Redundant check that allows us to avoid creating an SV
11131 most of the time: */
11132 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11133 report_redefined_cv(newSVpvn_flags(
11134 name,len,(flags&SVf_UTF8)|SVs_TEMP
11145 if (cv) /* must reuse cv if autoloaded */
11148 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11152 if (HvENAME_HEK(GvSTASH(gv)))
11153 gv_method_changed(gv); /* newXS */
11157 assert(SvREFCNT((SV*)cv) != 0);
11161 /* XSUBs can't be perl lang/perl5db.pl debugged
11162 if (PERLDB_LINE_OR_SAVESRC)
11163 (void)gv_fetchfile(filename); */
11164 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
11165 if (flags & XS_DYNAMIC_FILENAME) {
11167 CvFILE(cv) = savepv(filename);
11169 /* NOTE: not copied, as it is expected to be an external constant string */
11170 CvFILE(cv) = (char *)filename;
11173 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
11174 CvFILE(cv) = (char*)PL_xsubfilename;
11177 CvXSUB(cv) = subaddr;
11178 #ifndef PERL_IMPLICIT_CONTEXT
11179 CvHSCXT(cv) = &PL_stack_sp;
11185 evanescent = process_special_blocks(0, name, gv, cv);
11188 } /* <- not a conditional branch */
11191 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11193 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
11194 if (interleave) LEAVE;
11195 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11199 /* Add a stub CV to a typeglob.
11200 * This is the implementation of a forward declaration, 'sub foo';'
11204 Perl_newSTUB(pTHX_ GV *gv, bool fake)
11206 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11208 PERL_ARGS_ASSERT_NEWSTUB;
11209 assert(!GvCVu(gv));
11212 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
11213 gv_method_changed(gv);
11215 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
11219 CvGV_set(cv, cvgv);
11220 CvFILE_set_from_cop(cv, PL_curcop);
11221 CvSTASH_set(cv, PL_curstash);
11227 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
11234 if (PL_parser && PL_parser->error_count) {
11240 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
11241 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
11244 if ((cv = GvFORM(gv))) {
11245 if (ckWARN(WARN_REDEFINE)) {
11246 const line_t oldline = CopLINE(PL_curcop);
11247 if (PL_parser && PL_parser->copline != NOLINE)
11248 CopLINE_set(PL_curcop, PL_parser->copline);
11250 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11251 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
11253 /* diag_listed_as: Format %s redefined */
11254 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11255 "Format STDOUT redefined");
11257 CopLINE_set(PL_curcop, oldline);
11262 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
11264 CvFILE_set_from_cop(cv, PL_curcop);
11267 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
11269 start = LINKLIST(root);
11271 S_process_optree(aTHX_ cv, root, start);
11272 cv_forget_slab(cv);
11277 PL_parser->copline = NOLINE;
11278 LEAVE_SCOPE(floor);
11279 PL_compiling.cop_seq = 0;
11283 Perl_newANONLIST(pTHX_ OP *o)
11285 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
11289 Perl_newANONHASH(pTHX_ OP *o)
11291 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
11295 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
11297 return newANONATTRSUB(floor, proto, NULL, block);
11301 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
11303 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
11305 newSVOP(OP_ANONCODE, 0,
11307 if (CvANONCONST(cv))
11308 anoncode = newUNOP(OP_ANONCONST, 0,
11309 op_convert_list(OP_ENTERSUB,
11310 OPf_STACKED|OPf_WANT_SCALAR,
11312 return newUNOP(OP_REFGEN, 0, anoncode);
11316 Perl_oopsAV(pTHX_ OP *o)
11320 PERL_ARGS_ASSERT_OOPSAV;
11322 switch (o->op_type) {
11325 OpTYPE_set(o, OP_PADAV);
11326 return ref(o, OP_RV2AV);
11330 OpTYPE_set(o, OP_RV2AV);
11335 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11342 Perl_oopsHV(pTHX_ OP *o)
11346 PERL_ARGS_ASSERT_OOPSHV;
11348 switch (o->op_type) {
11351 OpTYPE_set(o, OP_PADHV);
11352 return ref(o, OP_RV2HV);
11356 OpTYPE_set(o, OP_RV2HV);
11357 /* rv2hv steals the bottom bit for its own uses */
11358 o->op_private &= ~OPpARG1_MASK;
11363 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11370 Perl_newAVREF(pTHX_ OP *o)
11374 PERL_ARGS_ASSERT_NEWAVREF;
11376 if (o->op_type == OP_PADANY) {
11377 OpTYPE_set(o, OP_PADAV);
11380 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11381 Perl_croak(aTHX_ "Can't use an array as a reference");
11383 return newUNOP(OP_RV2AV, 0, scalar(o));
11387 Perl_newGVREF(pTHX_ I32 type, OP *o)
11389 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11390 return newUNOP(OP_NULL, 0, o);
11391 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11395 Perl_newHVREF(pTHX_ OP *o)
11399 PERL_ARGS_ASSERT_NEWHVREF;
11401 if (o->op_type == OP_PADANY) {
11402 OpTYPE_set(o, OP_PADHV);
11405 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11406 Perl_croak(aTHX_ "Can't use a hash as a reference");
11408 return newUNOP(OP_RV2HV, 0, scalar(o));
11412 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11414 if (o->op_type == OP_PADANY) {
11416 OpTYPE_set(o, OP_PADCV);
11418 return newUNOP(OP_RV2CV, flags, scalar(o));
11422 Perl_newSVREF(pTHX_ OP *o)
11426 PERL_ARGS_ASSERT_NEWSVREF;
11428 if (o->op_type == OP_PADANY) {
11429 OpTYPE_set(o, OP_PADSV);
11433 return newUNOP(OP_RV2SV, 0, scalar(o));
11436 /* Check routines. See the comments at the top of this file for details
11437 * on when these are called */
11440 Perl_ck_anoncode(pTHX_ OP *o)
11442 PERL_ARGS_ASSERT_CK_ANONCODE;
11444 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11445 cSVOPo->op_sv = NULL;
11450 S_io_hints(pTHX_ OP *o)
11452 #if O_BINARY != 0 || O_TEXT != 0
11454 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11456 SV **svp = hv_fetchs(table, "open_IN", FALSE);
11459 const char *d = SvPV_const(*svp, len);
11460 const I32 mode = mode_from_discipline(d, len);
11461 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11463 if (mode & O_BINARY)
11464 o->op_private |= OPpOPEN_IN_RAW;
11468 o->op_private |= OPpOPEN_IN_CRLF;
11472 svp = hv_fetchs(table, "open_OUT", FALSE);
11475 const char *d = SvPV_const(*svp, len);
11476 const I32 mode = mode_from_discipline(d, len);
11477 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11479 if (mode & O_BINARY)
11480 o->op_private |= OPpOPEN_OUT_RAW;
11484 o->op_private |= OPpOPEN_OUT_CRLF;
11489 PERL_UNUSED_CONTEXT;
11490 PERL_UNUSED_ARG(o);
11495 Perl_ck_backtick(pTHX_ OP *o)
11500 PERL_ARGS_ASSERT_CK_BACKTICK;
11502 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11503 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11504 && (gv = gv_override("readpipe",8)))
11506 /* detach rest of siblings from o and its first child */
11507 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11508 newop = S_new_entersubop(aTHX_ gv, sibl);
11510 else if (!(o->op_flags & OPf_KIDS))
11511 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11516 S_io_hints(aTHX_ o);
11521 Perl_ck_bitop(pTHX_ OP *o)
11523 PERL_ARGS_ASSERT_CK_BITOP;
11525 o->op_private = (U8)(PL_hints & HINT_INTEGER);
11527 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11528 && OP_IS_INFIX_BIT(o->op_type))
11530 const OP * const left = cBINOPo->op_first;
11531 const OP * const right = OpSIBLING(left);
11532 if ((OP_IS_NUMCOMPARE(left->op_type) &&
11533 (left->op_flags & OPf_PARENS) == 0) ||
11534 (OP_IS_NUMCOMPARE(right->op_type) &&
11535 (right->op_flags & OPf_PARENS) == 0))
11536 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11537 "Possible precedence problem on bitwise %s operator",
11538 o->op_type == OP_BIT_OR
11539 ||o->op_type == OP_NBIT_OR ? "|"
11540 : o->op_type == OP_BIT_AND
11541 ||o->op_type == OP_NBIT_AND ? "&"
11542 : o->op_type == OP_BIT_XOR
11543 ||o->op_type == OP_NBIT_XOR ? "^"
11544 : o->op_type == OP_SBIT_OR ? "|."
11545 : o->op_type == OP_SBIT_AND ? "&." : "^."
11551 PERL_STATIC_INLINE bool
11552 is_dollar_bracket(pTHX_ const OP * const o)
11555 PERL_UNUSED_CONTEXT;
11556 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11557 && (kid = cUNOPx(o)->op_first)
11558 && kid->op_type == OP_GV
11559 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11562 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11565 Perl_ck_cmp(pTHX_ OP *o)
11571 OP *indexop, *constop, *start;
11575 PERL_ARGS_ASSERT_CK_CMP;
11577 is_eq = ( o->op_type == OP_EQ
11578 || o->op_type == OP_NE
11579 || o->op_type == OP_I_EQ
11580 || o->op_type == OP_I_NE);
11582 if (!is_eq && ckWARN(WARN_SYNTAX)) {
11583 const OP *kid = cUNOPo->op_first;
11586 ( is_dollar_bracket(aTHX_ kid)
11587 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11589 || ( kid->op_type == OP_CONST
11590 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11594 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11595 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11598 /* convert (index(...) == -1) and variations into
11599 * (r)index/BOOL(,NEG)
11604 indexop = cUNOPo->op_first;
11605 constop = OpSIBLING(indexop);
11607 if (indexop->op_type == OP_CONST) {
11609 indexop = OpSIBLING(constop);
11614 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11617 /* ($lex = index(....)) == -1 */
11618 if (indexop->op_private & OPpTARGET_MY)
11621 if (constop->op_type != OP_CONST)
11624 sv = cSVOPx_sv(constop);
11625 if (!(sv && SvIOK_notUV(sv)))
11629 if (iv != -1 && iv != 0)
11633 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11634 if (!(iv0 ^ reverse))
11638 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11643 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11644 if (!(iv0 ^ reverse))
11648 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11653 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11659 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11665 indexop->op_flags &= ~OPf_PARENS;
11666 indexop->op_flags |= (o->op_flags & OPf_PARENS);
11667 indexop->op_private |= OPpTRUEBOOL;
11669 indexop->op_private |= OPpINDEX_BOOLNEG;
11670 /* cut out the index op and free the eq,const ops */
11671 (void)op_sibling_splice(o, start, 1, NULL);
11679 Perl_ck_concat(pTHX_ OP *o)
11681 const OP * const kid = cUNOPo->op_first;
11683 PERL_ARGS_ASSERT_CK_CONCAT;
11684 PERL_UNUSED_CONTEXT;
11686 /* reuse the padtmp returned by the concat child */
11687 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11688 !(kUNOP->op_first->op_flags & OPf_MOD))
11690 o->op_flags |= OPf_STACKED;
11691 o->op_private |= OPpCONCAT_NESTED;
11697 Perl_ck_spair(pTHX_ OP *o)
11701 PERL_ARGS_ASSERT_CK_SPAIR;
11703 if (o->op_flags & OPf_KIDS) {
11707 const OPCODE type = o->op_type;
11708 o = modkids(ck_fun(o), type);
11709 kid = cUNOPo->op_first;
11710 kidkid = kUNOP->op_first;
11711 newop = OpSIBLING(kidkid);
11713 const OPCODE type = newop->op_type;
11714 if (OpHAS_SIBLING(newop))
11716 if (o->op_type == OP_REFGEN
11717 && ( type == OP_RV2CV
11718 || ( !(newop->op_flags & OPf_PARENS)
11719 && ( type == OP_RV2AV || type == OP_PADAV
11720 || type == OP_RV2HV || type == OP_PADHV))))
11721 NOOP; /* OK (allow srefgen for \@a and \%h) */
11722 else if (OP_GIMME(newop,0) != G_SCALAR)
11725 /* excise first sibling */
11726 op_sibling_splice(kid, NULL, 1, NULL);
11729 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11730 * and OP_CHOMP into OP_SCHOMP */
11731 o->op_ppaddr = PL_ppaddr[++o->op_type];
11736 Perl_ck_delete(pTHX_ OP *o)
11738 PERL_ARGS_ASSERT_CK_DELETE;
11742 if (o->op_flags & OPf_KIDS) {
11743 OP * const kid = cUNOPo->op_first;
11744 switch (kid->op_type) {
11746 o->op_flags |= OPf_SPECIAL;
11749 o->op_private |= OPpSLICE;
11752 o->op_flags |= OPf_SPECIAL;
11757 o->op_flags |= OPf_SPECIAL;
11760 o->op_private |= OPpKVSLICE;
11763 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11764 "element or slice");
11766 if (kid->op_private & OPpLVAL_INTRO)
11767 o->op_private |= OPpLVAL_INTRO;
11774 Perl_ck_eof(pTHX_ OP *o)
11776 PERL_ARGS_ASSERT_CK_EOF;
11778 if (o->op_flags & OPf_KIDS) {
11780 if (cLISTOPo->op_first->op_type == OP_STUB) {
11782 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11787 kid = cLISTOPo->op_first;
11788 if (kid->op_type == OP_RV2GV)
11789 kid->op_private |= OPpALLOW_FAKE;
11796 Perl_ck_eval(pTHX_ OP *o)
11800 PERL_ARGS_ASSERT_CK_EVAL;
11802 PL_hints |= HINT_BLOCK_SCOPE;
11803 if (o->op_flags & OPf_KIDS) {
11804 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11807 if (o->op_type == OP_ENTERTRY) {
11810 /* cut whole sibling chain free from o */
11811 op_sibling_splice(o, NULL, -1, NULL);
11814 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11816 /* establish postfix order */
11817 enter->op_next = (OP*)enter;
11819 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11820 OpTYPE_set(o, OP_LEAVETRY);
11821 enter->op_other = o;
11826 S_set_haseval(aTHX);
11830 const U8 priv = o->op_private;
11832 /* the newUNOP will recursively call ck_eval(), which will handle
11833 * all the stuff at the end of this function, like adding
11836 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11838 o->op_targ = (PADOFFSET)PL_hints;
11839 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11840 if ((PL_hints & HINT_LOCALIZE_HH) != 0
11841 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11842 /* Store a copy of %^H that pp_entereval can pick up. */
11843 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11844 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11845 /* append hhop to only child */
11846 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11848 o->op_private |= OPpEVAL_HAS_HH;
11850 if (!(o->op_private & OPpEVAL_BYTES)
11851 && FEATURE_UNIEVAL_IS_ENABLED)
11852 o->op_private |= OPpEVAL_UNICODE;
11857 Perl_ck_exec(pTHX_ OP *o)
11859 PERL_ARGS_ASSERT_CK_EXEC;
11861 if (o->op_flags & OPf_STACKED) {
11864 kid = OpSIBLING(cUNOPo->op_first);
11865 if (kid->op_type == OP_RV2GV)
11874 Perl_ck_exists(pTHX_ OP *o)
11876 PERL_ARGS_ASSERT_CK_EXISTS;
11879 if (o->op_flags & OPf_KIDS) {
11880 OP * const kid = cUNOPo->op_first;
11881 if (kid->op_type == OP_ENTERSUB) {
11882 (void) ref(kid, o->op_type);
11883 if (kid->op_type != OP_RV2CV
11884 && !(PL_parser && PL_parser->error_count))
11886 "exists argument is not a subroutine name");
11887 o->op_private |= OPpEXISTS_SUB;
11889 else if (kid->op_type == OP_AELEM)
11890 o->op_flags |= OPf_SPECIAL;
11891 else if (kid->op_type != OP_HELEM)
11892 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11893 "element or a subroutine");
11900 Perl_ck_rvconst(pTHX_ OP *o)
11903 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11905 PERL_ARGS_ASSERT_CK_RVCONST;
11907 if (o->op_type == OP_RV2HV)
11908 /* rv2hv steals the bottom bit for its own uses */
11909 o->op_private &= ~OPpARG1_MASK;
11911 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11913 if (kid->op_type == OP_CONST) {
11916 SV * const kidsv = kid->op_sv;
11918 /* Is it a constant from cv_const_sv()? */
11919 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11922 if (SvTYPE(kidsv) == SVt_PVAV) return o;
11923 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11924 const char *badthing;
11925 switch (o->op_type) {
11927 badthing = "a SCALAR";
11930 badthing = "an ARRAY";
11933 badthing = "a HASH";
11941 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11942 SVfARG(kidsv), badthing);
11945 * This is a little tricky. We only want to add the symbol if we
11946 * didn't add it in the lexer. Otherwise we get duplicate strict
11947 * warnings. But if we didn't add it in the lexer, we must at
11948 * least pretend like we wanted to add it even if it existed before,
11949 * or we get possible typo warnings. OPpCONST_ENTERED says
11950 * whether the lexer already added THIS instance of this symbol.
11952 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11953 gv = gv_fetchsv(kidsv,
11954 o->op_type == OP_RV2CV
11955 && o->op_private & OPpMAY_RETURN_CONSTANT
11957 : iscv | !(kid->op_private & OPpCONST_ENTERED),
11960 : o->op_type == OP_RV2SV
11962 : o->op_type == OP_RV2AV
11964 : o->op_type == OP_RV2HV
11971 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11972 && SvTYPE(SvRV(gv)) != SVt_PVCV)
11973 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11975 OpTYPE_set(kid, OP_GV);
11976 SvREFCNT_dec(kid->op_sv);
11977 #ifdef USE_ITHREADS
11978 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11979 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11980 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11981 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11982 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11984 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11986 kid->op_private = 0;
11987 /* FAKE globs in the symbol table cause weird bugs (#77810) */
11995 Perl_ck_ftst(pTHX_ OP *o)
11998 const I32 type = o->op_type;
12000 PERL_ARGS_ASSERT_CK_FTST;
12002 if (o->op_flags & OPf_REF) {
12005 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12006 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12007 const OPCODE kidtype = kid->op_type;
12009 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12010 && !kid->op_folded) {
12011 OP * const newop = newGVOP(type, OPf_REF,
12012 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12017 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12018 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12020 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12021 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12022 array_passed_to_stat, name);
12025 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12026 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12029 scalar((OP *) kid);
12030 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12031 o->op_private |= OPpFT_ACCESS;
12032 if (OP_IS_FILETEST(type)
12033 && OP_IS_FILETEST(kidtype)
12035 o->op_private |= OPpFT_STACKED;
12036 kid->op_private |= OPpFT_STACKING;
12037 if (kidtype == OP_FTTTY && (
12038 !(kid->op_private & OPpFT_STACKED)
12039 || kid->op_private & OPpFT_AFTER_t
12041 o->op_private |= OPpFT_AFTER_t;
12046 if (type == OP_FTTTY)
12047 o = newGVOP(type, OPf_REF, PL_stdingv);
12049 o = newUNOP(type, 0, newDEFSVOP());
12055 Perl_ck_fun(pTHX_ OP *o)
12057 const int type = o->op_type;
12058 I32 oa = PL_opargs[type] >> OASHIFT;
12060 PERL_ARGS_ASSERT_CK_FUN;
12062 if (o->op_flags & OPf_STACKED) {
12063 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12064 oa &= ~OA_OPTIONAL;
12066 return no_fh_allowed(o);
12069 if (o->op_flags & OPf_KIDS) {
12070 OP *prev_kid = NULL;
12071 OP *kid = cLISTOPo->op_first;
12073 bool seen_optional = FALSE;
12075 if (kid->op_type == OP_PUSHMARK ||
12076 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
12079 kid = OpSIBLING(kid);
12081 if (kid && kid->op_type == OP_COREARGS) {
12082 bool optional = FALSE;
12085 if (oa & OA_OPTIONAL) optional = TRUE;
12088 if (optional) o->op_private |= numargs;
12093 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
12094 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
12095 kid = newDEFSVOP();
12096 /* append kid to chain */
12097 op_sibling_splice(o, prev_kid, 0, kid);
12099 seen_optional = TRUE;
12106 /* list seen where single (scalar) arg expected? */
12107 if (numargs == 1 && !(oa >> 4)
12108 && kid->op_type == OP_LIST && type != OP_SCALAR)
12110 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12112 if (type != OP_DELETE) scalar(kid);
12123 if ((type == OP_PUSH || type == OP_UNSHIFT)
12124 && !OpHAS_SIBLING(kid))
12125 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12126 "Useless use of %s with no values",
12129 if (kid->op_type == OP_CONST
12130 && ( !SvROK(cSVOPx_sv(kid))
12131 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
12133 bad_type_pv(numargs, "array", o, kid);
12134 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
12135 || kid->op_type == OP_RV2GV) {
12136 bad_type_pv(1, "array", o, kid);
12138 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
12139 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
12140 PL_op_desc[type]), 0);
12143 op_lvalue(kid, type);
12147 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
12148 bad_type_pv(numargs, "hash", o, kid);
12149 op_lvalue(kid, type);
12153 /* replace kid with newop in chain */
12155 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
12156 newop->op_next = newop;
12161 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
12162 if (kid->op_type == OP_CONST &&
12163 (kid->op_private & OPpCONST_BARE))
12165 OP * const newop = newGVOP(OP_GV, 0,
12166 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
12167 /* replace kid with newop in chain */
12168 op_sibling_splice(o, prev_kid, 1, newop);
12172 else if (kid->op_type == OP_READLINE) {
12173 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
12174 bad_type_pv(numargs, "HANDLE", o, kid);
12177 I32 flags = OPf_SPECIAL;
12179 PADOFFSET targ = 0;
12181 /* is this op a FH constructor? */
12182 if (is_handle_constructor(o,numargs)) {
12183 const char *name = NULL;
12186 bool want_dollar = TRUE;
12189 /* Set a flag to tell rv2gv to vivify
12190 * need to "prove" flag does not mean something
12191 * else already - NI-S 1999/05/07
12194 if (kid->op_type == OP_PADSV) {
12196 = PAD_COMPNAME_SV(kid->op_targ);
12197 name = PadnamePV (pn);
12198 len = PadnameLEN(pn);
12199 name_utf8 = PadnameUTF8(pn);
12201 else if (kid->op_type == OP_RV2SV
12202 && kUNOP->op_first->op_type == OP_GV)
12204 GV * const gv = cGVOPx_gv(kUNOP->op_first);
12206 len = GvNAMELEN(gv);
12207 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
12209 else if (kid->op_type == OP_AELEM
12210 || kid->op_type == OP_HELEM)
12213 OP *op = ((BINOP*)kid)->op_first;
12217 const char * const a =
12218 kid->op_type == OP_AELEM ?
12220 if (((op->op_type == OP_RV2AV) ||
12221 (op->op_type == OP_RV2HV)) &&
12222 (firstop = ((UNOP*)op)->op_first) &&
12223 (firstop->op_type == OP_GV)) {
12224 /* packagevar $a[] or $h{} */
12225 GV * const gv = cGVOPx_gv(firstop);
12228 Perl_newSVpvf(aTHX_
12233 else if (op->op_type == OP_PADAV
12234 || op->op_type == OP_PADHV) {
12235 /* lexicalvar $a[] or $h{} */
12236 const char * const padname =
12237 PAD_COMPNAME_PV(op->op_targ);
12240 Perl_newSVpvf(aTHX_
12246 name = SvPV_const(tmpstr, len);
12247 name_utf8 = SvUTF8(tmpstr);
12248 sv_2mortal(tmpstr);
12252 name = "__ANONIO__";
12254 want_dollar = FALSE;
12256 op_lvalue(kid, type);
12260 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
12261 namesv = PAD_SVl(targ);
12262 if (want_dollar && *name != '$')
12263 sv_setpvs(namesv, "$");
12266 sv_catpvn(namesv, name, len);
12267 if ( name_utf8 ) SvUTF8_on(namesv);
12271 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
12273 kid->op_targ = targ;
12274 kid->op_private |= priv;
12280 if ((type == OP_UNDEF || type == OP_POS)
12281 && numargs == 1 && !(oa >> 4)
12282 && kid->op_type == OP_LIST)
12283 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12284 op_lvalue(scalar(kid), type);
12289 kid = OpSIBLING(kid);
12291 /* FIXME - should the numargs or-ing move after the too many
12292 * arguments check? */
12293 o->op_private |= numargs;
12295 return too_many_arguments_pv(o,OP_DESC(o), 0);
12298 else if (PL_opargs[type] & OA_DEFGV) {
12299 /* Ordering of these two is important to keep f_map.t passing. */
12301 return newUNOP(type, 0, newDEFSVOP());
12305 while (oa & OA_OPTIONAL)
12307 if (oa && oa != OA_LIST)
12308 return too_few_arguments_pv(o,OP_DESC(o), 0);
12314 Perl_ck_glob(pTHX_ OP *o)
12318 PERL_ARGS_ASSERT_CK_GLOB;
12321 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
12322 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
12324 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
12328 * \ null - const(wildcard)
12333 * \ mark - glob - rv2cv
12334 * | \ gv(CORE::GLOBAL::glob)
12336 * \ null - const(wildcard)
12338 o->op_flags |= OPf_SPECIAL;
12339 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12340 o = S_new_entersubop(aTHX_ gv, o);
12341 o = newUNOP(OP_NULL, 0, o);
12342 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12345 else o->op_flags &= ~OPf_SPECIAL;
12346 #if !defined(PERL_EXTERNAL_GLOB)
12347 if (!PL_globhook) {
12349 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12350 newSVpvs("File::Glob"), NULL, NULL, NULL);
12353 #endif /* !PERL_EXTERNAL_GLOB */
12354 gv = (GV *)newSV(0);
12355 gv_init(gv, 0, "", 0, 0);
12357 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12358 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12364 Perl_ck_grep(pTHX_ OP *o)
12368 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12370 PERL_ARGS_ASSERT_CK_GREP;
12372 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12374 if (o->op_flags & OPf_STACKED) {
12375 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12376 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12377 return no_fh_allowed(o);
12378 o->op_flags &= ~OPf_STACKED;
12380 kid = OpSIBLING(cLISTOPo->op_first);
12381 if (type == OP_MAPWHILE)
12386 if (PL_parser && PL_parser->error_count)
12388 kid = OpSIBLING(cLISTOPo->op_first);
12389 if (kid->op_type != OP_NULL)
12390 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12391 kid = kUNOP->op_first;
12393 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12394 kid->op_next = (OP*)gwop;
12395 o->op_private = gwop->op_private = 0;
12396 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12398 kid = OpSIBLING(cLISTOPo->op_first);
12399 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12400 op_lvalue(kid, OP_GREPSTART);
12406 Perl_ck_index(pTHX_ OP *o)
12408 PERL_ARGS_ASSERT_CK_INDEX;
12410 if (o->op_flags & OPf_KIDS) {
12411 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12413 kid = OpSIBLING(kid); /* get past "big" */
12414 if (kid && kid->op_type == OP_CONST) {
12415 const bool save_taint = TAINT_get;
12416 SV *sv = kSVOP->op_sv;
12417 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12418 && SvOK(sv) && !SvROK(sv))
12421 sv_copypv(sv, kSVOP->op_sv);
12422 SvREFCNT_dec_NN(kSVOP->op_sv);
12425 if (SvOK(sv)) fbm_compile(sv, 0);
12426 TAINT_set(save_taint);
12427 #ifdef NO_TAINT_SUPPORT
12428 PERL_UNUSED_VAR(save_taint);
12436 Perl_ck_lfun(pTHX_ OP *o)
12438 const OPCODE type = o->op_type;
12440 PERL_ARGS_ASSERT_CK_LFUN;
12442 return modkids(ck_fun(o), type);
12446 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
12448 PERL_ARGS_ASSERT_CK_DEFINED;
12450 if ((o->op_flags & OPf_KIDS)) {
12451 switch (cUNOPo->op_first->op_type) {
12454 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12455 " (Maybe you should just omit the defined()?)");
12456 NOT_REACHED; /* NOTREACHED */
12460 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12461 " (Maybe you should just omit the defined()?)");
12462 NOT_REACHED; /* NOTREACHED */
12473 Perl_ck_readline(pTHX_ OP *o)
12475 PERL_ARGS_ASSERT_CK_READLINE;
12477 if (o->op_flags & OPf_KIDS) {
12478 OP *kid = cLISTOPo->op_first;
12479 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12484 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12492 Perl_ck_rfun(pTHX_ OP *o)
12494 const OPCODE type = o->op_type;
12496 PERL_ARGS_ASSERT_CK_RFUN;
12498 return refkids(ck_fun(o), type);
12502 Perl_ck_listiob(pTHX_ OP *o)
12506 PERL_ARGS_ASSERT_CK_LISTIOB;
12508 kid = cLISTOPo->op_first;
12510 o = force_list(o, 1);
12511 kid = cLISTOPo->op_first;
12513 if (kid->op_type == OP_PUSHMARK)
12514 kid = OpSIBLING(kid);
12515 if (kid && o->op_flags & OPf_STACKED)
12516 kid = OpSIBLING(kid);
12517 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
12518 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12519 && !kid->op_folded) {
12520 o->op_flags |= OPf_STACKED; /* make it a filehandle */
12522 /* replace old const op with new OP_RV2GV parent */
12523 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12524 OP_RV2GV, OPf_REF);
12525 kid = OpSIBLING(kid);
12530 op_append_elem(o->op_type, o, newDEFSVOP());
12532 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12533 return listkids(o);
12537 Perl_ck_smartmatch(pTHX_ OP *o)
12540 PERL_ARGS_ASSERT_CK_SMARTMATCH;
12541 if (0 == (o->op_flags & OPf_SPECIAL)) {
12542 OP *first = cBINOPo->op_first;
12543 OP *second = OpSIBLING(first);
12545 /* Implicitly take a reference to an array or hash */
12547 /* remove the original two siblings, then add back the
12548 * (possibly different) first and second sibs.
12550 op_sibling_splice(o, NULL, 1, NULL);
12551 op_sibling_splice(o, NULL, 1, NULL);
12552 first = ref_array_or_hash(first);
12553 second = ref_array_or_hash(second);
12554 op_sibling_splice(o, NULL, 0, second);
12555 op_sibling_splice(o, NULL, 0, first);
12557 /* Implicitly take a reference to a regular expression */
12558 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12559 OpTYPE_set(first, OP_QR);
12561 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12562 OpTYPE_set(second, OP_QR);
12571 S_maybe_targlex(pTHX_ OP *o)
12573 OP * const kid = cLISTOPo->op_first;
12574 /* has a disposable target? */
12575 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12576 && !(kid->op_flags & OPf_STACKED)
12577 /* Cannot steal the second time! */
12578 && !(kid->op_private & OPpTARGET_MY)
12581 OP * const kkid = OpSIBLING(kid);
12583 /* Can just relocate the target. */
12584 if (kkid && kkid->op_type == OP_PADSV
12585 && (!(kkid->op_private & OPpLVAL_INTRO)
12586 || kkid->op_private & OPpPAD_STATE))
12588 kid->op_targ = kkid->op_targ;
12590 /* Now we do not need PADSV and SASSIGN.
12591 * Detach kid and free the rest. */
12592 op_sibling_splice(o, NULL, 1, NULL);
12594 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
12602 Perl_ck_sassign(pTHX_ OP *o)
12605 OP * const kid = cBINOPo->op_first;
12607 PERL_ARGS_ASSERT_CK_SASSIGN;
12609 if (OpHAS_SIBLING(kid)) {
12610 OP *kkid = OpSIBLING(kid);
12611 /* For state variable assignment with attributes, kkid is a list op
12612 whose op_last is a padsv. */
12613 if ((kkid->op_type == OP_PADSV ||
12614 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12615 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12618 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12619 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12620 return S_newONCEOP(aTHX_ o, kkid);
12623 return S_maybe_targlex(aTHX_ o);
12628 Perl_ck_match(pTHX_ OP *o)
12630 PERL_UNUSED_CONTEXT;
12631 PERL_ARGS_ASSERT_CK_MATCH;
12637 Perl_ck_method(pTHX_ OP *o)
12639 SV *sv, *methsv, *rclass;
12640 const char* method;
12643 STRLEN len, nsplit = 0, i;
12645 OP * const kid = cUNOPo->op_first;
12647 PERL_ARGS_ASSERT_CK_METHOD;
12648 if (kid->op_type != OP_CONST) return o;
12652 /* replace ' with :: */
12653 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12654 SvEND(sv) - SvPVX(sv) )))
12657 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12660 method = SvPVX_const(sv);
12662 utf8 = SvUTF8(sv) ? -1 : 1;
12664 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12669 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12671 if (!nsplit) { /* $proto->method() */
12673 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12676 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12678 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12681 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12682 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12683 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12684 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12686 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12687 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12689 #ifdef USE_ITHREADS
12690 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12692 cMETHOPx(new_op)->op_rclass_sv = rclass;
12699 Perl_ck_null(pTHX_ OP *o)
12701 PERL_ARGS_ASSERT_CK_NULL;
12702 PERL_UNUSED_CONTEXT;
12707 Perl_ck_open(pTHX_ OP *o)
12709 PERL_ARGS_ASSERT_CK_OPEN;
12711 S_io_hints(aTHX_ o);
12713 /* In case of three-arg dup open remove strictness
12714 * from the last arg if it is a bareword. */
12715 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12716 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
12720 if ((last->op_type == OP_CONST) && /* The bareword. */
12721 (last->op_private & OPpCONST_BARE) &&
12722 (last->op_private & OPpCONST_STRICT) &&
12723 (oa = OpSIBLING(first)) && /* The fh. */
12724 (oa = OpSIBLING(oa)) && /* The mode. */
12725 (oa->op_type == OP_CONST) &&
12726 SvPOK(((SVOP*)oa)->op_sv) &&
12727 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12728 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
12729 (last == OpSIBLING(oa))) /* The bareword. */
12730 last->op_private &= ~OPpCONST_STRICT;
12736 Perl_ck_prototype(pTHX_ OP *o)
12738 PERL_ARGS_ASSERT_CK_PROTOTYPE;
12739 if (!(o->op_flags & OPf_KIDS)) {
12741 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12747 Perl_ck_refassign(pTHX_ OP *o)
12749 OP * const right = cLISTOPo->op_first;
12750 OP * const left = OpSIBLING(right);
12751 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12754 PERL_ARGS_ASSERT_CK_REFASSIGN;
12756 assert (left->op_type == OP_SREFGEN);
12759 /* we use OPpPAD_STATE in refassign to mean either of those things,
12760 * and the code assumes the two flags occupy the same bit position
12761 * in the various ops below */
12762 assert(OPpPAD_STATE == OPpOUR_INTRO);
12764 switch (varop->op_type) {
12766 o->op_private |= OPpLVREF_AV;
12769 o->op_private |= OPpLVREF_HV;
12773 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12774 o->op_targ = varop->op_targ;
12775 varop->op_targ = 0;
12776 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12780 o->op_private |= OPpLVREF_AV;
12782 NOT_REACHED; /* NOTREACHED */
12784 o->op_private |= OPpLVREF_HV;
12788 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12789 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12791 /* Point varop to its GV kid, detached. */
12792 varop = op_sibling_splice(varop, NULL, -1, NULL);
12796 OP * const kidparent =
12797 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12798 OP * const kid = cUNOPx(kidparent)->op_first;
12799 o->op_private |= OPpLVREF_CV;
12800 if (kid->op_type == OP_GV) {
12801 SV *sv = (SV*)cGVOPx_gv(kid);
12803 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
12804 /* a CVREF here confuses pp_refassign, so make sure
12806 CV *const cv = (CV*)SvRV(sv);
12807 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
12808 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
12809 assert(SvTYPE(sv) == SVt_PVGV);
12811 goto detach_and_stack;
12813 if (kid->op_type != OP_PADCV) goto bad;
12814 o->op_targ = kid->op_targ;
12820 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12821 o->op_private |= OPpLVREF_ELEM;
12824 /* Detach varop. */
12825 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12829 /* diag_listed_as: Can't modify reference to %s in %s assignment */
12830 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12835 if (!FEATURE_REFALIASING_IS_ENABLED)
12837 "Experimental aliasing via reference not enabled");
12838 Perl_ck_warner_d(aTHX_
12839 packWARN(WARN_EXPERIMENTAL__REFALIASING),
12840 "Aliasing via reference is experimental");
12842 o->op_flags |= OPf_STACKED;
12843 op_sibling_splice(o, right, 1, varop);
12846 o->op_flags &=~ OPf_STACKED;
12847 op_sibling_splice(o, right, 1, NULL);
12854 Perl_ck_repeat(pTHX_ OP *o)
12856 PERL_ARGS_ASSERT_CK_REPEAT;
12858 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12860 o->op_private |= OPpREPEAT_DOLIST;
12861 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12862 kids = force_list(kids, 1); /* promote it to a list */
12863 op_sibling_splice(o, NULL, 0, kids); /* and add back */
12871 Perl_ck_require(pTHX_ OP *o)
12875 PERL_ARGS_ASSERT_CK_REQUIRE;
12877 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
12878 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12882 if (kid->op_type == OP_CONST) {
12883 SV * const sv = kid->op_sv;
12884 U32 const was_readonly = SvREADONLY(sv);
12885 if (kid->op_private & OPpCONST_BARE) {
12890 if (was_readonly) {
12891 SvREADONLY_off(sv);
12893 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12898 /* treat ::foo::bar as foo::bar */
12899 if (len >= 2 && s[0] == ':' && s[1] == ':')
12900 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12902 DIE(aTHX_ "Bareword in require maps to empty filename");
12904 for (; s < end; s++) {
12905 if (*s == ':' && s[1] == ':') {
12907 Move(s+2, s+1, end - s - 1, char);
12911 SvEND_set(sv, end);
12912 sv_catpvs(sv, ".pm");
12913 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12914 hek = share_hek(SvPVX(sv),
12915 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12917 sv_sethek(sv, hek);
12919 SvFLAGS(sv) |= was_readonly;
12921 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12924 if (SvREFCNT(sv) > 1) {
12925 kid->op_sv = newSVpvn_share(
12926 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12927 SvREFCNT_dec_NN(sv);
12932 if (was_readonly) SvREADONLY_off(sv);
12933 PERL_HASH(hash, s, len);
12935 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12937 sv_sethek(sv, hek);
12939 SvFLAGS(sv) |= was_readonly;
12945 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12946 /* handle override, if any */
12947 && (gv = gv_override("require", 7))) {
12949 if (o->op_flags & OPf_KIDS) {
12950 kid = cUNOPo->op_first;
12951 op_sibling_splice(o, NULL, -1, NULL);
12954 kid = newDEFSVOP();
12957 newop = S_new_entersubop(aTHX_ gv, kid);
12965 Perl_ck_return(pTHX_ OP *o)
12969 PERL_ARGS_ASSERT_CK_RETURN;
12971 kid = OpSIBLING(cLISTOPo->op_first);
12972 if (PL_compcv && CvLVALUE(PL_compcv)) {
12973 for (; kid; kid = OpSIBLING(kid))
12974 op_lvalue(kid, OP_LEAVESUBLV);
12981 Perl_ck_select(pTHX_ OP *o)
12986 PERL_ARGS_ASSERT_CK_SELECT;
12988 if (o->op_flags & OPf_KIDS) {
12989 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12990 if (kid && OpHAS_SIBLING(kid)) {
12991 OpTYPE_set(o, OP_SSELECT);
12993 return fold_constants(op_integerize(op_std_init(o)));
12997 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12998 if (kid && kid->op_type == OP_RV2GV)
12999 kid->op_private &= ~HINT_STRICT_REFS;
13004 Perl_ck_shift(pTHX_ OP *o)
13006 const I32 type = o->op_type;
13008 PERL_ARGS_ASSERT_CK_SHIFT;
13010 if (!(o->op_flags & OPf_KIDS)) {
13013 if (!CvUNIQUE(PL_compcv)) {
13014 o->op_flags |= OPf_SPECIAL;
13018 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13020 return newUNOP(type, 0, scalar(argop));
13022 return scalar(ck_fun(o));
13026 Perl_ck_sort(pTHX_ OP *o)
13030 HV * const hinthv =
13031 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
13034 PERL_ARGS_ASSERT_CK_SORT;
13037 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
13039 const I32 sorthints = (I32)SvIV(*svp);
13040 if ((sorthints & HINT_SORT_STABLE) != 0)
13041 o->op_private |= OPpSORT_STABLE;
13042 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
13043 o->op_private |= OPpSORT_UNSTABLE;
13047 if (o->op_flags & OPf_STACKED)
13049 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13051 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
13052 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
13054 /* if the first arg is a code block, process it and mark sort as
13056 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13058 if (kid->op_type == OP_LEAVE)
13059 op_null(kid); /* wipe out leave */
13060 /* Prevent execution from escaping out of the sort block. */
13063 /* provide scalar context for comparison function/block */
13064 kid = scalar(firstkid);
13065 kid->op_next = kid;
13066 o->op_flags |= OPf_SPECIAL;
13068 else if (kid->op_type == OP_CONST
13069 && kid->op_private & OPpCONST_BARE) {
13073 const char * const name = SvPV(kSVOP_sv, len);
13075 assert (len < 256);
13076 Copy(name, tmpbuf+1, len, char);
13077 off = pad_findmy_pvn(tmpbuf, len+1, 0);
13078 if (off != NOT_IN_PAD) {
13079 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
13081 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
13082 sv_catpvs(fq, "::");
13083 sv_catsv(fq, kSVOP_sv);
13084 SvREFCNT_dec_NN(kSVOP_sv);
13088 OP * const padop = newOP(OP_PADCV, 0);
13089 padop->op_targ = off;
13090 /* replace the const op with the pad op */
13091 op_sibling_splice(firstkid, NULL, 1, padop);
13097 firstkid = OpSIBLING(firstkid);
13100 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13101 /* provide list context for arguments */
13104 op_lvalue(kid, OP_GREPSTART);
13110 /* for sort { X } ..., where X is one of
13111 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
13112 * elide the second child of the sort (the one containing X),
13113 * and set these flags as appropriate
13117 * Also, check and warn on lexical $a, $b.
13121 S_simplify_sort(pTHX_ OP *o)
13123 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13127 const char *gvname;
13130 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
13132 kid = kUNOP->op_first; /* get past null */
13133 if (!(have_scopeop = kid->op_type == OP_SCOPE)
13134 && kid->op_type != OP_LEAVE)
13136 kid = kLISTOP->op_last; /* get past scope */
13137 switch(kid->op_type) {
13141 if (!have_scopeop) goto padkids;
13146 k = kid; /* remember this node*/
13147 if (kBINOP->op_first->op_type != OP_RV2SV
13148 || kBINOP->op_last ->op_type != OP_RV2SV)
13151 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
13152 then used in a comparison. This catches most, but not
13153 all cases. For instance, it catches
13154 sort { my($a); $a <=> $b }
13156 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
13157 (although why you'd do that is anyone's guess).
13161 if (!ckWARN(WARN_SYNTAX)) return;
13162 kid = kBINOP->op_first;
13164 if (kid->op_type == OP_PADSV) {
13165 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
13166 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
13167 && ( PadnamePV(name)[1] == 'a'
13168 || PadnamePV(name)[1] == 'b' ))
13169 /* diag_listed_as: "my %s" used in sort comparison */
13170 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13171 "\"%s %s\" used in sort comparison",
13172 PadnameIsSTATE(name)
13177 } while ((kid = OpSIBLING(kid)));
13180 kid = kBINOP->op_first; /* get past cmp */
13181 if (kUNOP->op_first->op_type != OP_GV)
13183 kid = kUNOP->op_first; /* get past rv2sv */
13185 if (GvSTASH(gv) != PL_curstash)
13187 gvname = GvNAME(gv);
13188 if (*gvname == 'a' && gvname[1] == '\0')
13190 else if (*gvname == 'b' && gvname[1] == '\0')
13195 kid = k; /* back to cmp */
13196 /* already checked above that it is rv2sv */
13197 kid = kBINOP->op_last; /* down to 2nd arg */
13198 if (kUNOP->op_first->op_type != OP_GV)
13200 kid = kUNOP->op_first; /* get past rv2sv */
13202 if (GvSTASH(gv) != PL_curstash)
13204 gvname = GvNAME(gv);
13206 ? !(*gvname == 'a' && gvname[1] == '\0')
13207 : !(*gvname == 'b' && gvname[1] == '\0'))
13209 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
13211 o->op_private |= OPpSORT_DESCEND;
13212 if (k->op_type == OP_NCMP)
13213 o->op_private |= OPpSORT_NUMERIC;
13214 if (k->op_type == OP_I_NCMP)
13215 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
13216 kid = OpSIBLING(cLISTOPo->op_first);
13217 /* cut out and delete old block (second sibling) */
13218 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
13223 Perl_ck_split(pTHX_ OP *o)
13229 PERL_ARGS_ASSERT_CK_SPLIT;
13231 assert(o->op_type == OP_LIST);
13233 if (o->op_flags & OPf_STACKED)
13234 return no_fh_allowed(o);
13236 kid = cLISTOPo->op_first;
13237 /* delete leading NULL node, then add a CONST if no other nodes */
13238 assert(kid->op_type == OP_NULL);
13239 op_sibling_splice(o, NULL, 1,
13240 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
13242 kid = cLISTOPo->op_first;
13244 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
13245 /* remove match expression, and replace with new optree with
13246 * a match op at its head */
13247 op_sibling_splice(o, NULL, 1, NULL);
13248 /* pmruntime will handle split " " behavior with flag==2 */
13249 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
13250 op_sibling_splice(o, NULL, 0, kid);
13253 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
13255 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
13256 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
13257 "Use of /g modifier is meaningless in split");
13260 /* eliminate the split op, and move the match op (plus any children)
13261 * into its place, then convert the match op into a split op. i.e.
13263 * SPLIT MATCH SPLIT(ex-MATCH)
13265 * MATCH - A - B - C => R - A - B - C => R - A - B - C
13271 * (R, if it exists, will be a regcomp op)
13274 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
13275 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
13276 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
13277 OpTYPE_set(kid, OP_SPLIT);
13278 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
13279 kid->op_private = o->op_private;
13282 kid = sibs; /* kid is now the string arg of the split */
13285 kid = newDEFSVOP();
13286 op_append_elem(OP_SPLIT, o, kid);
13290 kid = OpSIBLING(kid);
13292 kid = newSVOP(OP_CONST, 0, newSViv(0));
13293 op_append_elem(OP_SPLIT, o, kid);
13294 o->op_private |= OPpSPLIT_IMPLIM;
13298 if (OpHAS_SIBLING(kid))
13299 return too_many_arguments_pv(o,OP_DESC(o), 0);
13305 Perl_ck_stringify(pTHX_ OP *o)
13307 OP * const kid = OpSIBLING(cUNOPo->op_first);
13308 PERL_ARGS_ASSERT_CK_STRINGIFY;
13309 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
13310 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
13311 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
13312 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
13314 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
13322 Perl_ck_join(pTHX_ OP *o)
13324 OP * const kid = OpSIBLING(cLISTOPo->op_first);
13326 PERL_ARGS_ASSERT_CK_JOIN;
13328 if (kid && kid->op_type == OP_MATCH) {
13329 if (ckWARN(WARN_SYNTAX)) {
13330 const REGEXP *re = PM_GETRE(kPMOP);
13332 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
13333 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
13334 : newSVpvs_flags( "STRING", SVs_TEMP );
13335 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13336 "/%" SVf "/ should probably be written as \"%" SVf "\"",
13337 SVfARG(msg), SVfARG(msg));
13341 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
13342 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
13343 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
13344 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
13346 const OP * const bairn = OpSIBLING(kid); /* the list */
13347 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
13348 && OP_GIMME(bairn,0) == G_SCALAR)
13350 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13351 op_sibling_splice(o, kid, 1, NULL));
13361 =for apidoc rv2cv_op_cv
13363 Examines an op, which is expected to identify a subroutine at runtime,
13364 and attempts to determine at compile time which subroutine it identifies.
13365 This is normally used during Perl compilation to determine whether
13366 a prototype can be applied to a function call. C<cvop> is the op
13367 being considered, normally an C<rv2cv> op. A pointer to the identified
13368 subroutine is returned, if it could be determined statically, and a null
13369 pointer is returned if it was not possible to determine statically.
13371 Currently, the subroutine can be identified statically if the RV that the
13372 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13373 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
13374 suitable if the constant value must be an RV pointing to a CV. Details of
13375 this process may change in future versions of Perl. If the C<rv2cv> op
13376 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13377 the subroutine statically: this flag is used to suppress compile-time
13378 magic on a subroutine call, forcing it to use default runtime behaviour.
13380 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13381 of a GV reference is modified. If a GV was examined and its CV slot was
13382 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13383 If the op is not optimised away, and the CV slot is later populated with
13384 a subroutine having a prototype, that flag eventually triggers the warning
13385 "called too early to check prototype".
13387 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13388 of returning a pointer to the subroutine it returns a pointer to the
13389 GV giving the most appropriate name for the subroutine in this context.
13390 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13391 (C<CvANON>) subroutine that is referenced through a GV it will be the
13392 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
13393 A null pointer is returned as usual if there is no statically-determinable
13399 /* shared by toke.c:yylex */
13401 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13403 PADNAME *name = PAD_COMPNAME(off);
13404 CV *compcv = PL_compcv;
13405 while (PadnameOUTER(name)) {
13406 assert(PARENT_PAD_INDEX(name));
13407 compcv = CvOUTSIDE(compcv);
13408 name = PadlistNAMESARRAY(CvPADLIST(compcv))
13409 [off = PARENT_PAD_INDEX(name)];
13411 assert(!PadnameIsOUR(name));
13412 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13413 return PadnamePROTOCV(name);
13415 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13419 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13424 PERL_ARGS_ASSERT_RV2CV_OP_CV;
13425 if (flags & ~RV2CVOPCV_FLAG_MASK)
13426 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13427 if (cvop->op_type != OP_RV2CV)
13429 if (cvop->op_private & OPpENTERSUB_AMPER)
13431 if (!(cvop->op_flags & OPf_KIDS))
13433 rvop = cUNOPx(cvop)->op_first;
13434 switch (rvop->op_type) {
13436 gv = cGVOPx_gv(rvop);
13438 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13439 cv = MUTABLE_CV(SvRV(gv));
13443 if (flags & RV2CVOPCV_RETURN_STUB)
13449 if (flags & RV2CVOPCV_MARK_EARLY)
13450 rvop->op_private |= OPpEARLY_CV;
13455 SV *rv = cSVOPx_sv(rvop);
13458 cv = (CV*)SvRV(rv);
13462 cv = find_lexical_cv(rvop->op_targ);
13467 } NOT_REACHED; /* NOTREACHED */
13469 if (SvTYPE((SV*)cv) != SVt_PVCV)
13471 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13472 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13476 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13477 if (CvLEXICAL(cv) || CvNAMED(cv))
13479 if (!CvANON(cv) || !gv)
13489 =for apidoc ck_entersub_args_list
13491 Performs the default fixup of the arguments part of an C<entersub>
13492 op tree. This consists of applying list context to each of the
13493 argument ops. This is the standard treatment used on a call marked
13494 with C<&>, or a method call, or a call through a subroutine reference,
13495 or any other call where the callee can't be identified at compile time,
13496 or a call where the callee has no prototype.
13502 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13506 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13508 aop = cUNOPx(entersubop)->op_first;
13509 if (!OpHAS_SIBLING(aop))
13510 aop = cUNOPx(aop)->op_first;
13511 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13512 /* skip the extra attributes->import() call implicitly added in
13513 * something like foo(my $x : bar)
13515 if ( aop->op_type == OP_ENTERSUB
13516 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13520 op_lvalue(aop, OP_ENTERSUB);
13526 =for apidoc ck_entersub_args_proto
13528 Performs the fixup of the arguments part of an C<entersub> op tree
13529 based on a subroutine prototype. This makes various modifications to
13530 the argument ops, from applying context up to inserting C<refgen> ops,
13531 and checking the number and syntactic types of arguments, as directed by
13532 the prototype. This is the standard treatment used on a subroutine call,
13533 not marked with C<&>, where the callee can be identified at compile time
13534 and has a prototype.
13536 C<protosv> supplies the subroutine prototype to be applied to the call.
13537 It may be a normal defined scalar, of which the string value will be used.
13538 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13539 that has been cast to C<SV*>) which has a prototype. The prototype
13540 supplied, in whichever form, does not need to match the actual callee
13541 referenced by the op tree.
13543 If the argument ops disagree with the prototype, for example by having
13544 an unacceptable number of arguments, a valid op tree is returned anyway.
13545 The error is reflected in the parser state, normally resulting in a single
13546 exception at the top level of parsing which covers all the compilation
13547 errors that occurred. In the error message, the callee is referred to
13548 by the name defined by the C<namegv> parameter.
13554 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13557 const char *proto, *proto_end;
13558 OP *aop, *prev, *cvop, *parent;
13561 I32 contextclass = 0;
13562 const char *e = NULL;
13563 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13564 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13565 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13566 "flags=%lx", (unsigned long) SvFLAGS(protosv));
13567 if (SvTYPE(protosv) == SVt_PVCV)
13568 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13569 else proto = SvPV(protosv, proto_len);
13570 proto = S_strip_spaces(aTHX_ proto, &proto_len);
13571 proto_end = proto + proto_len;
13572 parent = entersubop;
13573 aop = cUNOPx(entersubop)->op_first;
13574 if (!OpHAS_SIBLING(aop)) {
13576 aop = cUNOPx(aop)->op_first;
13579 aop = OpSIBLING(aop);
13580 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13581 while (aop != cvop) {
13584 if (proto >= proto_end)
13586 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13587 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13588 SVfARG(namesv)), SvUTF8(namesv));
13598 /* _ must be at the end */
13599 if (proto[1] && !strchr(";@%", proto[1]))
13615 if ( o3->op_type != OP_UNDEF
13616 && (o3->op_type != OP_SREFGEN
13617 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13619 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13621 bad_type_gv(arg, namegv, o3,
13622 arg == 1 ? "block or sub {}" : "sub {}");
13625 /* '*' allows any scalar type, including bareword */
13628 if (o3->op_type == OP_RV2GV)
13629 goto wrapref; /* autoconvert GLOB -> GLOBref */
13630 else if (o3->op_type == OP_CONST)
13631 o3->op_private &= ~OPpCONST_STRICT;
13637 if (o3->op_type == OP_RV2AV ||
13638 o3->op_type == OP_PADAV ||
13639 o3->op_type == OP_RV2HV ||
13640 o3->op_type == OP_PADHV
13646 case '[': case ']':
13653 switch (*proto++) {
13655 if (contextclass++ == 0) {
13656 e = (char *) memchr(proto, ']', proto_end - proto);
13657 if (!e || e == proto)
13665 if (contextclass) {
13666 const char *p = proto;
13667 const char *const end = proto;
13669 while (*--p != '[')
13670 /* \[$] accepts any scalar lvalue */
13672 && Perl_op_lvalue_flags(aTHX_
13674 OP_READ, /* not entersub */
13677 bad_type_gv(arg, namegv, o3,
13678 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13683 if (o3->op_type == OP_RV2GV)
13686 bad_type_gv(arg, namegv, o3, "symbol");
13689 if (o3->op_type == OP_ENTERSUB
13690 && !(o3->op_flags & OPf_STACKED))
13693 bad_type_gv(arg, namegv, o3, "subroutine");
13696 if (o3->op_type == OP_RV2SV ||
13697 o3->op_type == OP_PADSV ||
13698 o3->op_type == OP_HELEM ||
13699 o3->op_type == OP_AELEM)
13701 if (!contextclass) {
13702 /* \$ accepts any scalar lvalue */
13703 if (Perl_op_lvalue_flags(aTHX_
13705 OP_READ, /* not entersub */
13708 bad_type_gv(arg, namegv, o3, "scalar");
13712 if (o3->op_type == OP_RV2AV ||
13713 o3->op_type == OP_PADAV)
13715 o3->op_flags &=~ OPf_PARENS;
13719 bad_type_gv(arg, namegv, o3, "array");
13722 if (o3->op_type == OP_RV2HV ||
13723 o3->op_type == OP_PADHV)
13725 o3->op_flags &=~ OPf_PARENS;
13729 bad_type_gv(arg, namegv, o3, "hash");
13732 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13734 if (contextclass && e) {
13739 default: goto oops;
13749 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13750 SVfARG(cv_name((CV *)namegv, NULL, 0)),
13755 op_lvalue(aop, OP_ENTERSUB);
13757 aop = OpSIBLING(aop);
13759 if (aop == cvop && *proto == '_') {
13760 /* generate an access to $_ */
13761 op_sibling_splice(parent, prev, 0, newDEFSVOP());
13763 if (!optional && proto_end > proto &&
13764 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13766 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13767 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13768 SVfARG(namesv)), SvUTF8(namesv));
13774 =for apidoc ck_entersub_args_proto_or_list
13776 Performs the fixup of the arguments part of an C<entersub> op tree either
13777 based on a subroutine prototype or using default list-context processing.
13778 This is the standard treatment used on a subroutine call, not marked
13779 with C<&>, where the callee can be identified at compile time.
13781 C<protosv> supplies the subroutine prototype to be applied to the call,
13782 or indicates that there is no prototype. It may be a normal scalar,
13783 in which case if it is defined then the string value will be used
13784 as a prototype, and if it is undefined then there is no prototype.
13785 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13786 that has been cast to C<SV*>), of which the prototype will be used if it
13787 has one. The prototype (or lack thereof) supplied, in whichever form,
13788 does not need to match the actual callee referenced by the op tree.
13790 If the argument ops disagree with the prototype, for example by having
13791 an unacceptable number of arguments, a valid op tree is returned anyway.
13792 The error is reflected in the parser state, normally resulting in a single
13793 exception at the top level of parsing which covers all the compilation
13794 errors that occurred. In the error message, the callee is referred to
13795 by the name defined by the C<namegv> parameter.
13801 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13802 GV *namegv, SV *protosv)
13804 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13805 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13806 return ck_entersub_args_proto(entersubop, namegv, protosv);
13808 return ck_entersub_args_list(entersubop);
13812 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13814 IV cvflags = SvIVX(protosv);
13815 int opnum = cvflags & 0xffff;
13816 OP *aop = cUNOPx(entersubop)->op_first;
13818 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13822 if (!OpHAS_SIBLING(aop))
13823 aop = cUNOPx(aop)->op_first;
13824 aop = OpSIBLING(aop);
13825 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13827 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13828 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13829 SVfARG(namesv)), SvUTF8(namesv));
13832 op_free(entersubop);
13833 switch(cvflags >> 16) {
13834 case 'F': return newSVOP(OP_CONST, 0,
13835 newSVpv(CopFILE(PL_curcop),0));
13836 case 'L': return newSVOP(
13838 Perl_newSVpvf(aTHX_
13839 "%" IVdf, (IV)CopLINE(PL_curcop)
13842 case 'P': return newSVOP(OP_CONST, 0,
13844 ? newSVhek(HvNAME_HEK(PL_curstash))
13849 NOT_REACHED; /* NOTREACHED */
13852 OP *prev, *cvop, *first, *parent;
13855 parent = entersubop;
13856 if (!OpHAS_SIBLING(aop)) {
13858 aop = cUNOPx(aop)->op_first;
13861 first = prev = aop;
13862 aop = OpSIBLING(aop);
13863 /* find last sibling */
13865 OpHAS_SIBLING(cvop);
13866 prev = cvop, cvop = OpSIBLING(cvop))
13868 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13869 /* Usually, OPf_SPECIAL on an op with no args means that it had
13870 * parens, but these have their own meaning for that flag: */
13871 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13872 && opnum != OP_DELETE && opnum != OP_EXISTS)
13873 flags |= OPf_SPECIAL;
13874 /* excise cvop from end of sibling chain */
13875 op_sibling_splice(parent, prev, 1, NULL);
13877 if (aop == cvop) aop = NULL;
13879 /* detach remaining siblings from the first sibling, then
13880 * dispose of original optree */
13883 op_sibling_splice(parent, first, -1, NULL);
13884 op_free(entersubop);
13886 if (cvflags == (OP_ENTEREVAL | (1<<16)))
13887 flags |= OPpEVAL_BYTES <<8;
13889 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13891 case OA_BASEOP_OR_UNOP:
13892 case OA_FILESTATOP:
13894 return newOP(opnum,flags); /* zero args */
13896 return newUNOP(opnum,flags,aop); /* one arg */
13897 /* too many args */
13904 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13905 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13906 SVfARG(namesv)), SvUTF8(namesv));
13908 nextop = OpSIBLING(aop);
13914 return opnum == OP_RUNCV
13915 ? newPVOP(OP_RUNCV,0,NULL)
13918 return op_convert_list(opnum,0,aop);
13921 NOT_REACHED; /* NOTREACHED */
13926 =for apidoc cv_get_call_checker_flags
13928 Retrieves the function that will be used to fix up a call to C<cv>.
13929 Specifically, the function is applied to an C<entersub> op tree for a
13930 subroutine call, not marked with C<&>, where the callee can be identified
13931 at compile time as C<cv>.
13933 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13934 for it is returned in C<*ckobj_p>, and control flags are returned in
13935 C<*ckflags_p>. The function is intended to be called in this manner:
13937 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13939 In this call, C<entersubop> is a pointer to the C<entersub> op,
13940 which may be replaced by the check function, and C<namegv> supplies
13941 the name that should be used by the check function to refer
13942 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13943 It is permitted to apply the check function in non-standard situations,
13944 such as to a call to a different subroutine or to a method call.
13946 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
13947 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13948 instead, anything that can be used as the first argument to L</cv_name>.
13949 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13950 check function requires C<namegv> to be a genuine GV.
13952 By default, the check function is
13953 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13954 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13955 flag is clear. This implements standard prototype processing. It can
13956 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13958 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13959 indicates that the caller only knows about the genuine GV version of
13960 C<namegv>, and accordingly the corresponding bit will always be set in
13961 C<*ckflags_p>, regardless of the check function's recorded requirements.
13962 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13963 indicates the caller knows about the possibility of passing something
13964 other than a GV as C<namegv>, and accordingly the corresponding bit may
13965 be either set or clear in C<*ckflags_p>, indicating the check function's
13966 recorded requirements.
13968 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13969 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13970 (for which see above). All other bits should be clear.
13972 =for apidoc cv_get_call_checker
13974 The original form of L</cv_get_call_checker_flags>, which does not return
13975 checker flags. When using a checker function returned by this function,
13976 it is only safe to call it with a genuine GV as its C<namegv> argument.
13982 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13983 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13986 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13987 PERL_UNUSED_CONTEXT;
13988 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13990 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13991 *ckobj_p = callmg->mg_obj;
13992 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13994 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13995 *ckobj_p = (SV*)cv;
13996 *ckflags_p = gflags & MGf_REQUIRE_GV;
14001 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14004 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14005 PERL_UNUSED_CONTEXT;
14006 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14011 =for apidoc cv_set_call_checker_flags
14013 Sets the function that will be used to fix up a call to C<cv>.
14014 Specifically, the function is applied to an C<entersub> op tree for a
14015 subroutine call, not marked with C<&>, where the callee can be identified
14016 at compile time as C<cv>.
14018 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14019 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14020 The function should be defined like this:
14022 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14024 It is intended to be called in this manner:
14026 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14028 In this call, C<entersubop> is a pointer to the C<entersub> op,
14029 which may be replaced by the check function, and C<namegv> supplies
14030 the name that should be used by the check function to refer
14031 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14032 It is permitted to apply the check function in non-standard situations,
14033 such as to a call to a different subroutine or to a method call.
14035 C<namegv> may not actually be a GV. For efficiency, perl may pass a
14036 CV or other SV instead. Whatever is passed can be used as the first
14037 argument to L</cv_name>. You can force perl to pass a GV by including
14038 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14040 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14041 bit currently has a defined meaning (for which see above). All other
14042 bits should be clear.
14044 The current setting for a particular CV can be retrieved by
14045 L</cv_get_call_checker_flags>.
14047 =for apidoc cv_set_call_checker
14049 The original form of L</cv_set_call_checker_flags>, which passes it the
14050 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
14051 of that flag setting is that the check function is guaranteed to get a
14052 genuine GV as its C<namegv> argument.
14058 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14060 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14061 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14065 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14066 SV *ckobj, U32 ckflags)
14068 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14069 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
14070 if (SvMAGICAL((SV*)cv))
14071 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
14074 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
14075 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
14077 if (callmg->mg_flags & MGf_REFCOUNTED) {
14078 SvREFCNT_dec(callmg->mg_obj);
14079 callmg->mg_flags &= ~MGf_REFCOUNTED;
14081 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
14082 callmg->mg_obj = ckobj;
14083 if (ckobj != (SV*)cv) {
14084 SvREFCNT_inc_simple_void_NN(ckobj);
14085 callmg->mg_flags |= MGf_REFCOUNTED;
14087 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
14088 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
14093 S_entersub_alloc_targ(pTHX_ OP * const o)
14095 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14096 o->op_private |= OPpENTERSUB_HASTARG;
14100 Perl_ck_subr(pTHX_ OP *o)
14105 SV **const_class = NULL;
14107 PERL_ARGS_ASSERT_CK_SUBR;
14109 aop = cUNOPx(o)->op_first;
14110 if (!OpHAS_SIBLING(aop))
14111 aop = cUNOPx(aop)->op_first;
14112 aop = OpSIBLING(aop);
14113 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14114 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
14115 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
14117 o->op_private &= ~1;
14118 o->op_private |= (PL_hints & HINT_STRICT_REFS);
14119 if (PERLDB_SUB && PL_curstash != PL_debstash)
14120 o->op_private |= OPpENTERSUB_DB;
14121 switch (cvop->op_type) {
14123 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
14127 case OP_METHOD_NAMED:
14128 case OP_METHOD_SUPER:
14129 case OP_METHOD_REDIR:
14130 case OP_METHOD_REDIR_SUPER:
14131 o->op_flags |= OPf_REF;
14132 if (aop->op_type == OP_CONST) {
14133 aop->op_private &= ~OPpCONST_STRICT;
14134 const_class = &cSVOPx(aop)->op_sv;
14136 else if (aop->op_type == OP_LIST) {
14137 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
14138 if (sib && sib->op_type == OP_CONST) {
14139 sib->op_private &= ~OPpCONST_STRICT;
14140 const_class = &cSVOPx(sib)->op_sv;
14143 /* make class name a shared cow string to speedup method calls */
14144 /* constant string might be replaced with object, f.e. bigint */
14145 if (const_class && SvPOK(*const_class)) {
14147 const char* str = SvPV(*const_class, len);
14149 SV* const shared = newSVpvn_share(
14150 str, SvUTF8(*const_class)
14151 ? -(SSize_t)len : (SSize_t)len,
14154 if (SvREADONLY(*const_class))
14155 SvREADONLY_on(shared);
14156 SvREFCNT_dec(*const_class);
14157 *const_class = shared;
14164 S_entersub_alloc_targ(aTHX_ o);
14165 return ck_entersub_args_list(o);
14167 Perl_call_checker ckfun;
14170 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
14171 if (CvISXSUB(cv) || !CvROOT(cv))
14172 S_entersub_alloc_targ(aTHX_ o);
14174 /* The original call checker API guarantees that a GV will be
14175 be provided with the right name. So, if the old API was
14176 used (or the REQUIRE_GV flag was passed), we have to reify
14177 the CV’s GV, unless this is an anonymous sub. This is not
14178 ideal for lexical subs, as its stringification will include
14179 the package. But it is the best we can do. */
14180 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
14181 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
14184 else namegv = MUTABLE_GV(cv);
14185 /* After a syntax error in a lexical sub, the cv that
14186 rv2cv_op_cv returns may be a nameless stub. */
14187 if (!namegv) return ck_entersub_args_list(o);
14190 return ckfun(aTHX_ o, namegv, ckobj);
14195 Perl_ck_svconst(pTHX_ OP *o)
14197 SV * const sv = cSVOPo->op_sv;
14198 PERL_ARGS_ASSERT_CK_SVCONST;
14199 PERL_UNUSED_CONTEXT;
14200 #ifdef PERL_COPY_ON_WRITE
14201 /* Since the read-only flag may be used to protect a string buffer, we
14202 cannot do copy-on-write with existing read-only scalars that are not
14203 already copy-on-write scalars. To allow $_ = "hello" to do COW with
14204 that constant, mark the constant as COWable here, if it is not
14205 already read-only. */
14206 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
14209 # ifdef PERL_DEBUG_READONLY_COW
14219 Perl_ck_trunc(pTHX_ OP *o)
14221 PERL_ARGS_ASSERT_CK_TRUNC;
14223 if (o->op_flags & OPf_KIDS) {
14224 SVOP *kid = (SVOP*)cUNOPo->op_first;
14226 if (kid->op_type == OP_NULL)
14227 kid = (SVOP*)OpSIBLING(kid);
14228 if (kid && kid->op_type == OP_CONST &&
14229 (kid->op_private & OPpCONST_BARE) &&
14232 o->op_flags |= OPf_SPECIAL;
14233 kid->op_private &= ~OPpCONST_STRICT;
14240 Perl_ck_substr(pTHX_ OP *o)
14242 PERL_ARGS_ASSERT_CK_SUBSTR;
14245 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
14246 OP *kid = cLISTOPo->op_first;
14248 if (kid->op_type == OP_NULL)
14249 kid = OpSIBLING(kid);
14251 /* Historically, substr(delete $foo{bar},...) has been allowed
14252 with 4-arg substr. Keep it working by applying entersub
14254 op_lvalue(kid, OP_ENTERSUB);
14261 Perl_ck_tell(pTHX_ OP *o)
14263 PERL_ARGS_ASSERT_CK_TELL;
14265 if (o->op_flags & OPf_KIDS) {
14266 OP *kid = cLISTOPo->op_first;
14267 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
14268 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
14274 Perl_ck_each(pTHX_ OP *o)
14277 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
14278 const unsigned orig_type = o->op_type;
14280 PERL_ARGS_ASSERT_CK_EACH;
14283 switch (kid->op_type) {
14289 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
14290 : orig_type == OP_KEYS ? OP_AKEYS
14294 if (kid->op_private == OPpCONST_BARE
14295 || !SvROK(cSVOPx_sv(kid))
14296 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
14297 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
14302 qerror(Perl_mess(aTHX_
14303 "Experimental %s on scalar is now forbidden",
14304 PL_op_desc[orig_type]));
14306 bad_type_pv(1, "hash or array", o, kid);
14314 Perl_ck_length(pTHX_ OP *o)
14316 PERL_ARGS_ASSERT_CK_LENGTH;
14320 if (ckWARN(WARN_SYNTAX)) {
14321 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
14325 const bool hash = kid->op_type == OP_PADHV
14326 || kid->op_type == OP_RV2HV;
14327 switch (kid->op_type) {
14332 name = S_op_varname(aTHX_ kid);
14338 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14339 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
14341 SVfARG(name), hash ? "keys " : "", SVfARG(name)
14344 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14345 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14346 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
14348 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14349 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14350 "length() used on @array (did you mean \"scalar(@array)\"?)");
14360 ---------------------------------------------------------
14362 Common vars in list assignment
14364 There now follows some enums and static functions for detecting
14365 common variables in list assignments. Here is a little essay I wrote
14366 for myself when trying to get my head around this. DAPM.
14370 First some random observations:
14372 * If a lexical var is an alias of something else, e.g.
14373 for my $x ($lex, $pkg, $a[0]) {...}
14374 then the act of aliasing will increase the reference count of the SV
14376 * If a package var is an alias of something else, it may still have a
14377 reference count of 1, depending on how the alias was created, e.g.
14378 in *a = *b, $a may have a refcount of 1 since the GP is shared
14379 with a single GvSV pointer to the SV. So If it's an alias of another
14380 package var, then RC may be 1; if it's an alias of another scalar, e.g.
14381 a lexical var or an array element, then it will have RC > 1.
14383 * There are many ways to create a package alias; ultimately, XS code
14384 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
14385 run-time tracing mechanisms are unlikely to be able to catch all cases.
14387 * When the LHS is all my declarations, the same vars can't appear directly
14388 on the RHS, but they can indirectly via closures, aliasing and lvalue
14389 subs. But those techniques all involve an increase in the lexical
14390 scalar's ref count.
14392 * When the LHS is all lexical vars (but not necessarily my declarations),
14393 it is possible for the same lexicals to appear directly on the RHS, and
14394 without an increased ref count, since the stack isn't refcounted.
14395 This case can be detected at compile time by scanning for common lex
14396 vars with PL_generation.
14398 * lvalue subs defeat common var detection, but they do at least
14399 return vars with a temporary ref count increment. Also, you can't
14400 tell at compile time whether a sub call is lvalue.
14405 A: There are a few circumstances where there definitely can't be any
14408 LHS empty: () = (...);
14409 RHS empty: (....) = ();
14410 RHS contains only constants or other 'can't possibly be shared'
14411 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
14412 i.e. they only contain ops not marked as dangerous, whose children
14413 are also not dangerous;
14415 LHS contains a single scalar element: e.g. ($x) = (....); because
14416 after $x has been modified, it won't be used again on the RHS;
14417 RHS contains a single element with no aggregate on LHS: e.g.
14418 ($a,$b,$c) = ($x); again, once $a has been modified, its value
14419 won't be used again.
14421 B: If LHS are all 'my' lexical var declarations (or safe ops, which
14424 my ($a, $b, @c) = ...;
14426 Due to closure and goto tricks, these vars may already have content.
14427 For the same reason, an element on the RHS may be a lexical or package
14428 alias of one of the vars on the left, or share common elements, for
14431 my ($x,$y) = f(); # $x and $y on both sides
14432 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14437 my @a = @$ra; # elements of @a on both sides
14438 sub f { @a = 1..4; \@a }
14441 First, just consider scalar vars on LHS:
14443 RHS is safe only if (A), or in addition,
14444 * contains only lexical *scalar* vars, where neither side's
14445 lexicals have been flagged as aliases
14447 If RHS is not safe, then it's always legal to check LHS vars for
14448 RC==1, since the only RHS aliases will always be associated
14451 Note that in particular, RHS is not safe if:
14453 * it contains package scalar vars; e.g.:
14456 my ($x, $y) = (2, $x_alias);
14457 sub f { $x = 1; *x_alias = \$x; }
14459 * It contains other general elements, such as flattened or
14460 * spliced or single array or hash elements, e.g.
14463 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14467 use feature 'refaliasing';
14468 \($a[0], $a[1]) = \($y,$x);
14471 It doesn't matter if the array/hash is lexical or package.
14473 * it contains a function call that happens to be an lvalue
14474 sub which returns one or more of the above, e.g.
14485 (so a sub call on the RHS should be treated the same
14486 as having a package var on the RHS).
14488 * any other "dangerous" thing, such an op or built-in that
14489 returns one of the above, e.g. pp_preinc
14492 If RHS is not safe, what we can do however is at compile time flag
14493 that the LHS are all my declarations, and at run time check whether
14494 all the LHS have RC == 1, and if so skip the full scan.
14496 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14498 Here the issue is whether there can be elements of @a on the RHS
14499 which will get prematurely freed when @a is cleared prior to
14500 assignment. This is only a problem if the aliasing mechanism
14501 is one which doesn't increase the refcount - only if RC == 1
14502 will the RHS element be prematurely freed.
14504 Because the array/hash is being INTROed, it or its elements
14505 can't directly appear on the RHS:
14507 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14509 but can indirectly, e.g.:
14513 sub f { @a = 1..3; \@a }
14515 So if the RHS isn't safe as defined by (A), we must always
14516 mortalise and bump the ref count of any remaining RHS elements
14517 when assigning to a non-empty LHS aggregate.
14519 Lexical scalars on the RHS aren't safe if they've been involved in
14522 use feature 'refaliasing';
14525 \(my $lex) = \$pkg;
14526 my @a = ($lex,3); # equivalent to ($a[0],3)
14533 Similarly with lexical arrays and hashes on the RHS:
14547 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14548 my $a; ($a, my $b) = (....);
14550 The difference between (B) and (C) is that it is now physically
14551 possible for the LHS vars to appear on the RHS too, where they
14552 are not reference counted; but in this case, the compile-time
14553 PL_generation sweep will detect such common vars.
14555 So the rules for (C) differ from (B) in that if common vars are
14556 detected, the runtime "test RC==1" optimisation can no longer be used,
14557 and a full mark and sweep is required
14559 D: As (C), but in addition the LHS may contain package vars.
14561 Since package vars can be aliased without a corresponding refcount
14562 increase, all bets are off. It's only safe if (A). E.g.
14564 my ($x, $y) = (1,2);
14566 for $x_alias ($x) {
14567 ($x_alias, $y) = (3, $x); # whoops
14570 Ditto for LHS aggregate package vars.
14572 E: Any other dangerous ops on LHS, e.g.
14573 (f(), $a[0], @$r) = (...);
14575 this is similar to (E) in that all bets are off. In addition, it's
14576 impossible to determine at compile time whether the LHS
14577 contains a scalar or an aggregate, e.g.
14579 sub f : lvalue { @a }
14582 * ---------------------------------------------------------
14586 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14587 * that at least one of the things flagged was seen.
14591 AAS_MY_SCALAR = 0x001, /* my $scalar */
14592 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
14593 AAS_LEX_SCALAR = 0x004, /* $lexical */
14594 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
14595 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14596 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
14597 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
14598 AAS_DANGEROUS = 0x080, /* an op (other than the above)
14599 that's flagged OA_DANGEROUS */
14600 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
14601 not in any of the categories above */
14602 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
14607 /* helper function for S_aassign_scan().
14608 * check a PAD-related op for commonality and/or set its generation number.
14609 * Returns a boolean indicating whether its shared */
14612 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14614 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14615 /* lexical used in aliasing */
14619 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14621 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14628 Helper function for OPpASSIGN_COMMON* detection in rpeep().
14629 It scans the left or right hand subtree of the aassign op, and returns a
14630 set of flags indicating what sorts of things it found there.
14631 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14632 set PL_generation on lexical vars; if the latter, we see if
14633 PL_generation matches.
14634 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14635 This fn will increment it by the number seen. It's not intended to
14636 be an accurate count (especially as many ops can push a variable
14637 number of SVs onto the stack); rather it's used as to test whether there
14638 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14642 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
14645 OP *effective_top_op = o;
14649 bool top = o == effective_top_op;
14651 OP* next_kid = NULL;
14653 /* first, look for a solitary @_ on the RHS */
14656 && (o->op_flags & OPf_KIDS)
14657 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14659 OP *kid = cUNOPo->op_first;
14660 if ( ( kid->op_type == OP_PUSHMARK
14661 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14662 && ((kid = OpSIBLING(kid)))
14663 && !OpHAS_SIBLING(kid)
14664 && kid->op_type == OP_RV2AV
14665 && !(kid->op_flags & OPf_REF)
14666 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14667 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14668 && ((kid = cUNOPx(kid)->op_first))
14669 && kid->op_type == OP_GV
14670 && cGVOPx_gv(kid) == PL_defgv
14675 switch (o->op_type) {
14678 all_flags |= AAS_PKG_SCALAR;
14684 /* if !top, could be e.g. @a[0,1] */
14685 all_flags |= (top && (o->op_flags & OPf_REF))
14686 ? ((o->op_private & OPpLVAL_INTRO)
14687 ? AAS_MY_AGG : AAS_LEX_AGG)
14693 int comm = S_aassign_padcheck(aTHX_ o, rhs)
14694 ? AAS_LEX_SCALAR_COMM : 0;
14696 all_flags |= (o->op_private & OPpLVAL_INTRO)
14697 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14705 if (cUNOPx(o)->op_first->op_type != OP_GV)
14706 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
14708 /* if !top, could be e.g. @a[0,1] */
14709 else if (top && (o->op_flags & OPf_REF))
14710 all_flags |= AAS_PKG_AGG;
14712 all_flags |= AAS_DANGEROUS;
14717 if (cUNOPx(o)->op_first->op_type != OP_GV) {
14719 all_flags |= AAS_DANGEROUS; /* ${expr} */
14722 all_flags |= AAS_PKG_SCALAR; /* $pkg */
14726 if (o->op_private & OPpSPLIT_ASSIGN) {
14727 /* the assign in @a = split() has been optimised away
14728 * and the @a attached directly to the split op
14729 * Treat the array as appearing on the RHS, i.e.
14730 * ... = (@a = split)
14735 if (o->op_flags & OPf_STACKED) {
14736 /* @{expr} = split() - the array expression is tacked
14737 * on as an extra child to split - process kid */
14738 next_kid = cLISTOPo->op_last;
14742 /* ... else array is directly attached to split op */
14744 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
14745 ? ((o->op_private & OPpLVAL_INTRO)
14746 ? AAS_MY_AGG : AAS_LEX_AGG)
14751 /* other args of split can't be returned */
14752 all_flags |= AAS_SAFE_SCALAR;
14756 /* undef counts as a scalar on the RHS:
14757 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
14758 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
14762 flags = AAS_SAFE_SCALAR;
14767 /* these are all no-ops; they don't push a potentially common SV
14768 * onto the stack, so they are neither AAS_DANGEROUS nor
14769 * AAS_SAFE_SCALAR */
14772 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14777 /* these do nothing, but may have children */
14781 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14783 flags = AAS_DANGEROUS;
14787 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
14788 && (o->op_private & OPpTARGET_MY))
14791 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
14792 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14796 /* if its an unrecognised, non-dangerous op, assume that it
14797 * it the cause of at least one safe scalar */
14799 flags = AAS_SAFE_SCALAR;
14803 all_flags |= flags;
14805 /* by default, process all kids next
14806 * XXX this assumes that all other ops are "transparent" - i.e. that
14807 * they can return some of their children. While this true for e.g.
14808 * sort and grep, it's not true for e.g. map. We really need a
14809 * 'transparent' flag added to regen/opcodes
14811 if (o->op_flags & OPf_KIDS) {
14812 next_kid = cUNOPo->op_first;
14813 /* these ops do nothing but may have children; but their
14814 * children should also be treated as top-level */
14815 if ( o == effective_top_op
14816 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
14818 effective_top_op = next_kid;
14822 /* If next_kid is set, someone in the code above wanted us to process
14823 * that kid and all its remaining siblings. Otherwise, work our way
14824 * back up the tree */
14826 while (!next_kid) {
14828 return all_flags; /* at top; no parents/siblings to try */
14829 if (OpHAS_SIBLING(o)) {
14830 next_kid = o->op_sibparent;
14831 if (o == effective_top_op)
14832 effective_top_op = next_kid;
14835 if (o == effective_top_op)
14836 effective_top_op = o->op_sibparent;
14837 o = o->op_sibparent; /* try parent's next sibling */
14846 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14847 and modify the optree to make them work inplace */
14850 S_inplace_aassign(pTHX_ OP *o) {
14852 OP *modop, *modop_pushmark;
14854 OP *oleft, *oleft_pushmark;
14856 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14858 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14860 assert(cUNOPo->op_first->op_type == OP_NULL);
14861 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14862 assert(modop_pushmark->op_type == OP_PUSHMARK);
14863 modop = OpSIBLING(modop_pushmark);
14865 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14868 /* no other operation except sort/reverse */
14869 if (OpHAS_SIBLING(modop))
14872 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14873 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14875 if (modop->op_flags & OPf_STACKED) {
14876 /* skip sort subroutine/block */
14877 assert(oright->op_type == OP_NULL);
14878 oright = OpSIBLING(oright);
14881 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14882 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14883 assert(oleft_pushmark->op_type == OP_PUSHMARK);
14884 oleft = OpSIBLING(oleft_pushmark);
14886 /* Check the lhs is an array */
14888 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14889 || OpHAS_SIBLING(oleft)
14890 || (oleft->op_private & OPpLVAL_INTRO)
14894 /* Only one thing on the rhs */
14895 if (OpHAS_SIBLING(oright))
14898 /* check the array is the same on both sides */
14899 if (oleft->op_type == OP_RV2AV) {
14900 if (oright->op_type != OP_RV2AV
14901 || !cUNOPx(oright)->op_first
14902 || cUNOPx(oright)->op_first->op_type != OP_GV
14903 || cUNOPx(oleft )->op_first->op_type != OP_GV
14904 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14905 cGVOPx_gv(cUNOPx(oright)->op_first)
14909 else if (oright->op_type != OP_PADAV
14910 || oright->op_targ != oleft->op_targ
14914 /* This actually is an inplace assignment */
14916 modop->op_private |= OPpSORT_INPLACE;
14918 /* transfer MODishness etc from LHS arg to RHS arg */
14919 oright->op_flags = oleft->op_flags;
14921 /* remove the aassign op and the lhs */
14923 op_null(oleft_pushmark);
14924 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14925 op_null(cUNOPx(oleft)->op_first);
14931 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14932 * that potentially represent a series of one or more aggregate derefs
14933 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14934 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14935 * additional ops left in too).
14937 * The caller will have already verified that the first few ops in the
14938 * chain following 'start' indicate a multideref candidate, and will have
14939 * set 'orig_o' to the point further on in the chain where the first index
14940 * expression (if any) begins. 'orig_action' specifies what type of
14941 * beginning has already been determined by the ops between start..orig_o
14942 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
14944 * 'hints' contains any hints flags that need adding (currently just
14945 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14949 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14953 UNOP_AUX_item *arg_buf = NULL;
14954 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
14955 int index_skip = -1; /* don't output index arg on this action */
14957 /* similar to regex compiling, do two passes; the first pass
14958 * determines whether the op chain is convertible and calculates the
14959 * buffer size; the second pass populates the buffer and makes any
14960 * changes necessary to ops (such as moving consts to the pad on
14961 * threaded builds).
14963 * NB: for things like Coverity, note that both passes take the same
14964 * path through the logic tree (except for 'if (pass)' bits), since
14965 * both passes are following the same op_next chain; and in
14966 * particular, if it would return early on the second pass, it would
14967 * already have returned early on the first pass.
14969 for (pass = 0; pass < 2; pass++) {
14971 UV action = orig_action;
14972 OP *first_elem_op = NULL; /* first seen aelem/helem */
14973 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
14974 int action_count = 0; /* number of actions seen so far */
14975 int action_ix = 0; /* action_count % (actions per IV) */
14976 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
14977 bool is_last = FALSE; /* no more derefs to follow */
14978 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14979 UNOP_AUX_item *arg = arg_buf;
14980 UNOP_AUX_item *action_ptr = arg_buf;
14983 action_ptr->uv = 0;
14987 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14988 case MDEREF_HV_gvhv_helem:
14989 next_is_hash = TRUE;
14991 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14992 case MDEREF_AV_gvav_aelem:
14994 #ifdef USE_ITHREADS
14995 arg->pad_offset = cPADOPx(start)->op_padix;
14996 /* stop it being swiped when nulled */
14997 cPADOPx(start)->op_padix = 0;
14999 arg->sv = cSVOPx(start)->op_sv;
15000 cSVOPx(start)->op_sv = NULL;
15006 case MDEREF_HV_padhv_helem:
15007 case MDEREF_HV_padsv_vivify_rv2hv_helem:
15008 next_is_hash = TRUE;
15010 case MDEREF_AV_padav_aelem:
15011 case MDEREF_AV_padsv_vivify_rv2av_aelem:
15013 arg->pad_offset = start->op_targ;
15014 /* we skip setting op_targ = 0 for now, since the intact
15015 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
15016 reset_start_targ = TRUE;
15021 case MDEREF_HV_pop_rv2hv_helem:
15022 next_is_hash = TRUE;
15024 case MDEREF_AV_pop_rv2av_aelem:
15028 NOT_REACHED; /* NOTREACHED */
15033 /* look for another (rv2av/hv; get index;
15034 * aelem/helem/exists/delele) sequence */
15039 UV index_type = MDEREF_INDEX_none;
15041 if (action_count) {
15042 /* if this is not the first lookup, consume the rv2av/hv */
15044 /* for N levels of aggregate lookup, we normally expect
15045 * that the first N-1 [ah]elem ops will be flagged as
15046 * /DEREF (so they autovivifiy if necessary), and the last
15047 * lookup op not to be.
15048 * For other things (like @{$h{k1}{k2}}) extra scope or
15049 * leave ops can appear, so abandon the effort in that
15051 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
15054 /* rv2av or rv2hv sKR/1 */
15056 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15057 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15058 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15061 /* at this point, we wouldn't expect any of these
15062 * possible private flags:
15063 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
15064 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
15066 ASSUME(!(o->op_private &
15067 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
15069 hints = (o->op_private & OPpHINT_STRICT_REFS);
15071 /* make sure the type of the previous /DEREF matches the
15072 * type of the next lookup */
15073 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
15076 action = next_is_hash
15077 ? MDEREF_HV_vivify_rv2hv_helem
15078 : MDEREF_AV_vivify_rv2av_aelem;
15082 /* if this is the second pass, and we're at the depth where
15083 * previously we encountered a non-simple index expression,
15084 * stop processing the index at this point */
15085 if (action_count != index_skip) {
15087 /* look for one or more simple ops that return an array
15088 * index or hash key */
15090 switch (o->op_type) {
15092 /* it may be a lexical var index */
15093 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
15094 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15095 ASSUME(!(o->op_private &
15096 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15098 if ( OP_GIMME(o,0) == G_SCALAR
15099 && !(o->op_flags & (OPf_REF|OPf_MOD))
15100 && o->op_private == 0)
15103 arg->pad_offset = o->op_targ;
15105 index_type = MDEREF_INDEX_padsv;
15111 if (next_is_hash) {
15112 /* it's a constant hash index */
15113 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
15114 /* "use constant foo => FOO; $h{+foo}" for
15115 * some weird FOO, can leave you with constants
15116 * that aren't simple strings. It's not worth
15117 * the extra hassle for those edge cases */
15122 OP * helem_op = o->op_next;
15124 ASSUME( helem_op->op_type == OP_HELEM
15125 || helem_op->op_type == OP_NULL
15127 if (helem_op->op_type == OP_HELEM) {
15128 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
15129 if ( helem_op->op_private & OPpLVAL_INTRO
15130 || rop->op_type != OP_RV2HV
15134 /* on first pass just check; on second pass
15136 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
15141 #ifdef USE_ITHREADS
15142 /* Relocate sv to the pad for thread safety */
15143 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
15144 arg->pad_offset = o->op_targ;
15147 arg->sv = cSVOPx_sv(o);
15152 /* it's a constant array index */
15154 SV *ix_sv = cSVOPo->op_sv;
15159 if ( action_count == 0
15162 && ( action == MDEREF_AV_padav_aelem
15163 || action == MDEREF_AV_gvav_aelem)
15165 maybe_aelemfast = TRUE;
15169 SvREFCNT_dec_NN(cSVOPo->op_sv);
15173 /* we've taken ownership of the SV */
15174 cSVOPo->op_sv = NULL;
15176 index_type = MDEREF_INDEX_const;
15181 /* it may be a package var index */
15183 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
15184 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
15185 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
15186 || o->op_private != 0
15191 if (kid->op_type != OP_RV2SV)
15194 ASSUME(!(kid->op_flags &
15195 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
15196 |OPf_SPECIAL|OPf_PARENS)));
15197 ASSUME(!(kid->op_private &
15199 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
15200 |OPpDEREF|OPpLVAL_INTRO)));
15201 if( (kid->op_flags &~ OPf_PARENS)
15202 != (OPf_WANT_SCALAR|OPf_KIDS)
15203 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
15208 #ifdef USE_ITHREADS
15209 arg->pad_offset = cPADOPx(o)->op_padix;
15210 /* stop it being swiped when nulled */
15211 cPADOPx(o)->op_padix = 0;
15213 arg->sv = cSVOPx(o)->op_sv;
15214 cSVOPo->op_sv = NULL;
15218 index_type = MDEREF_INDEX_gvsv;
15223 } /* action_count != index_skip */
15225 action |= index_type;
15228 /* at this point we have either:
15229 * * detected what looks like a simple index expression,
15230 * and expect the next op to be an [ah]elem, or
15231 * an nulled [ah]elem followed by a delete or exists;
15232 * * found a more complex expression, so something other
15233 * than the above follows.
15236 /* possibly an optimised away [ah]elem (where op_next is
15237 * exists or delete) */
15238 if (o->op_type == OP_NULL)
15241 /* at this point we're looking for an OP_AELEM, OP_HELEM,
15242 * OP_EXISTS or OP_DELETE */
15244 /* if a custom array/hash access checker is in scope,
15245 * abandon optimisation attempt */
15246 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
15247 && PL_check[o->op_type] != Perl_ck_null)
15249 /* similarly for customised exists and delete */
15250 if ( (o->op_type == OP_EXISTS)
15251 && PL_check[o->op_type] != Perl_ck_exists)
15253 if ( (o->op_type == OP_DELETE)
15254 && PL_check[o->op_type] != Perl_ck_delete)
15257 if ( o->op_type != OP_AELEM
15258 || (o->op_private &
15259 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
15261 maybe_aelemfast = FALSE;
15263 /* look for aelem/helem/exists/delete. If it's not the last elem
15264 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
15265 * flags; if it's the last, then it mustn't have
15266 * OPpDEREF_AV/HV, but may have lots of other flags, like
15267 * OPpLVAL_INTRO etc
15270 if ( index_type == MDEREF_INDEX_none
15271 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
15272 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
15276 /* we have aelem/helem/exists/delete with valid simple index */
15278 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
15279 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
15280 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
15282 /* This doesn't make much sense but is legal:
15283 * @{ local $x[0][0] } = 1
15284 * Since scope exit will undo the autovivification,
15285 * don't bother in the first place. The OP_LEAVE
15286 * assertion is in case there are other cases of both
15287 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
15288 * exit that would undo the local - in which case this
15289 * block of code would need rethinking.
15291 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
15293 OP *n = o->op_next;
15294 while (n && ( n->op_type == OP_NULL
15295 || n->op_type == OP_LIST
15296 || n->op_type == OP_SCALAR))
15298 assert(n && n->op_type == OP_LEAVE);
15300 o->op_private &= ~OPpDEREF;
15305 ASSUME(!(o->op_flags &
15306 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
15307 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
15309 ok = (o->op_flags &~ OPf_PARENS)
15310 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
15311 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
15313 else if (o->op_type == OP_EXISTS) {
15314 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15315 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15316 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
15317 ok = !(o->op_private & ~OPpARG1_MASK);
15319 else if (o->op_type == OP_DELETE) {
15320 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15321 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15322 ASSUME(!(o->op_private &
15323 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
15324 /* don't handle slices or 'local delete'; the latter
15325 * is fairly rare, and has a complex runtime */
15326 ok = !(o->op_private & ~OPpARG1_MASK);
15327 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
15328 /* skip handling run-tome error */
15329 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
15332 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
15333 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
15334 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
15335 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
15336 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
15337 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
15342 if (!first_elem_op)
15346 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
15351 action |= MDEREF_FLAG_last;
15355 /* at this point we have something that started
15356 * promisingly enough (with rv2av or whatever), but failed
15357 * to find a simple index followed by an
15358 * aelem/helem/exists/delete. If this is the first action,
15359 * give up; but if we've already seen at least one
15360 * aelem/helem, then keep them and add a new action with
15361 * MDEREF_INDEX_none, which causes it to do the vivify
15362 * from the end of the previous lookup, and do the deref,
15363 * but stop at that point. So $a[0][expr] will do one
15364 * av_fetch, vivify and deref, then continue executing at
15369 index_skip = action_count;
15370 action |= MDEREF_FLAG_last;
15371 if (index_type != MDEREF_INDEX_none)
15376 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
15379 /* if there's no space for the next action, create a new slot
15380 * for it *before* we start adding args for that action */
15381 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
15388 } /* while !is_last */
15396 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
15397 if (index_skip == -1) {
15398 mderef->op_flags = o->op_flags
15399 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
15400 if (o->op_type == OP_EXISTS)
15401 mderef->op_private = OPpMULTIDEREF_EXISTS;
15402 else if (o->op_type == OP_DELETE)
15403 mderef->op_private = OPpMULTIDEREF_DELETE;
15405 mderef->op_private = o->op_private
15406 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
15408 /* accumulate strictness from every level (although I don't think
15409 * they can actually vary) */
15410 mderef->op_private |= hints;
15412 /* integrate the new multideref op into the optree and the
15415 * In general an op like aelem or helem has two child
15416 * sub-trees: the aggregate expression (a_expr) and the
15417 * index expression (i_expr):
15423 * The a_expr returns an AV or HV, while the i-expr returns an
15424 * index. In general a multideref replaces most or all of a
15425 * multi-level tree, e.g.
15441 * With multideref, all the i_exprs will be simple vars or
15442 * constants, except that i_expr1 may be arbitrary in the case
15443 * of MDEREF_INDEX_none.
15445 * The bottom-most a_expr will be either:
15446 * 1) a simple var (so padXv or gv+rv2Xv);
15447 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
15448 * so a simple var with an extra rv2Xv;
15449 * 3) or an arbitrary expression.
15451 * 'start', the first op in the execution chain, will point to
15452 * 1),2): the padXv or gv op;
15453 * 3): the rv2Xv which forms the last op in the a_expr
15454 * execution chain, and the top-most op in the a_expr
15457 * For all cases, the 'start' node is no longer required,
15458 * but we can't free it since one or more external nodes
15459 * may point to it. E.g. consider
15460 * $h{foo} = $a ? $b : $c
15461 * Here, both the op_next and op_other branches of the
15462 * cond_expr point to the gv[*h] of the hash expression, so
15463 * we can't free the 'start' op.
15465 * For expr->[...], we need to save the subtree containing the
15466 * expression; for the other cases, we just need to save the
15468 * So in all cases, we null the start op and keep it around by
15469 * making it the child of the multideref op; for the expr->
15470 * case, the expr will be a subtree of the start node.
15472 * So in the simple 1,2 case the optree above changes to
15478 * ex-gv (or ex-padxv)
15480 * with the op_next chain being
15482 * -> ex-gv -> multideref -> op-following-ex-exists ->
15484 * In the 3 case, we have
15497 * -> rest-of-a_expr subtree ->
15498 * ex-rv2xv -> multideref -> op-following-ex-exists ->
15501 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15502 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15503 * multideref attached as the child, e.g.
15509 * ex-rv2av - i_expr1
15517 /* if we free this op, don't free the pad entry */
15518 if (reset_start_targ)
15519 start->op_targ = 0;
15522 /* Cut the bit we need to save out of the tree and attach to
15523 * the multideref op, then free the rest of the tree */
15525 /* find parent of node to be detached (for use by splice) */
15527 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
15528 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15530 /* there is an arbitrary expression preceding us, e.g.
15531 * expr->[..]? so we need to save the 'expr' subtree */
15532 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15533 p = cUNOPx(p)->op_first;
15534 ASSUME( start->op_type == OP_RV2AV
15535 || start->op_type == OP_RV2HV);
15538 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15539 * above for exists/delete. */
15540 while ( (p->op_flags & OPf_KIDS)
15541 && cUNOPx(p)->op_first != start
15543 p = cUNOPx(p)->op_first;
15545 ASSUME(cUNOPx(p)->op_first == start);
15547 /* detach from main tree, and re-attach under the multideref */
15548 op_sibling_splice(mderef, NULL, 0,
15549 op_sibling_splice(p, NULL, 1, NULL));
15552 start->op_next = mderef;
15554 mderef->op_next = index_skip == -1 ? o->op_next : o;
15556 /* excise and free the original tree, and replace with
15557 * the multideref op */
15558 p = op_sibling_splice(top_op, NULL, -1, mderef);
15567 Size_t size = arg - arg_buf;
15569 if (maybe_aelemfast && action_count == 1)
15572 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15573 sizeof(UNOP_AUX_item) * (size + 1));
15574 /* for dumping etc: store the length in a hidden first slot;
15575 * we set the op_aux pointer to the second slot */
15576 arg_buf->uv = size;
15579 } /* for (pass = ...) */
15582 /* See if the ops following o are such that o will always be executed in
15583 * boolean context: that is, the SV which o pushes onto the stack will
15584 * only ever be consumed by later ops via SvTRUE(sv) or similar.
15585 * If so, set a suitable private flag on o. Normally this will be
15586 * bool_flag; but see below why maybe_flag is needed too.
15588 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15589 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15590 * already be taken, so you'll have to give that op two different flags.
15592 * More explanation of 'maybe_flag' and 'safe_and' parameters.
15593 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15594 * those underlying ops) short-circuit, which means that rather than
15595 * necessarily returning a truth value, they may return the LH argument,
15596 * which may not be boolean. For example in $x = (keys %h || -1), keys
15597 * should return a key count rather than a boolean, even though its
15598 * sort-of being used in boolean context.
15600 * So we only consider such logical ops to provide boolean context to
15601 * their LH argument if they themselves are in void or boolean context.
15602 * However, sometimes the context isn't known until run-time. In this
15603 * case the op is marked with the maybe_flag flag it.
15605 * Consider the following.
15607 * sub f { ....; if (%h) { .... } }
15609 * This is actually compiled as
15611 * sub f { ....; %h && do { .... } }
15613 * Here we won't know until runtime whether the final statement (and hence
15614 * the &&) is in void context and so is safe to return a boolean value.
15615 * So mark o with maybe_flag rather than the bool_flag.
15616 * Note that there is cost associated with determining context at runtime
15617 * (e.g. a call to block_gimme()), so it may not be worth setting (at
15618 * compile time) and testing (at runtime) maybe_flag if the scalar verses
15619 * boolean costs savings are marginal.
15621 * However, we can do slightly better with && (compared to || and //):
15622 * this op only returns its LH argument when that argument is false. In
15623 * this case, as long as the op promises to return a false value which is
15624 * valid in both boolean and scalar contexts, we can mark an op consumed
15625 * by && with bool_flag rather than maybe_flag.
15626 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15627 * than &PL_sv_no for a false result in boolean context, then it's safe. An
15628 * op which promises to handle this case is indicated by setting safe_and
15633 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15638 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15640 /* OPpTARGET_MY and boolean context probably don't mix well.
15641 * If someone finds a valid use case, maybe add an extra flag to this
15642 * function which indicates its safe to do so for this op? */
15643 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
15644 && (o->op_private & OPpTARGET_MY)));
15649 switch (lop->op_type) {
15654 /* these two consume the stack argument in the scalar case,
15655 * and treat it as a boolean in the non linenumber case */
15658 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15659 || (lop->op_private & OPpFLIP_LINENUM))
15665 /* these never leave the original value on the stack */
15674 /* OR DOR and AND evaluate their arg as a boolean, but then may
15675 * leave the original scalar value on the stack when following the
15676 * op_next route. If not in void context, we need to ensure
15677 * that whatever follows consumes the arg only in boolean context
15689 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15693 else if (!(lop->op_flags & OPf_WANT)) {
15694 /* unknown context - decide at runtime */
15706 lop = lop->op_next;
15709 o->op_private |= flag;
15714 /* mechanism for deferring recursion in rpeep() */
15716 #define MAX_DEFERRED 4
15720 if (defer_ix == (MAX_DEFERRED-1)) { \
15721 OP **defer = defer_queue[defer_base]; \
15722 CALL_RPEEP(*defer); \
15723 S_prune_chain_head(defer); \
15724 defer_base = (defer_base + 1) % MAX_DEFERRED; \
15727 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15730 #define IS_AND_OP(o) (o->op_type == OP_AND)
15731 #define IS_OR_OP(o) (o->op_type == OP_OR)
15734 /* A peephole optimizer. We visit the ops in the order they're to execute.
15735 * See the comments at the top of this file for more details about when
15736 * peep() is called */
15739 Perl_rpeep(pTHX_ OP *o)
15743 OP* oldoldop = NULL;
15744 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15745 int defer_base = 0;
15748 if (!o || o->op_opt)
15751 assert(o->op_type != OP_FREED);
15755 SAVEVPTR(PL_curcop);
15756 for (;; o = o->op_next) {
15757 if (o && o->op_opt)
15760 while (defer_ix >= 0) {
15762 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15763 CALL_RPEEP(*defer);
15764 S_prune_chain_head(defer);
15771 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15772 assert(!oldoldop || oldoldop->op_next == oldop);
15773 assert(!oldop || oldop->op_next == o);
15775 /* By default, this op has now been optimised. A couple of cases below
15776 clear this again. */
15780 /* look for a series of 1 or more aggregate derefs, e.g.
15781 * $a[1]{foo}[$i]{$k}
15782 * and replace with a single OP_MULTIDEREF op.
15783 * Each index must be either a const, or a simple variable,
15785 * First, look for likely combinations of starting ops,
15786 * corresponding to (global and lexical variants of)
15788 * $r->[...] $r->{...}
15789 * (preceding expression)->[...]
15790 * (preceding expression)->{...}
15791 * and if so, call maybe_multideref() to do a full inspection
15792 * of the op chain and if appropriate, replace with an
15800 switch (o2->op_type) {
15802 /* $pkg[..] : gv[*pkg]
15803 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
15805 /* Fail if there are new op flag combinations that we're
15806 * not aware of, rather than:
15807 * * silently failing to optimise, or
15808 * * silently optimising the flag away.
15809 * If this ASSUME starts failing, examine what new flag
15810 * has been added to the op, and decide whether the
15811 * optimisation should still occur with that flag, then
15812 * update the code accordingly. This applies to all the
15813 * other ASSUMEs in the block of code too.
15815 ASSUME(!(o2->op_flags &
15816 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15817 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15821 if (o2->op_type == OP_RV2AV) {
15822 action = MDEREF_AV_gvav_aelem;
15826 if (o2->op_type == OP_RV2HV) {
15827 action = MDEREF_HV_gvhv_helem;
15831 if (o2->op_type != OP_RV2SV)
15834 /* at this point we've seen gv,rv2sv, so the only valid
15835 * construct left is $pkg->[] or $pkg->{} */
15837 ASSUME(!(o2->op_flags & OPf_STACKED));
15838 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15839 != (OPf_WANT_SCALAR|OPf_MOD))
15842 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15843 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15844 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15846 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
15847 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15851 if (o2->op_type == OP_RV2AV) {
15852 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15855 if (o2->op_type == OP_RV2HV) {
15856 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15862 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15864 ASSUME(!(o2->op_flags &
15865 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15866 if ((o2->op_flags &
15867 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15868 != (OPf_WANT_SCALAR|OPf_MOD))
15871 ASSUME(!(o2->op_private &
15872 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15873 /* skip if state or intro, or not a deref */
15874 if ( o2->op_private != OPpDEREF_AV
15875 && o2->op_private != OPpDEREF_HV)
15879 if (o2->op_type == OP_RV2AV) {
15880 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15883 if (o2->op_type == OP_RV2HV) {
15884 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15891 /* $lex[..]: padav[@lex:1,2] sR *
15892 * or $lex{..}: padhv[%lex:1,2] sR */
15893 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15894 OPf_REF|OPf_SPECIAL)));
15895 if ((o2->op_flags &
15896 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15897 != (OPf_WANT_SCALAR|OPf_REF))
15899 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15901 /* OPf_PARENS isn't currently used in this case;
15902 * if that changes, let us know! */
15903 ASSUME(!(o2->op_flags & OPf_PARENS));
15905 /* at this point, we wouldn't expect any of the remaining
15906 * possible private flags:
15907 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15908 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15910 * OPpSLICEWARNING shouldn't affect runtime
15912 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15914 action = o2->op_type == OP_PADAV
15915 ? MDEREF_AV_padav_aelem
15916 : MDEREF_HV_padhv_helem;
15918 S_maybe_multideref(aTHX_ o, o2, action, 0);
15924 action = o2->op_type == OP_RV2AV
15925 ? MDEREF_AV_pop_rv2av_aelem
15926 : MDEREF_HV_pop_rv2hv_helem;
15929 /* (expr)->[...]: rv2av sKR/1;
15930 * (expr)->{...}: rv2hv sKR/1; */
15932 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15934 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15935 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15936 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15939 /* at this point, we wouldn't expect any of these
15940 * possible private flags:
15941 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15942 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15944 ASSUME(!(o2->op_private &
15945 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15947 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15951 S_maybe_multideref(aTHX_ o, o2, action, hints);
15960 switch (o->op_type) {
15962 PL_curcop = ((COP*)o); /* for warnings */
15965 PL_curcop = ((COP*)o); /* for warnings */
15967 /* Optimise a "return ..." at the end of a sub to just be "...".
15968 * This saves 2 ops. Before:
15969 * 1 <;> nextstate(main 1 -e:1) v ->2
15970 * 4 <@> return K ->5
15971 * 2 <0> pushmark s ->3
15972 * - <1> ex-rv2sv sK/1 ->4
15973 * 3 <#> gvsv[*cat] s ->4
15976 * - <@> return K ->-
15977 * - <0> pushmark s ->2
15978 * - <1> ex-rv2sv sK/1 ->-
15979 * 2 <$> gvsv(*cat) s ->3
15982 OP *next = o->op_next;
15983 OP *sibling = OpSIBLING(o);
15984 if ( OP_TYPE_IS(next, OP_PUSHMARK)
15985 && OP_TYPE_IS(sibling, OP_RETURN)
15986 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15987 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15988 ||OP_TYPE_IS(sibling->op_next->op_next,
15990 && cUNOPx(sibling)->op_first == next
15991 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15994 /* Look through the PUSHMARK's siblings for one that
15995 * points to the RETURN */
15996 OP *top = OpSIBLING(next);
15997 while (top && top->op_next) {
15998 if (top->op_next == sibling) {
15999 top->op_next = sibling->op_next;
16000 o->op_next = next->op_next;
16003 top = OpSIBLING(top);
16008 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
16010 * This latter form is then suitable for conversion into padrange
16011 * later on. Convert:
16013 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
16017 * nextstate1 -> listop -> nextstate3
16019 * pushmark -> padop1 -> padop2
16021 if (o->op_next && (
16022 o->op_next->op_type == OP_PADSV
16023 || o->op_next->op_type == OP_PADAV
16024 || o->op_next->op_type == OP_PADHV
16026 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
16027 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
16028 && o->op_next->op_next->op_next && (
16029 o->op_next->op_next->op_next->op_type == OP_PADSV
16030 || o->op_next->op_next->op_next->op_type == OP_PADAV
16031 || o->op_next->op_next->op_next->op_type == OP_PADHV
16033 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
16034 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
16035 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
16036 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
16038 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
16041 ns2 = pad1->op_next;
16042 pad2 = ns2->op_next;
16043 ns3 = pad2->op_next;
16045 /* we assume here that the op_next chain is the same as
16046 * the op_sibling chain */
16047 assert(OpSIBLING(o) == pad1);
16048 assert(OpSIBLING(pad1) == ns2);
16049 assert(OpSIBLING(ns2) == pad2);
16050 assert(OpSIBLING(pad2) == ns3);
16052 /* excise and delete ns2 */
16053 op_sibling_splice(NULL, pad1, 1, NULL);
16056 /* excise pad1 and pad2 */
16057 op_sibling_splice(NULL, o, 2, NULL);
16059 /* create new listop, with children consisting of:
16060 * a new pushmark, pad1, pad2. */
16061 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
16062 newop->op_flags |= OPf_PARENS;
16063 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16065 /* insert newop between o and ns3 */
16066 op_sibling_splice(NULL, o, 0, newop);
16068 /*fixup op_next chain */
16069 newpm = cUNOPx(newop)->op_first; /* pushmark */
16070 o ->op_next = newpm;
16071 newpm->op_next = pad1;
16072 pad1 ->op_next = pad2;
16073 pad2 ->op_next = newop; /* listop */
16074 newop->op_next = ns3;
16076 /* Ensure pushmark has this flag if padops do */
16077 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
16078 newpm->op_flags |= OPf_MOD;
16084 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
16085 to carry two labels. For now, take the easier option, and skip
16086 this optimisation if the first NEXTSTATE has a label. */
16087 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
16088 OP *nextop = o->op_next;
16089 while (nextop && nextop->op_type == OP_NULL)
16090 nextop = nextop->op_next;
16092 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
16095 oldop->op_next = nextop;
16097 /* Skip (old)oldop assignment since the current oldop's
16098 op_next already points to the next op. */
16105 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
16106 if (o->op_next->op_private & OPpTARGET_MY) {
16107 if (o->op_flags & OPf_STACKED) /* chained concats */
16108 break; /* ignore_optimization */
16110 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
16111 o->op_targ = o->op_next->op_targ;
16112 o->op_next->op_targ = 0;
16113 o->op_private |= OPpTARGET_MY;
16116 op_null(o->op_next);
16120 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
16121 break; /* Scalar stub must produce undef. List stub is noop */
16125 if (o->op_targ == OP_NEXTSTATE
16126 || o->op_targ == OP_DBSTATE)
16128 PL_curcop = ((COP*)o);
16130 /* XXX: We avoid setting op_seq here to prevent later calls
16131 to rpeep() from mistakenly concluding that optimisation
16132 has already occurred. This doesn't fix the real problem,
16133 though (See 20010220.007 (#5874)). AMS 20010719 */
16134 /* op_seq functionality is now replaced by op_opt */
16142 oldop->op_next = o->op_next;
16156 convert repeat into a stub with no kids.
16158 if (o->op_next->op_type == OP_CONST
16159 || ( o->op_next->op_type == OP_PADSV
16160 && !(o->op_next->op_private & OPpLVAL_INTRO))
16161 || ( o->op_next->op_type == OP_GV
16162 && o->op_next->op_next->op_type == OP_RV2SV
16163 && !(o->op_next->op_next->op_private
16164 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
16166 const OP *kid = o->op_next->op_next;
16167 if (o->op_next->op_type == OP_GV)
16168 kid = kid->op_next;
16169 /* kid is now the ex-list. */
16170 if (kid->op_type == OP_NULL
16171 && (kid = kid->op_next)->op_type == OP_CONST
16172 /* kid is now the repeat count. */
16173 && kid->op_next->op_type == OP_REPEAT
16174 && kid->op_next->op_private & OPpREPEAT_DOLIST
16175 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
16176 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
16179 o = kid->op_next; /* repeat */
16180 oldop->op_next = o;
16181 op_free(cBINOPo->op_first);
16182 op_free(cBINOPo->op_last );
16183 o->op_flags &=~ OPf_KIDS;
16184 /* stub is a baseop; repeat is a binop */
16185 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
16186 OpTYPE_set(o, OP_STUB);
16192 /* Convert a series of PAD ops for my vars plus support into a
16193 * single padrange op. Basically
16195 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
16197 * becomes, depending on circumstances, one of
16199 * padrange ----------------------------------> (list) -> rest
16200 * padrange --------------------------------------------> rest
16202 * where all the pad indexes are sequential and of the same type
16204 * We convert the pushmark into a padrange op, then skip
16205 * any other pad ops, and possibly some trailing ops.
16206 * Note that we don't null() the skipped ops, to make it
16207 * easier for Deparse to undo this optimisation (and none of
16208 * the skipped ops are holding any resourses). It also makes
16209 * it easier for find_uninit_var(), as it can just ignore
16210 * padrange, and examine the original pad ops.
16214 OP *followop = NULL; /* the op that will follow the padrange op */
16217 PADOFFSET base = 0; /* init only to stop compiler whining */
16218 bool gvoid = 0; /* init only to stop compiler whining */
16219 bool defav = 0; /* seen (...) = @_ */
16220 bool reuse = 0; /* reuse an existing padrange op */
16222 /* look for a pushmark -> gv[_] -> rv2av */
16227 if ( p->op_type == OP_GV
16228 && cGVOPx_gv(p) == PL_defgv
16229 && (rv2av = p->op_next)
16230 && rv2av->op_type == OP_RV2AV
16231 && !(rv2av->op_flags & OPf_REF)
16232 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
16233 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
16235 q = rv2av->op_next;
16236 if (q->op_type == OP_NULL)
16238 if (q->op_type == OP_PUSHMARK) {
16248 /* scan for PAD ops */
16250 for (p = p->op_next; p; p = p->op_next) {
16251 if (p->op_type == OP_NULL)
16254 if (( p->op_type != OP_PADSV
16255 && p->op_type != OP_PADAV
16256 && p->op_type != OP_PADHV
16258 /* any private flag other than INTRO? e.g. STATE */
16259 || (p->op_private & ~OPpLVAL_INTRO)
16263 /* let $a[N] potentially be optimised into AELEMFAST_LEX
16265 if ( p->op_type == OP_PADAV
16267 && p->op_next->op_type == OP_CONST
16268 && p->op_next->op_next
16269 && p->op_next->op_next->op_type == OP_AELEM
16273 /* for 1st padop, note what type it is and the range
16274 * start; for the others, check that it's the same type
16275 * and that the targs are contiguous */
16277 intro = (p->op_private & OPpLVAL_INTRO);
16279 gvoid = OP_GIMME(p,0) == G_VOID;
16282 if ((p->op_private & OPpLVAL_INTRO) != intro)
16284 /* Note that you'd normally expect targs to be
16285 * contiguous in my($a,$b,$c), but that's not the case
16286 * when external modules start doing things, e.g.
16287 * Function::Parameters */
16288 if (p->op_targ != base + count)
16290 assert(p->op_targ == base + count);
16291 /* Either all the padops or none of the padops should
16292 be in void context. Since we only do the optimisa-
16293 tion for av/hv when the aggregate itself is pushed
16294 on to the stack (one item), there is no need to dis-
16295 tinguish list from scalar context. */
16296 if (gvoid != (OP_GIMME(p,0) == G_VOID))
16300 /* for AV, HV, only when we're not flattening */
16301 if ( p->op_type != OP_PADSV
16303 && !(p->op_flags & OPf_REF)
16307 if (count >= OPpPADRANGE_COUNTMASK)
16310 /* there's a biggest base we can fit into a
16311 * SAVEt_CLEARPADRANGE in pp_padrange.
16312 * (The sizeof() stuff will be constant-folded, and is
16313 * intended to avoid getting "comparison is always false"
16314 * compiler warnings. See the comments above
16315 * MEM_WRAP_CHECK for more explanation on why we do this
16316 * in a weird way to avoid compiler warnings.)
16319 && (8*sizeof(base) >
16320 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
16322 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
16324 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
16328 /* Success! We've got another valid pad op to optimise away */
16330 followop = p->op_next;
16333 if (count < 1 || (count == 1 && !defav))
16336 /* pp_padrange in specifically compile-time void context
16337 * skips pushing a mark and lexicals; in all other contexts
16338 * (including unknown till runtime) it pushes a mark and the
16339 * lexicals. We must be very careful then, that the ops we
16340 * optimise away would have exactly the same effect as the
16342 * In particular in void context, we can only optimise to
16343 * a padrange if we see the complete sequence
16344 * pushmark, pad*v, ...., list
16345 * which has the net effect of leaving the markstack as it
16346 * was. Not pushing onto the stack (whereas padsv does touch
16347 * the stack) makes no difference in void context.
16351 if (followop->op_type == OP_LIST
16352 && OP_GIMME(followop,0) == G_VOID
16355 followop = followop->op_next; /* skip OP_LIST */
16357 /* consolidate two successive my(...);'s */
16360 && oldoldop->op_type == OP_PADRANGE
16361 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
16362 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
16363 && !(oldoldop->op_flags & OPf_SPECIAL)
16366 assert(oldoldop->op_next == oldop);
16367 assert( oldop->op_type == OP_NEXTSTATE
16368 || oldop->op_type == OP_DBSTATE);
16369 assert(oldop->op_next == o);
16372 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
16374 /* Do not assume pad offsets for $c and $d are con-
16379 if ( oldoldop->op_targ + old_count == base
16380 && old_count < OPpPADRANGE_COUNTMASK - count) {
16381 base = oldoldop->op_targ;
16382 count += old_count;
16387 /* if there's any immediately following singleton
16388 * my var's; then swallow them and the associated
16390 * my ($a,$b); my $c; my $d;
16392 * my ($a,$b,$c,$d);
16395 while ( ((p = followop->op_next))
16396 && ( p->op_type == OP_PADSV
16397 || p->op_type == OP_PADAV
16398 || p->op_type == OP_PADHV)
16399 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
16400 && (p->op_private & OPpLVAL_INTRO) == intro
16401 && !(p->op_private & ~OPpLVAL_INTRO)
16403 && ( p->op_next->op_type == OP_NEXTSTATE
16404 || p->op_next->op_type == OP_DBSTATE)
16405 && count < OPpPADRANGE_COUNTMASK
16406 && base + count == p->op_targ
16409 followop = p->op_next;
16417 assert(oldoldop->op_type == OP_PADRANGE);
16418 oldoldop->op_next = followop;
16419 oldoldop->op_private = (intro | count);
16425 /* Convert the pushmark into a padrange.
16426 * To make Deparse easier, we guarantee that a padrange was
16427 * *always* formerly a pushmark */
16428 assert(o->op_type == OP_PUSHMARK);
16429 o->op_next = followop;
16430 OpTYPE_set(o, OP_PADRANGE);
16432 /* bit 7: INTRO; bit 6..0: count */
16433 o->op_private = (intro | count);
16434 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
16435 | gvoid * OPf_WANT_VOID
16436 | (defav ? OPf_SPECIAL : 0));
16442 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16443 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16448 /*'keys %h' in void or scalar context: skip the OP_KEYS
16449 * and perform the functionality directly in the RV2HV/PADHV
16452 if (o->op_flags & OPf_REF) {
16453 OP *k = o->op_next;
16454 U8 want = (k->op_flags & OPf_WANT);
16456 && k->op_type == OP_KEYS
16457 && ( want == OPf_WANT_VOID
16458 || want == OPf_WANT_SCALAR)
16459 && !(k->op_private & OPpMAYBE_LVSUB)
16460 && !(k->op_flags & OPf_MOD)
16462 o->op_next = k->op_next;
16463 o->op_flags &= ~(OPf_REF|OPf_WANT);
16464 o->op_flags |= want;
16465 o->op_private |= (o->op_type == OP_PADHV ?
16466 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
16467 /* for keys(%lex), hold onto the OP_KEYS's targ
16468 * since padhv doesn't have its own targ to return
16470 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16475 /* see if %h is used in boolean context */
16476 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16477 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16480 if (o->op_type != OP_PADHV)
16484 if ( o->op_type == OP_PADAV
16485 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16487 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16490 /* Skip over state($x) in void context. */
16491 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16492 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16494 oldop->op_next = o->op_next;
16495 goto redo_nextstate;
16497 if (o->op_type != OP_PADAV)
16501 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16502 OP* const pop = (o->op_type == OP_PADAV) ?
16503 o->op_next : o->op_next->op_next;
16505 if (pop && pop->op_type == OP_CONST &&
16506 ((PL_op = pop->op_next)) &&
16507 pop->op_next->op_type == OP_AELEM &&
16508 !(pop->op_next->op_private &
16509 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16510 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16513 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16514 no_bareword_allowed(pop);
16515 if (o->op_type == OP_GV)
16516 op_null(o->op_next);
16517 op_null(pop->op_next);
16519 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16520 o->op_next = pop->op_next->op_next;
16521 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16522 o->op_private = (U8)i;
16523 if (o->op_type == OP_GV) {
16526 o->op_type = OP_AELEMFAST;
16529 o->op_type = OP_AELEMFAST_LEX;
16531 if (o->op_type != OP_GV)
16535 /* Remove $foo from the op_next chain in void context. */
16537 && ( o->op_next->op_type == OP_RV2SV
16538 || o->op_next->op_type == OP_RV2AV
16539 || o->op_next->op_type == OP_RV2HV )
16540 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16541 && !(o->op_next->op_private & OPpLVAL_INTRO))
16543 oldop->op_next = o->op_next->op_next;
16544 /* Reprocess the previous op if it is a nextstate, to
16545 allow double-nextstate optimisation. */
16547 if (oldop->op_type == OP_NEXTSTATE) {
16554 o = oldop->op_next;
16557 else if (o->op_next->op_type == OP_RV2SV) {
16558 if (!(o->op_next->op_private & OPpDEREF)) {
16559 op_null(o->op_next);
16560 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16562 o->op_next = o->op_next->op_next;
16563 OpTYPE_set(o, OP_GVSV);
16566 else if (o->op_next->op_type == OP_READLINE
16567 && o->op_next->op_next->op_type == OP_CONCAT
16568 && (o->op_next->op_next->op_flags & OPf_STACKED))
16570 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16571 OpTYPE_set(o, OP_RCATLINE);
16572 o->op_flags |= OPf_STACKED;
16573 op_null(o->op_next->op_next);
16574 op_null(o->op_next);
16585 while (cLOGOP->op_other->op_type == OP_NULL)
16586 cLOGOP->op_other = cLOGOP->op_other->op_next;
16587 while (o->op_next && ( o->op_type == o->op_next->op_type
16588 || o->op_next->op_type == OP_NULL))
16589 o->op_next = o->op_next->op_next;
16591 /* If we're an OR and our next is an AND in void context, we'll
16592 follow its op_other on short circuit, same for reverse.
16593 We can't do this with OP_DOR since if it's true, its return
16594 value is the underlying value which must be evaluated
16598 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16599 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16601 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16603 o->op_next = ((LOGOP*)o->op_next)->op_other;
16605 DEFER(cLOGOP->op_other);
16610 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16611 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16620 case OP_ARGDEFELEM:
16621 while (cLOGOP->op_other->op_type == OP_NULL)
16622 cLOGOP->op_other = cLOGOP->op_other->op_next;
16623 DEFER(cLOGOP->op_other);
16628 while (cLOOP->op_redoop->op_type == OP_NULL)
16629 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16630 while (cLOOP->op_nextop->op_type == OP_NULL)
16631 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16632 while (cLOOP->op_lastop->op_type == OP_NULL)
16633 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16634 /* a while(1) loop doesn't have an op_next that escapes the
16635 * loop, so we have to explicitly follow the op_lastop to
16636 * process the rest of the code */
16637 DEFER(cLOOP->op_lastop);
16641 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16642 DEFER(cLOGOPo->op_other);
16646 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16647 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16648 assert(!(cPMOP->op_pmflags & PMf_ONCE));
16649 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16650 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16651 cPMOP->op_pmstashstartu.op_pmreplstart
16652 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16653 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16659 if (o->op_flags & OPf_SPECIAL) {
16660 /* first arg is a code block */
16661 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16662 OP * kid = cUNOPx(nullop)->op_first;
16664 assert(nullop->op_type == OP_NULL);
16665 assert(kid->op_type == OP_SCOPE
16666 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16667 /* since OP_SORT doesn't have a handy op_other-style
16668 * field that can point directly to the start of the code
16669 * block, store it in the otherwise-unused op_next field
16670 * of the top-level OP_NULL. This will be quicker at
16671 * run-time, and it will also allow us to remove leading
16672 * OP_NULLs by just messing with op_nexts without
16673 * altering the basic op_first/op_sibling layout. */
16674 kid = kLISTOP->op_first;
16676 (kid->op_type == OP_NULL
16677 && ( kid->op_targ == OP_NEXTSTATE
16678 || kid->op_targ == OP_DBSTATE ))
16679 || kid->op_type == OP_STUB
16680 || kid->op_type == OP_ENTER
16681 || (PL_parser && PL_parser->error_count));
16682 nullop->op_next = kid->op_next;
16683 DEFER(nullop->op_next);
16686 /* check that RHS of sort is a single plain array */
16687 oright = cUNOPo->op_first;
16688 if (!oright || oright->op_type != OP_PUSHMARK)
16691 if (o->op_private & OPpSORT_INPLACE)
16694 /* reverse sort ... can be optimised. */
16695 if (!OpHAS_SIBLING(cUNOPo)) {
16696 /* Nothing follows us on the list. */
16697 OP * const reverse = o->op_next;
16699 if (reverse->op_type == OP_REVERSE &&
16700 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16701 OP * const pushmark = cUNOPx(reverse)->op_first;
16702 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16703 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16704 /* reverse -> pushmark -> sort */
16705 o->op_private |= OPpSORT_REVERSE;
16707 pushmark->op_next = oright->op_next;
16717 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16719 LISTOP *enter, *exlist;
16721 if (o->op_private & OPpSORT_INPLACE)
16724 enter = (LISTOP *) o->op_next;
16727 if (enter->op_type == OP_NULL) {
16728 enter = (LISTOP *) enter->op_next;
16732 /* for $a (...) will have OP_GV then OP_RV2GV here.
16733 for (...) just has an OP_GV. */
16734 if (enter->op_type == OP_GV) {
16735 gvop = (OP *) enter;
16736 enter = (LISTOP *) enter->op_next;
16739 if (enter->op_type == OP_RV2GV) {
16740 enter = (LISTOP *) enter->op_next;
16746 if (enter->op_type != OP_ENTERITER)
16749 iter = enter->op_next;
16750 if (!iter || iter->op_type != OP_ITER)
16753 expushmark = enter->op_first;
16754 if (!expushmark || expushmark->op_type != OP_NULL
16755 || expushmark->op_targ != OP_PUSHMARK)
16758 exlist = (LISTOP *) OpSIBLING(expushmark);
16759 if (!exlist || exlist->op_type != OP_NULL
16760 || exlist->op_targ != OP_LIST)
16763 if (exlist->op_last != o) {
16764 /* Mmm. Was expecting to point back to this op. */
16767 theirmark = exlist->op_first;
16768 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16771 if (OpSIBLING(theirmark) != o) {
16772 /* There's something between the mark and the reverse, eg
16773 for (1, reverse (...))
16778 ourmark = ((LISTOP *)o)->op_first;
16779 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16782 ourlast = ((LISTOP *)o)->op_last;
16783 if (!ourlast || ourlast->op_next != o)
16786 rv2av = OpSIBLING(ourmark);
16787 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16788 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16789 /* We're just reversing a single array. */
16790 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16791 enter->op_flags |= OPf_STACKED;
16794 /* We don't have control over who points to theirmark, so sacrifice
16796 theirmark->op_next = ourmark->op_next;
16797 theirmark->op_flags = ourmark->op_flags;
16798 ourlast->op_next = gvop ? gvop : (OP *) enter;
16801 enter->op_private |= OPpITER_REVERSED;
16802 iter->op_private |= OPpITER_REVERSED;
16806 o = oldop->op_next;
16808 NOT_REACHED; /* NOTREACHED */
16814 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16815 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16820 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16821 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16824 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16826 sv = newRV((SV *)PL_compcv);
16830 OpTYPE_set(o, OP_CONST);
16831 o->op_flags |= OPf_SPECIAL;
16832 cSVOPo->op_sv = sv;
16837 if (OP_GIMME(o,0) == G_VOID
16838 || ( o->op_next->op_type == OP_LINESEQ
16839 && ( o->op_next->op_next->op_type == OP_LEAVESUB
16840 || ( o->op_next->op_next->op_type == OP_RETURN
16841 && !CvLVALUE(PL_compcv)))))
16843 OP *right = cBINOP->op_first;
16862 OP *left = OpSIBLING(right);
16863 if (left->op_type == OP_SUBSTR
16864 && (left->op_private & 7) < 4) {
16866 /* cut out right */
16867 op_sibling_splice(o, NULL, 1, NULL);
16868 /* and insert it as second child of OP_SUBSTR */
16869 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16871 left->op_private |= OPpSUBSTR_REPL_FIRST;
16873 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16880 int l, r, lr, lscalars, rscalars;
16882 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16883 Note that we do this now rather than in newASSIGNOP(),
16884 since only by now are aliased lexicals flagged as such
16886 See the essay "Common vars in list assignment" above for
16887 the full details of the rationale behind all the conditions
16890 PL_generation sorcery:
16891 To detect whether there are common vars, the global var
16892 PL_generation is incremented for each assign op we scan.
16893 Then we run through all the lexical variables on the LHS,
16894 of the assignment, setting a spare slot in each of them to
16895 PL_generation. Then we scan the RHS, and if any lexicals
16896 already have that value, we know we've got commonality.
16897 Also, if the generation number is already set to
16898 PERL_INT_MAX, then the variable is involved in aliasing, so
16899 we also have potential commonality in that case.
16905 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
16908 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
16912 /* After looking for things which are *always* safe, this main
16913 * if/else chain selects primarily based on the type of the
16914 * LHS, gradually working its way down from the more dangerous
16915 * to the more restrictive and thus safer cases */
16917 if ( !l /* () = ....; */
16918 || !r /* .... = (); */
16919 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16920 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16921 || (lscalars < 2) /* ($x, undef) = ... */
16923 NOOP; /* always safe */
16925 else if (l & AAS_DANGEROUS) {
16926 /* always dangerous */
16927 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16928 o->op_private |= OPpASSIGN_COMMON_AGG;
16930 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16931 /* package vars are always dangerous - too many
16932 * aliasing possibilities */
16933 if (l & AAS_PKG_SCALAR)
16934 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16935 if (l & AAS_PKG_AGG)
16936 o->op_private |= OPpASSIGN_COMMON_AGG;
16938 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16939 |AAS_LEX_SCALAR|AAS_LEX_AGG))
16941 /* LHS contains only lexicals and safe ops */
16943 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16944 o->op_private |= OPpASSIGN_COMMON_AGG;
16946 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16947 if (lr & AAS_LEX_SCALAR_COMM)
16948 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16949 else if ( !(l & AAS_LEX_SCALAR)
16950 && (r & AAS_DEFAV))
16954 * as scalar-safe for performance reasons.
16955 * (it will still have been marked _AGG if necessary */
16958 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16959 /* if there are only lexicals on the LHS and no
16960 * common ones on the RHS, then we assume that the
16961 * only way those lexicals could also get
16962 * on the RHS is via some sort of dereffing or
16965 * ($lex, $x) = (1, $$r)
16966 * and in this case we assume the var must have
16967 * a bumped ref count. So if its ref count is 1,
16968 * it must only be on the LHS.
16970 o->op_private |= OPpASSIGN_COMMON_RC1;
16975 * may have to handle aggregate on LHS, but we can't
16976 * have common scalars. */
16979 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16981 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16982 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16987 /* see if ref() is used in boolean context */
16988 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16989 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16993 /* see if the op is used in known boolean context,
16994 * but not if OA_TARGLEX optimisation is enabled */
16995 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16996 && !(o->op_private & OPpTARGET_MY)
16998 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17002 /* see if the op is used in known boolean context */
17003 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17004 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17008 Perl_cpeep_t cpeep =
17009 XopENTRYCUSTOM(o, xop_peep);
17011 cpeep(aTHX_ o, oldop);
17016 /* did we just null the current op? If so, re-process it to handle
17017 * eliding "empty" ops from the chain */
17018 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
17031 Perl_peep(pTHX_ OP *o)
17037 =head1 Custom Operators
17039 =for apidoc custom_op_xop
17040 Return the XOP structure for a given custom op. This macro should be
17041 considered internal to C<OP_NAME> and the other access macros: use them instead.
17042 This macro does call a function. Prior
17043 to 5.19.6, this was implemented as a
17050 /* use PERL_MAGIC_ext to call a function to free the xop structure when
17051 * freeing PL_custom_ops */
17054 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
17058 PERL_UNUSED_ARG(mg);
17059 xop = INT2PTR(XOP *, SvIV(sv));
17060 Safefree(xop->xop_name);
17061 Safefree(xop->xop_desc);
17067 static const MGVTBL custom_op_register_vtbl = {
17072 custom_op_register_free, /* free */
17082 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
17088 static const XOP xop_null = { 0, 0, 0, 0, 0 };
17090 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
17091 assert(o->op_type == OP_CUSTOM);
17093 /* This is wrong. It assumes a function pointer can be cast to IV,
17094 * which isn't guaranteed, but this is what the old custom OP code
17095 * did. In principle it should be safer to Copy the bytes of the
17096 * pointer into a PV: since the new interface is hidden behind
17097 * functions, this can be changed later if necessary. */
17098 /* Change custom_op_xop if this ever happens */
17099 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
17102 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
17104 /* See if the op isn't registered, but its name *is* registered.
17105 * That implies someone is using the pre-5.14 API,where only name and
17106 * description could be registered. If so, fake up a real
17108 * We only check for an existing name, and assume no one will have
17109 * just registered a desc */
17110 if (!he && PL_custom_op_names &&
17111 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
17116 /* XXX does all this need to be shared mem? */
17117 Newxz(xop, 1, XOP);
17118 pv = SvPV(HeVAL(he), l);
17119 XopENTRY_set(xop, xop_name, savepvn(pv, l));
17120 if (PL_custom_op_descs &&
17121 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
17123 pv = SvPV(HeVAL(he), l);
17124 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
17126 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
17127 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
17128 /* add magic to the SV so that the xop struct (pointed to by
17129 * SvIV(sv)) is freed. Normally a static xop is registered, but
17130 * for this backcompat hack, we've alloced one */
17131 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
17132 &custom_op_register_vtbl, NULL, 0);
17137 xop = (XOP *)&xop_null;
17139 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
17143 if(field == XOPe_xop_ptr) {
17146 const U32 flags = XopFLAGS(xop);
17147 if(flags & field) {
17149 case XOPe_xop_name:
17150 any.xop_name = xop->xop_name;
17152 case XOPe_xop_desc:
17153 any.xop_desc = xop->xop_desc;
17155 case XOPe_xop_class:
17156 any.xop_class = xop->xop_class;
17158 case XOPe_xop_peep:
17159 any.xop_peep = xop->xop_peep;
17162 NOT_REACHED; /* NOTREACHED */
17167 case XOPe_xop_name:
17168 any.xop_name = XOPd_xop_name;
17170 case XOPe_xop_desc:
17171 any.xop_desc = XOPd_xop_desc;
17173 case XOPe_xop_class:
17174 any.xop_class = XOPd_xop_class;
17176 case XOPe_xop_peep:
17177 any.xop_peep = XOPd_xop_peep;
17180 NOT_REACHED; /* NOTREACHED */
17185 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
17186 * op.c: In function 'Perl_custom_op_get_field':
17187 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
17188 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
17189 * expands to assert(0), which expands to ((0) ? (void)0 :
17190 * __assert(...)), and gcc doesn't know that __assert can never return. */
17196 =for apidoc custom_op_register
17197 Register a custom op. See L<perlguts/"Custom Operators">.
17203 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
17207 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
17209 /* see the comment in custom_op_xop */
17210 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
17212 if (!PL_custom_ops)
17213 PL_custom_ops = newHV();
17215 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
17216 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
17221 =for apidoc core_prototype
17223 This function assigns the prototype of the named core function to C<sv>, or
17224 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
17225 C<NULL> if the core function has no prototype. C<code> is a code as returned
17226 by C<keyword()>. It must not be equal to 0.
17232 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
17235 int i = 0, n = 0, seen_question = 0, defgv = 0;
17237 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
17238 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
17239 bool nullret = FALSE;
17241 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
17245 if (!sv) sv = sv_newmortal();
17247 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
17249 switch (code < 0 ? -code : code) {
17250 case KEY_and : case KEY_chop: case KEY_chomp:
17251 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
17252 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
17253 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
17254 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
17255 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
17256 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
17257 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
17258 case KEY_x : case KEY_xor :
17259 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
17260 case KEY_glob: retsetpvs("_;", OP_GLOB);
17261 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
17262 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
17263 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
17264 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
17265 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
17267 case KEY_evalbytes:
17268 name = "entereval"; break;
17276 while (i < MAXO) { /* The slow way. */
17277 if (strEQ(name, PL_op_name[i])
17278 || strEQ(name, PL_op_desc[i]))
17280 if (nullret) { assert(opnum); *opnum = i; return NULL; }
17287 defgv = PL_opargs[i] & OA_DEFGV;
17288 oa = PL_opargs[i] >> OASHIFT;
17290 if (oa & OA_OPTIONAL && !seen_question && (
17291 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
17296 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
17297 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
17298 /* But globs are already references (kinda) */
17299 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
17303 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
17304 && !scalar_mod_type(NULL, i)) {
17309 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
17313 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
17314 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
17315 str[n-1] = '_'; defgv = 0;
17319 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
17321 sv_setpvn(sv, str, n - 1);
17322 if (opnum) *opnum = i;
17327 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
17330 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
17331 newSVOP(OP_COREARGS,0,coreargssv);
17334 PERL_ARGS_ASSERT_CORESUB_OP;
17338 return op_append_elem(OP_LINESEQ,
17341 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
17348 o = newUNOP(OP_AVHVSWITCH,0,argop);
17349 o->op_private = opnum-OP_EACH;
17351 case OP_SELECT: /* which represents OP_SSELECT as well */
17356 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
17357 newSVOP(OP_CONST, 0, newSVuv(1))
17359 coresub_op(newSVuv((UV)OP_SSELECT), 0,
17361 coresub_op(coreargssv, 0, OP_SELECT)
17365 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
17367 return op_append_elem(
17370 opnum == OP_WANTARRAY || opnum == OP_RUNCV
17371 ? OPpOFFBYONE << 8 : 0)
17373 case OA_BASEOP_OR_UNOP:
17374 if (opnum == OP_ENTEREVAL) {
17375 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
17376 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
17378 else o = newUNOP(opnum,0,argop);
17379 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
17382 if (is_handle_constructor(o, 1))
17383 argop->op_private |= OPpCOREARGS_DEREF1;
17384 if (scalar_mod_type(NULL, opnum))
17385 argop->op_private |= OPpCOREARGS_SCALARMOD;
17389 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
17390 if (is_handle_constructor(o, 2))
17391 argop->op_private |= OPpCOREARGS_DEREF2;
17392 if (opnum == OP_SUBSTR) {
17393 o->op_private |= OPpMAYBE_LVSUB;
17402 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
17403 SV * const *new_const_svp)
17405 const char *hvname;
17406 bool is_const = !!CvCONST(old_cv);
17407 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
17409 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
17411 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
17413 /* They are 2 constant subroutines generated from
17414 the same constant. This probably means that
17415 they are really the "same" proxy subroutine
17416 instantiated in 2 places. Most likely this is
17417 when a constant is exported twice. Don't warn.
17420 (ckWARN(WARN_REDEFINE)
17422 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
17423 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
17424 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
17425 strEQ(hvname, "autouse"))
17429 && ckWARN_d(WARN_REDEFINE)
17430 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
17433 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
17435 ? "Constant subroutine %" SVf " redefined"
17436 : "Subroutine %" SVf " redefined",
17441 =head1 Hook manipulation
17443 These functions provide convenient and thread-safe means of manipulating
17450 =for apidoc wrap_op_checker
17452 Puts a C function into the chain of check functions for a specified op
17453 type. This is the preferred way to manipulate the L</PL_check> array.
17454 C<opcode> specifies which type of op is to be affected. C<new_checker>
17455 is a pointer to the C function that is to be added to that opcode's
17456 check chain, and C<old_checker_p> points to the storage location where a
17457 pointer to the next function in the chain will be stored. The value of
17458 C<new_checker> is written into the L</PL_check> array, while the value
17459 previously stored there is written to C<*old_checker_p>.
17461 L</PL_check> is global to an entire process, and a module wishing to
17462 hook op checking may find itself invoked more than once per process,
17463 typically in different threads. To handle that situation, this function
17464 is idempotent. The location C<*old_checker_p> must initially (once
17465 per process) contain a null pointer. A C variable of static duration
17466 (declared at file scope, typically also marked C<static> to give
17467 it internal linkage) will be implicitly initialised appropriately,
17468 if it does not have an explicit initialiser. This function will only
17469 actually modify the check chain if it finds C<*old_checker_p> to be null.
17470 This function is also thread safe on the small scale. It uses appropriate
17471 locking to avoid race conditions in accessing L</PL_check>.
17473 When this function is called, the function referenced by C<new_checker>
17474 must be ready to be called, except for C<*old_checker_p> being unfilled.
17475 In a threading situation, C<new_checker> may be called immediately,
17476 even before this function has returned. C<*old_checker_p> will always
17477 be appropriately set before C<new_checker> is called. If C<new_checker>
17478 decides not to do anything special with an op that it is given (which
17479 is the usual case for most uses of op check hooking), it must chain the
17480 check function referenced by C<*old_checker_p>.
17482 Taken all together, XS code to hook an op checker should typically look
17483 something like this:
17485 static Perl_check_t nxck_frob;
17486 static OP *myck_frob(pTHX_ OP *op) {
17488 op = nxck_frob(aTHX_ op);
17493 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
17495 If you want to influence compilation of calls to a specific subroutine,
17496 then use L</cv_set_call_checker_flags> rather than hooking checking of
17497 all C<entersub> ops.
17503 Perl_wrap_op_checker(pTHX_ Optype opcode,
17504 Perl_check_t new_checker, Perl_check_t *old_checker_p)
17508 PERL_UNUSED_CONTEXT;
17509 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
17510 if (*old_checker_p) return;
17511 OP_CHECK_MUTEX_LOCK;
17512 if (!*old_checker_p) {
17513 *old_checker_p = PL_check[opcode];
17514 PL_check[opcode] = new_checker;
17516 OP_CHECK_MUTEX_UNLOCK;
17521 /* Efficient sub that returns a constant scalar value. */
17523 const_sv_xsub(pTHX_ CV* cv)
17526 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17527 PERL_UNUSED_ARG(items);
17537 const_av_xsub(pTHX_ CV* cv)
17540 AV * const av = MUTABLE_AV(XSANY.any_ptr);
17548 if (SvRMAGICAL(av))
17549 Perl_croak(aTHX_ "Magical list constants are not supported");
17550 if (GIMME_V != G_ARRAY) {
17552 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17555 EXTEND(SP, AvFILLp(av)+1);
17556 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17557 XSRETURN(AvFILLp(av)+1);
17560 /* Copy an existing cop->cop_warnings field.
17561 * If it's one of the standard addresses, just re-use the address.
17562 * This is the e implementation for the DUP_WARNINGS() macro
17566 Perl_dup_warnings(pTHX_ STRLEN* warnings)
17569 STRLEN *new_warnings;
17571 if (warnings == NULL || specialWARN(warnings))
17574 size = sizeof(*warnings) + *warnings;
17576 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
17577 Copy(warnings, new_warnings, size, char);
17578 return new_warnings;
17582 * ex: set ts=8 sts=4 sw=4 et: