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 /* malloc a new op slab (suitable for attaching to PL_compcv) */
214 S_new_slab(pTHX_ size_t sz)
216 #ifdef PERL_DEBUG_READONLY_OPS
217 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
218 PROT_READ|PROT_WRITE,
219 MAP_ANON|MAP_PRIVATE, -1, 0);
220 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
221 (unsigned long) sz, slab));
222 if (slab == MAP_FAILED) {
223 perror("mmap failed");
226 slab->opslab_size = (U16)sz;
228 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
231 /* The context is unused in non-Windows */
234 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
238 /* requires double parens and aTHX_ */
239 #define DEBUG_S_warn(args) \
241 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
244 /* Returns a sz-sized block of memory (suitable for holding an op) from
245 * a free slot in the chain of op slabs attached to PL_compcv.
246 * Allocates a new slab if necessary.
247 * if PL_compcv isn't compiling, malloc() instead.
251 Perl_Slab_Alloc(pTHX_ size_t sz)
259 /* We only allocate ops from the slab during subroutine compilation.
260 We find the slab via PL_compcv, hence that must be non-NULL. It could
261 also be pointing to a subroutine which is now fully set up (CvROOT()
262 pointing to the top of the optree for that sub), or a subroutine
263 which isn't using the slab allocator. If our sanity checks aren't met,
264 don't use a slab, but allocate the OP directly from the heap. */
265 if (!PL_compcv || CvROOT(PL_compcv)
266 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
268 o = (OP*)PerlMemShared_calloc(1, sz);
272 /* While the subroutine is under construction, the slabs are accessed via
273 CvSTART(), to avoid needing to expand PVCV by one pointer for something
274 unneeded at runtime. Once a subroutine is constructed, the slabs are
275 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
276 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
278 if (!CvSTART(PL_compcv)) {
280 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
281 CvSLABBED_on(PL_compcv);
282 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
284 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
286 opsz = SIZE_TO_PSIZE(sz);
287 sz = opsz + OPSLOT_HEADER_P;
289 /* The slabs maintain a free list of OPs. In particular, constant folding
290 will free up OPs, so it makes sense to re-use them where possible. A
291 freed up slot is used in preference to a new allocation. */
292 if (slab->opslab_freed) {
293 OP **too = &slab->opslab_freed;
295 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
296 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
297 DEBUG_S_warn((aTHX_ "Alas! too small"));
298 o = *(too = &o->op_next);
299 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
303 Zero(o, opsz, I32 *);
309 #define INIT_OPSLOT \
310 slot->opslot_slab = slab; \
311 slot->opslot_next = slab2->opslab_first; \
312 slab2->opslab_first = slot; \
313 o = &slot->opslot_op; \
316 /* The partially-filled slab is next in the chain. */
317 slab2 = slab->opslab_next ? slab->opslab_next : slab;
318 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
319 /* Remaining space is too small. */
321 /* If we can fit a BASEOP, add it to the free chain, so as not
323 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
324 slot = &slab2->opslab_slots;
326 o->op_type = OP_FREED;
327 o->op_next = slab->opslab_freed;
328 slab->opslab_freed = o;
331 /* Create a new slab. Make this one twice as big. */
332 slot = slab2->opslab_first;
333 while (slot->opslot_next) slot = slot->opslot_next;
334 slab2 = S_new_slab(aTHX_
335 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
337 : (DIFF(slab2, slot)+1)*2);
338 slab2->opslab_next = slab->opslab_next;
339 slab->opslab_next = slab2;
341 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
343 /* Create a new op slot */
344 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
345 assert(slot >= &slab2->opslab_slots);
346 if (DIFF(&slab2->opslab_slots, slot)
347 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
348 slot = &slab2->opslab_slots;
350 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
353 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
354 assert(!o->op_moresib);
355 assert(!o->op_sibparent);
362 #ifdef PERL_DEBUG_READONLY_OPS
364 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
366 PERL_ARGS_ASSERT_SLAB_TO_RO;
368 if (slab->opslab_readonly) return;
369 slab->opslab_readonly = 1;
370 for (; slab; slab = slab->opslab_next) {
371 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
372 (unsigned long) slab->opslab_size, slab));*/
373 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
374 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
375 (unsigned long)slab->opslab_size, errno);
380 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
384 PERL_ARGS_ASSERT_SLAB_TO_RW;
386 if (!slab->opslab_readonly) return;
388 for (; slab2; slab2 = slab2->opslab_next) {
389 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
390 (unsigned long) size, slab2));*/
391 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
392 PROT_READ|PROT_WRITE)) {
393 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
394 (unsigned long)slab2->opslab_size, errno);
397 slab->opslab_readonly = 0;
401 # define Slab_to_rw(op) NOOP
404 /* This cannot possibly be right, but it was copied from the old slab
405 allocator, to which it was originally added, without explanation, in
408 # define PerlMemShared PerlMem
411 /* make freed ops die if they're inadvertently executed */
416 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
421 /* Return the block of memory used by an op to the free list of
422 * the OP slab associated with that op.
426 Perl_Slab_Free(pTHX_ void *op)
428 OP * const o = (OP *)op;
431 PERL_ARGS_ASSERT_SLAB_FREE;
434 o->op_ppaddr = S_pp_freed;
437 if (!o->op_slabbed) {
439 PerlMemShared_free(op);
444 /* If this op is already freed, our refcount will get screwy. */
445 assert(o->op_type != OP_FREED);
446 o->op_type = OP_FREED;
447 o->op_next = slab->opslab_freed;
448 slab->opslab_freed = o;
449 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
450 OpslabREFCNT_dec_padok(slab);
454 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
456 const bool havepad = !!PL_comppad;
457 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
460 PAD_SAVE_SETNULLPAD();
466 /* Free a chain of OP slabs. Should only be called after all ops contained
467 * in it have been freed. At this point, its reference count should be 1,
468 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
469 * and just directly calls opslab_free().
470 * (Note that the reference count which PL_compcv held on the slab should
471 * have been removed once compilation of the sub was complete).
477 Perl_opslab_free(pTHX_ OPSLAB *slab)
480 PERL_ARGS_ASSERT_OPSLAB_FREE;
482 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
483 assert(slab->opslab_refcnt == 1);
485 slab2 = slab->opslab_next;
487 slab->opslab_refcnt = ~(size_t)0;
489 #ifdef PERL_DEBUG_READONLY_OPS
490 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
492 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
493 perror("munmap failed");
497 PerlMemShared_free(slab);
503 /* like opslab_free(), but first calls op_free() on any ops in the slab
504 * not marked as OP_FREED
508 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
512 size_t savestack_count = 0;
514 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
518 for (slot = slab2->opslab_first;
520 slot = slot->opslot_next) {
521 if (slot->opslot_op.op_type != OP_FREED
522 && !(slot->opslot_op.op_savefree
528 assert(slot->opslot_op.op_slabbed);
529 op_free(&slot->opslot_op);
530 if (slab->opslab_refcnt == 1) goto free;
533 } while ((slab2 = slab2->opslab_next));
534 /* > 1 because the CV still holds a reference count. */
535 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
537 assert(savestack_count == slab->opslab_refcnt-1);
539 /* Remove the CV’s reference count. */
540 slab->opslab_refcnt--;
547 #ifdef PERL_DEBUG_READONLY_OPS
549 Perl_op_refcnt_inc(pTHX_ OP *o)
552 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
553 if (slab && slab->opslab_readonly) {
566 Perl_op_refcnt_dec(pTHX_ OP *o)
569 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
571 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
573 if (slab && slab->opslab_readonly) {
575 result = --o->op_targ;
578 result = --o->op_targ;
584 * In the following definition, the ", (OP*)0" is just to make the compiler
585 * think the expression is of the right type: croak actually does a Siglongjmp.
587 #define CHECKOP(type,o) \
588 ((PL_op_mask && PL_op_mask[type]) \
589 ? ( op_free((OP*)o), \
590 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
592 : PL_check[type](aTHX_ (OP*)o))
594 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
596 #define OpTYPE_set(o,type) \
598 o->op_type = (OPCODE)type; \
599 o->op_ppaddr = PL_ppaddr[type]; \
603 S_no_fh_allowed(pTHX_ OP *o)
605 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
607 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
613 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
615 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
616 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
621 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
623 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
625 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
630 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
632 PERL_ARGS_ASSERT_BAD_TYPE_PV;
634 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
635 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
638 /* remove flags var, its unused in all callers, move to to right end since gv
639 and kid are always the same */
641 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
643 SV * const namesv = cv_name((CV *)gv, NULL, 0);
644 PERL_ARGS_ASSERT_BAD_TYPE_GV;
646 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
647 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
651 S_no_bareword_allowed(pTHX_ OP *o)
653 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
655 qerror(Perl_mess(aTHX_
656 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
658 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
661 /* "register" allocation */
664 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
667 const bool is_our = (PL_parser->in_my == KEY_our);
669 PERL_ARGS_ASSERT_ALLOCMY;
671 if (flags & ~SVf_UTF8)
672 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
675 /* complain about "my $<special_var>" etc etc */
679 || ( (flags & SVf_UTF8)
680 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
681 || (name[1] == '_' && len > 2)))
683 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
685 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
686 /* diag_listed_as: Can't use global %s in "%s" */
687 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
688 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
689 PL_parser->in_my == KEY_state ? "state" : "my"));
691 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
692 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
696 /* allocate a spare slot and store the name in that slot */
698 off = pad_add_name_pvn(name, len,
699 (is_our ? padadd_OUR :
700 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
701 PL_parser->in_my_stash,
703 /* $_ is always in main::, even with our */
704 ? (PL_curstash && !memEQs(name,len,"$_")
710 /* anon sub prototypes contains state vars should always be cloned,
711 * otherwise the state var would be shared between anon subs */
713 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
714 CvCLONE_on(PL_compcv);
720 =head1 Optree Manipulation Functions
722 =for apidoc alloccopstash
724 Available only under threaded builds, this function allocates an entry in
725 C<PL_stashpad> for the stash passed to it.
732 Perl_alloccopstash(pTHX_ HV *hv)
734 PADOFFSET off = 0, o = 1;
735 bool found_slot = FALSE;
737 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
739 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
741 for (; o < PL_stashpadmax; ++o) {
742 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
743 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
744 found_slot = TRUE, off = o;
747 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
748 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
749 off = PL_stashpadmax;
750 PL_stashpadmax += 10;
753 PL_stashpad[PL_stashpadix = off] = hv;
758 /* free the body of an op without examining its contents.
759 * Always use this rather than FreeOp directly */
762 S_op_destroy(pTHX_ OP *o)
772 Free an op and its children. Only use this when an op is no longer linked
779 Perl_op_free(pTHX_ OP *o)
785 bool went_up = FALSE; /* whether we reached the current node by
786 following the parent pointer from a child, and
787 so have already seen this node */
789 if (!o || o->op_type == OP_FREED)
792 if (o->op_private & OPpREFCOUNTED) {
793 /* if base of tree is refcounted, just decrement */
794 switch (o->op_type) {
804 refcnt = OpREFCNT_dec(o);
807 /* Need to find and remove any pattern match ops from
808 * the list we maintain for reset(). */
809 find_and_forget_pmops(o);
822 /* free child ops before ourself, (then free ourself "on the
825 if (!went_up && o->op_flags & OPf_KIDS) {
826 next_op = cUNOPo->op_first;
830 /* find the next node to visit, *then* free the current node
831 * (can't rely on o->op_* fields being valid after o has been
834 /* The next node to visit will be either the sibling, or the
835 * parent if no siblings left, or NULL if we've worked our way
836 * back up to the top node in the tree */
837 next_op = (o == top_op) ? NULL : o->op_sibparent;
838 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
840 /* Now process the current node */
842 /* Though ops may be freed twice, freeing the op after its slab is a
844 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
845 /* During the forced freeing of ops after compilation failure, kidops
846 may be freed before their parents. */
847 if (!o || o->op_type == OP_FREED)
852 /* an op should only ever acquire op_private flags that we know about.
853 * If this fails, you may need to fix something in regen/op_private.
854 * Don't bother testing if:
855 * * the op_ppaddr doesn't match the op; someone may have
856 * overridden the op and be doing strange things with it;
857 * * we've errored, as op flags are often left in an
858 * inconsistent state then. Note that an error when
859 * compiling the main program leaves PL_parser NULL, so
860 * we can't spot faults in the main code, only
861 * evaled/required code */
863 if ( o->op_ppaddr == PL_ppaddr[type]
865 && !PL_parser->error_count)
867 assert(!(o->op_private & ~PL_op_private_valid[type]));
872 /* Call the op_free hook if it has been set. Do it now so that it's called
873 * at the right time for refcounted ops, but still before all of the kids
878 type = (OPCODE)o->op_targ;
881 Slab_to_rw(OpSLAB(o));
883 /* COP* is not cleared by op_clear() so that we may track line
884 * numbers etc even after null() */
885 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
897 /* S_op_clear_gv(): free a GV attached to an OP */
901 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
903 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
907 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
908 || o->op_type == OP_MULTIDEREF)
911 ? ((GV*)PAD_SVl(*ixp)) : NULL;
913 ? (GV*)(*svp) : NULL;
915 /* It's possible during global destruction that the GV is freed
916 before the optree. Whilst the SvREFCNT_inc is happy to bump from
917 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
918 will trigger an assertion failure, because the entry to sv_clear
919 checks that the scalar is not already freed. A check of for
920 !SvIS_FREED(gv) turns out to be invalid, because during global
921 destruction the reference count can be forced down to zero
922 (with SVf_BREAK set). In which case raising to 1 and then
923 dropping to 0 triggers cleanup before it should happen. I
924 *think* that this might actually be a general, systematic,
925 weakness of the whole idea of SVf_BREAK, in that code *is*
926 allowed to raise and lower references during global destruction,
927 so any *valid* code that happens to do this during global
928 destruction might well trigger premature cleanup. */
929 bool still_valid = gv && SvREFCNT(gv);
932 SvREFCNT_inc_simple_void(gv);
935 pad_swipe(*ixp, TRUE);
943 int try_downgrade = SvREFCNT(gv) == 2;
946 gv_try_downgrade(gv);
952 Perl_op_clear(pTHX_ OP *o)
957 PERL_ARGS_ASSERT_OP_CLEAR;
959 switch (o->op_type) {
960 case OP_NULL: /* Was holding old type, if any. */
963 case OP_ENTEREVAL: /* Was holding hints. */
964 case OP_ARGDEFELEM: /* Was holding signature index. */
968 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
975 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
977 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
980 case OP_METHOD_REDIR:
981 case OP_METHOD_REDIR_SUPER:
983 if (cMETHOPx(o)->op_rclass_targ) {
984 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
985 cMETHOPx(o)->op_rclass_targ = 0;
988 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
989 cMETHOPx(o)->op_rclass_sv = NULL;
992 case OP_METHOD_NAMED:
993 case OP_METHOD_SUPER:
994 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
995 cMETHOPx(o)->op_u.op_meth_sv = NULL;
998 pad_swipe(o->op_targ, 1);
1005 SvREFCNT_dec(cSVOPo->op_sv);
1006 cSVOPo->op_sv = NULL;
1009 Even if op_clear does a pad_free for the target of the op,
1010 pad_free doesn't actually remove the sv that exists in the pad;
1011 instead it lives on. This results in that it could be reused as
1012 a target later on when the pad was reallocated.
1015 pad_swipe(o->op_targ,1);
1025 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1030 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1031 && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1034 if (cPADOPo->op_padix > 0) {
1035 pad_swipe(cPADOPo->op_padix, TRUE);
1036 cPADOPo->op_padix = 0;
1039 SvREFCNT_dec(cSVOPo->op_sv);
1040 cSVOPo->op_sv = NULL;
1044 PerlMemShared_free(cPVOPo->op_pv);
1045 cPVOPo->op_pv = NULL;
1049 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1053 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1054 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1056 if (o->op_private & OPpSPLIT_LEX)
1057 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1060 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1062 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1069 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1070 op_free(cPMOPo->op_code_list);
1071 cPMOPo->op_code_list = NULL;
1072 forget_pmop(cPMOPo);
1073 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1074 /* we use the same protection as the "SAFE" version of the PM_ macros
1075 * here since sv_clean_all might release some PMOPs
1076 * after PL_regex_padav has been cleared
1077 * and the clearing of PL_regex_padav needs to
1078 * happen before sv_clean_all
1081 if(PL_regex_pad) { /* We could be in destruction */
1082 const IV offset = (cPMOPo)->op_pmoffset;
1083 ReREFCNT_dec(PM_GETRE(cPMOPo));
1084 PL_regex_pad[offset] = &PL_sv_undef;
1085 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1089 ReREFCNT_dec(PM_GETRE(cPMOPo));
1090 PM_SETRE(cPMOPo, NULL);
1096 PerlMemShared_free(cUNOP_AUXo->op_aux);
1099 case OP_MULTICONCAT:
1101 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1102 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1103 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1104 * utf8 shared strings */
1105 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1106 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1108 PerlMemShared_free(p1);
1110 PerlMemShared_free(p2);
1111 PerlMemShared_free(aux);
1117 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1118 UV actions = items->uv;
1120 bool is_hash = FALSE;
1123 switch (actions & MDEREF_ACTION_MASK) {
1126 actions = (++items)->uv;
1129 case MDEREF_HV_padhv_helem:
1132 case MDEREF_AV_padav_aelem:
1133 pad_free((++items)->pad_offset);
1136 case MDEREF_HV_gvhv_helem:
1139 case MDEREF_AV_gvav_aelem:
1141 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1143 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1147 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1150 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1152 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1154 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1156 goto do_vivify_rv2xv_elem;
1158 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1161 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1162 pad_free((++items)->pad_offset);
1163 goto do_vivify_rv2xv_elem;
1165 case MDEREF_HV_pop_rv2hv_helem:
1166 case MDEREF_HV_vivify_rv2hv_helem:
1169 do_vivify_rv2xv_elem:
1170 case MDEREF_AV_pop_rv2av_aelem:
1171 case MDEREF_AV_vivify_rv2av_aelem:
1173 switch (actions & MDEREF_INDEX_MASK) {
1174 case MDEREF_INDEX_none:
1177 case MDEREF_INDEX_const:
1181 pad_swipe((++items)->pad_offset, 1);
1183 SvREFCNT_dec((++items)->sv);
1189 case MDEREF_INDEX_padsv:
1190 pad_free((++items)->pad_offset);
1192 case MDEREF_INDEX_gvsv:
1194 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1196 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1201 if (actions & MDEREF_FLAG_last)
1214 actions >>= MDEREF_SHIFT;
1217 /* start of malloc is at op_aux[-1], where the length is
1219 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1224 if (o->op_targ > 0) {
1225 pad_free(o->op_targ);
1231 S_cop_free(pTHX_ COP* cop)
1233 PERL_ARGS_ASSERT_COP_FREE;
1236 if (! specialWARN(cop->cop_warnings))
1237 PerlMemShared_free(cop->cop_warnings);
1238 cophh_free(CopHINTHASH_get(cop));
1239 if (PL_curcop == cop)
1244 S_forget_pmop(pTHX_ PMOP *const o)
1246 HV * const pmstash = PmopSTASH(o);
1248 PERL_ARGS_ASSERT_FORGET_PMOP;
1250 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1251 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1253 PMOP **const array = (PMOP**) mg->mg_ptr;
1254 U32 count = mg->mg_len / sizeof(PMOP**);
1258 if (array[i] == o) {
1259 /* Found it. Move the entry at the end to overwrite it. */
1260 array[i] = array[--count];
1261 mg->mg_len = count * sizeof(PMOP**);
1262 /* Could realloc smaller at this point always, but probably
1263 not worth it. Probably worth free()ing if we're the
1266 Safefree(mg->mg_ptr);
1280 S_find_and_forget_pmops(pTHX_ OP *o)
1284 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1287 switch (o->op_type) {
1292 forget_pmop((PMOP*)o);
1295 if (o->op_flags & OPf_KIDS) {
1296 o = cUNOPo->op_first;
1302 return; /* at top; no parents/siblings to try */
1303 if (OpHAS_SIBLING(o)) {
1304 o = o->op_sibparent; /* process next sibling */
1307 o = o->op_sibparent; /*try parent's next sibling */
1316 Neutralizes an op when it is no longer needed, but is still linked to from
1323 Perl_op_null(pTHX_ OP *o)
1327 PERL_ARGS_ASSERT_OP_NULL;
1329 if (o->op_type == OP_NULL)
1332 o->op_targ = o->op_type;
1333 OpTYPE_set(o, OP_NULL);
1337 Perl_op_refcnt_lock(pTHX)
1338 PERL_TSA_ACQUIRE(PL_op_mutex)
1343 PERL_UNUSED_CONTEXT;
1348 Perl_op_refcnt_unlock(pTHX)
1349 PERL_TSA_RELEASE(PL_op_mutex)
1354 PERL_UNUSED_CONTEXT;
1360 =for apidoc op_sibling_splice
1362 A general function for editing the structure of an existing chain of
1363 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1364 you to delete zero or more sequential nodes, replacing them with zero or
1365 more different nodes. Performs the necessary op_first/op_last
1366 housekeeping on the parent node and op_sibling manipulation on the
1367 children. The last deleted node will be marked as as the last node by
1368 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1370 Note that op_next is not manipulated, and nodes are not freed; that is the
1371 responsibility of the caller. It also won't create a new list op for an
1372 empty list etc; use higher-level functions like op_append_elem() for that.
1374 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1375 the splicing doesn't affect the first or last op in the chain.
1377 C<start> is the node preceding the first node to be spliced. Node(s)
1378 following it will be deleted, and ops will be inserted after it. If it is
1379 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1382 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1383 If -1 or greater than or equal to the number of remaining kids, all
1384 remaining kids are deleted.
1386 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1387 If C<NULL>, no nodes are inserted.
1389 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1394 action before after returns
1395 ------ ----- ----- -------
1398 splice(P, A, 2, X-Y-Z) | | B-C
1402 splice(P, NULL, 1, X-Y) | | A
1406 splice(P, NULL, 3, NULL) | | A-B-C
1410 splice(P, B, 0, X-Y) | | NULL
1414 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1415 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1421 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1425 OP *last_del = NULL;
1426 OP *last_ins = NULL;
1429 first = OpSIBLING(start);
1433 first = cLISTOPx(parent)->op_first;
1435 assert(del_count >= -1);
1437 if (del_count && first) {
1439 while (--del_count && OpHAS_SIBLING(last_del))
1440 last_del = OpSIBLING(last_del);
1441 rest = OpSIBLING(last_del);
1442 OpLASTSIB_set(last_del, NULL);
1449 while (OpHAS_SIBLING(last_ins))
1450 last_ins = OpSIBLING(last_ins);
1451 OpMAYBESIB_set(last_ins, rest, NULL);
1457 OpMAYBESIB_set(start, insert, NULL);
1461 cLISTOPx(parent)->op_first = insert;
1463 parent->op_flags |= OPf_KIDS;
1465 parent->op_flags &= ~OPf_KIDS;
1469 /* update op_last etc */
1476 /* ought to use OP_CLASS(parent) here, but that can't handle
1477 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1479 type = parent->op_type;
1480 if (type == OP_CUSTOM) {
1482 type = XopENTRYCUSTOM(parent, xop_class);
1485 if (type == OP_NULL)
1486 type = parent->op_targ;
1487 type = PL_opargs[type] & OA_CLASS_MASK;
1490 lastop = last_ins ? last_ins : start ? start : NULL;
1491 if ( type == OA_BINOP
1492 || type == OA_LISTOP
1496 cLISTOPx(parent)->op_last = lastop;
1499 OpLASTSIB_set(lastop, parent);
1501 return last_del ? first : NULL;
1504 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1508 =for apidoc op_parent
1510 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1516 Perl_op_parent(OP *o)
1518 PERL_ARGS_ASSERT_OP_PARENT;
1519 while (OpHAS_SIBLING(o))
1521 return o->op_sibparent;
1524 /* replace the sibling following start with a new UNOP, which becomes
1525 * the parent of the original sibling; e.g.
1527 * op_sibling_newUNOP(P, A, unop-args...)
1535 * where U is the new UNOP.
1537 * parent and start args are the same as for op_sibling_splice();
1538 * type and flags args are as newUNOP().
1540 * Returns the new UNOP.
1544 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1548 kid = op_sibling_splice(parent, start, 1, NULL);
1549 newop = newUNOP(type, flags, kid);
1550 op_sibling_splice(parent, start, 0, newop);
1555 /* lowest-level newLOGOP-style function - just allocates and populates
1556 * the struct. Higher-level stuff should be done by S_new_logop() /
1557 * newLOGOP(). This function exists mainly to avoid op_first assignment
1558 * being spread throughout this file.
1562 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1567 NewOp(1101, logop, 1, LOGOP);
1568 OpTYPE_set(logop, type);
1569 logop->op_first = first;
1570 logop->op_other = other;
1572 logop->op_flags = OPf_KIDS;
1573 while (kid && OpHAS_SIBLING(kid))
1574 kid = OpSIBLING(kid);
1576 OpLASTSIB_set(kid, (OP*)logop);
1581 /* Contextualizers */
1584 =for apidoc op_contextualize
1586 Applies a syntactic context to an op tree representing an expression.
1587 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1588 or C<G_VOID> to specify the context to apply. The modified op tree
1595 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1597 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1599 case G_SCALAR: return scalar(o);
1600 case G_ARRAY: return list(o);
1601 case G_VOID: return scalarvoid(o);
1603 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1610 =for apidoc op_linklist
1611 This function is the implementation of the L</LINKLIST> macro. It should
1612 not be called directly.
1619 Perl_op_linklist(pTHX_ OP *o)
1626 PERL_ARGS_ASSERT_OP_LINKLIST;
1629 /* Descend down the tree looking for any unprocessed subtrees to
1632 if (o->op_flags & OPf_KIDS) {
1633 o = cUNOPo->op_first;
1636 o->op_next = o; /* leaf node; link to self initially */
1639 /* if we're at the top level, there either weren't any children
1640 * to process, or we've worked our way back to the top. */
1644 /* o is now processed. Next, process any sibling subtrees */
1646 if (OpHAS_SIBLING(o)) {
1651 /* Done all the subtrees at this level. Go back up a level and
1652 * link the parent in with all its (processed) children.
1655 o = o->op_sibparent;
1656 assert(!o->op_next);
1657 prevp = &(o->op_next);
1658 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1660 *prevp = kid->op_next;
1661 prevp = &(kid->op_next);
1662 kid = OpSIBLING(kid);
1670 S_scalarkids(pTHX_ OP *o)
1672 if (o && o->op_flags & OPf_KIDS) {
1674 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1681 S_scalarboolean(pTHX_ OP *o)
1683 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1685 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1686 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1687 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1688 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1689 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1690 if (ckWARN(WARN_SYNTAX)) {
1691 const line_t oldline = CopLINE(PL_curcop);
1693 if (PL_parser && PL_parser->copline != NOLINE) {
1694 /* This ensures that warnings are reported at the first line
1695 of the conditional, not the last. */
1696 CopLINE_set(PL_curcop, PL_parser->copline);
1698 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1699 CopLINE_set(PL_curcop, oldline);
1706 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1709 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1710 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1712 const char funny = o->op_type == OP_PADAV
1713 || o->op_type == OP_RV2AV ? '@' : '%';
1714 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1716 if (cUNOPo->op_first->op_type != OP_GV
1717 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1719 return varname(gv, funny, 0, NULL, 0, subscript_type);
1722 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1727 S_op_varname(pTHX_ const OP *o)
1729 return S_op_varname_subscript(aTHX_ o, 1);
1733 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1734 { /* or not so pretty :-) */
1735 if (o->op_type == OP_CONST) {
1737 if (SvPOK(*retsv)) {
1739 *retsv = sv_newmortal();
1740 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1741 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1743 else if (!SvOK(*retsv))
1746 else *retpv = "...";
1750 S_scalar_slice_warning(pTHX_ const OP *o)
1753 const bool h = o->op_type == OP_HSLICE
1754 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1760 SV *keysv = NULL; /* just to silence compiler warnings */
1761 const char *key = NULL;
1763 if (!(o->op_private & OPpSLICEWARNING))
1765 if (PL_parser && PL_parser->error_count)
1766 /* This warning can be nonsensical when there is a syntax error. */
1769 kid = cLISTOPo->op_first;
1770 kid = OpSIBLING(kid); /* get past pushmark */
1771 /* weed out false positives: any ops that can return lists */
1772 switch (kid->op_type) {
1798 /* Don't warn if we have a nulled list either. */
1799 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1802 assert(OpSIBLING(kid));
1803 name = S_op_varname(aTHX_ OpSIBLING(kid));
1804 if (!name) /* XS module fiddling with the op tree */
1806 S_op_pretty(aTHX_ kid, &keysv, &key);
1807 assert(SvPOK(name));
1808 sv_chop(name,SvPVX(name)+1);
1810 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1811 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1812 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1814 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1815 lbrack, key, rbrack);
1817 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1818 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1819 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1821 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1822 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1827 /* apply scalar context to the o subtree */
1830 Perl_scalar(pTHX_ OP *o)
1835 OP *next_kid = NULL; /* what op (if any) to process next */
1838 /* assumes no premature commitment */
1839 if (!o || (PL_parser && PL_parser->error_count)
1840 || (o->op_flags & OPf_WANT)
1841 || o->op_type == OP_RETURN)
1846 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1848 switch (o->op_type) {
1850 scalar(cBINOPo->op_first);
1851 /* convert what initially looked like a list repeat into a
1852 * scalar repeat, e.g. $s = (1) x $n
1854 if (o->op_private & OPpREPEAT_DOLIST) {
1855 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1856 assert(kid->op_type == OP_PUSHMARK);
1857 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1858 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1859 o->op_private &=~ OPpREPEAT_DOLIST;
1867 /* impose scalar context on everything except the condition */
1868 next_kid = OpSIBLING(cUNOPo->op_first);
1872 if (o->op_flags & OPf_KIDS)
1873 next_kid = cUNOPo->op_first; /* do all kids */
1876 /* the children of these ops are usually a list of statements,
1877 * except the leaves, whose first child is a corresponding enter
1882 kid = cLISTOPo->op_first;
1886 kid = cLISTOPo->op_first;
1888 kid = OpSIBLING(kid);
1891 OP *sib = OpSIBLING(kid);
1892 /* Apply void context to all kids except the last, which
1893 * is scalar (ignoring a trailing ex-nextstate in determining
1894 * if it's the last kid). E.g.
1895 * $scalar = do { void; void; scalar }
1896 * Except that 'when's are always scalar, e.g.
1897 * $scalar = do { given(..) {
1898 * when (..) { scalar }
1899 * when (..) { scalar }
1904 || ( !OpHAS_SIBLING(sib)
1905 && sib->op_type == OP_NULL
1906 && ( sib->op_targ == OP_NEXTSTATE
1907 || sib->op_targ == OP_DBSTATE )
1911 /* tail call optimise calling scalar() on the last kid */
1915 else if (kid->op_type == OP_LEAVEWHEN)
1921 NOT_REACHED; /* NOTREACHED */
1925 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1931 /* Warn about scalar context */
1932 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1933 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1936 const char *key = NULL;
1938 /* This warning can be nonsensical when there is a syntax error. */
1939 if (PL_parser && PL_parser->error_count)
1942 if (!ckWARN(WARN_SYNTAX)) break;
1944 kid = cLISTOPo->op_first;
1945 kid = OpSIBLING(kid); /* get past pushmark */
1946 assert(OpSIBLING(kid));
1947 name = S_op_varname(aTHX_ OpSIBLING(kid));
1948 if (!name) /* XS module fiddling with the op tree */
1950 S_op_pretty(aTHX_ kid, &keysv, &key);
1951 assert(SvPOK(name));
1952 sv_chop(name,SvPVX(name)+1);
1954 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1955 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1956 "%%%" SVf "%c%s%c in scalar context better written "
1957 "as $%" SVf "%c%s%c",
1958 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1959 lbrack, key, rbrack);
1961 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1962 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1963 "%%%" SVf "%c%" SVf "%c in scalar context better "
1964 "written as $%" SVf "%c%" SVf "%c",
1965 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1966 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1970 /* If next_kid is set, someone in the code above wanted us to process
1971 * that kid and all its remaining siblings. Otherwise, work our way
1972 * back up the tree */
1976 return top_op; /* at top; no parents/siblings to try */
1977 if (OpHAS_SIBLING(o))
1978 next_kid = o->op_sibparent;
1980 o = o->op_sibparent; /*try parent's next sibling */
1981 switch (o->op_type) {
1987 /* should really restore PL_curcop to its old value, but
1988 * setting it to PL_compiling is better than do nothing */
1989 PL_curcop = &PL_compiling;
1998 /* apply void context to the optree arg */
2001 Perl_scalarvoid(pTHX_ OP *arg)
2008 PERL_ARGS_ASSERT_SCALARVOID;
2012 SV *useless_sv = NULL;
2013 const char* useless = NULL;
2014 OP * next_kid = NULL;
2016 if (o->op_type == OP_NEXTSTATE
2017 || o->op_type == OP_DBSTATE
2018 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2019 || o->op_targ == OP_DBSTATE)))
2020 PL_curcop = (COP*)o; /* for warning below */
2022 /* assumes no premature commitment */
2023 want = o->op_flags & OPf_WANT;
2024 if ((want && want != OPf_WANT_SCALAR)
2025 || (PL_parser && PL_parser->error_count)
2026 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2031 if ((o->op_private & OPpTARGET_MY)
2032 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2034 /* newASSIGNOP has already applied scalar context, which we
2035 leave, as if this op is inside SASSIGN. */
2039 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2041 switch (o->op_type) {
2043 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2047 if (o->op_flags & OPf_STACKED)
2049 if (o->op_type == OP_REPEAT)
2050 scalar(cBINOPo->op_first);
2053 if ((o->op_flags & OPf_STACKED) &&
2054 !(o->op_private & OPpCONCAT_NESTED))
2058 if (o->op_private == 4)
2093 case OP_GETSOCKNAME:
2094 case OP_GETPEERNAME:
2099 case OP_GETPRIORITY:
2124 useless = OP_DESC(o);
2134 case OP_AELEMFAST_LEX:
2138 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2139 /* Otherwise it's "Useless use of grep iterator" */
2140 useless = OP_DESC(o);
2144 if (!(o->op_private & OPpSPLIT_ASSIGN))
2145 useless = OP_DESC(o);
2149 kid = cUNOPo->op_first;
2150 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2151 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2154 useless = "negative pattern binding (!~)";
2158 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2159 useless = "non-destructive substitution (s///r)";
2163 useless = "non-destructive transliteration (tr///r)";
2170 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2171 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2172 useless = "a variable";
2177 if (cSVOPo->op_private & OPpCONST_STRICT)
2178 no_bareword_allowed(o);
2180 if (ckWARN(WARN_VOID)) {
2182 /* don't warn on optimised away booleans, eg
2183 * use constant Foo, 5; Foo || print; */
2184 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2186 /* the constants 0 and 1 are permitted as they are
2187 conventionally used as dummies in constructs like
2188 1 while some_condition_with_side_effects; */
2189 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2191 else if (SvPOK(sv)) {
2192 SV * const dsv = newSVpvs("");
2194 = Perl_newSVpvf(aTHX_
2196 pv_pretty(dsv, SvPVX_const(sv),
2197 SvCUR(sv), 32, NULL, NULL,
2199 | PERL_PV_ESCAPE_NOCLEAR
2200 | PERL_PV_ESCAPE_UNI_DETECT));
2201 SvREFCNT_dec_NN(dsv);
2203 else if (SvOK(sv)) {
2204 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2207 useless = "a constant (undef)";
2210 op_null(o); /* don't execute or even remember it */
2214 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2218 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2222 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2226 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2231 UNOP *refgen, *rv2cv;
2234 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2237 rv2gv = ((BINOP *)o)->op_last;
2238 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2241 refgen = (UNOP *)((BINOP *)o)->op_first;
2243 if (!refgen || (refgen->op_type != OP_REFGEN
2244 && refgen->op_type != OP_SREFGEN))
2247 exlist = (LISTOP *)refgen->op_first;
2248 if (!exlist || exlist->op_type != OP_NULL
2249 || exlist->op_targ != OP_LIST)
2252 if (exlist->op_first->op_type != OP_PUSHMARK
2253 && exlist->op_first != exlist->op_last)
2256 rv2cv = (UNOP*)exlist->op_last;
2258 if (rv2cv->op_type != OP_RV2CV)
2261 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2262 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2263 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2265 o->op_private |= OPpASSIGN_CV_TO_GV;
2266 rv2gv->op_private |= OPpDONT_INIT_GV;
2267 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2279 kid = cLOGOPo->op_first;
2280 if (kid->op_type == OP_NOT
2281 && (kid->op_flags & OPf_KIDS)) {
2282 if (o->op_type == OP_AND) {
2283 OpTYPE_set(o, OP_OR);
2285 OpTYPE_set(o, OP_AND);
2295 next_kid = OpSIBLING(cUNOPo->op_first);
2299 if (o->op_flags & OPf_STACKED)
2306 if (!(o->op_flags & OPf_KIDS))
2317 next_kid = cLISTOPo->op_first;
2320 /* If the first kid after pushmark is something that the padrange
2321 optimisation would reject, then null the list and the pushmark.
2323 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2324 && ( !(kid = OpSIBLING(kid))
2325 || ( kid->op_type != OP_PADSV
2326 && kid->op_type != OP_PADAV
2327 && kid->op_type != OP_PADHV)
2328 || kid->op_private & ~OPpLVAL_INTRO
2329 || !(kid = OpSIBLING(kid))
2330 || ( kid->op_type != OP_PADSV
2331 && kid->op_type != OP_PADAV
2332 && kid->op_type != OP_PADHV)
2333 || kid->op_private & ~OPpLVAL_INTRO)
2335 op_null(cUNOPo->op_first); /* NULL the pushmark */
2336 op_null(o); /* NULL the list */
2348 /* mortalise it, in case warnings are fatal. */
2349 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2350 "Useless use of %" SVf " in void context",
2351 SVfARG(sv_2mortal(useless_sv)));
2354 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2355 "Useless use of %s in void context",
2360 /* if a kid hasn't been nominated to process, continue with the
2361 * next sibling, or if no siblings left, go back to the parent's
2362 * siblings and so on
2366 return arg; /* at top; no parents/siblings to try */
2367 if (OpHAS_SIBLING(o))
2368 next_kid = o->op_sibparent;
2370 o = o->op_sibparent; /*try parent's next sibling */
2380 S_listkids(pTHX_ OP *o)
2382 if (o && o->op_flags & OPf_KIDS) {
2384 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2391 /* apply list context to the o subtree */
2394 Perl_list(pTHX_ OP *o)
2399 OP *next_kid = NULL; /* what op (if any) to process next */
2403 /* assumes no premature commitment */
2404 if (!o || (o->op_flags & OPf_WANT)
2405 || (PL_parser && PL_parser->error_count)
2406 || o->op_type == OP_RETURN)
2411 if ((o->op_private & OPpTARGET_MY)
2412 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2414 goto do_next; /* As if inside SASSIGN */
2417 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2419 switch (o->op_type) {
2421 if (o->op_private & OPpREPEAT_DOLIST
2422 && !(o->op_flags & OPf_STACKED))
2424 list(cBINOPo->op_first);
2425 kid = cBINOPo->op_last;
2426 /* optimise away (.....) x 1 */
2427 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2428 && SvIVX(kSVOP_sv) == 1)
2430 op_null(o); /* repeat */
2431 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2433 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2441 /* impose list context on everything except the condition */
2442 next_kid = OpSIBLING(cUNOPo->op_first);
2446 if (!(o->op_flags & OPf_KIDS))
2448 /* possibly flatten 1..10 into a constant array */
2449 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2450 list(cBINOPo->op_first);
2451 gen_constant_list(o);
2454 next_kid = cUNOPo->op_first; /* do all kids */
2458 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2459 op_null(cUNOPo->op_first); /* NULL the pushmark */
2460 op_null(o); /* NULL the list */
2462 if (o->op_flags & OPf_KIDS)
2463 next_kid = cUNOPo->op_first; /* do all kids */
2466 /* the children of these ops are usually a list of statements,
2467 * except the leaves, whose first child is a corresponding enter
2471 kid = cLISTOPo->op_first;
2475 kid = cLISTOPo->op_first;
2477 kid = OpSIBLING(kid);
2480 OP *sib = OpSIBLING(kid);
2481 /* Apply void context to all kids except the last, which
2483 * @a = do { void; void; list }
2484 * Except that 'when's are always list context, e.g.
2485 * @a = do { given(..) {
2486 * when (..) { list }
2487 * when (..) { list }
2492 /* tail call optimise calling list() on the last kid */
2496 else if (kid->op_type == OP_LEAVEWHEN)
2502 NOT_REACHED; /* NOTREACHED */
2507 /* If next_kid is set, someone in the code above wanted us to process
2508 * that kid and all its remaining siblings. Otherwise, work our way
2509 * back up the tree */
2513 return top_op; /* at top; no parents/siblings to try */
2514 if (OpHAS_SIBLING(o))
2515 next_kid = o->op_sibparent;
2517 o = o->op_sibparent; /*try parent's next sibling */
2518 switch (o->op_type) {
2524 /* should really restore PL_curcop to its old value, but
2525 * setting it to PL_compiling is better than do nothing */
2526 PL_curcop = &PL_compiling;
2538 S_scalarseq(pTHX_ OP *o)
2541 const OPCODE type = o->op_type;
2543 if (type == OP_LINESEQ || type == OP_SCOPE ||
2544 type == OP_LEAVE || type == OP_LEAVETRY)
2547 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2548 if ((sib = OpSIBLING(kid))
2549 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2550 || ( sib->op_targ != OP_NEXTSTATE
2551 && sib->op_targ != OP_DBSTATE )))
2556 PL_curcop = &PL_compiling;
2558 o->op_flags &= ~OPf_PARENS;
2559 if (PL_hints & HINT_BLOCK_SCOPE)
2560 o->op_flags |= OPf_PARENS;
2563 o = newOP(OP_STUB, 0);
2568 S_modkids(pTHX_ OP *o, I32 type)
2570 if (o && o->op_flags & OPf_KIDS) {
2572 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2573 op_lvalue(kid, type);
2579 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2580 * const fields. Also, convert CONST keys to HEK-in-SVs.
2581 * rop is the op that retrieves the hash;
2582 * key_op is the first key
2583 * real if false, only check (and possibly croak); don't update op
2587 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2593 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2595 if (rop->op_first->op_type == OP_PADSV)
2596 /* @$hash{qw(keys here)} */
2597 rop = (UNOP*)rop->op_first;
2599 /* @{$hash}{qw(keys here)} */
2600 if (rop->op_first->op_type == OP_SCOPE
2601 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2603 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2610 lexname = NULL; /* just to silence compiler warnings */
2611 fields = NULL; /* just to silence compiler warnings */
2615 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2616 SvPAD_TYPED(lexname))
2617 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2618 && isGV(*fields) && GvHV(*fields);
2620 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2622 if (key_op->op_type != OP_CONST)
2624 svp = cSVOPx_svp(key_op);
2626 /* make sure it's not a bareword under strict subs */
2627 if (key_op->op_private & OPpCONST_BARE &&
2628 key_op->op_private & OPpCONST_STRICT)
2630 no_bareword_allowed((OP*)key_op);
2633 /* Make the CONST have a shared SV */
2634 if ( !SvIsCOW_shared_hash(sv = *svp)
2635 && SvTYPE(sv) < SVt_PVMG
2641 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2642 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2643 SvREFCNT_dec_NN(sv);
2648 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2650 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2651 "in variable %" PNf " of type %" HEKf,
2652 SVfARG(*svp), PNfARG(lexname),
2653 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2658 /* info returned by S_sprintf_is_multiconcatable() */
2660 struct sprintf_ismc_info {
2661 SSize_t nargs; /* num of args to sprintf (not including the format) */
2662 char *start; /* start of raw format string */
2663 char *end; /* bytes after end of raw format string */
2664 STRLEN total_len; /* total length (in bytes) of format string, not
2665 including '%s' and half of '%%' */
2666 STRLEN variant; /* number of bytes by which total_len_p would grow
2667 if upgraded to utf8 */
2668 bool utf8; /* whether the format is utf8 */
2672 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2673 * i.e. its format argument is a const string with only '%s' and '%%'
2674 * formats, and the number of args is known, e.g.
2675 * sprintf "a=%s f=%s", $a[0], scalar(f());
2677 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2679 * If successful, the sprintf_ismc_info struct pointed to by info will be
2684 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2686 OP *pm, *constop, *kid;
2689 SSize_t nargs, nformats;
2690 STRLEN cur, total_len, variant;
2693 /* if sprintf's behaviour changes, die here so that someone
2694 * can decide whether to enhance this function or skip optimising
2695 * under those new circumstances */
2696 assert(!(o->op_flags & OPf_STACKED));
2697 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2698 assert(!(o->op_private & ~OPpARG4_MASK));
2700 pm = cUNOPo->op_first;
2701 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2703 constop = OpSIBLING(pm);
2704 if (!constop || constop->op_type != OP_CONST)
2706 sv = cSVOPx_sv(constop);
2707 if (SvMAGICAL(sv) || !SvPOK(sv))
2713 /* Scan format for %% and %s and work out how many %s there are.
2714 * Abandon if other format types are found.
2721 for (p = s; p < e; p++) {
2724 if (!UTF8_IS_INVARIANT(*p))
2730 return FALSE; /* lone % at end gives "Invalid conversion" */
2739 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2742 utf8 = cBOOL(SvUTF8(sv));
2746 /* scan args; they must all be in scalar cxt */
2749 kid = OpSIBLING(constop);
2752 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2755 kid = OpSIBLING(kid);
2758 if (nargs != nformats)
2759 return FALSE; /* e.g. sprintf("%s%s", $a); */
2762 info->nargs = nargs;
2765 info->total_len = total_len;
2766 info->variant = variant;
2774 /* S_maybe_multiconcat():
2776 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2777 * convert it (and its children) into an OP_MULTICONCAT. See the code
2778 * comments just before pp_multiconcat() for the full details of what
2779 * OP_MULTICONCAT supports.
2781 * Basically we're looking for an optree with a chain of OP_CONCATS down
2782 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2783 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2791 * STRINGIFY -- PADSV[$x]
2794 * ex-PUSHMARK -- CONCAT/S
2796 * CONCAT/S -- PADSV[$d]
2798 * CONCAT -- CONST["-"]
2800 * PADSV[$a] -- PADSV[$b]
2802 * Note that at this stage the OP_SASSIGN may have already been optimised
2803 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2807 S_maybe_multiconcat(pTHX_ OP *o)
2810 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2811 OP *topop; /* the top-most op in the concat tree (often equals o,
2812 unless there are assign/stringify ops above it */
2813 OP *parentop; /* the parent op of topop (or itself if no parent) */
2814 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2815 OP *targetop; /* the op corresponding to target=... or target.=... */
2816 OP *stringop; /* the OP_STRINGIFY op, if any */
2817 OP *nextop; /* used for recreating the op_next chain without consts */
2818 OP *kid; /* general-purpose op pointer */
2820 UNOP_AUX_item *lenp;
2821 char *const_str, *p;
2822 struct sprintf_ismc_info sprintf_info;
2824 /* store info about each arg in args[];
2825 * toparg is the highest used slot; argp is a general
2826 * pointer to args[] slots */
2828 void *p; /* initially points to const sv (or null for op);
2829 later, set to SvPV(constsv), with ... */
2830 STRLEN len; /* ... len set to SvPV(..., len) */
2831 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2835 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2838 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2839 the last-processed arg will the LHS of one,
2840 as args are processed in reverse order */
2841 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2842 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2843 U8 flags = 0; /* what will become the op_flags and ... */
2844 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2845 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2846 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2847 bool prev_was_const = FALSE; /* previous arg was a const */
2849 /* -----------------------------------------------------------------
2852 * Examine the optree non-destructively to determine whether it's
2853 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2854 * information about the optree in args[].
2864 assert( o->op_type == OP_SASSIGN
2865 || o->op_type == OP_CONCAT
2866 || o->op_type == OP_SPRINTF
2867 || o->op_type == OP_STRINGIFY);
2869 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2871 /* first see if, at the top of the tree, there is an assign,
2872 * append and/or stringify */
2874 if (topop->op_type == OP_SASSIGN) {
2876 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2878 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2880 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2883 topop = cBINOPo->op_first;
2884 targetop = OpSIBLING(topop);
2885 if (!targetop) /* probably some sort of syntax error */
2888 else if ( topop->op_type == OP_CONCAT
2889 && (topop->op_flags & OPf_STACKED)
2890 && (!(topop->op_private & OPpCONCAT_NESTED))
2895 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2896 * decide what to do about it */
2897 assert(!(o->op_private & OPpTARGET_MY));
2899 /* barf on unknown flags */
2900 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2901 private_flags |= OPpMULTICONCAT_APPEND;
2902 targetop = cBINOPo->op_first;
2904 topop = OpSIBLING(targetop);
2906 /* $x .= <FOO> gets optimised to rcatline instead */
2907 if (topop->op_type == OP_READLINE)
2912 /* Can targetop (the LHS) if it's a padsv, be be optimised
2913 * away and use OPpTARGET_MY instead?
2915 if ( (targetop->op_type == OP_PADSV)
2916 && !(targetop->op_private & OPpDEREF)
2917 && !(targetop->op_private & OPpPAD_STATE)
2918 /* we don't support 'my $x .= ...' */
2919 && ( o->op_type == OP_SASSIGN
2920 || !(targetop->op_private & OPpLVAL_INTRO))
2925 if (topop->op_type == OP_STRINGIFY) {
2926 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2930 /* barf on unknown flags */
2931 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2933 if ((topop->op_private & OPpTARGET_MY)) {
2934 if (o->op_type == OP_SASSIGN)
2935 return; /* can't have two assigns */
2939 private_flags |= OPpMULTICONCAT_STRINGIFY;
2941 topop = cBINOPx(topop)->op_first;
2942 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2943 topop = OpSIBLING(topop);
2946 if (topop->op_type == OP_SPRINTF) {
2947 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2949 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2950 nargs = sprintf_info.nargs;
2951 total_len = sprintf_info.total_len;
2952 variant = sprintf_info.variant;
2953 utf8 = sprintf_info.utf8;
2955 private_flags |= OPpMULTICONCAT_FAKE;
2957 /* we have an sprintf op rather than a concat optree.
2958 * Skip most of the code below which is associated with
2959 * processing that optree. We also skip phase 2, determining
2960 * whether its cost effective to optimise, since for sprintf,
2961 * multiconcat is *always* faster */
2964 /* note that even if the sprintf itself isn't multiconcatable,
2965 * the expression as a whole may be, e.g. in
2966 * $x .= sprintf("%d",...)
2967 * the sprintf op will be left as-is, but the concat/S op may
2968 * be upgraded to multiconcat
2971 else if (topop->op_type == OP_CONCAT) {
2972 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2975 if ((topop->op_private & OPpTARGET_MY)) {
2976 if (o->op_type == OP_SASSIGN || targmyop)
2977 return; /* can't have two assigns */
2982 /* Is it safe to convert a sassign/stringify/concat op into
2984 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
2985 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
2986 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2987 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
2988 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
2989 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2990 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
2991 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2993 /* Now scan the down the tree looking for a series of
2994 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2995 * stacked). For example this tree:
3000 * CONCAT/STACKED -- EXPR5
3002 * CONCAT/STACKED -- EXPR4
3008 * corresponds to an expression like
3010 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3012 * Record info about each EXPR in args[]: in particular, whether it is
3013 * a stringifiable OP_CONST and if so what the const sv is.
3015 * The reason why the last concat can't be STACKED is the difference
3018 * ((($a .= $a) .= $a) .= $a) .= $a
3021 * $a . $a . $a . $a . $a
3023 * The main difference between the optrees for those two constructs
3024 * is the presence of the last STACKED. As well as modifying $a,
3025 * the former sees the changed $a between each concat, so if $s is
3026 * initially 'a', the first returns 'a' x 16, while the latter returns
3027 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3037 if ( kid->op_type == OP_CONCAT
3041 k1 = cUNOPx(kid)->op_first;
3043 /* shouldn't happen except maybe after compile err? */
3047 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3048 if (kid->op_private & OPpTARGET_MY)
3051 stacked_last = (kid->op_flags & OPf_STACKED);
3063 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3064 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3066 /* At least two spare slots are needed to decompose both
3067 * concat args. If there are no slots left, continue to
3068 * examine the rest of the optree, but don't push new values
3069 * on args[]. If the optree as a whole is legal for conversion
3070 * (in particular that the last concat isn't STACKED), then
3071 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3072 * can be converted into an OP_MULTICONCAT now, with the first
3073 * child of that op being the remainder of the optree -
3074 * which may itself later be converted to a multiconcat op
3078 /* the last arg is the rest of the optree */
3083 else if ( argop->op_type == OP_CONST
3084 && ((sv = cSVOPx_sv(argop)))
3085 /* defer stringification until runtime of 'constant'
3086 * things that might stringify variantly, e.g. the radix
3087 * point of NVs, or overloaded RVs */
3088 && (SvPOK(sv) || SvIOK(sv))
3089 && (!SvGMAGICAL(sv))
3092 utf8 |= cBOOL(SvUTF8(sv));
3095 /* this const may be demoted back to a plain arg later;
3096 * make sure we have enough arg slots left */
3098 prev_was_const = !prev_was_const;
3103 prev_was_const = FALSE;
3113 return; /* we don't support ((A.=B).=C)...) */
3115 /* look for two adjacent consts and don't fold them together:
3118 * $o->concat("a")->concat("b")
3121 * (but $o .= "a" . "b" should still fold)
3124 bool seen_nonconst = FALSE;
3125 for (argp = toparg; argp >= args; argp--) {
3126 if (argp->p == NULL) {
3127 seen_nonconst = TRUE;
3133 /* both previous and current arg were constants;
3134 * leave the current OP_CONST as-is */
3142 /* -----------------------------------------------------------------
3145 * At this point we have determined that the optree *can* be converted
3146 * into a multiconcat. Having gathered all the evidence, we now decide
3147 * whether it *should*.
3151 /* we need at least one concat action, e.g.:
3157 * otherwise we could be doing something like $x = "foo", which
3158 * if treated as as a concat, would fail to COW.
3160 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3163 /* Benchmarking seems to indicate that we gain if:
3164 * * we optimise at least two actions into a single multiconcat
3165 * (e.g concat+concat, sassign+concat);
3166 * * or if we can eliminate at least 1 OP_CONST;
3167 * * or if we can eliminate a padsv via OPpTARGET_MY
3171 /* eliminated at least one OP_CONST */
3173 /* eliminated an OP_SASSIGN */
3174 || o->op_type == OP_SASSIGN
3175 /* eliminated an OP_PADSV */
3176 || (!targmyop && is_targable)
3178 /* definitely a net gain to optimise */
3181 /* ... if not, what else? */
3183 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3184 * multiconcat is faster (due to not creating a temporary copy of
3185 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3191 && topop->op_type == OP_CONCAT
3193 PADOFFSET t = targmyop->op_targ;
3194 OP *k1 = cBINOPx(topop)->op_first;
3195 OP *k2 = cBINOPx(topop)->op_last;
3196 if ( k2->op_type == OP_PADSV
3198 && ( k1->op_type != OP_PADSV
3199 || k1->op_targ != t)
3204 /* need at least two concats */
3205 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3210 /* -----------------------------------------------------------------
3213 * At this point the optree has been verified as ok to be optimised
3214 * into an OP_MULTICONCAT. Now start changing things.
3219 /* stringify all const args and determine utf8ness */
3222 for (argp = args; argp <= toparg; argp++) {
3223 SV *sv = (SV*)argp->p;
3225 continue; /* not a const op */
3226 if (utf8 && !SvUTF8(sv))
3227 sv_utf8_upgrade_nomg(sv);
3228 argp->p = SvPV_nomg(sv, argp->len);
3229 total_len += argp->len;
3231 /* see if any strings would grow if converted to utf8 */
3233 variant += variant_under_utf8_count((U8 *) argp->p,
3234 (U8 *) argp->p + argp->len);
3238 /* create and populate aux struct */
3242 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3243 sizeof(UNOP_AUX_item)
3245 PERL_MULTICONCAT_HEADER_SIZE
3246 + ((nargs + 1) * (variant ? 2 : 1))
3249 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3251 /* Extract all the non-const expressions from the concat tree then
3252 * dispose of the old tree, e.g. convert the tree from this:
3256 * STRINGIFY -- TARGET
3258 * ex-PUSHMARK -- CONCAT
3273 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3275 * except that if EXPRi is an OP_CONST, it's discarded.
3277 * During the conversion process, EXPR ops are stripped from the tree
3278 * and unshifted onto o. Finally, any of o's remaining original
3279 * childen are discarded and o is converted into an OP_MULTICONCAT.
3281 * In this middle of this, o may contain both: unshifted args on the
3282 * left, and some remaining original args on the right. lastkidop
3283 * is set to point to the right-most unshifted arg to delineate
3284 * between the two sets.
3289 /* create a copy of the format with the %'s removed, and record
3290 * the sizes of the const string segments in the aux struct */
3292 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3294 p = sprintf_info.start;
3297 for (; p < sprintf_info.end; p++) {
3301 (lenp++)->ssize = q - oldq;
3308 lenp->ssize = q - oldq;
3309 assert((STRLEN)(q - const_str) == total_len);
3311 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3312 * may or may not be topop) The pushmark and const ops need to be
3313 * kept in case they're an op_next entry point.
3315 lastkidop = cLISTOPx(topop)->op_last;
3316 kid = cUNOPx(topop)->op_first; /* pushmark */
3318 op_null(OpSIBLING(kid)); /* const */
3320 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3321 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3322 lastkidop->op_next = o;
3327 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3331 /* Concatenate all const strings into const_str.
3332 * Note that args[] contains the RHS args in reverse order, so
3333 * we scan args[] from top to bottom to get constant strings
3336 for (argp = toparg; argp >= args; argp--) {
3338 /* not a const op */
3339 (++lenp)->ssize = -1;
3341 STRLEN l = argp->len;
3342 Copy(argp->p, p, l, char);
3344 if (lenp->ssize == -1)
3355 for (argp = args; argp <= toparg; argp++) {
3356 /* only keep non-const args, except keep the first-in-next-chain
3357 * arg no matter what it is (but nulled if OP_CONST), because it
3358 * may be the entry point to this subtree from the previous
3361 bool last = (argp == toparg);
3364 /* set prev to the sibling *before* the arg to be cut out,
3365 * e.g. when cutting EXPR:
3370 * prev= CONCAT -- EXPR
3373 if (argp == args && kid->op_type != OP_CONCAT) {
3374 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3375 * so the expression to be cut isn't kid->op_last but
3378 /* find the op before kid */
3380 o2 = cUNOPx(parentop)->op_first;
3381 while (o2 && o2 != kid) {
3389 else if (kid == o && lastkidop)
3390 prev = last ? lastkidop : OpSIBLING(lastkidop);
3392 prev = last ? NULL : cUNOPx(kid)->op_first;
3394 if (!argp->p || last) {
3396 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3397 /* and unshift to front of o */
3398 op_sibling_splice(o, NULL, 0, aop);
3399 /* record the right-most op added to o: later we will
3400 * free anything to the right of it */
3403 aop->op_next = nextop;
3406 /* null the const at start of op_next chain */
3410 nextop = prev->op_next;
3413 /* the last two arguments are both attached to the same concat op */
3414 if (argp < toparg - 1)
3419 /* Populate the aux struct */
3421 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3422 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3423 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3424 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3425 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3427 /* if variant > 0, calculate a variant const string and lengths where
3428 * the utf8 version of the string will take 'variant' more bytes than
3432 char *p = const_str;
3433 STRLEN ulen = total_len + variant;
3434 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3435 UNOP_AUX_item *ulens = lens + (nargs + 1);
3436 char *up = (char*)PerlMemShared_malloc(ulen);
3439 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3440 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3442 for (n = 0; n < (nargs + 1); n++) {
3444 char * orig_up = up;
3445 for (i = (lens++)->ssize; i > 0; i--) {
3447 append_utf8_from_native_byte(c, (U8**)&up);
3449 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3454 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3455 * that op's first child - an ex-PUSHMARK - because the op_next of
3456 * the previous op may point to it (i.e. it's the entry point for
3461 ? op_sibling_splice(o, lastkidop, 1, NULL)
3462 : op_sibling_splice(stringop, NULL, 1, NULL);
3463 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3464 op_sibling_splice(o, NULL, 0, pmop);
3471 * target .= A.B.C...
3477 if (o->op_type == OP_SASSIGN) {
3478 /* Move the target subtree from being the last of o's children
3479 * to being the last of o's preserved children.
3480 * Note the difference between 'target = ...' and 'target .= ...':
3481 * for the former, target is executed last; for the latter,
3484 kid = OpSIBLING(lastkidop);
3485 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3486 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3487 lastkidop->op_next = kid->op_next;
3488 lastkidop = targetop;
3491 /* Move the target subtree from being the first of o's
3492 * original children to being the first of *all* o's children.
3495 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3496 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3499 /* if the RHS of .= doesn't contain a concat (e.g.
3500 * $x .= "foo"), it gets missed by the "strip ops from the
3501 * tree and add to o" loop earlier */
3502 assert(topop->op_type != OP_CONCAT);
3504 /* in e.g. $x .= "$y", move the $y expression
3505 * from being a child of OP_STRINGIFY to being the
3506 * second child of the OP_CONCAT
3508 assert(cUNOPx(stringop)->op_first == topop);
3509 op_sibling_splice(stringop, NULL, 1, NULL);
3510 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3512 assert(topop == OpSIBLING(cBINOPo->op_first));
3521 * my $lex = A.B.C...
3524 * The original padsv op is kept but nulled in case it's the
3525 * entry point for the optree (which it will be for
3528 private_flags |= OPpTARGET_MY;
3529 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3530 o->op_targ = targetop->op_targ;
3531 targetop->op_targ = 0;
3535 flags |= OPf_STACKED;
3537 else if (targmyop) {
3538 private_flags |= OPpTARGET_MY;
3539 if (o != targmyop) {
3540 o->op_targ = targmyop->op_targ;
3541 targmyop->op_targ = 0;
3545 /* detach the emaciated husk of the sprintf/concat optree and free it */
3547 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3553 /* and convert o into a multiconcat */
3555 o->op_flags = (flags|OPf_KIDS|stacked_last
3556 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3557 o->op_private = private_flags;
3558 o->op_type = OP_MULTICONCAT;
3559 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3560 cUNOP_AUXo->op_aux = aux;
3564 /* do all the final processing on an optree (e.g. running the peephole
3565 * optimiser on it), then attach it to cv (if cv is non-null)
3569 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3573 /* XXX for some reason, evals, require and main optrees are
3574 * never attached to their CV; instead they just hang off
3575 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3576 * and get manually freed when appropriate */
3578 startp = &CvSTART(cv);
3580 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3583 optree->op_private |= OPpREFCOUNTED;
3584 OpREFCNT_set(optree, 1);
3585 optimize_optree(optree);
3587 finalize_optree(optree);
3588 S_prune_chain_head(startp);
3591 /* now that optimizer has done its work, adjust pad values */
3592 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3593 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3599 =for apidoc optimize_optree
3601 This function applies some optimisations to the optree in top-down order.
3602 It is called before the peephole optimizer, which processes ops in
3603 execution order. Note that finalize_optree() also does a top-down scan,
3604 but is called *after* the peephole optimizer.
3610 Perl_optimize_optree(pTHX_ OP* o)
3612 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3615 SAVEVPTR(PL_curcop);
3623 /* helper for optimize_optree() which optimises one op then recurses
3624 * to optimise any children.
3628 S_optimize_op(pTHX_ OP* o)
3632 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3635 OP * next_kid = NULL;
3637 assert(o->op_type != OP_FREED);
3639 switch (o->op_type) {
3642 PL_curcop = ((COP*)o); /* for warnings */
3650 S_maybe_multiconcat(aTHX_ o);
3654 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3655 /* we can't assume that op_pmreplroot->op_sibparent == o
3656 * and that it is thus possible to walk back up the tree
3657 * past op_pmreplroot. So, although we try to avoid
3658 * recursing through op trees, do it here. After all,
3659 * there are unlikely to be many nested s///e's within
3660 * the replacement part of a s///e.
3662 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3670 if (o->op_flags & OPf_KIDS)
3671 next_kid = cUNOPo->op_first;
3673 /* if a kid hasn't been nominated to process, continue with the
3674 * next sibling, or if no siblings left, go back to the parent's
3675 * siblings and so on
3679 return; /* at top; no parents/siblings to try */
3680 if (OpHAS_SIBLING(o))
3681 next_kid = o->op_sibparent;
3683 o = o->op_sibparent; /*try parent's next sibling */
3686 /* this label not yet used. Goto here if any code above sets
3696 =for apidoc finalize_optree
3698 This function finalizes the optree. Should be called directly after
3699 the complete optree is built. It does some additional
3700 checking which can't be done in the normal C<ck_>xxx functions and makes
3701 the tree thread-safe.
3706 Perl_finalize_optree(pTHX_ OP* o)
3708 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3711 SAVEVPTR(PL_curcop);
3719 /* Relocate sv to the pad for thread safety.
3720 * Despite being a "constant", the SV is written to,
3721 * for reference counts, sv_upgrade() etc. */
3722 PERL_STATIC_INLINE void
3723 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3726 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3728 ix = pad_alloc(OP_CONST, SVf_READONLY);
3729 SvREFCNT_dec(PAD_SVl(ix));
3730 PAD_SETSV(ix, *svp);
3731 /* XXX I don't know how this isn't readonly already. */
3732 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3739 =for apidoc traverse_op_tree
3741 Return the next op in a depth-first traversal of the op tree,
3742 returning NULL when the traversal is complete.
3744 The initial call must supply the root of the tree as both top and o.
3746 For now it's static, but it may be exposed to the API in the future.
3752 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3755 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3757 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3758 return cUNOPo->op_first;
3760 else if ((sib = OpSIBLING(o))) {
3764 OP *parent = o->op_sibparent;
3765 assert(!(o->op_moresib));
3766 while (parent && parent != top) {
3767 OP *sib = OpSIBLING(parent);
3770 parent = parent->op_sibparent;
3778 S_finalize_op(pTHX_ OP* o)
3781 PERL_ARGS_ASSERT_FINALIZE_OP;
3784 assert(o->op_type != OP_FREED);
3786 switch (o->op_type) {
3789 PL_curcop = ((COP*)o); /* for warnings */
3792 if (OpHAS_SIBLING(o)) {
3793 OP *sib = OpSIBLING(o);
3794 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3795 && ckWARN(WARN_EXEC)
3796 && OpHAS_SIBLING(sib))
3798 const OPCODE type = OpSIBLING(sib)->op_type;
3799 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3800 const line_t oldline = CopLINE(PL_curcop);
3801 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3802 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3803 "Statement unlikely to be reached");
3804 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3805 "\t(Maybe you meant system() when you said exec()?)\n");
3806 CopLINE_set(PL_curcop, oldline);
3813 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3814 GV * const gv = cGVOPo_gv;
3815 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3816 /* XXX could check prototype here instead of just carping */
3817 SV * const sv = sv_newmortal();
3818 gv_efullname3(sv, gv, NULL);
3819 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3820 "%" SVf "() called too early to check prototype",
3827 if (cSVOPo->op_private & OPpCONST_STRICT)
3828 no_bareword_allowed(o);
3832 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3837 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3838 case OP_METHOD_NAMED:
3839 case OP_METHOD_SUPER:
3840 case OP_METHOD_REDIR:
3841 case OP_METHOD_REDIR_SUPER:
3842 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3851 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3854 rop = (UNOP*)((BINOP*)o)->op_first;
3859 S_scalar_slice_warning(aTHX_ o);
3863 kid = OpSIBLING(cLISTOPo->op_first);
3864 if (/* I bet there's always a pushmark... */
3865 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3866 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3871 key_op = (SVOP*)(kid->op_type == OP_CONST
3873 : OpSIBLING(kLISTOP->op_first));
3875 rop = (UNOP*)((LISTOP*)o)->op_last;
3878 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3880 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3884 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3888 S_scalar_slice_warning(aTHX_ o);
3892 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3893 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3901 if (o->op_flags & OPf_KIDS) {
3904 /* check that op_last points to the last sibling, and that
3905 * the last op_sibling/op_sibparent field points back to the
3906 * parent, and that the only ops with KIDS are those which are
3907 * entitled to them */
3908 U32 type = o->op_type;
3912 if (type == OP_NULL) {
3914 /* ck_glob creates a null UNOP with ex-type GLOB
3915 * (which is a list op. So pretend it wasn't a listop */
3916 if (type == OP_GLOB)
3919 family = PL_opargs[type] & OA_CLASS_MASK;
3921 has_last = ( family == OA_BINOP
3922 || family == OA_LISTOP
3923 || family == OA_PMOP
3924 || family == OA_LOOP
3926 assert( has_last /* has op_first and op_last, or ...
3927 ... has (or may have) op_first: */
3928 || family == OA_UNOP
3929 || family == OA_UNOP_AUX
3930 || family == OA_LOGOP
3931 || family == OA_BASEOP_OR_UNOP
3932 || family == OA_FILESTATOP
3933 || family == OA_LOOPEXOP
3934 || family == OA_METHOP
3935 || type == OP_CUSTOM
3936 || type == OP_NULL /* new_logop does this */
3939 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3940 if (!OpHAS_SIBLING(kid)) {
3942 assert(kid == cLISTOPo->op_last);
3943 assert(kid->op_sibparent == o);
3948 } while (( o = traverse_op_tree(top, o)) != NULL);
3952 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3955 PadnameLVALUE_on(pn);
3956 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3958 /* RT #127786: cv can be NULL due to an eval within the DB package
3959 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3960 * unless they contain an eval, but calling eval within DB
3961 * pretends the eval was done in the caller's scope.
3965 assert(CvPADLIST(cv));
3967 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3968 assert(PadnameLEN(pn));
3969 PadnameLVALUE_on(pn);
3974 S_vivifies(const OPCODE type)
3977 case OP_RV2AV: case OP_ASLICE:
3978 case OP_RV2HV: case OP_KVASLICE:
3979 case OP_RV2SV: case OP_HSLICE:
3980 case OP_AELEMFAST: case OP_KVHSLICE:
3989 /* apply lvalue reference (aliasing) context to the optree o.
3992 * o would be the list ($x,$y) and type would be OP_AASSIGN.
3993 * It may descend and apply this to children too, for example in
3994 * \( $cond ? $x, $y) = (...)
3998 S_lvref(pTHX_ OP *o, I32 type)
4005 switch (o->op_type) {
4007 o = OpSIBLING(cUNOPo->op_first);
4014 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4015 o->op_flags |= OPf_STACKED;
4016 if (o->op_flags & OPf_PARENS) {
4017 if (o->op_private & OPpLVAL_INTRO) {
4018 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4019 "localized parenthesized array in list assignment"));
4023 OpTYPE_set(o, OP_LVAVREF);
4024 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4025 o->op_flags |= OPf_MOD|OPf_REF;
4028 o->op_private |= OPpLVREF_AV;
4032 kid = cUNOPo->op_first;
4033 if (kid->op_type == OP_NULL)
4034 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4036 o->op_private = OPpLVREF_CV;
4037 if (kid->op_type == OP_GV)
4038 o->op_flags |= OPf_STACKED;
4039 else if (kid->op_type == OP_PADCV) {
4040 o->op_targ = kid->op_targ;
4042 op_free(cUNOPo->op_first);
4043 cUNOPo->op_first = NULL;
4044 o->op_flags &=~ OPf_KIDS;
4050 if (o->op_flags & OPf_PARENS) {
4052 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4053 "parenthesized hash in list assignment"));
4056 o->op_private |= OPpLVREF_HV;
4060 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4061 o->op_flags |= OPf_STACKED;
4065 if (o->op_flags & OPf_PARENS) goto parenhash;
4066 o->op_private |= OPpLVREF_HV;
4069 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4073 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4074 if (o->op_flags & OPf_PARENS) goto slurpy;
4075 o->op_private |= OPpLVREF_AV;
4080 o->op_private |= OPpLVREF_ELEM;
4081 o->op_flags |= OPf_STACKED;
4086 OpTYPE_set(o, OP_LVREFSLICE);
4087 o->op_private &= OPpLVAL_INTRO;
4091 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4093 else if (!(o->op_flags & OPf_KIDS))
4096 /* the code formerly only recursed into the first child of
4097 * a non ex-list OP_NULL. if we ever encounter such a null op with
4098 * more than one child, need to decide whether its ok to process
4099 * *all* its kids or not */
4100 assert(o->op_targ == OP_LIST
4101 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4104 o = cLISTOPo->op_first;
4108 if (o->op_flags & OPf_PARENS)
4113 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4114 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4115 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4122 OpTYPE_set(o, OP_LVREF);
4124 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4125 if (type == OP_ENTERLOOP)
4126 o->op_private |= OPpLVREF_ITER;
4131 return; /* at top; no parents/siblings to try */
4132 if (OpHAS_SIBLING(o)) {
4133 o = o->op_sibparent;
4136 o = o->op_sibparent; /*try parent's next sibling */
4142 PERL_STATIC_INLINE bool
4143 S_potential_mod_type(I32 type)
4145 /* Types that only potentially result in modification. */
4146 return type == OP_GREPSTART || type == OP_ENTERSUB
4147 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4152 =for apidoc op_lvalue
4154 Propagate lvalue ("modifiable") context to an op and its children.
4155 C<type> represents the context type, roughly based on the type of op that
4156 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4157 because it has no op type of its own (it is signalled by a flag on
4160 This function detects things that can't be modified, such as C<$x+1>, and
4161 generates errors for them. For example, C<$x+1 = 2> would cause it to be
4162 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4164 It also flags things that need to behave specially in an lvalue context,
4165 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4169 Perl_op_lvalue_flags() is a non-API lower-level interface to
4170 op_lvalue(). The flags param has these bits:
4171 OP_LVALUE_NO_CROAK: return rather than croaking on error
4176 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4180 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4183 if (!o || (PL_parser && PL_parser->error_count))
4186 if ((o->op_private & OPpTARGET_MY)
4187 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4192 /* elements of a list might be in void context because the list is
4193 in scalar context or because they are attribute sub calls */
4194 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4197 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4199 switch (o->op_type) {
4204 if ((o->op_flags & OPf_PARENS))
4208 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4209 !(o->op_flags & OPf_STACKED)) {
4210 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4211 assert(cUNOPo->op_first->op_type == OP_NULL);
4212 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4215 else { /* lvalue subroutine call */
4216 o->op_private |= OPpLVAL_INTRO;
4217 PL_modcount = RETURN_UNLIMITED_NUMBER;
4218 if (S_potential_mod_type(type)) {
4219 o->op_private |= OPpENTERSUB_INARGS;
4222 else { /* Compile-time error message: */
4223 OP *kid = cUNOPo->op_first;
4228 if (kid->op_type != OP_PUSHMARK) {
4229 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4231 "panic: unexpected lvalue entersub "
4232 "args: type/targ %ld:%" UVuf,
4233 (long)kid->op_type, (UV)kid->op_targ);
4234 kid = kLISTOP->op_first;
4236 while (OpHAS_SIBLING(kid))
4237 kid = OpSIBLING(kid);
4238 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4239 break; /* Postpone until runtime */
4242 kid = kUNOP->op_first;
4243 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4244 kid = kUNOP->op_first;
4245 if (kid->op_type == OP_NULL)
4247 "Unexpected constant lvalue entersub "
4248 "entry via type/targ %ld:%" UVuf,
4249 (long)kid->op_type, (UV)kid->op_targ);
4250 if (kid->op_type != OP_GV) {
4257 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4258 ? MUTABLE_CV(SvRV(gv))
4264 if (flags & OP_LVALUE_NO_CROAK)
4267 namesv = cv_name(cv, NULL, 0);
4268 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4269 "subroutine call of &%" SVf " in %s",
4270 SVfARG(namesv), PL_op_desc[type]),
4278 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4279 /* grep, foreach, subcalls, refgen */
4280 if (S_potential_mod_type(type))
4282 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4283 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4286 type ? PL_op_desc[type] : "local"));
4299 case OP_RIGHT_SHIFT:
4308 if (!(o->op_flags & OPf_STACKED))
4314 if (o->op_flags & OPf_STACKED) {
4318 if (!(o->op_private & OPpREPEAT_DOLIST))
4321 const I32 mods = PL_modcount;
4322 modkids(cBINOPo->op_first, type);
4323 if (type != OP_AASSIGN)
4325 kid = cBINOPo->op_last;
4326 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4327 const IV iv = SvIV(kSVOP_sv);
4328 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4330 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4333 PL_modcount = RETURN_UNLIMITED_NUMBER;
4339 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4340 op_lvalue(kid, type);
4345 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4346 PL_modcount = RETURN_UNLIMITED_NUMBER;
4347 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4348 fiable since some contexts need to know. */
4349 o->op_flags |= OPf_MOD;
4354 if (scalar_mod_type(o, type))
4356 ref(cUNOPo->op_first, o->op_type);
4363 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4364 if (type == OP_LEAVESUBLV && (
4365 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4366 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4368 o->op_private |= OPpMAYBE_LVSUB;
4372 PL_modcount = RETURN_UNLIMITED_NUMBER;
4377 if (type == OP_LEAVESUBLV)
4378 o->op_private |= OPpMAYBE_LVSUB;
4381 if (type == OP_LEAVESUBLV
4382 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4383 o->op_private |= OPpMAYBE_LVSUB;
4386 PL_hints |= HINT_BLOCK_SCOPE;
4387 if (type == OP_LEAVESUBLV)
4388 o->op_private |= OPpMAYBE_LVSUB;
4392 ref(cUNOPo->op_first, o->op_type);
4396 PL_hints |= HINT_BLOCK_SCOPE;
4406 case OP_AELEMFAST_LEX:
4413 PL_modcount = RETURN_UNLIMITED_NUMBER;
4414 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4416 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4417 fiable since some contexts need to know. */
4418 o->op_flags |= OPf_MOD;
4421 if (scalar_mod_type(o, type))
4423 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4424 && type == OP_LEAVESUBLV)
4425 o->op_private |= OPpMAYBE_LVSUB;
4429 if (!type) /* local() */
4430 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4431 PNfARG(PAD_COMPNAME(o->op_targ)));
4432 if (!(o->op_private & OPpLVAL_INTRO)
4433 || ( type != OP_SASSIGN && type != OP_AASSIGN
4434 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4435 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4443 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4447 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4453 if (type == OP_LEAVESUBLV)
4454 o->op_private |= OPpMAYBE_LVSUB;
4455 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4456 /* substr and vec */
4457 /* If this op is in merely potential (non-fatal) modifiable
4458 context, then apply OP_ENTERSUB context to
4459 the kid op (to avoid croaking). Other-
4460 wise pass this op’s own type so the correct op is mentioned
4461 in error messages. */
4462 op_lvalue(OpSIBLING(cBINOPo->op_first),
4463 S_potential_mod_type(type)
4471 ref(cBINOPo->op_first, o->op_type);
4472 if (type == OP_ENTERSUB &&
4473 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4474 o->op_private |= OPpLVAL_DEFER;
4475 if (type == OP_LEAVESUBLV)
4476 o->op_private |= OPpMAYBE_LVSUB;
4483 o->op_private |= OPpLVALUE;
4489 if (o->op_flags & OPf_KIDS)
4490 op_lvalue(cLISTOPo->op_last, type);
4495 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4497 else if (!(o->op_flags & OPf_KIDS))
4500 if (o->op_targ != OP_LIST) {
4501 OP *sib = OpSIBLING(cLISTOPo->op_first);
4502 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4509 * compared with things like OP_MATCH which have the argument
4515 * so handle specially to correctly get "Can't modify" croaks etc
4518 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4520 /* this should trigger a "Can't modify transliteration" err */
4521 op_lvalue(sib, type);
4523 op_lvalue(cBINOPo->op_first, type);
4529 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4530 op_lvalue(kid, type);
4538 if (type == OP_LEAVESUBLV
4539 || !S_vivifies(cLOGOPo->op_first->op_type))
4540 op_lvalue(cLOGOPo->op_first, type);
4541 if (type == OP_LEAVESUBLV
4542 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4543 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4547 if (type == OP_NULL) { /* local */
4549 if (!FEATURE_MYREF_IS_ENABLED)
4550 Perl_croak(aTHX_ "The experimental declared_refs "
4551 "feature is not enabled");
4552 Perl_ck_warner_d(aTHX_
4553 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4554 "Declaring references is experimental");
4555 op_lvalue(cUNOPo->op_first, OP_NULL);
4558 if (type != OP_AASSIGN && type != OP_SASSIGN
4559 && type != OP_ENTERLOOP)
4561 /* Don’t bother applying lvalue context to the ex-list. */
4562 kid = cUNOPx(cUNOPo->op_first)->op_first;
4563 assert (!OpHAS_SIBLING(kid));
4566 if (type == OP_NULL) /* local */
4568 if (type != OP_AASSIGN) goto nomod;
4569 kid = cUNOPo->op_first;
4572 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4573 S_lvref(aTHX_ kid, type);
4574 if (!PL_parser || PL_parser->error_count == ec) {
4575 if (!FEATURE_REFALIASING_IS_ENABLED)
4577 "Experimental aliasing via reference not enabled");
4578 Perl_ck_warner_d(aTHX_
4579 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4580 "Aliasing via reference is experimental");
4583 if (o->op_type == OP_REFGEN)
4584 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4589 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4590 /* This is actually @array = split. */
4591 PL_modcount = RETURN_UNLIMITED_NUMBER;
4597 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4601 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4602 their argument is a filehandle; thus \stat(".") should not set
4604 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4607 if (type != OP_LEAVESUBLV)
4608 o->op_flags |= OPf_MOD;
4610 if (type == OP_AASSIGN || type == OP_SASSIGN)
4611 o->op_flags |= OPf_SPECIAL
4612 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4613 else if (!type) { /* local() */
4616 o->op_private |= OPpLVAL_INTRO;
4617 o->op_flags &= ~OPf_SPECIAL;
4618 PL_hints |= HINT_BLOCK_SCOPE;
4623 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4624 "Useless localization of %s", OP_DESC(o));
4627 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4628 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4629 o->op_flags |= OPf_REF;
4634 S_scalar_mod_type(const OP *o, I32 type)
4639 if (o && o->op_type == OP_RV2GV)
4663 case OP_RIGHT_SHIFT:
4692 S_is_handle_constructor(const OP *o, I32 numargs)
4694 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4696 switch (o->op_type) {
4704 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4717 S_refkids(pTHX_ OP *o, I32 type)
4719 if (o && o->op_flags & OPf_KIDS) {
4721 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4728 /* Apply reference (autovivification) context to the subtree at o.
4730 * push @{expression}, ....;
4731 * o will be the head of 'expression' and type will be OP_RV2AV.
4732 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4734 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4735 * set_op_ref is true.
4737 * Also calls scalar(o).
4741 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4746 PERL_ARGS_ASSERT_DOREF;
4748 if (PL_parser && PL_parser->error_count)
4752 switch (o->op_type) {
4754 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4755 !(o->op_flags & OPf_STACKED)) {
4756 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4757 assert(cUNOPo->op_first->op_type == OP_NULL);
4758 /* disable pushmark */
4759 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4760 o->op_flags |= OPf_SPECIAL;
4762 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4763 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4764 : type == OP_RV2HV ? OPpDEREF_HV
4766 o->op_flags |= OPf_MOD;
4772 o = OpSIBLING(cUNOPo->op_first);
4776 if (type == OP_DEFINED)
4777 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4780 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4781 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4782 : type == OP_RV2HV ? OPpDEREF_HV
4784 o->op_flags |= OPf_MOD;
4786 if (o->op_flags & OPf_KIDS) {
4788 o = cUNOPo->op_first;
4796 o->op_flags |= OPf_REF;
4799 if (type == OP_DEFINED)
4800 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4802 o = cUNOPo->op_first;
4808 o->op_flags |= OPf_REF;
4813 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4815 o = cBINOPo->op_first;
4820 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4821 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4822 : type == OP_RV2HV ? OPpDEREF_HV
4824 o->op_flags |= OPf_MOD;
4827 o = cBINOPo->op_first;
4836 if (!(o->op_flags & OPf_KIDS))
4838 o = cLISTOPo->op_last;
4847 return scalar(top_op); /* at top; no parents/siblings to try */
4848 if (OpHAS_SIBLING(o)) {
4849 o = o->op_sibparent;
4850 /* Normally skip all siblings and go straight to the parent;
4851 * the only op that requires two children to be processed
4852 * is OP_COND_EXPR */
4853 if (!OpHAS_SIBLING(o)
4854 && o->op_sibparent->op_type == OP_COND_EXPR)
4858 o = o->op_sibparent; /*try parent's next sibling */
4865 S_dup_attrlist(pTHX_ OP *o)
4869 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4871 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4872 * where the first kid is OP_PUSHMARK and the remaining ones
4873 * are OP_CONST. We need to push the OP_CONST values.
4875 if (o->op_type == OP_CONST)
4876 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4878 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4880 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4881 if (o->op_type == OP_CONST)
4882 rop = op_append_elem(OP_LIST, rop,
4883 newSVOP(OP_CONST, o->op_flags,
4884 SvREFCNT_inc_NN(cSVOPo->op_sv)));
4891 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4893 PERL_ARGS_ASSERT_APPLY_ATTRS;
4895 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4897 /* fake up C<use attributes $pkg,$rv,@attrs> */
4899 #define ATTRSMODULE "attributes"
4900 #define ATTRSMODULE_PM "attributes.pm"
4903 aTHX_ PERL_LOADMOD_IMPORT_OPS,
4904 newSVpvs(ATTRSMODULE),
4906 op_prepend_elem(OP_LIST,
4907 newSVOP(OP_CONST, 0, stashsv),
4908 op_prepend_elem(OP_LIST,
4909 newSVOP(OP_CONST, 0,
4911 dup_attrlist(attrs))));
4916 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4918 OP *pack, *imop, *arg;
4919 SV *meth, *stashsv, **svp;
4921 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4926 assert(target->op_type == OP_PADSV ||
4927 target->op_type == OP_PADHV ||
4928 target->op_type == OP_PADAV);
4930 /* Ensure that attributes.pm is loaded. */
4931 /* Don't force the C<use> if we don't need it. */
4932 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4933 if (svp && *svp != &PL_sv_undef)
4934 NOOP; /* already in %INC */
4936 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4937 newSVpvs(ATTRSMODULE), NULL);
4939 /* Need package name for method call. */
4940 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4942 /* Build up the real arg-list. */
4943 stashsv = newSVhek(HvNAME_HEK(stash));
4945 arg = newOP(OP_PADSV, 0);
4946 arg->op_targ = target->op_targ;
4947 arg = op_prepend_elem(OP_LIST,
4948 newSVOP(OP_CONST, 0, stashsv),
4949 op_prepend_elem(OP_LIST,
4950 newUNOP(OP_REFGEN, 0,
4952 dup_attrlist(attrs)));
4954 /* Fake up a method call to import */
4955 meth = newSVpvs_share("import");
4956 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4957 op_append_elem(OP_LIST,
4958 op_prepend_elem(OP_LIST, pack, arg),
4959 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4961 /* Combine the ops. */
4962 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4966 =notfor apidoc apply_attrs_string
4968 Attempts to apply a list of attributes specified by the C<attrstr> and
4969 C<len> arguments to the subroutine identified by the C<cv> argument which
4970 is expected to be associated with the package identified by the C<stashpv>
4971 argument (see L<attributes>). It gets this wrong, though, in that it
4972 does not correctly identify the boundaries of the individual attribute
4973 specifications within C<attrstr>. This is not really intended for the
4974 public API, but has to be listed here for systems such as AIX which
4975 need an explicit export list for symbols. (It's called from XS code
4976 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
4977 to respect attribute syntax properly would be welcome.
4983 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4984 const char *attrstr, STRLEN len)
4988 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4991 len = strlen(attrstr);
4995 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4997 const char * const sstr = attrstr;
4998 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4999 attrs = op_append_elem(OP_LIST, attrs,
5000 newSVOP(OP_CONST, 0,
5001 newSVpvn(sstr, attrstr-sstr)));
5005 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5006 newSVpvs(ATTRSMODULE),
5007 NULL, op_prepend_elem(OP_LIST,
5008 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5009 op_prepend_elem(OP_LIST,
5010 newSVOP(OP_CONST, 0,
5011 newRV(MUTABLE_SV(cv))),
5016 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5019 OP *new_proto = NULL;
5024 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5030 if (o->op_type == OP_CONST) {
5031 pv = SvPV(cSVOPo_sv, pvlen);
5032 if (memBEGINs(pv, pvlen, "prototype(")) {
5033 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5034 SV ** const tmpo = cSVOPx_svp(o);
5035 SvREFCNT_dec(cSVOPo_sv);
5040 } else if (o->op_type == OP_LIST) {
5042 assert(o->op_flags & OPf_KIDS);
5043 lasto = cLISTOPo->op_first;
5044 assert(lasto->op_type == OP_PUSHMARK);
5045 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5046 if (o->op_type == OP_CONST) {
5047 pv = SvPV(cSVOPo_sv, pvlen);
5048 if (memBEGINs(pv, pvlen, "prototype(")) {
5049 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5050 SV ** const tmpo = cSVOPx_svp(o);
5051 SvREFCNT_dec(cSVOPo_sv);
5053 if (new_proto && ckWARN(WARN_MISC)) {
5055 const char * newp = SvPV(cSVOPo_sv, new_len);
5056 Perl_warner(aTHX_ packWARN(WARN_MISC),
5057 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5058 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5064 /* excise new_proto from the list */
5065 op_sibling_splice(*attrs, lasto, 1, NULL);
5072 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5073 would get pulled in with no real need */
5074 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5083 svname = sv_newmortal();
5084 gv_efullname3(svname, name, NULL);
5086 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5087 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5089 svname = (SV *)name;
5090 if (ckWARN(WARN_ILLEGALPROTO))
5091 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5093 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5094 STRLEN old_len, new_len;
5095 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5096 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5098 if (curstash && svname == (SV *)name
5099 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5100 svname = sv_2mortal(newSVsv(PL_curstname));
5101 sv_catpvs(svname, "::");
5102 sv_catsv(svname, (SV *)name);
5105 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5106 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5108 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5109 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5119 S_cant_declare(pTHX_ OP *o)
5121 if (o->op_type == OP_NULL
5122 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5123 o = cUNOPo->op_first;
5124 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5125 o->op_type == OP_NULL
5126 && o->op_flags & OPf_SPECIAL
5129 PL_parser->in_my == KEY_our ? "our" :
5130 PL_parser->in_my == KEY_state ? "state" :
5135 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5138 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5140 PERL_ARGS_ASSERT_MY_KID;
5142 if (!o || (PL_parser && PL_parser->error_count))
5147 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5149 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5150 my_kid(kid, attrs, imopsp);
5152 } else if (type == OP_UNDEF || type == OP_STUB) {
5154 } else if (type == OP_RV2SV || /* "our" declaration */
5157 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5158 S_cant_declare(aTHX_ o);
5160 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5162 PL_parser->in_my = FALSE;
5163 PL_parser->in_my_stash = NULL;
5164 apply_attrs(GvSTASH(gv),
5165 (type == OP_RV2SV ? GvSVn(gv) :
5166 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5167 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5170 o->op_private |= OPpOUR_INTRO;
5173 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5174 if (!FEATURE_MYREF_IS_ENABLED)
5175 Perl_croak(aTHX_ "The experimental declared_refs "
5176 "feature is not enabled");
5177 Perl_ck_warner_d(aTHX_
5178 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5179 "Declaring references is experimental");
5180 /* Kid is a nulled OP_LIST, handled above. */
5181 my_kid(cUNOPo->op_first, attrs, imopsp);
5184 else if (type != OP_PADSV &&
5187 type != OP_PUSHMARK)
5189 S_cant_declare(aTHX_ o);
5192 else if (attrs && type != OP_PUSHMARK) {
5196 PL_parser->in_my = FALSE;
5197 PL_parser->in_my_stash = NULL;
5199 /* check for C<my Dog $spot> when deciding package */
5200 stash = PAD_COMPNAME_TYPE(o->op_targ);
5202 stash = PL_curstash;
5203 apply_attrs_my(stash, o, attrs, imopsp);
5205 o->op_flags |= OPf_MOD;
5206 o->op_private |= OPpLVAL_INTRO;
5208 o->op_private |= OPpPAD_STATE;
5213 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5216 int maybe_scalar = 0;
5218 PERL_ARGS_ASSERT_MY_ATTRS;
5220 /* [perl #17376]: this appears to be premature, and results in code such as
5221 C< our(%x); > executing in list mode rather than void mode */
5223 if (o->op_flags & OPf_PARENS)
5233 o = my_kid(o, attrs, &rops);
5235 if (maybe_scalar && o->op_type == OP_PADSV) {
5236 o = scalar(op_append_list(OP_LIST, rops, o));
5237 o->op_private |= OPpLVAL_INTRO;
5240 /* The listop in rops might have a pushmark at the beginning,
5241 which will mess up list assignment. */
5242 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5243 if (rops->op_type == OP_LIST &&
5244 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5246 OP * const pushmark = lrops->op_first;
5247 /* excise pushmark */
5248 op_sibling_splice(rops, NULL, 1, NULL);
5251 o = op_append_list(OP_LIST, o, rops);
5254 PL_parser->in_my = FALSE;
5255 PL_parser->in_my_stash = NULL;
5260 Perl_sawparens(pTHX_ OP *o)
5262 PERL_UNUSED_CONTEXT;
5264 o->op_flags |= OPf_PARENS;
5269 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5273 const OPCODE ltype = left->op_type;
5274 const OPCODE rtype = right->op_type;
5276 PERL_ARGS_ASSERT_BIND_MATCH;
5278 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5279 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5281 const char * const desc
5283 rtype == OP_SUBST || rtype == OP_TRANS
5284 || rtype == OP_TRANSR
5286 ? (int)rtype : OP_MATCH];
5287 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5289 S_op_varname(aTHX_ left);
5291 Perl_warner(aTHX_ packWARN(WARN_MISC),
5292 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5293 desc, SVfARG(name), SVfARG(name));
5295 const char * const sample = (isary
5296 ? "@array" : "%hash");
5297 Perl_warner(aTHX_ packWARN(WARN_MISC),
5298 "Applying %s to %s will act on scalar(%s)",
5299 desc, sample, sample);
5303 if (rtype == OP_CONST &&
5304 cSVOPx(right)->op_private & OPpCONST_BARE &&
5305 cSVOPx(right)->op_private & OPpCONST_STRICT)
5307 no_bareword_allowed(right);
5310 /* !~ doesn't make sense with /r, so error on it for now */
5311 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5313 /* diag_listed_as: Using !~ with %s doesn't make sense */
5314 yyerror("Using !~ with s///r doesn't make sense");
5315 if (rtype == OP_TRANSR && type == OP_NOT)
5316 /* diag_listed_as: Using !~ with %s doesn't make sense */
5317 yyerror("Using !~ with tr///r doesn't make sense");
5319 ismatchop = (rtype == OP_MATCH ||
5320 rtype == OP_SUBST ||
5321 rtype == OP_TRANS || rtype == OP_TRANSR)
5322 && !(right->op_flags & OPf_SPECIAL);
5323 if (ismatchop && right->op_private & OPpTARGET_MY) {
5325 right->op_private &= ~OPpTARGET_MY;
5327 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5328 if (left->op_type == OP_PADSV
5329 && !(left->op_private & OPpLVAL_INTRO))
5331 right->op_targ = left->op_targ;
5336 right->op_flags |= OPf_STACKED;
5337 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5338 ! (rtype == OP_TRANS &&
5339 right->op_private & OPpTRANS_IDENTICAL) &&
5340 ! (rtype == OP_SUBST &&
5341 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5342 left = op_lvalue(left, rtype);
5343 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5344 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5346 o = op_prepend_elem(rtype, scalar(left), right);
5349 return newUNOP(OP_NOT, 0, scalar(o));
5353 return bind_match(type, left,
5354 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5358 Perl_invert(pTHX_ OP *o)
5362 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5366 =for apidoc op_scope
5368 Wraps up an op tree with some additional ops so that at runtime a dynamic
5369 scope will be created. The original ops run in the new dynamic scope,
5370 and then, provided that they exit normally, the scope will be unwound.
5371 The additional ops used to create and unwind the dynamic scope will
5372 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5373 instead if the ops are simple enough to not need the full dynamic scope
5380 Perl_op_scope(pTHX_ OP *o)
5384 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5385 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5386 OpTYPE_set(o, OP_LEAVE);
5388 else if (o->op_type == OP_LINESEQ) {
5390 OpTYPE_set(o, OP_SCOPE);
5391 kid = ((LISTOP*)o)->op_first;
5392 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5395 /* The following deals with things like 'do {1 for 1}' */
5396 kid = OpSIBLING(kid);
5398 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5403 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5409 Perl_op_unscope(pTHX_ OP *o)
5411 if (o && o->op_type == OP_LINESEQ) {
5412 OP *kid = cLISTOPo->op_first;
5413 for(; kid; kid = OpSIBLING(kid))
5414 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5421 =for apidoc block_start
5423 Handles compile-time scope entry.
5424 Arranges for hints to be restored on block
5425 exit and also handles pad sequence numbers to make lexical variables scope
5426 right. Returns a savestack index for use with C<block_end>.
5432 Perl_block_start(pTHX_ int full)
5434 const int retval = PL_savestack_ix;
5436 PL_compiling.cop_seq = PL_cop_seqmax;
5438 pad_block_start(full);
5440 PL_hints &= ~HINT_BLOCK_SCOPE;
5441 SAVECOMPILEWARNINGS();
5442 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5443 SAVEI32(PL_compiling.cop_seq);
5444 PL_compiling.cop_seq = 0;
5446 CALL_BLOCK_HOOKS(bhk_start, full);
5452 =for apidoc block_end
5454 Handles compile-time scope exit. C<floor>
5455 is the savestack index returned by
5456 C<block_start>, and C<seq> is the body of the block. Returns the block,
5463 Perl_block_end(pTHX_ I32 floor, OP *seq)
5465 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5466 OP* retval = scalarseq(seq);
5469 /* XXX Is the null PL_parser check necessary here? */
5470 assert(PL_parser); /* Let’s find out under debugging builds. */
5471 if (PL_parser && PL_parser->parsed_sub) {
5472 o = newSTATEOP(0, NULL, NULL);
5474 retval = op_append_elem(OP_LINESEQ, retval, o);
5477 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5481 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5485 /* pad_leavemy has created a sequence of introcv ops for all my
5486 subs declared in the block. We have to replicate that list with
5487 clonecv ops, to deal with this situation:
5492 sub s1 { state sub foo { \&s2 } }
5495 Originally, I was going to have introcv clone the CV and turn
5496 off the stale flag. Since &s1 is declared before &s2, the
5497 introcv op for &s1 is executed (on sub entry) before the one for
5498 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5499 cloned, since it is a state sub) closes over &s2 and expects
5500 to see it in its outer CV’s pad. If the introcv op clones &s1,
5501 then &s2 is still marked stale. Since &s1 is not active, and
5502 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5503 ble will not stay shared’ warning. Because it is the same stub
5504 that will be used when the introcv op for &s2 is executed, clos-
5505 ing over it is safe. Hence, we have to turn off the stale flag
5506 on all lexical subs in the block before we clone any of them.
5507 Hence, having introcv clone the sub cannot work. So we create a
5508 list of ops like this:
5532 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5533 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5534 for (;; kid = OpSIBLING(kid)) {
5535 OP *newkid = newOP(OP_CLONECV, 0);
5536 newkid->op_targ = kid->op_targ;
5537 o = op_append_elem(OP_LINESEQ, o, newkid);
5538 if (kid == last) break;
5540 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5543 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5549 =head1 Compile-time scope hooks
5551 =for apidoc blockhook_register
5553 Register a set of hooks to be called when the Perl lexical scope changes
5554 at compile time. See L<perlguts/"Compile-time scope hooks">.
5560 Perl_blockhook_register(pTHX_ BHK *hk)
5562 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5564 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5568 Perl_newPROG(pTHX_ OP *o)
5572 PERL_ARGS_ASSERT_NEWPROG;
5579 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5580 ((PL_in_eval & EVAL_KEEPERR)
5581 ? OPf_SPECIAL : 0), o);
5584 assert(CxTYPE(cx) == CXt_EVAL);
5586 if ((cx->blk_gimme & G_WANT) == G_VOID)
5587 scalarvoid(PL_eval_root);
5588 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5591 scalar(PL_eval_root);
5593 start = op_linklist(PL_eval_root);
5594 PL_eval_root->op_next = 0;
5595 i = PL_savestack_ix;
5598 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5600 PL_savestack_ix = i;
5603 if (o->op_type == OP_STUB) {
5604 /* This block is entered if nothing is compiled for the main
5605 program. This will be the case for an genuinely empty main
5606 program, or one which only has BEGIN blocks etc, so already
5609 Historically (5.000) the guard above was !o. However, commit
5610 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5611 c71fccf11fde0068, changed perly.y so that newPROG() is now
5612 called with the output of block_end(), which returns a new
5613 OP_STUB for the case of an empty optree. ByteLoader (and
5614 maybe other things) also take this path, because they set up
5615 PL_main_start and PL_main_root directly, without generating an
5618 If the parsing the main program aborts (due to parse errors,
5619 or due to BEGIN or similar calling exit), then newPROG()
5620 isn't even called, and hence this code path and its cleanups
5621 are skipped. This shouldn't make a make a difference:
5622 * a non-zero return from perl_parse is a failure, and
5623 perl_destruct() should be called immediately.
5624 * however, if exit(0) is called during the parse, then
5625 perl_parse() returns 0, and perl_run() is called. As
5626 PL_main_start will be NULL, perl_run() will return
5627 promptly, and the exit code will remain 0.
5630 PL_comppad_name = 0;
5632 S_op_destroy(aTHX_ o);
5635 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5636 PL_curcop = &PL_compiling;
5637 start = LINKLIST(PL_main_root);
5638 PL_main_root->op_next = 0;
5639 S_process_optree(aTHX_ NULL, PL_main_root, start);
5640 if (!PL_parser->error_count)
5641 /* on error, leave CV slabbed so that ops left lying around
5642 * will eb cleaned up. Else unslab */
5643 cv_forget_slab(PL_compcv);
5646 /* Register with debugger */
5648 CV * const cv = get_cvs("DB::postponed", 0);
5652 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5654 call_sv(MUTABLE_SV(cv), G_DISCARD);
5661 Perl_localize(pTHX_ OP *o, I32 lex)
5663 PERL_ARGS_ASSERT_LOCALIZE;
5665 if (o->op_flags & OPf_PARENS)
5666 /* [perl #17376]: this appears to be premature, and results in code such as
5667 C< our(%x); > executing in list mode rather than void mode */
5674 if ( PL_parser->bufptr > PL_parser->oldbufptr
5675 && PL_parser->bufptr[-1] == ','
5676 && ckWARN(WARN_PARENTHESIS))
5678 char *s = PL_parser->bufptr;
5681 /* some heuristics to detect a potential error */
5682 while (*s && (strchr(", \t\n", *s)))
5686 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5688 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5691 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5693 while (*s && (strchr(", \t\n", *s)))
5699 if (sigil && (*s == ';' || *s == '=')) {
5700 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5701 "Parentheses missing around \"%s\" list",
5703 ? (PL_parser->in_my == KEY_our
5705 : PL_parser->in_my == KEY_state
5715 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5716 PL_parser->in_my = FALSE;
5717 PL_parser->in_my_stash = NULL;
5722 Perl_jmaybe(pTHX_ OP *o)
5724 PERL_ARGS_ASSERT_JMAYBE;
5726 if (o->op_type == OP_LIST) {
5728 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5729 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5734 PERL_STATIC_INLINE OP *
5735 S_op_std_init(pTHX_ OP *o)
5737 I32 type = o->op_type;
5739 PERL_ARGS_ASSERT_OP_STD_INIT;
5741 if (PL_opargs[type] & OA_RETSCALAR)
5743 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5744 o->op_targ = pad_alloc(type, SVs_PADTMP);
5749 PERL_STATIC_INLINE OP *
5750 S_op_integerize(pTHX_ OP *o)
5752 I32 type = o->op_type;
5754 PERL_ARGS_ASSERT_OP_INTEGERIZE;
5756 /* integerize op. */
5757 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5760 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5763 if (type == OP_NEGATE)
5764 /* XXX might want a ck_negate() for this */
5765 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5770 /* This function exists solely to provide a scope to limit
5771 setjmp/longjmp() messing with auto variables.
5773 PERL_STATIC_INLINE int
5774 S_fold_constants_eval(pTHX) {
5790 S_fold_constants(pTHX_ OP *const o)
5795 I32 type = o->op_type;
5800 SV * const oldwarnhook = PL_warnhook;
5801 SV * const olddiehook = PL_diehook;
5803 U8 oldwarn = PL_dowarn;
5806 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5808 if (!(PL_opargs[type] & OA_FOLDCONST))
5817 #ifdef USE_LOCALE_CTYPE
5818 if (IN_LC_COMPILETIME(LC_CTYPE))
5827 #ifdef USE_LOCALE_COLLATE
5828 if (IN_LC_COMPILETIME(LC_COLLATE))
5833 /* XXX what about the numeric ops? */
5834 #ifdef USE_LOCALE_NUMERIC
5835 if (IN_LC_COMPILETIME(LC_NUMERIC))
5840 if (!OpHAS_SIBLING(cLISTOPo->op_first)
5841 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5844 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5845 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5847 const char *s = SvPVX_const(sv);
5848 while (s < SvEND(sv)) {
5849 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5856 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5859 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5860 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5864 if (PL_parser && PL_parser->error_count)
5865 goto nope; /* Don't try to run w/ errors */
5867 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5868 switch (curop->op_type) {
5870 if ( (curop->op_private & OPpCONST_BARE)
5871 && (curop->op_private & OPpCONST_STRICT)) {
5872 no_bareword_allowed(curop);
5880 /* Foldable; move to next op in list */
5884 /* No other op types are considered foldable */
5889 curop = LINKLIST(o);
5890 old_next = o->op_next;
5894 old_cxix = cxstack_ix;
5895 create_eval_scope(NULL, G_FAKINGEVAL);
5897 /* Verify that we don't need to save it: */
5898 assert(PL_curcop == &PL_compiling);
5899 StructCopy(&PL_compiling, ¬_compiling, COP);
5900 PL_curcop = ¬_compiling;
5901 /* The above ensures that we run with all the correct hints of the
5902 currently compiling COP, but that IN_PERL_RUNTIME is true. */
5903 assert(IN_PERL_RUNTIME);
5904 PL_warnhook = PERL_WARNHOOK_FATAL;
5907 /* Effective $^W=1. */
5908 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5909 PL_dowarn |= G_WARN_ON;
5911 ret = S_fold_constants_eval(aTHX);
5915 sv = *(PL_stack_sp--);
5916 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
5917 pad_swipe(o->op_targ, FALSE);
5919 else if (SvTEMP(sv)) { /* grab mortal temp? */
5920 SvREFCNT_inc_simple_void(sv);
5923 else { assert(SvIMMORTAL(sv)); }
5926 /* Something tried to die. Abandon constant folding. */
5927 /* Pretend the error never happened. */
5929 o->op_next = old_next;
5932 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
5933 PL_warnhook = oldwarnhook;
5934 PL_diehook = olddiehook;
5935 /* XXX note that this croak may fail as we've already blown away
5936 * the stack - eg any nested evals */
5937 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5939 PL_dowarn = oldwarn;
5940 PL_warnhook = oldwarnhook;
5941 PL_diehook = olddiehook;
5942 PL_curcop = &PL_compiling;
5944 /* if we croaked, depending on how we croaked the eval scope
5945 * may or may not have already been popped */
5946 if (cxstack_ix > old_cxix) {
5947 assert(cxstack_ix == old_cxix + 1);
5948 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5949 delete_eval_scope();
5954 /* OP_STRINGIFY and constant folding are used to implement qq.
5955 Here the constant folding is an implementation detail that we
5956 want to hide. If the stringify op is itself already marked
5957 folded, however, then it is actually a folded join. */
5958 is_stringify = type == OP_STRINGIFY && !o->op_folded;
5963 else if (!SvIMMORTAL(sv)) {
5967 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5968 if (!is_stringify) newop->op_folded = 1;
5975 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
5976 * the constant value being an AV holding the flattened range.
5980 S_gen_constant_list(pTHX_ OP *o)
5983 OP *curop, *old_next;
5984 SV * const oldwarnhook = PL_warnhook;
5985 SV * const olddiehook = PL_diehook;
5987 U8 oldwarn = PL_dowarn;
5997 if (PL_parser && PL_parser->error_count)
5998 return; /* Don't attempt to run with errors */
6000 curop = LINKLIST(o);
6001 old_next = o->op_next;
6003 op_was_null = o->op_type == OP_NULL;
6004 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6005 o->op_type = OP_CUSTOM;
6008 o->op_type = OP_NULL;
6009 S_prune_chain_head(&curop);
6012 old_cxix = cxstack_ix;
6013 create_eval_scope(NULL, G_FAKINGEVAL);
6015 old_curcop = PL_curcop;
6016 StructCopy(old_curcop, ¬_compiling, COP);
6017 PL_curcop = ¬_compiling;
6018 /* The above ensures that we run with all the correct hints of the
6019 current COP, but that IN_PERL_RUNTIME is true. */
6020 assert(IN_PERL_RUNTIME);
6021 PL_warnhook = PERL_WARNHOOK_FATAL;
6025 /* Effective $^W=1. */
6026 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6027 PL_dowarn |= G_WARN_ON;
6031 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6032 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6034 Perl_pp_pushmark(aTHX);
6037 assert (!(curop->op_flags & OPf_SPECIAL));
6038 assert(curop->op_type == OP_RANGE);
6039 Perl_pp_anonlist(aTHX);
6043 o->op_next = old_next;
6047 PL_warnhook = oldwarnhook;
6048 PL_diehook = olddiehook;
6049 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6054 PL_dowarn = oldwarn;
6055 PL_warnhook = oldwarnhook;
6056 PL_diehook = olddiehook;
6057 PL_curcop = old_curcop;
6059 if (cxstack_ix > old_cxix) {
6060 assert(cxstack_ix == old_cxix + 1);
6061 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6062 delete_eval_scope();
6067 OpTYPE_set(o, OP_RV2AV);
6068 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6069 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6070 o->op_opt = 0; /* needs to be revisited in rpeep() */
6071 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6073 /* replace subtree with an OP_CONST */
6074 curop = ((UNOP*)o)->op_first;
6075 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6078 if (AvFILLp(av) != -1)
6079 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6082 SvREADONLY_on(*svp);
6090 =head1 Optree Manipulation Functions
6093 /* List constructors */
6096 =for apidoc op_append_elem
6098 Append an item to the list of ops contained directly within a list-type
6099 op, returning the lengthened list. C<first> is the list-type op,
6100 and C<last> is the op to append to the list. C<optype> specifies the
6101 intended opcode for the list. If C<first> is not already a list of the
6102 right type, it will be upgraded into one. If either C<first> or C<last>
6103 is null, the other is returned unchanged.
6109 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6117 if (first->op_type != (unsigned)type
6118 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6120 return newLISTOP(type, 0, first, last);
6123 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6124 first->op_flags |= OPf_KIDS;
6129 =for apidoc op_append_list
6131 Concatenate the lists of ops contained directly within two list-type ops,
6132 returning the combined list. C<first> and C<last> are the list-type ops
6133 to concatenate. C<optype> specifies the intended opcode for the list.
6134 If either C<first> or C<last> is not already a list of the right type,
6135 it will be upgraded into one. If either C<first> or C<last> is null,
6136 the other is returned unchanged.
6142 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6150 if (first->op_type != (unsigned)type)
6151 return op_prepend_elem(type, first, last);
6153 if (last->op_type != (unsigned)type)
6154 return op_append_elem(type, first, last);
6156 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6157 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6158 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6159 first->op_flags |= (last->op_flags & OPf_KIDS);
6161 S_op_destroy(aTHX_ last);
6167 =for apidoc op_prepend_elem
6169 Prepend an item to the list of ops contained directly within a list-type
6170 op, returning the lengthened list. C<first> is the op to prepend to the
6171 list, and C<last> is the list-type op. C<optype> specifies the intended
6172 opcode for the list. If C<last> is not already a list of the right type,
6173 it will be upgraded into one. If either C<first> or C<last> is null,
6174 the other is returned unchanged.
6180 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6188 if (last->op_type == (unsigned)type) {
6189 if (type == OP_LIST) { /* already a PUSHMARK there */
6190 /* insert 'first' after pushmark */
6191 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6192 if (!(first->op_flags & OPf_PARENS))
6193 last->op_flags &= ~OPf_PARENS;
6196 op_sibling_splice(last, NULL, 0, first);
6197 last->op_flags |= OPf_KIDS;
6201 return newLISTOP(type, 0, first, last);
6205 =for apidoc op_convert_list
6207 Converts C<o> into a list op if it is not one already, and then converts it
6208 into the specified C<type>, calling its check function, allocating a target if
6209 it needs one, and folding constants.
6211 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6212 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6213 C<op_convert_list> to make it the right type.
6219 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6222 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6223 if (!o || o->op_type != OP_LIST)
6224 o = force_list(o, 0);
6227 o->op_flags &= ~OPf_WANT;
6228 o->op_private &= ~OPpLVAL_INTRO;
6231 if (!(PL_opargs[type] & OA_MARK))
6232 op_null(cLISTOPo->op_first);
6234 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6235 if (kid2 && kid2->op_type == OP_COREARGS) {
6236 op_null(cLISTOPo->op_first);
6237 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6241 if (type != OP_SPLIT)
6242 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6243 * ck_split() create a real PMOP and leave the op's type as listop
6244 * for now. Otherwise op_free() etc will crash.
6246 OpTYPE_set(o, type);
6248 o->op_flags |= flags;
6249 if (flags & OPf_FOLDED)
6252 o = CHECKOP(type, o);
6253 if (o->op_type != (unsigned)type)
6256 return fold_constants(op_integerize(op_std_init(o)));
6263 =head1 Optree construction
6265 =for apidoc newNULLLIST
6267 Constructs, checks, and returns a new C<stub> op, which represents an
6268 empty list expression.
6274 Perl_newNULLLIST(pTHX)
6276 return newOP(OP_STUB, 0);
6279 /* promote o and any siblings to be a list if its not already; i.e.
6287 * pushmark - o - A - B
6289 * If nullit it true, the list op is nulled.
6293 S_force_list(pTHX_ OP *o, bool nullit)
6295 if (!o || o->op_type != OP_LIST) {
6298 /* manually detach any siblings then add them back later */
6299 rest = OpSIBLING(o);
6300 OpLASTSIB_set(o, NULL);
6302 o = newLISTOP(OP_LIST, 0, o, NULL);
6304 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6312 =for apidoc newLISTOP
6314 Constructs, checks, and returns an op of any list type. C<type> is
6315 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6316 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6317 supply up to two ops to be direct children of the list op; they are
6318 consumed by this function and become part of the constructed op tree.
6320 For most list operators, the check function expects all the kid ops to be
6321 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6322 appropriate. What you want to do in that case is create an op of type
6323 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6324 See L</op_convert_list> for more information.
6331 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6335 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6336 * pushmark is banned. So do it now while existing ops are in a
6337 * consistent state, in case they suddenly get freed */
6338 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6340 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6341 || type == OP_CUSTOM);
6343 NewOp(1101, listop, 1, LISTOP);
6344 OpTYPE_set(listop, type);
6347 listop->op_flags = (U8)flags;
6351 else if (!first && last)
6354 OpMORESIB_set(first, last);
6355 listop->op_first = first;
6356 listop->op_last = last;
6359 OpMORESIB_set(pushop, first);
6360 listop->op_first = pushop;
6361 listop->op_flags |= OPf_KIDS;
6363 listop->op_last = pushop;
6365 if (listop->op_last)
6366 OpLASTSIB_set(listop->op_last, (OP*)listop);
6368 return CHECKOP(type, listop);
6374 Constructs, checks, and returns an op of any base type (any type that
6375 has no extra fields). C<type> is the opcode. C<flags> gives the
6376 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6383 Perl_newOP(pTHX_ I32 type, I32 flags)
6388 if (type == -OP_ENTEREVAL) {
6389 type = OP_ENTEREVAL;
6390 flags |= OPpEVAL_BYTES<<8;
6393 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6394 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6395 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6396 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6398 NewOp(1101, o, 1, OP);
6399 OpTYPE_set(o, type);
6400 o->op_flags = (U8)flags;
6403 o->op_private = (U8)(0 | (flags >> 8));
6404 if (PL_opargs[type] & OA_RETSCALAR)
6406 if (PL_opargs[type] & OA_TARGET)
6407 o->op_targ = pad_alloc(type, SVs_PADTMP);
6408 return CHECKOP(type, o);
6414 Constructs, checks, and returns an op of any unary type. C<type> is
6415 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6416 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6417 bits, the eight bits of C<op_private>, except that the bit with value 1
6418 is automatically set. C<first> supplies an optional op to be the direct
6419 child of the unary op; it is consumed by this function and become part
6420 of the constructed op tree.
6426 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6431 if (type == -OP_ENTEREVAL) {
6432 type = OP_ENTEREVAL;
6433 flags |= OPpEVAL_BYTES<<8;
6436 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6437 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6438 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6439 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6440 || type == OP_SASSIGN
6441 || type == OP_ENTERTRY
6442 || type == OP_CUSTOM
6443 || type == OP_NULL );
6446 first = newOP(OP_STUB, 0);
6447 if (PL_opargs[type] & OA_MARK)
6448 first = force_list(first, 1);
6450 NewOp(1101, unop, 1, UNOP);
6451 OpTYPE_set(unop, type);
6452 unop->op_first = first;
6453 unop->op_flags = (U8)(flags | OPf_KIDS);
6454 unop->op_private = (U8)(1 | (flags >> 8));
6456 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6457 OpLASTSIB_set(first, (OP*)unop);
6459 unop = (UNOP*) CHECKOP(type, unop);
6463 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6467 =for apidoc newUNOP_AUX
6469 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6470 initialised to C<aux>
6476 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6481 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6482 || type == OP_CUSTOM);
6484 NewOp(1101, unop, 1, UNOP_AUX);
6485 unop->op_type = (OPCODE)type;
6486 unop->op_ppaddr = PL_ppaddr[type];
6487 unop->op_first = first;
6488 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6489 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6492 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6493 OpLASTSIB_set(first, (OP*)unop);
6495 unop = (UNOP_AUX*) CHECKOP(type, unop);
6497 return op_std_init((OP *) unop);
6501 =for apidoc newMETHOP
6503 Constructs, checks, and returns an op of method type with a method name
6504 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6505 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6506 and, shifted up eight bits, the eight bits of C<op_private>, except that
6507 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6508 op which evaluates method name; it is consumed by this function and
6509 become part of the constructed op tree.
6510 Supported optypes: C<OP_METHOD>.
6516 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6520 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6521 || type == OP_CUSTOM);
6523 NewOp(1101, methop, 1, METHOP);
6525 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6526 methop->op_flags = (U8)(flags | OPf_KIDS);
6527 methop->op_u.op_first = dynamic_meth;
6528 methop->op_private = (U8)(1 | (flags >> 8));
6530 if (!OpHAS_SIBLING(dynamic_meth))
6531 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6535 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6536 methop->op_u.op_meth_sv = const_meth;
6537 methop->op_private = (U8)(0 | (flags >> 8));
6538 methop->op_next = (OP*)methop;
6542 methop->op_rclass_targ = 0;
6544 methop->op_rclass_sv = NULL;
6547 OpTYPE_set(methop, type);
6548 return CHECKOP(type, methop);
6552 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6553 PERL_ARGS_ASSERT_NEWMETHOP;
6554 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6558 =for apidoc newMETHOP_named
6560 Constructs, checks, and returns an op of method type with a constant
6561 method name. C<type> is the opcode. C<flags> gives the eight bits of
6562 C<op_flags>, and, shifted up eight bits, the eight bits of
6563 C<op_private>. C<const_meth> supplies a constant method name;
6564 it must be a shared COW string.
6565 Supported optypes: C<OP_METHOD_NAMED>.
6571 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6572 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6573 return newMETHOP_internal(type, flags, NULL, const_meth);
6577 =for apidoc newBINOP
6579 Constructs, checks, and returns an op of any binary type. C<type>
6580 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6581 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6582 the eight bits of C<op_private>, except that the bit with value 1 or
6583 2 is automatically set as required. C<first> and C<last> supply up to
6584 two ops to be the direct children of the binary op; they are consumed
6585 by this function and become part of the constructed op tree.
6591 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6596 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6597 || type == OP_NULL || type == OP_CUSTOM);
6599 NewOp(1101, binop, 1, BINOP);
6602 first = newOP(OP_NULL, 0);
6604 OpTYPE_set(binop, type);
6605 binop->op_first = first;
6606 binop->op_flags = (U8)(flags | OPf_KIDS);
6609 binop->op_private = (U8)(1 | (flags >> 8));
6612 binop->op_private = (U8)(2 | (flags >> 8));
6613 OpMORESIB_set(first, last);
6616 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6617 OpLASTSIB_set(last, (OP*)binop);
6619 binop->op_last = OpSIBLING(binop->op_first);
6621 OpLASTSIB_set(binop->op_last, (OP*)binop);
6623 binop = (BINOP*)CHECKOP(type, binop);
6624 if (binop->op_next || binop->op_type != (OPCODE)type)
6627 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6630 /* Helper function for S_pmtrans(): comparison function to sort an array
6631 * of codepoint range pairs. Sorts by start point, or if equal, by end
6634 static int uvcompare(const void *a, const void *b)
6635 __attribute__nonnull__(1)
6636 __attribute__nonnull__(2)
6637 __attribute__pure__;
6638 static int uvcompare(const void *a, const void *b)
6640 if (*((const UV *)a) < (*(const UV *)b))
6642 if (*((const UV *)a) > (*(const UV *)b))
6644 if (*((const UV *)a+1) < (*(const UV *)b+1))
6646 if (*((const UV *)a+1) > (*(const UV *)b+1))
6651 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6652 * containing the search and replacement strings, assemble into
6653 * a translation table attached as o->op_pv.
6654 * Free expr and repl.
6655 * It expects the toker to have already set the
6656 * OPpTRANS_COMPLEMENT
6659 * flags as appropriate; this function may add
6662 * OPpTRANS_IDENTICAL
6668 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6670 SV * const tstr = ((SVOP*)expr)->op_sv;
6671 SV * const rstr = ((SVOP*)repl)->op_sv;
6674 const U8 *t = (U8*)SvPV_const(tstr, tlen);
6675 const U8 *r = (U8*)SvPV_const(rstr, rlen);
6679 SSize_t struct_size; /* malloced size of table struct */
6681 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6682 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6683 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6686 PERL_ARGS_ASSERT_PMTRANS;
6688 PL_hints |= HINT_BLOCK_SCOPE;
6691 o->op_private |= OPpTRANS_FROM_UTF;
6694 o->op_private |= OPpTRANS_TO_UTF;
6696 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6698 /* for utf8 translations, op_sv will be set to point to a swash
6699 * containing codepoint ranges. This is done by first assembling
6700 * a textual representation of the ranges in listsv then compiling
6701 * it using swash_init(). For more details of the textual format,
6702 * see L<perlunicode.pod/"User-Defined Character Properties"> .
6705 SV* const listsv = newSVpvs("# comment\n");
6707 const U8* tend = t + tlen;
6708 const U8* rend = r + rlen;
6724 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
6725 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
6728 const U32 flags = UTF8_ALLOW_DEFAULT;
6732 t = tsave = bytes_to_utf8(t, &len);
6735 if (!to_utf && rlen) {
6737 r = rsave = bytes_to_utf8(r, &len);
6741 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6742 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6747 * replace t/tlen/tend with a version that has the ranges
6750 U8 tmpbuf[UTF8_MAXBYTES+1];
6753 Newx(cp, 2*tlen, UV);
6755 transv = newSVpvs("");
6757 /* convert search string into array of (start,end) range
6758 * codepoint pairs stored in cp[]. Most "ranges" will start
6759 * and end at the same char */
6761 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6763 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6764 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6766 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6770 cp[2*i+1] = cp[2*i];
6775 /* sort the ranges */
6776 qsort(cp, i, 2*sizeof(UV), uvcompare);
6778 /* Create a utf8 string containing the complement of the
6779 * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6780 * then transv will contain the equivalent of:
6781 * join '', map chr, 0, ILLEGAL_UTF8_BYTE, A - 1,
6782 * B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6783 * D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6784 * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6787 for (j = 0; j < i; j++) {
6789 diff = val - nextmin;
6791 t = uvchr_to_utf8(tmpbuf,nextmin);
6792 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6794 U8 range_mark = ILLEGAL_UTF8_BYTE;
6795 t = uvchr_to_utf8(tmpbuf, val - 1);
6796 sv_catpvn(transv, (char *)&range_mark, 1);
6797 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6805 t = uvchr_to_utf8(tmpbuf,nextmin);
6806 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6808 U8 range_mark = ILLEGAL_UTF8_BYTE;
6809 sv_catpvn(transv, (char *)&range_mark, 1);
6811 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6812 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6813 t = (const U8*)SvPVX_const(transv);
6814 tlen = SvCUR(transv);
6818 else if (!rlen && !del) {
6819 r = t; rlen = tlen; rend = tend;
6823 if ((!rlen && !del) || t == r ||
6824 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6826 o->op_private |= OPpTRANS_IDENTICAL;
6830 /* extract char ranges from t and r and append them to listsv */
6832 while (t < tend || tfirst <= tlast) {
6833 /* see if we need more "t" chars */
6834 if (tfirst > tlast) {
6835 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6837 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6839 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6846 /* now see if we need more "r" chars */
6847 if (rfirst > rlast) {
6849 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6851 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6853 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6862 rfirst = rlast = 0xffffffff;
6866 /* now see which range will peter out first, if either. */
6867 tdiff = tlast - tfirst;
6868 rdiff = rlast - rfirst;
6869 tcount += tdiff + 1;
6870 rcount += rdiff + 1;
6877 if (rfirst == 0xffffffff) {
6878 diff = tdiff; /* oops, pretend rdiff is infinite */
6880 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6881 (long)tfirst, (long)tlast);
6883 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6887 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6888 (long)tfirst, (long)(tfirst + diff),
6891 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6892 (long)tfirst, (long)rfirst);
6894 if (rfirst + diff > max)
6895 max = rfirst + diff;
6897 grows = (tfirst < rfirst &&
6898 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6904 /* compile listsv into a swash and attach to o */
6912 else if (max > 0xff)
6917 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6919 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6920 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6921 PAD_SETSV(cPADOPo->op_padix, swash);
6923 SvREADONLY_on(swash);
6925 cSVOPo->op_sv = swash;
6927 SvREFCNT_dec(listsv);
6928 SvREFCNT_dec(transv);
6930 if (!del && havefinal && rlen)
6931 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6932 newSVuv((UV)final), 0);
6941 else if (rlast == 0xffffffff)
6947 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6948 * table. Entries with the value -1 indicate chars not to be
6949 * translated, while -2 indicates a search char without a
6950 * corresponding replacement char under /d.
6952 * Normally, the table has 256 slots. However, in the presence of
6953 * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6954 * added, and if there are enough replacement chars to start pairing
6955 * with the \x{100},... search chars, then a larger (> 256) table
6958 * In addition, regardless of whether under /c, an extra slot at the
6959 * end is used to store the final repeating char, or -3 under an empty
6960 * replacement list, or -2 under /d; which makes the runtime code
6963 * The toker will have already expanded char ranges in t and r.
6966 /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6967 * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6968 * The OPtrans_map struct already contains one slot; hence the -1.
6970 struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6971 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6973 cPVOPo->op_pv = (char*)tbl;
6978 /* in this branch, j is a count of 'consumed' (i.e. paired off
6979 * with a search char) replacement chars (so j <= rlen always)
6981 for (i = 0; i < tlen; i++)
6982 tbl->map[t[i]] = -1;
6984 for (i = 0, j = 0; i < 256; i++) {
6990 tbl->map[i] = r[j-1];
6992 tbl->map[i] = (short)i;
6995 tbl->map[i] = r[j++];
6997 if ( tbl->map[i] >= 0
6998 && UVCHR_IS_INVARIANT((UV)i)
6999 && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
7009 /* More replacement chars than search chars:
7010 * store excess replacement chars at end of main table.
7013 struct_size += excess;
7014 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
7015 struct_size + excess * sizeof(short));
7016 tbl->size += excess;
7017 cPVOPo->op_pv = (char*)tbl;
7019 for (i = 0; i < excess; i++)
7020 tbl->map[i + 256] = r[j+i];
7023 /* no more replacement chars than search chars */
7024 if (!rlen && !del && !squash)
7025 o->op_private |= OPpTRANS_IDENTICAL;
7028 tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
7031 if (!rlen && !del) {
7034 o->op_private |= OPpTRANS_IDENTICAL;
7036 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
7037 o->op_private |= OPpTRANS_IDENTICAL;
7040 for (i = 0; i < 256; i++)
7042 for (i = 0, j = 0; i < tlen; i++,j++) {
7045 if (tbl->map[t[i]] == -1)
7046 tbl->map[t[i]] = -2;
7051 if (tbl->map[t[i]] == -1) {
7052 if ( UVCHR_IS_INVARIANT(t[i])
7053 && ! UVCHR_IS_INVARIANT(r[j]))
7055 tbl->map[t[i]] = r[j];
7058 tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
7061 /* both non-utf8 and utf8 code paths end up here */
7064 if(del && rlen == tlen) {
7065 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
7066 } else if(rlen > tlen && !complement) {
7067 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
7071 o->op_private |= OPpTRANS_GROWS;
7082 Constructs, checks, and returns an op of any pattern matching type.
7083 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
7084 and, shifted up eight bits, the eight bits of C<op_private>.
7090 Perl_newPMOP(pTHX_ I32 type, I32 flags)
7095 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
7096 || type == OP_CUSTOM);
7098 NewOp(1101, pmop, 1, PMOP);
7099 OpTYPE_set(pmop, type);
7100 pmop->op_flags = (U8)flags;
7101 pmop->op_private = (U8)(0 | (flags >> 8));
7102 if (PL_opargs[type] & OA_RETSCALAR)
7105 if (PL_hints & HINT_RE_TAINT)
7106 pmop->op_pmflags |= PMf_RETAINT;
7107 #ifdef USE_LOCALE_CTYPE
7108 if (IN_LC_COMPILETIME(LC_CTYPE)) {
7109 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
7114 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
7116 if (PL_hints & HINT_RE_FLAGS) {
7117 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7118 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
7120 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
7121 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7122 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
7124 if (reflags && SvOK(reflags)) {
7125 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
7131 assert(SvPOK(PL_regex_pad[0]));
7132 if (SvCUR(PL_regex_pad[0])) {
7133 /* Pop off the "packed" IV from the end. */
7134 SV *const repointer_list = PL_regex_pad[0];
7135 const char *p = SvEND(repointer_list) - sizeof(IV);
7136 const IV offset = *((IV*)p);
7138 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
7140 SvEND_set(repointer_list, p);
7142 pmop->op_pmoffset = offset;
7143 /* This slot should be free, so assert this: */
7144 assert(PL_regex_pad[offset] == &PL_sv_undef);
7146 SV * const repointer = &PL_sv_undef;
7147 av_push(PL_regex_padav, repointer);
7148 pmop->op_pmoffset = av_tindex(PL_regex_padav);
7149 PL_regex_pad = AvARRAY(PL_regex_padav);
7153 return CHECKOP(type, pmop);
7161 /* Any pad names in scope are potentially lvalues. */
7162 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
7163 PADNAME *pn = PAD_COMPNAME_SV(i);
7164 if (!pn || !PadnameLEN(pn))
7166 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
7167 S_mark_padname_lvalue(aTHX_ pn);
7171 /* Given some sort of match op o, and an expression expr containing a
7172 * pattern, either compile expr into a regex and attach it to o (if it's
7173 * constant), or convert expr into a runtime regcomp op sequence (if it's
7176 * Flags currently has 2 bits of meaning:
7177 * 1: isreg indicates that the pattern is part of a regex construct, eg
7178 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
7179 * split "pattern", which aren't. In the former case, expr will be a list
7180 * if the pattern contains more than one term (eg /a$b/).
7181 * 2: The pattern is for a split.
7183 * When the pattern has been compiled within a new anon CV (for
7184 * qr/(?{...})/ ), then floor indicates the savestack level just before
7185 * the new sub was created
7189 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
7193 I32 repl_has_vars = 0;
7194 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
7195 bool is_compiletime;
7197 bool isreg = cBOOL(flags & 1);
7198 bool is_split = cBOOL(flags & 2);
7200 PERL_ARGS_ASSERT_PMRUNTIME;
7203 return pmtrans(o, expr, repl);
7206 /* find whether we have any runtime or code elements;
7207 * at the same time, temporarily set the op_next of each DO block;
7208 * then when we LINKLIST, this will cause the DO blocks to be excluded
7209 * from the op_next chain (and from having LINKLIST recursively
7210 * applied to them). We fix up the DOs specially later */
7214 if (expr->op_type == OP_LIST) {
7216 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7217 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
7219 assert(!o->op_next);
7220 if (UNLIKELY(!OpHAS_SIBLING(o))) {
7221 assert(PL_parser && PL_parser->error_count);
7222 /* This can happen with qr/ (?{(^{})/. Just fake up
7223 the op we were expecting to see, to avoid crashing
7225 op_sibling_splice(expr, o, 0,
7226 newSVOP(OP_CONST, 0, &PL_sv_no));
7228 o->op_next = OpSIBLING(o);
7230 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
7234 else if (expr->op_type != OP_CONST)
7239 /* fix up DO blocks; treat each one as a separate little sub;
7240 * also, mark any arrays as LIST/REF */
7242 if (expr->op_type == OP_LIST) {
7244 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7246 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
7247 assert( !(o->op_flags & OPf_WANT));
7248 /* push the array rather than its contents. The regex
7249 * engine will retrieve and join the elements later */
7250 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
7254 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
7256 o->op_next = NULL; /* undo temporary hack from above */
7259 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
7260 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
7262 assert(leaveop->op_first->op_type == OP_ENTER);
7263 assert(OpHAS_SIBLING(leaveop->op_first));
7264 o->op_next = OpSIBLING(leaveop->op_first);
7266 assert(leaveop->op_flags & OPf_KIDS);
7267 assert(leaveop->op_last->op_next == (OP*)leaveop);
7268 leaveop->op_next = NULL; /* stop on last op */
7269 op_null((OP*)leaveop);
7273 OP *scope = cLISTOPo->op_first;
7274 assert(scope->op_type == OP_SCOPE);
7275 assert(scope->op_flags & OPf_KIDS);
7276 scope->op_next = NULL; /* stop on last op */
7280 /* XXX optimize_optree() must be called on o before
7281 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7282 * currently cope with a peephole-optimised optree.
7283 * Calling optimize_optree() here ensures that condition
7284 * is met, but may mean optimize_optree() is applied
7285 * to the same optree later (where hopefully it won't do any
7286 * harm as it can't convert an op to multiconcat if it's
7287 * already been converted */
7290 /* have to peep the DOs individually as we've removed it from
7291 * the op_next chain */
7293 S_prune_chain_head(&(o->op_next));
7295 /* runtime finalizes as part of finalizing whole tree */
7299 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7300 assert( !(expr->op_flags & OPf_WANT));
7301 /* push the array rather than its contents. The regex
7302 * engine will retrieve and join the elements later */
7303 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7306 PL_hints |= HINT_BLOCK_SCOPE;
7308 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7310 if (is_compiletime) {
7311 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7312 regexp_engine const *eng = current_re_engine();
7315 /* make engine handle split ' ' specially */
7316 pm->op_pmflags |= PMf_SPLIT;
7317 rx_flags |= RXf_SPLIT;
7320 if (!has_code || !eng->op_comp) {
7321 /* compile-time simple constant pattern */
7323 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7324 /* whoops! we guessed that a qr// had a code block, but we
7325 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7326 * that isn't required now. Note that we have to be pretty
7327 * confident that nothing used that CV's pad while the
7328 * regex was parsed, except maybe op targets for \Q etc.
7329 * If there were any op targets, though, they should have
7330 * been stolen by constant folding.
7334 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7335 while (++i <= AvFILLp(PL_comppad)) {
7336 # ifdef USE_PAD_RESET
7337 /* under USE_PAD_RESET, pad swipe replaces a swiped
7338 * folded constant with a fresh padtmp */
7339 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7341 assert(!PL_curpad[i]);
7345 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7346 * outer CV (the one whose slab holds the pm op). The
7347 * inner CV (which holds expr) will be freed later, once
7348 * all the entries on the parse stack have been popped on
7349 * return from this function. Which is why its safe to
7350 * call op_free(expr) below.
7353 pm->op_pmflags &= ~PMf_HAS_CV;
7356 /* Skip compiling if parser found an error for this pattern */
7357 if (pm->op_pmflags & PMf_HAS_ERROR) {
7363 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7364 rx_flags, pm->op_pmflags)
7365 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7366 rx_flags, pm->op_pmflags)
7371 /* compile-time pattern that includes literal code blocks */
7375 /* Skip compiling if parser found an error for this pattern */
7376 if (pm->op_pmflags & PMf_HAS_ERROR) {
7380 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7383 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7386 if (pm->op_pmflags & PMf_HAS_CV) {
7388 /* this QR op (and the anon sub we embed it in) is never
7389 * actually executed. It's just a placeholder where we can
7390 * squirrel away expr in op_code_list without the peephole
7391 * optimiser etc processing it for a second time */
7392 OP *qr = newPMOP(OP_QR, 0);
7393 ((PMOP*)qr)->op_code_list = expr;
7395 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7396 SvREFCNT_inc_simple_void(PL_compcv);
7397 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7398 ReANY(re)->qr_anoncv = cv;
7400 /* attach the anon CV to the pad so that
7401 * pad_fixup_inner_anons() can find it */
7402 (void)pad_add_anon(cv, o->op_type);
7403 SvREFCNT_inc_simple_void(cv);
7406 pm->op_code_list = expr;
7411 /* runtime pattern: build chain of regcomp etc ops */
7413 PADOFFSET cv_targ = 0;
7415 reglist = isreg && expr->op_type == OP_LIST;
7420 pm->op_code_list = expr;
7421 /* don't free op_code_list; its ops are embedded elsewhere too */
7422 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7426 /* make engine handle split ' ' specially */
7427 pm->op_pmflags |= PMf_SPLIT;
7429 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7430 * to allow its op_next to be pointed past the regcomp and
7431 * preceding stacking ops;
7432 * OP_REGCRESET is there to reset taint before executing the
7434 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7435 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7437 if (pm->op_pmflags & PMf_HAS_CV) {
7438 /* we have a runtime qr with literal code. This means
7439 * that the qr// has been wrapped in a new CV, which
7440 * means that runtime consts, vars etc will have been compiled
7441 * against a new pad. So... we need to execute those ops
7442 * within the environment of the new CV. So wrap them in a call
7443 * to a new anon sub. i.e. for
7447 * we build an anon sub that looks like
7449 * sub { "a", $b, '(?{...})' }
7451 * and call it, passing the returned list to regcomp.
7452 * Or to put it another way, the list of ops that get executed
7456 * ------ -------------------
7457 * pushmark (for regcomp)
7458 * pushmark (for entersub)
7462 * regcreset regcreset
7464 * const("a") const("a")
7466 * const("(?{...})") const("(?{...})")
7471 SvREFCNT_inc_simple_void(PL_compcv);
7472 CvLVALUE_on(PL_compcv);
7473 /* these lines are just an unrolled newANONATTRSUB */
7474 expr = newSVOP(OP_ANONCODE, 0,
7475 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7476 cv_targ = expr->op_targ;
7477 expr = newUNOP(OP_REFGEN, 0, expr);
7479 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7482 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7483 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7484 | (reglist ? OPf_STACKED : 0);
7485 rcop->op_targ = cv_targ;
7487 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
7488 if (PL_hints & HINT_RE_EVAL)
7489 S_set_haseval(aTHX);
7491 /* establish postfix order */
7492 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7494 rcop->op_next = expr;
7495 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7498 rcop->op_next = LINKLIST(expr);
7499 expr->op_next = (OP*)rcop;
7502 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7508 /* If we are looking at s//.../e with a single statement, get past
7509 the implicit do{}. */
7510 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7511 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7512 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7515 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7516 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7517 && !OpHAS_SIBLING(sib))
7520 if (curop->op_type == OP_CONST)
7522 else if (( (curop->op_type == OP_RV2SV ||
7523 curop->op_type == OP_RV2AV ||
7524 curop->op_type == OP_RV2HV ||
7525 curop->op_type == OP_RV2GV)
7526 && cUNOPx(curop)->op_first
7527 && cUNOPx(curop)->op_first->op_type == OP_GV )
7528 || curop->op_type == OP_PADSV
7529 || curop->op_type == OP_PADAV
7530 || curop->op_type == OP_PADHV
7531 || curop->op_type == OP_PADANY) {
7539 || !RX_PRELEN(PM_GETRE(pm))
7540 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7542 pm->op_pmflags |= PMf_CONST; /* const for long enough */
7543 op_prepend_elem(o->op_type, scalar(repl), o);
7546 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7547 rcop->op_private = 1;
7549 /* establish postfix order */
7550 rcop->op_next = LINKLIST(repl);
7551 repl->op_next = (OP*)rcop;
7553 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7554 assert(!(pm->op_pmflags & PMf_ONCE));
7555 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7566 Constructs, checks, and returns an op of any type that involves an
7567 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
7568 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
7569 takes ownership of one reference to it.
7575 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7580 PERL_ARGS_ASSERT_NEWSVOP;
7582 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7583 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7584 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7585 || type == OP_CUSTOM);
7587 NewOp(1101, svop, 1, SVOP);
7588 OpTYPE_set(svop, type);
7590 svop->op_next = (OP*)svop;
7591 svop->op_flags = (U8)flags;
7592 svop->op_private = (U8)(0 | (flags >> 8));
7593 if (PL_opargs[type] & OA_RETSCALAR)
7595 if (PL_opargs[type] & OA_TARGET)
7596 svop->op_targ = pad_alloc(type, SVs_PADTMP);
7597 return CHECKOP(type, svop);
7601 =for apidoc newDEFSVOP
7603 Constructs and returns an op to access C<$_>.
7609 Perl_newDEFSVOP(pTHX)
7611 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7617 =for apidoc newPADOP
7619 Constructs, checks, and returns an op of any type that involves a
7620 reference to a pad element. C<type> is the opcode. C<flags> gives the
7621 eight bits of C<op_flags>. A pad slot is automatically allocated, and
7622 is populated with C<sv>; this function takes ownership of one reference
7625 This function only exists if Perl has been compiled to use ithreads.
7631 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7636 PERL_ARGS_ASSERT_NEWPADOP;
7638 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7639 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7640 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7641 || type == OP_CUSTOM);
7643 NewOp(1101, padop, 1, PADOP);
7644 OpTYPE_set(padop, type);
7646 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7647 SvREFCNT_dec(PAD_SVl(padop->op_padix));
7648 PAD_SETSV(padop->op_padix, sv);
7650 padop->op_next = (OP*)padop;
7651 padop->op_flags = (U8)flags;
7652 if (PL_opargs[type] & OA_RETSCALAR)
7654 if (PL_opargs[type] & OA_TARGET)
7655 padop->op_targ = pad_alloc(type, SVs_PADTMP);
7656 return CHECKOP(type, padop);
7659 #endif /* USE_ITHREADS */
7664 Constructs, checks, and returns an op of any type that involves an
7665 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
7666 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
7667 reference; calling this function does not transfer ownership of any
7674 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7676 PERL_ARGS_ASSERT_NEWGVOP;
7679 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7681 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7688 Constructs, checks, and returns an op of any type that involves an
7689 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
7690 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
7691 Depending on the op type, the memory referenced by C<pv> may be freed
7692 when the op is destroyed. If the op is of a freeing type, C<pv> must
7693 have been allocated using C<PerlMemShared_malloc>.
7699 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7702 const bool utf8 = cBOOL(flags & SVf_UTF8);
7707 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7708 || type == OP_RUNCV || type == OP_CUSTOM
7709 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7711 NewOp(1101, pvop, 1, PVOP);
7712 OpTYPE_set(pvop, type);
7714 pvop->op_next = (OP*)pvop;
7715 pvop->op_flags = (U8)flags;
7716 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7717 if (PL_opargs[type] & OA_RETSCALAR)
7719 if (PL_opargs[type] & OA_TARGET)
7720 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7721 return CHECKOP(type, pvop);
7725 Perl_package(pTHX_ OP *o)
7727 SV *const sv = cSVOPo->op_sv;
7729 PERL_ARGS_ASSERT_PACKAGE;
7731 SAVEGENERICSV(PL_curstash);
7732 save_item(PL_curstname);
7734 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7736 sv_setsv(PL_curstname, sv);
7738 PL_hints |= HINT_BLOCK_SCOPE;
7739 PL_parser->copline = NOLINE;
7745 Perl_package_version( pTHX_ OP *v )
7747 U32 savehints = PL_hints;
7748 PERL_ARGS_ASSERT_PACKAGE_VERSION;
7749 PL_hints &= ~HINT_STRICT_VARS;
7750 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7751 PL_hints = savehints;
7756 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7761 SV *use_version = NULL;
7763 PERL_ARGS_ASSERT_UTILIZE;
7765 if (idop->op_type != OP_CONST)
7766 Perl_croak(aTHX_ "Module name must be constant");
7771 SV * const vesv = ((SVOP*)version)->op_sv;
7773 if (!arg && !SvNIOKp(vesv)) {
7780 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7781 Perl_croak(aTHX_ "Version number must be a constant number");
7783 /* Make copy of idop so we don't free it twice */
7784 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7786 /* Fake up a method call to VERSION */
7787 meth = newSVpvs_share("VERSION");
7788 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7789 op_append_elem(OP_LIST,
7790 op_prepend_elem(OP_LIST, pack, version),
7791 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7795 /* Fake up an import/unimport */
7796 if (arg && arg->op_type == OP_STUB) {
7797 imop = arg; /* no import on explicit () */
7799 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7800 imop = NULL; /* use 5.0; */
7802 use_version = ((SVOP*)idop)->op_sv;
7804 idop->op_private |= OPpCONST_NOVER;
7809 /* Make copy of idop so we don't free it twice */
7810 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7812 /* Fake up a method call to import/unimport */
7814 ? newSVpvs_share("import") : newSVpvs_share("unimport");
7815 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7816 op_append_elem(OP_LIST,
7817 op_prepend_elem(OP_LIST, pack, arg),
7818 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7822 /* Fake up the BEGIN {}, which does its thing immediately. */
7824 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7827 op_append_elem(OP_LINESEQ,
7828 op_append_elem(OP_LINESEQ,
7829 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7830 newSTATEOP(0, NULL, veop)),
7831 newSTATEOP(0, NULL, imop) ));
7835 * feature bundle that corresponds to the required version. */
7836 use_version = sv_2mortal(new_version(use_version));
7837 S_enable_feature_bundle(aTHX_ use_version);
7839 /* If a version >= 5.11.0 is requested, strictures are on by default! */
7840 if (vcmp(use_version,
7841 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7842 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7843 PL_hints |= HINT_STRICT_REFS;
7844 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7845 PL_hints |= HINT_STRICT_SUBS;
7846 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7847 PL_hints |= HINT_STRICT_VARS;
7849 /* otherwise they are off */
7851 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7852 PL_hints &= ~HINT_STRICT_REFS;
7853 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7854 PL_hints &= ~HINT_STRICT_SUBS;
7855 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7856 PL_hints &= ~HINT_STRICT_VARS;
7860 /* The "did you use incorrect case?" warning used to be here.
7861 * The problem is that on case-insensitive filesystems one
7862 * might get false positives for "use" (and "require"):
7863 * "use Strict" or "require CARP" will work. This causes
7864 * portability problems for the script: in case-strict
7865 * filesystems the script will stop working.
7867 * The "incorrect case" warning checked whether "use Foo"
7868 * imported "Foo" to your namespace, but that is wrong, too:
7869 * there is no requirement nor promise in the language that
7870 * a Foo.pm should or would contain anything in package "Foo".
7872 * There is very little Configure-wise that can be done, either:
7873 * the case-sensitivity of the build filesystem of Perl does not
7874 * help in guessing the case-sensitivity of the runtime environment.
7877 PL_hints |= HINT_BLOCK_SCOPE;
7878 PL_parser->copline = NOLINE;
7879 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7883 =head1 Embedding Functions
7885 =for apidoc load_module
7887 Loads the module whose name is pointed to by the string part of C<name>.
7888 Note that the actual module name, not its filename, should be given.
7889 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7890 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7891 trailing arguments can be used to specify arguments to the module's C<import()>
7892 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7893 on the flags. The flags argument is a bitwise-ORed collection of any of
7894 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7895 (or 0 for no flags).
7897 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7898 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7899 the trailing optional arguments may be omitted entirely. Otherwise, if
7900 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7901 exactly one C<OP*>, containing the op tree that produces the relevant import
7902 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7903 will be used as import arguments; and the list must be terminated with C<(SV*)
7904 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7905 set, the trailing C<NULL> pointer is needed even if no import arguments are
7906 desired. The reference count for each specified C<SV*> argument is
7907 decremented. In addition, the C<name> argument is modified.
7909 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7915 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7919 PERL_ARGS_ASSERT_LOAD_MODULE;
7921 va_start(args, ver);
7922 vload_module(flags, name, ver, &args);
7926 #ifdef PERL_IMPLICIT_CONTEXT
7928 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7932 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7933 va_start(args, ver);
7934 vload_module(flags, name, ver, &args);
7940 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7946 PERL_ARGS_ASSERT_VLOAD_MODULE;
7948 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7949 * that it has a PL_parser to play with while doing that, and also
7950 * that it doesn't mess with any existing parser, by creating a tmp
7951 * new parser with lex_start(). This won't actually be used for much,
7952 * since pp_require() will create another parser for the real work.
7953 * The ENTER/LEAVE pair protect callers from any side effects of use.
7955 * start_subparse() creates a new PL_compcv. This means that any ops
7956 * allocated below will be allocated from that CV's op slab, and so
7957 * will be automatically freed if the utilise() fails
7961 SAVEVPTR(PL_curcop);
7962 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7963 floor = start_subparse(FALSE, 0);
7965 modname = newSVOP(OP_CONST, 0, name);
7966 modname->op_private |= OPpCONST_BARE;
7968 veop = newSVOP(OP_CONST, 0, ver);
7972 if (flags & PERL_LOADMOD_NOIMPORT) {
7973 imop = sawparens(newNULLLIST());
7975 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7976 imop = va_arg(*args, OP*);
7981 sv = va_arg(*args, SV*);
7983 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7984 sv = va_arg(*args, SV*);
7988 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
7992 PERL_STATIC_INLINE OP *
7993 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7995 return newUNOP(OP_ENTERSUB, OPf_STACKED,
7996 newLISTOP(OP_LIST, 0, arg,
7997 newUNOP(OP_RV2CV, 0,
7998 newGVOP(OP_GV, 0, gv))));
8002 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
8007 PERL_ARGS_ASSERT_DOFILE;
8009 if (!force_builtin && (gv = gv_override("do", 2))) {
8010 doop = S_new_entersubop(aTHX_ gv, term);
8013 doop = newUNOP(OP_DOFILE, 0, scalar(term));
8019 =head1 Optree construction
8021 =for apidoc newSLICEOP
8023 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
8024 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
8025 be set automatically, and, shifted up eight bits, the eight bits of
8026 C<op_private>, except that the bit with value 1 or 2 is automatically
8027 set as required. C<listval> and C<subscript> supply the parameters of
8028 the slice; they are consumed by this function and become part of the
8029 constructed op tree.
8035 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
8037 return newBINOP(OP_LSLICE, flags,
8038 list(force_list(subscript, 1)),
8039 list(force_list(listval, 1)) );
8042 #define ASSIGN_SCALAR 0
8043 #define ASSIGN_LIST 1
8044 #define ASSIGN_REF 2
8046 /* given the optree o on the LHS of an assignment, determine whether its:
8047 * ASSIGN_SCALAR $x = ...
8048 * ASSIGN_LIST ($x) = ...
8049 * ASSIGN_REF \$x = ...
8053 S_assignment_type(pTHX_ const OP *o)
8062 if (o->op_type == OP_SREFGEN)
8064 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
8065 type = kid->op_type;
8066 flags = o->op_flags | kid->op_flags;
8067 if (!(flags & OPf_PARENS)
8068 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
8069 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
8073 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
8074 o = cUNOPo->op_first;
8075 flags = o->op_flags;
8077 ret = ASSIGN_SCALAR;
8080 if (type == OP_COND_EXPR) {
8081 OP * const sib = OpSIBLING(cLOGOPo->op_first);
8082 const I32 t = assignment_type(sib);
8083 const I32 f = assignment_type(OpSIBLING(sib));
8085 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
8087 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
8088 yyerror("Assignment to both a list and a scalar");
8089 return ASSIGN_SCALAR;
8092 if (type == OP_LIST &&
8093 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
8094 o->op_private & OPpLVAL_INTRO)
8097 if (type == OP_LIST || flags & OPf_PARENS ||
8098 type == OP_RV2AV || type == OP_RV2HV ||
8099 type == OP_ASLICE || type == OP_HSLICE ||
8100 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
8103 if (type == OP_PADAV || type == OP_PADHV)
8106 if (type == OP_RV2SV)
8113 S_newONCEOP(pTHX_ OP *initop, OP *padop)
8116 const PADOFFSET target = padop->op_targ;
8117 OP *const other = newOP(OP_PADSV,
8119 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
8120 OP *const first = newOP(OP_NULL, 0);
8121 OP *const nullop = newCONDOP(0, first, initop, other);
8122 /* XXX targlex disabled for now; see ticket #124160
8123 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
8125 OP *const condop = first->op_next;
8127 OpTYPE_set(condop, OP_ONCE);
8128 other->op_targ = target;
8129 nullop->op_flags |= OPf_WANT_SCALAR;
8131 /* Store the initializedness of state vars in a separate
8134 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
8135 /* hijacking PADSTALE for uninitialized state variables */
8136 SvPADSTALE_on(PAD_SVl(condop->op_targ));
8142 =for apidoc newASSIGNOP
8144 Constructs, checks, and returns an assignment op. C<left> and C<right>
8145 supply the parameters of the assignment; they are consumed by this
8146 function and become part of the constructed op tree.
8148 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
8149 a suitable conditional optree is constructed. If C<optype> is the opcode
8150 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
8151 performs the binary operation and assigns the result to the left argument.
8152 Either way, if C<optype> is non-zero then C<flags> has no effect.
8154 If C<optype> is zero, then a plain scalar or list assignment is
8155 constructed. Which type of assignment it is is automatically determined.
8156 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8157 will be set automatically, and, shifted up eight bits, the eight bits
8158 of C<op_private>, except that the bit with value 1 or 2 is automatically
8165 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
8171 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
8172 right = scalar(right);
8173 return newLOGOP(optype, 0,
8174 op_lvalue(scalar(left), optype),
8175 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
8178 return newBINOP(optype, OPf_STACKED,
8179 op_lvalue(scalar(left), optype), scalar(right));
8183 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
8184 OP *state_var_op = NULL;
8185 static const char no_list_state[] = "Initialization of state variables"
8186 " in list currently forbidden";
8189 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
8190 left->op_private &= ~ OPpSLICEWARNING;
8193 left = op_lvalue(left, OP_AASSIGN);
8194 curop = list(force_list(left, 1));
8195 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
8196 o->op_private = (U8)(0 | (flags >> 8));
8198 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
8200 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
8201 if (!(left->op_flags & OPf_PARENS) &&
8202 lop->op_type == OP_PUSHMARK &&
8203 (vop = OpSIBLING(lop)) &&
8204 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
8205 !(vop->op_flags & OPf_PARENS) &&
8206 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
8207 (OPpLVAL_INTRO|OPpPAD_STATE) &&
8208 (eop = OpSIBLING(vop)) &&
8209 eop->op_type == OP_ENTERSUB &&
8210 !OpHAS_SIBLING(eop)) {
8214 if ((lop->op_type == OP_PADSV ||
8215 lop->op_type == OP_PADAV ||
8216 lop->op_type == OP_PADHV ||
8217 lop->op_type == OP_PADANY)
8218 && (lop->op_private & OPpPAD_STATE)
8220 yyerror(no_list_state);
8221 lop = OpSIBLING(lop);
8225 else if ( (left->op_private & OPpLVAL_INTRO)
8226 && (left->op_private & OPpPAD_STATE)
8227 && ( left->op_type == OP_PADSV
8228 || left->op_type == OP_PADAV
8229 || left->op_type == OP_PADHV
8230 || left->op_type == OP_PADANY)
8232 /* All single variable list context state assignments, hence
8242 if (left->op_flags & OPf_PARENS)
8243 yyerror(no_list_state);
8245 state_var_op = left;
8248 /* optimise @a = split(...) into:
8249 * @{expr}: split(..., @{expr}) (where @a is not flattened)
8250 * @a, my @a, local @a: split(...) (where @a is attached to
8251 * the split op itself)
8255 && right->op_type == OP_SPLIT
8256 /* don't do twice, e.g. @b = (@a = split) */
8257 && !(right->op_private & OPpSPLIT_ASSIGN))
8261 if ( ( left->op_type == OP_RV2AV
8262 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
8263 || left->op_type == OP_PADAV)
8265 /* @pkg or @lex or local @pkg' or 'my @lex' */
8269 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
8270 = cPADOPx(gvop)->op_padix;
8271 cPADOPx(gvop)->op_padix = 0; /* steal it */
8273 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
8274 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8275 cSVOPx(gvop)->op_sv = NULL; /* steal it */
8277 right->op_private |=
8278 left->op_private & OPpOUR_INTRO;
8281 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8282 left->op_targ = 0; /* steal it */
8283 right->op_private |= OPpSPLIT_LEX;
8285 right->op_private |= left->op_private & OPpLVAL_INTRO;
8288 tmpop = cUNOPo->op_first; /* to list (nulled) */
8289 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
8290 assert(OpSIBLING(tmpop) == right);
8291 assert(!OpHAS_SIBLING(right));
8292 /* detach the split subtreee from the o tree,
8293 * then free the residual o tree */
8294 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8295 op_free(o); /* blow off assign */
8296 right->op_private |= OPpSPLIT_ASSIGN;
8297 right->op_flags &= ~OPf_WANT;
8298 /* "I don't know and I don't care." */
8301 else if (left->op_type == OP_RV2AV) {
8304 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8305 assert(OpSIBLING(pushop) == left);
8306 /* Detach the array ... */
8307 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8308 /* ... and attach it to the split. */
8309 op_sibling_splice(right, cLISTOPx(right)->op_last,
8311 right->op_flags |= OPf_STACKED;
8312 /* Detach split and expunge aassign as above. */
8315 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8316 ((LISTOP*)right)->op_last->op_type == OP_CONST)
8318 /* convert split(...,0) to split(..., PL_modcount+1) */
8320 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8321 SV * const sv = *svp;
8322 if (SvIOK(sv) && SvIVX(sv) == 0)
8324 if (right->op_private & OPpSPLIT_IMPLIM) {
8325 /* our own SV, created in ck_split */
8327 sv_setiv(sv, PL_modcount+1);
8330 /* SV may belong to someone else */
8332 *svp = newSViv(PL_modcount+1);
8339 o = S_newONCEOP(aTHX_ o, state_var_op);
8342 if (assign_type == ASSIGN_REF)
8343 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8345 right = newOP(OP_UNDEF, 0);
8346 if (right->op_type == OP_READLINE) {
8347 right->op_flags |= OPf_STACKED;
8348 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8352 o = newBINOP(OP_SASSIGN, flags,
8353 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8359 =for apidoc newSTATEOP
8361 Constructs a state op (COP). The state op is normally a C<nextstate> op,
8362 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8363 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8364 If C<label> is non-null, it supplies the name of a label to attach to
8365 the state op; this function takes ownership of the memory pointed at by
8366 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
8369 If C<o> is null, the state op is returned. Otherwise the state op is
8370 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
8371 is consumed by this function and becomes part of the returned op tree.
8377 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8380 const U32 seq = intro_my();
8381 const U32 utf8 = flags & SVf_UTF8;
8384 PL_parser->parsed_sub = 0;
8388 NewOp(1101, cop, 1, COP);
8389 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8390 OpTYPE_set(cop, OP_DBSTATE);
8393 OpTYPE_set(cop, OP_NEXTSTATE);
8395 cop->op_flags = (U8)flags;
8396 CopHINTS_set(cop, PL_hints);
8398 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8400 cop->op_next = (OP*)cop;
8403 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8404 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8406 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8408 PL_hints |= HINT_BLOCK_SCOPE;
8409 /* It seems that we need to defer freeing this pointer, as other parts
8410 of the grammar end up wanting to copy it after this op has been
8415 if (PL_parser->preambling != NOLINE) {
8416 CopLINE_set(cop, PL_parser->preambling);
8417 PL_parser->copline = NOLINE;
8419 else if (PL_parser->copline == NOLINE)
8420 CopLINE_set(cop, CopLINE(PL_curcop));
8422 CopLINE_set(cop, PL_parser->copline);
8423 PL_parser->copline = NOLINE;
8426 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
8428 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8430 CopSTASH_set(cop, PL_curstash);
8432 if (cop->op_type == OP_DBSTATE) {
8433 /* this line can have a breakpoint - store the cop in IV */
8434 AV *av = CopFILEAVx(PL_curcop);
8436 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8437 if (svp && *svp != &PL_sv_undef ) {
8438 (void)SvIOK_on(*svp);
8439 SvIV_set(*svp, PTR2IV(cop));
8444 if (flags & OPf_SPECIAL)
8446 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8450 =for apidoc newLOGOP
8452 Constructs, checks, and returns a logical (flow control) op. C<type>
8453 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
8454 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8455 the eight bits of C<op_private>, except that the bit with value 1 is
8456 automatically set. C<first> supplies the expression controlling the
8457 flow, and C<other> supplies the side (alternate) chain of ops; they are
8458 consumed by this function and become part of the constructed op tree.
8464 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8466 PERL_ARGS_ASSERT_NEWLOGOP;
8468 return new_logop(type, flags, &first, &other);
8472 /* See if the optree o contains a single OP_CONST (plus possibly
8473 * surrounding enter/nextstate/null etc). If so, return it, else return
8478 S_search_const(pTHX_ OP *o)
8480 PERL_ARGS_ASSERT_SEARCH_CONST;
8483 switch (o->op_type) {
8487 if (o->op_flags & OPf_KIDS) {
8488 o = cUNOPo->op_first;
8497 if (!(o->op_flags & OPf_KIDS))
8499 kid = cLISTOPo->op_first;
8502 switch (kid->op_type) {
8506 kid = OpSIBLING(kid);
8509 if (kid != cLISTOPo->op_last)
8516 kid = cLISTOPo->op_last;
8528 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8536 int prepend_not = 0;
8538 PERL_ARGS_ASSERT_NEW_LOGOP;
8543 /* [perl #59802]: Warn about things like "return $a or $b", which
8544 is parsed as "(return $a) or $b" rather than "return ($a or
8545 $b)". NB: This also applies to xor, which is why we do it
8548 switch (first->op_type) {
8552 /* XXX: Perhaps we should emit a stronger warning for these.
8553 Even with the high-precedence operator they don't seem to do
8556 But until we do, fall through here.
8562 /* XXX: Currently we allow people to "shoot themselves in the
8563 foot" by explicitly writing "(return $a) or $b".
8565 Warn unless we are looking at the result from folding or if
8566 the programmer explicitly grouped the operators like this.
8567 The former can occur with e.g.
8569 use constant FEATURE => ( $] >= ... );
8570 sub { not FEATURE and return or do_stuff(); }
8572 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8573 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8574 "Possible precedence issue with control flow operator");
8575 /* XXX: Should we optimze this to "return $a;" (i.e. remove
8581 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8582 return newBINOP(type, flags, scalar(first), scalar(other));
8584 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8585 || type == OP_CUSTOM);
8587 scalarboolean(first);
8589 /* search for a constant op that could let us fold the test */
8590 if ((cstop = search_const(first))) {
8591 if (cstop->op_private & OPpCONST_STRICT)
8592 no_bareword_allowed(cstop);
8593 else if ((cstop->op_private & OPpCONST_BARE))
8594 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8595 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
8596 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8597 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8598 /* Elide the (constant) lhs, since it can't affect the outcome */
8600 if (other->op_type == OP_CONST)
8601 other->op_private |= OPpCONST_SHORTCIRCUIT;
8603 if (other->op_type == OP_LEAVE)
8604 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8605 else if (other->op_type == OP_MATCH
8606 || other->op_type == OP_SUBST
8607 || other->op_type == OP_TRANSR
8608 || other->op_type == OP_TRANS)
8609 /* Mark the op as being unbindable with =~ */
8610 other->op_flags |= OPf_SPECIAL;
8612 other->op_folded = 1;
8616 /* Elide the rhs, since the outcome is entirely determined by
8617 * the (constant) lhs */
8619 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8620 const OP *o2 = other;
8621 if ( ! (o2->op_type == OP_LIST
8622 && (( o2 = cUNOPx(o2)->op_first))
8623 && o2->op_type == OP_PUSHMARK
8624 && (( o2 = OpSIBLING(o2))) )
8627 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8628 || o2->op_type == OP_PADHV)
8629 && o2->op_private & OPpLVAL_INTRO
8630 && !(o2->op_private & OPpPAD_STATE))
8632 Perl_croak(aTHX_ "This use of my() in false conditional is "
8633 "no longer allowed");
8637 if (cstop->op_type == OP_CONST)
8638 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8643 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8644 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8646 const OP * const k1 = ((UNOP*)first)->op_first;
8647 const OP * const k2 = OpSIBLING(k1);
8649 switch (first->op_type)
8652 if (k2 && k2->op_type == OP_READLINE
8653 && (k2->op_flags & OPf_STACKED)
8654 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8656 warnop = k2->op_type;
8661 if (k1->op_type == OP_READDIR
8662 || k1->op_type == OP_GLOB
8663 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8664 || k1->op_type == OP_EACH
8665 || k1->op_type == OP_AEACH)
8667 warnop = ((k1->op_type == OP_NULL)
8668 ? (OPCODE)k1->op_targ : k1->op_type);
8673 const line_t oldline = CopLINE(PL_curcop);
8674 /* This ensures that warnings are reported at the first line
8675 of the construction, not the last. */
8676 CopLINE_set(PL_curcop, PL_parser->copline);
8677 Perl_warner(aTHX_ packWARN(WARN_MISC),
8678 "Value of %s%s can be \"0\"; test with defined()",
8680 ((warnop == OP_READLINE || warnop == OP_GLOB)
8681 ? " construct" : "() operator"));
8682 CopLINE_set(PL_curcop, oldline);
8686 /* optimize AND and OR ops that have NOTs as children */
8687 if (first->op_type == OP_NOT
8688 && (first->op_flags & OPf_KIDS)
8689 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8690 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8692 if (type == OP_AND || type == OP_OR) {
8698 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8700 prepend_not = 1; /* prepend a NOT op later */
8705 logop = alloc_LOGOP(type, first, LINKLIST(other));
8706 logop->op_flags |= (U8)flags;
8707 logop->op_private = (U8)(1 | (flags >> 8));
8709 /* establish postfix order */
8710 logop->op_next = LINKLIST(first);
8711 first->op_next = (OP*)logop;
8712 assert(!OpHAS_SIBLING(first));
8713 op_sibling_splice((OP*)logop, first, 0, other);
8715 CHECKOP(type,logop);
8717 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8718 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8726 =for apidoc newCONDOP
8728 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8729 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8730 will be set automatically, and, shifted up eight bits, the eight bits of
8731 C<op_private>, except that the bit with value 1 is automatically set.
8732 C<first> supplies the expression selecting between the two branches,
8733 and C<trueop> and C<falseop> supply the branches; they are consumed by
8734 this function and become part of the constructed op tree.
8740 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8748 PERL_ARGS_ASSERT_NEWCONDOP;
8751 return newLOGOP(OP_AND, 0, first, trueop);
8753 return newLOGOP(OP_OR, 0, first, falseop);
8755 scalarboolean(first);
8756 if ((cstop = search_const(first))) {
8757 /* Left or right arm of the conditional? */
8758 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8759 OP *live = left ? trueop : falseop;
8760 OP *const dead = left ? falseop : trueop;
8761 if (cstop->op_private & OPpCONST_BARE &&
8762 cstop->op_private & OPpCONST_STRICT) {
8763 no_bareword_allowed(cstop);
8767 if (live->op_type == OP_LEAVE)
8768 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8769 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8770 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8771 /* Mark the op as being unbindable with =~ */
8772 live->op_flags |= OPf_SPECIAL;
8773 live->op_folded = 1;
8776 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8777 logop->op_flags |= (U8)flags;
8778 logop->op_private = (U8)(1 | (flags >> 8));
8779 logop->op_next = LINKLIST(falseop);
8781 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8784 /* establish postfix order */
8785 start = LINKLIST(first);
8786 first->op_next = (OP*)logop;
8788 /* make first, trueop, falseop siblings */
8789 op_sibling_splice((OP*)logop, first, 0, trueop);
8790 op_sibling_splice((OP*)logop, trueop, 0, falseop);
8792 o = newUNOP(OP_NULL, 0, (OP*)logop);
8794 trueop->op_next = falseop->op_next = o;
8801 =for apidoc newRANGE
8803 Constructs and returns a C<range> op, with subordinate C<flip> and
8804 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
8805 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8806 for both the C<flip> and C<range> ops, except that the bit with value
8807 1 is automatically set. C<left> and C<right> supply the expressions
8808 controlling the endpoints of the range; they are consumed by this function
8809 and become part of the constructed op tree.
8815 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8823 PERL_ARGS_ASSERT_NEWRANGE;
8825 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8826 range->op_flags = OPf_KIDS;
8827 leftstart = LINKLIST(left);
8828 range->op_private = (U8)(1 | (flags >> 8));
8830 /* make left and right siblings */
8831 op_sibling_splice((OP*)range, left, 0, right);
8833 range->op_next = (OP*)range;
8834 flip = newUNOP(OP_FLIP, flags, (OP*)range);
8835 flop = newUNOP(OP_FLOP, 0, flip);
8836 o = newUNOP(OP_NULL, 0, flop);
8838 range->op_next = leftstart;
8840 left->op_next = flip;
8841 right->op_next = flop;
8844 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8845 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8847 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8848 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8849 SvPADTMP_on(PAD_SV(flip->op_targ));
8851 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8852 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8854 /* check barewords before they might be optimized aways */
8855 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8856 no_bareword_allowed(left);
8857 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8858 no_bareword_allowed(right);
8861 if (!flip->op_private || !flop->op_private)
8862 LINKLIST(o); /* blow off optimizer unless constant */
8868 =for apidoc newLOOPOP
8870 Constructs, checks, and returns an op tree expressing a loop. This is
8871 only a loop in the control flow through the op tree; it does not have
8872 the heavyweight loop structure that allows exiting the loop by C<last>
8873 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
8874 top-level op, except that some bits will be set automatically as required.
8875 C<expr> supplies the expression controlling loop iteration, and C<block>
8876 supplies the body of the loop; they are consumed by this function and
8877 become part of the constructed op tree. C<debuggable> is currently
8878 unused and should always be 1.
8884 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8888 const bool once = block && block->op_flags & OPf_SPECIAL &&
8889 block->op_type == OP_NULL;
8891 PERL_UNUSED_ARG(debuggable);
8895 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8896 || ( expr->op_type == OP_NOT
8897 && cUNOPx(expr)->op_first->op_type == OP_CONST
8898 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8901 /* Return the block now, so that S_new_logop does not try to
8905 return block; /* do {} while 0 does once */
8908 if (expr->op_type == OP_READLINE
8909 || expr->op_type == OP_READDIR
8910 || expr->op_type == OP_GLOB
8911 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8912 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8913 expr = newUNOP(OP_DEFINED, 0,
8914 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8915 } else if (expr->op_flags & OPf_KIDS) {
8916 const OP * const k1 = ((UNOP*)expr)->op_first;
8917 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8918 switch (expr->op_type) {
8920 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8921 && (k2->op_flags & OPf_STACKED)
8922 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8923 expr = newUNOP(OP_DEFINED, 0, expr);
8927 if (k1 && (k1->op_type == OP_READDIR
8928 || k1->op_type == OP_GLOB
8929 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8930 || k1->op_type == OP_EACH
8931 || k1->op_type == OP_AEACH))
8932 expr = newUNOP(OP_DEFINED, 0, expr);
8938 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8939 * op, in listop. This is wrong. [perl #27024] */
8941 block = newOP(OP_NULL, 0);
8942 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8943 o = new_logop(OP_AND, 0, &expr, &listop);
8950 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8952 if (once && o != listop)
8954 assert(cUNOPo->op_first->op_type == OP_AND
8955 || cUNOPo->op_first->op_type == OP_OR);
8956 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8960 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
8962 o->op_flags |= flags;
8964 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8969 =for apidoc newWHILEOP
8971 Constructs, checks, and returns an op tree expressing a C<while> loop.
8972 This is a heavyweight loop, with structure that allows exiting the loop
8973 by C<last> and suchlike.
8975 C<loop> is an optional preconstructed C<enterloop> op to use in the
8976 loop; if it is null then a suitable op will be constructed automatically.
8977 C<expr> supplies the loop's controlling expression. C<block> supplies the
8978 main body of the loop, and C<cont> optionally supplies a C<continue> block
8979 that operates as a second half of the body. All of these optree inputs
8980 are consumed by this function and become part of the constructed op tree.
8982 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8983 op and, shifted up eight bits, the eight bits of C<op_private> for
8984 the C<leaveloop> op, except that (in both cases) some bits will be set
8985 automatically. C<debuggable> is currently unused and should always be 1.
8986 C<has_my> can be supplied as true to force the
8987 loop body to be enclosed in its own scope.
8993 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8994 OP *expr, OP *block, OP *cont, I32 has_my)
9003 PERL_UNUSED_ARG(debuggable);
9006 if (expr->op_type == OP_READLINE
9007 || expr->op_type == OP_READDIR
9008 || expr->op_type == OP_GLOB
9009 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9010 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9011 expr = newUNOP(OP_DEFINED, 0,
9012 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9013 } else if (expr->op_flags & OPf_KIDS) {
9014 const OP * const k1 = ((UNOP*)expr)->op_first;
9015 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
9016 switch (expr->op_type) {
9018 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9019 && (k2->op_flags & OPf_STACKED)
9020 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9021 expr = newUNOP(OP_DEFINED, 0, expr);
9025 if (k1 && (k1->op_type == OP_READDIR
9026 || k1->op_type == OP_GLOB
9027 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9028 || k1->op_type == OP_EACH
9029 || k1->op_type == OP_AEACH))
9030 expr = newUNOP(OP_DEFINED, 0, expr);
9037 block = newOP(OP_NULL, 0);
9038 else if (cont || has_my) {
9039 block = op_scope(block);
9043 next = LINKLIST(cont);
9046 OP * const unstack = newOP(OP_UNSTACK, 0);
9049 cont = op_append_elem(OP_LINESEQ, cont, unstack);
9053 listop = op_append_list(OP_LINESEQ, block, cont);
9055 redo = LINKLIST(listop);
9059 o = new_logop(OP_AND, 0, &expr, &listop);
9060 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
9062 return expr; /* listop already freed by new_logop */
9065 ((LISTOP*)listop)->op_last->op_next =
9066 (o == listop ? redo : LINKLIST(o));
9072 NewOp(1101,loop,1,LOOP);
9073 OpTYPE_set(loop, OP_ENTERLOOP);
9074 loop->op_private = 0;
9075 loop->op_next = (OP*)loop;
9078 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
9080 loop->op_redoop = redo;
9081 loop->op_lastop = o;
9082 o->op_private |= loopflags;
9085 loop->op_nextop = next;
9087 loop->op_nextop = o;
9089 o->op_flags |= flags;
9090 o->op_private |= (flags >> 8);
9095 =for apidoc newFOROP
9097 Constructs, checks, and returns an op tree expressing a C<foreach>
9098 loop (iteration through a list of values). This is a heavyweight loop,
9099 with structure that allows exiting the loop by C<last> and suchlike.
9101 C<sv> optionally supplies the variable that will be aliased to each
9102 item in turn; if null, it defaults to C<$_>.
9103 C<expr> supplies the list of values to iterate over. C<block> supplies
9104 the main body of the loop, and C<cont> optionally supplies a C<continue>
9105 block that operates as a second half of the body. All of these optree
9106 inputs are consumed by this function and become part of the constructed
9109 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9110 op and, shifted up eight bits, the eight bits of C<op_private> for
9111 the C<leaveloop> op, except that (in both cases) some bits will be set
9118 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
9123 PADOFFSET padoff = 0;
9127 PERL_ARGS_ASSERT_NEWFOROP;
9130 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
9131 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
9132 OpTYPE_set(sv, OP_RV2GV);
9134 /* The op_type check is needed to prevent a possible segfault
9135 * if the loop variable is undeclared and 'strict vars' is in
9136 * effect. This is illegal but is nonetheless parsed, so we
9137 * may reach this point with an OP_CONST where we're expecting
9140 if (cUNOPx(sv)->op_first->op_type == OP_GV
9141 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
9142 iterpflags |= OPpITER_DEF;
9144 else if (sv->op_type == OP_PADSV) { /* private variable */
9145 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
9146 padoff = sv->op_targ;
9150 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9152 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
9155 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
9157 PADNAME * const pn = PAD_COMPNAME(padoff);
9158 const char * const name = PadnamePV(pn);
9160 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
9161 iterpflags |= OPpITER_DEF;
9165 sv = newGVOP(OP_GV, 0, PL_defgv);
9166 iterpflags |= OPpITER_DEF;
9169 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
9170 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
9171 iterflags |= OPf_STACKED;
9173 else if (expr->op_type == OP_NULL &&
9174 (expr->op_flags & OPf_KIDS) &&
9175 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
9177 /* Basically turn for($x..$y) into the same as for($x,$y), but we
9178 * set the STACKED flag to indicate that these values are to be
9179 * treated as min/max values by 'pp_enteriter'.
9181 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
9182 LOGOP* const range = (LOGOP*) flip->op_first;
9183 OP* const left = range->op_first;
9184 OP* const right = OpSIBLING(left);
9187 range->op_flags &= ~OPf_KIDS;
9188 /* detach range's children */
9189 op_sibling_splice((OP*)range, NULL, -1, NULL);
9191 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
9192 listop->op_first->op_next = range->op_next;
9193 left->op_next = range->op_other;
9194 right->op_next = (OP*)listop;
9195 listop->op_next = listop->op_first;
9198 expr = (OP*)(listop);
9200 iterflags |= OPf_STACKED;
9203 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
9206 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
9207 op_append_elem(OP_LIST, list(expr),
9209 assert(!loop->op_next);
9210 /* for my $x () sets OPpLVAL_INTRO;
9211 * for our $x () sets OPpOUR_INTRO */
9212 loop->op_private = (U8)iterpflags;
9213 if (loop->op_slabbed
9214 && DIFF(loop, OpSLOT(loop)->opslot_next)
9215 < SIZE_TO_PSIZE(sizeof(LOOP)))
9218 NewOp(1234,tmp,1,LOOP);
9219 Copy(loop,tmp,1,LISTOP);
9220 assert(loop->op_last->op_sibparent == (OP*)loop);
9221 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
9222 S_op_destroy(aTHX_ (OP*)loop);
9225 else if (!loop->op_slabbed)
9227 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
9228 OpLASTSIB_set(loop->op_last, (OP*)loop);
9230 loop->op_targ = padoff;
9231 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
9236 =for apidoc newLOOPEX
9238 Constructs, checks, and returns a loop-exiting op (such as C<goto>
9239 or C<last>). C<type> is the opcode. C<label> supplies the parameter
9240 determining the target of the op; it is consumed by this function and
9241 becomes part of the constructed op tree.
9247 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
9251 PERL_ARGS_ASSERT_NEWLOOPEX;
9253 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9254 || type == OP_CUSTOM);
9256 if (type != OP_GOTO) {
9257 /* "last()" means "last" */
9258 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9259 o = newOP(type, OPf_SPECIAL);
9263 /* Check whether it's going to be a goto &function */
9264 if (label->op_type == OP_ENTERSUB
9265 && !(label->op_flags & OPf_STACKED))
9266 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9269 /* Check for a constant argument */
9270 if (label->op_type == OP_CONST) {
9271 SV * const sv = ((SVOP *)label)->op_sv;
9273 const char *s = SvPV_const(sv,l);
9274 if (l == strlen(s)) {
9276 SvUTF8(((SVOP*)label)->op_sv),
9278 SvPV_nolen_const(((SVOP*)label)->op_sv)));
9282 /* If we have already created an op, we do not need the label. */
9285 else o = newUNOP(type, OPf_STACKED, label);
9287 PL_hints |= HINT_BLOCK_SCOPE;
9291 /* if the condition is a literal array or hash
9292 (or @{ ... } etc), make a reference to it.
9295 S_ref_array_or_hash(pTHX_ OP *cond)
9298 && (cond->op_type == OP_RV2AV
9299 || cond->op_type == OP_PADAV
9300 || cond->op_type == OP_RV2HV
9301 || cond->op_type == OP_PADHV))
9303 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9306 && (cond->op_type == OP_ASLICE
9307 || cond->op_type == OP_KVASLICE
9308 || cond->op_type == OP_HSLICE
9309 || cond->op_type == OP_KVHSLICE)) {
9311 /* anonlist now needs a list from this op, was previously used in
9313 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9314 cond->op_flags |= OPf_WANT_LIST;
9316 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9323 /* These construct the optree fragments representing given()
9326 entergiven and enterwhen are LOGOPs; the op_other pointer
9327 points up to the associated leave op. We need this so we
9328 can put it in the context and make break/continue work.
9329 (Also, of course, pp_enterwhen will jump straight to
9330 op_other if the match fails.)
9334 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9335 I32 enter_opcode, I32 leave_opcode,
9336 PADOFFSET entertarg)
9342 PERL_ARGS_ASSERT_NEWGIVWHENOP;
9343 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9345 enterop = alloc_LOGOP(enter_opcode, block, NULL);
9346 enterop->op_targ = 0;
9347 enterop->op_private = 0;
9349 o = newUNOP(leave_opcode, 0, (OP *) enterop);
9352 /* prepend cond if we have one */
9353 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9355 o->op_next = LINKLIST(cond);
9356 cond->op_next = (OP *) enterop;
9359 /* This is a default {} block */
9360 enterop->op_flags |= OPf_SPECIAL;
9361 o ->op_flags |= OPf_SPECIAL;
9363 o->op_next = (OP *) enterop;
9366 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9367 entergiven and enterwhen both
9370 enterop->op_next = LINKLIST(block);
9371 block->op_next = enterop->op_other = o;
9377 /* For the purposes of 'when(implied_smartmatch)'
9378 * versus 'when(boolean_expression)',
9379 * does this look like a boolean operation? For these purposes
9380 a boolean operation is:
9381 - a subroutine call [*]
9382 - a logical connective
9383 - a comparison operator
9384 - a filetest operator, with the exception of -s -M -A -C
9385 - defined(), exists() or eof()
9386 - /$re/ or $foo =~ /$re/
9388 [*] possibly surprising
9391 S_looks_like_bool(pTHX_ const OP *o)
9393 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9395 switch(o->op_type) {
9398 return looks_like_bool(cLOGOPo->op_first);
9402 OP* sibl = OpSIBLING(cLOGOPo->op_first);
9405 looks_like_bool(cLOGOPo->op_first)
9406 && looks_like_bool(sibl));
9412 o->op_flags & OPf_KIDS
9413 && looks_like_bool(cUNOPo->op_first));
9417 case OP_NOT: case OP_XOR:
9419 case OP_EQ: case OP_NE: case OP_LT:
9420 case OP_GT: case OP_LE: case OP_GE:
9422 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
9423 case OP_I_GT: case OP_I_LE: case OP_I_GE:
9425 case OP_SEQ: case OP_SNE: case OP_SLT:
9426 case OP_SGT: case OP_SLE: case OP_SGE:
9430 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
9431 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
9432 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
9433 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
9434 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
9435 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
9436 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
9437 case OP_FTTEXT: case OP_FTBINARY:
9439 case OP_DEFINED: case OP_EXISTS:
9440 case OP_MATCH: case OP_EOF:
9448 /* optimised-away (index() != -1) or similar comparison */
9449 if (o->op_private & OPpTRUEBOOL)
9454 /* Detect comparisons that have been optimized away */
9455 if (cSVOPo->op_sv == &PL_sv_yes
9456 || cSVOPo->op_sv == &PL_sv_no)
9469 =for apidoc newGIVENOP
9471 Constructs, checks, and returns an op tree expressing a C<given> block.
9472 C<cond> supplies the expression to whose value C<$_> will be locally
9473 aliased, and C<block> supplies the body of the C<given> construct; they
9474 are consumed by this function and become part of the constructed op tree.
9475 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9481 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9483 PERL_ARGS_ASSERT_NEWGIVENOP;
9484 PERL_UNUSED_ARG(defsv_off);
9487 return newGIVWHENOP(
9488 ref_array_or_hash(cond),
9490 OP_ENTERGIVEN, OP_LEAVEGIVEN,
9495 =for apidoc newWHENOP
9497 Constructs, checks, and returns an op tree expressing a C<when> block.
9498 C<cond> supplies the test expression, and C<block> supplies the block
9499 that will be executed if the test evaluates to true; they are consumed
9500 by this function and become part of the constructed op tree. C<cond>
9501 will be interpreted DWIMically, often as a comparison against C<$_>,
9502 and may be null to generate a C<default> block.
9508 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9510 const bool cond_llb = (!cond || looks_like_bool(cond));
9513 PERL_ARGS_ASSERT_NEWWHENOP;
9518 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9520 scalar(ref_array_or_hash(cond)));
9523 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9526 /* must not conflict with SVf_UTF8 */
9527 #define CV_CKPROTO_CURSTASH 0x1
9530 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9531 const STRLEN len, const U32 flags)
9533 SV *name = NULL, *msg;
9534 const char * cvp = SvROK(cv)
9535 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9536 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9539 STRLEN clen = CvPROTOLEN(cv), plen = len;
9541 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9543 if (p == NULL && cvp == NULL)
9546 if (!ckWARN_d(WARN_PROTOTYPE))
9550 p = S_strip_spaces(aTHX_ p, &plen);
9551 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9552 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9553 if (plen == clen && memEQ(cvp, p, plen))
9556 if (flags & SVf_UTF8) {
9557 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9561 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9567 msg = sv_newmortal();
9572 gv_efullname3(name = sv_newmortal(), gv, NULL);
9573 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9574 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9575 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9576 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9577 sv_catpvs(name, "::");
9579 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9580 assert (CvNAMED(SvRV_const(gv)));
9581 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9583 else sv_catsv(name, (SV *)gv);
9585 else name = (SV *)gv;
9587 sv_setpvs(msg, "Prototype mismatch:");
9589 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9591 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9592 UTF8fARG(SvUTF8(cv),clen,cvp)
9595 sv_catpvs(msg, ": none");
9596 sv_catpvs(msg, " vs ");
9598 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9600 sv_catpvs(msg, "none");
9601 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9604 static void const_sv_xsub(pTHX_ CV* cv);
9605 static void const_av_xsub(pTHX_ CV* cv);
9609 =head1 Optree Manipulation Functions
9611 =for apidoc cv_const_sv
9613 If C<cv> is a constant sub eligible for inlining, returns the constant
9614 value returned by the sub. Otherwise, returns C<NULL>.
9616 Constant subs can be created with C<newCONSTSUB> or as described in
9617 L<perlsub/"Constant Functions">.
9622 Perl_cv_const_sv(const CV *const cv)
9627 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9629 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9630 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9635 Perl_cv_const_sv_or_av(const CV * const cv)
9639 if (SvROK(cv)) return SvRV((SV *)cv);
9640 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9641 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9644 /* op_const_sv: examine an optree to determine whether it's in-lineable.
9645 * Can be called in 2 ways:
9648 * look for a single OP_CONST with attached value: return the value
9650 * allow_lex && !CvCONST(cv);
9652 * examine the clone prototype, and if contains only a single
9653 * OP_CONST, return the value; or if it contains a single PADSV ref-
9654 * erencing an outer lexical, turn on CvCONST to indicate the CV is
9655 * a candidate for "constizing" at clone time, and return NULL.
9659 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9667 for (; o; o = o->op_next) {
9668 const OPCODE type = o->op_type;
9670 if (type == OP_NEXTSTATE || type == OP_LINESEQ
9672 || type == OP_PUSHMARK)
9674 if (type == OP_DBSTATE)
9676 if (type == OP_LEAVESUB)
9680 if (type == OP_CONST && cSVOPo->op_sv)
9682 else if (type == OP_UNDEF && !o->op_private) {
9686 else if (allow_lex && type == OP_PADSV) {
9687 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9689 sv = &PL_sv_undef; /* an arbitrary non-null value */
9707 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9708 PADNAME * const name, SV ** const const_svp)
9714 if (CvFLAGS(PL_compcv)) {
9715 /* might have had built-in attrs applied */
9716 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9717 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9718 && ckWARN(WARN_MISC))
9720 /* protect against fatal warnings leaking compcv */
9721 SAVEFREESV(PL_compcv);
9722 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9723 SvREFCNT_inc_simple_void_NN(PL_compcv);
9726 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9727 & ~(CVf_LVALUE * pureperl));
9732 /* redundant check for speed: */
9733 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9734 const line_t oldline = CopLINE(PL_curcop);
9737 : sv_2mortal(newSVpvn_utf8(
9738 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9740 if (PL_parser && PL_parser->copline != NOLINE)
9741 /* This ensures that warnings are reported at the first
9742 line of a redefinition, not the last. */
9743 CopLINE_set(PL_curcop, PL_parser->copline);
9744 /* protect against fatal warnings leaking compcv */
9745 SAVEFREESV(PL_compcv);
9746 report_redefined_cv(namesv, cv, const_svp);
9747 SvREFCNT_inc_simple_void_NN(PL_compcv);
9748 CopLINE_set(PL_curcop, oldline);
9755 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9760 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9763 CV *compcv = PL_compcv;
9766 PADOFFSET pax = o->op_targ;
9767 CV *outcv = CvOUTSIDE(PL_compcv);
9770 bool reusable = FALSE;
9772 #ifdef PERL_DEBUG_READONLY_OPS
9773 OPSLAB *slab = NULL;
9776 PERL_ARGS_ASSERT_NEWMYSUB;
9778 PL_hints |= HINT_BLOCK_SCOPE;
9780 /* Find the pad slot for storing the new sub.
9781 We cannot use PL_comppad, as it is the pad owned by the new sub. We
9782 need to look in CvOUTSIDE and find the pad belonging to the enclos-
9783 ing sub. And then we need to dig deeper if this is a lexical from
9785 my sub foo; sub { sub foo { } }
9788 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9789 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9790 pax = PARENT_PAD_INDEX(name);
9791 outcv = CvOUTSIDE(outcv);
9796 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9797 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9798 spot = (CV **)svspot;
9800 if (!(PL_parser && PL_parser->error_count))
9801 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9804 assert(proto->op_type == OP_CONST);
9805 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9806 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9816 if (PL_parser && PL_parser->error_count) {
9818 SvREFCNT_dec(PL_compcv);
9823 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9825 svspot = (SV **)(spot = &clonee);
9827 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9830 assert (SvTYPE(*spot) == SVt_PVCV);
9832 hek = CvNAME_HEK(*spot);
9836 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9837 CvNAME_HEK_set(*spot, hek =
9840 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9844 CvLEXICAL_on(*spot);
9846 cv = PadnamePROTOCV(name);
9847 svspot = (SV **)(spot = &PadnamePROTOCV(name));
9851 /* This makes sub {}; work as expected. */
9852 if (block->op_type == OP_STUB) {
9853 const line_t l = PL_parser->copline;
9855 block = newSTATEOP(0, NULL, 0);
9856 PL_parser->copline = l;
9858 block = CvLVALUE(compcv)
9859 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9860 ? newUNOP(OP_LEAVESUBLV, 0,
9861 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9862 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9863 start = LINKLIST(block);
9865 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9866 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9874 const bool exists = CvROOT(cv) || CvXSUB(cv);
9876 /* if the subroutine doesn't exist and wasn't pre-declared
9877 * with a prototype, assume it will be AUTOLOADed,
9878 * skipping the prototype check
9880 if (exists || SvPOK(cv))
9881 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9883 /* already defined? */
9885 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9891 /* just a "sub foo;" when &foo is already defined */
9896 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9903 SvREFCNT_inc_simple_void_NN(const_sv);
9904 SvFLAGS(const_sv) |= SVs_PADTMP;
9906 assert(!CvROOT(cv) && !CvCONST(cv));
9910 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9911 CvFILE_set_from_cop(cv, PL_curcop);
9912 CvSTASH_set(cv, PL_curstash);
9915 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
9916 CvXSUBANY(cv).any_ptr = const_sv;
9917 CvXSUB(cv) = const_sv_xsub;
9921 CvFLAGS(cv) |= CvMETHOD(compcv);
9923 SvREFCNT_dec(compcv);
9928 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9929 determine whether this sub definition is in the same scope as its
9930 declaration. If this sub definition is inside an inner named pack-
9931 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9932 the package sub. So check PadnameOUTER(name) too.
9934 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9935 assert(!CvWEAKOUTSIDE(compcv));
9936 SvREFCNT_dec(CvOUTSIDE(compcv));
9937 CvWEAKOUTSIDE_on(compcv);
9939 /* XXX else do we have a circular reference? */
9941 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
9942 /* transfer PL_compcv to cv */
9944 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
9945 cv_flags_t preserved_flags =
9946 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9947 PADLIST *const temp_padl = CvPADLIST(cv);
9948 CV *const temp_cv = CvOUTSIDE(cv);
9949 const cv_flags_t other_flags =
9950 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9951 OP * const cvstart = CvSTART(cv);
9955 CvFLAGS(compcv) | preserved_flags;
9956 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9957 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9958 CvPADLIST_set(cv, CvPADLIST(compcv));
9959 CvOUTSIDE(compcv) = temp_cv;
9960 CvPADLIST_set(compcv, temp_padl);
9961 CvSTART(cv) = CvSTART(compcv);
9962 CvSTART(compcv) = cvstart;
9963 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9964 CvFLAGS(compcv) |= other_flags;
9967 Safefree(CvFILE(cv));
9971 /* inner references to compcv must be fixed up ... */
9972 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9973 if (PERLDB_INTER)/* Advice debugger on the new sub. */
9974 ++PL_sub_generation;
9977 /* Might have had built-in attributes applied -- propagate them. */
9978 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9980 /* ... before we throw it away */
9981 SvREFCNT_dec(compcv);
9982 PL_compcv = compcv = cv;
9991 if (!CvNAME_HEK(cv)) {
9992 if (hek) (void)share_hek_hek(hek);
9996 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9997 hek = share_hek(PadnamePV(name)+1,
9998 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10001 CvNAME_HEK_set(cv, hek);
10007 if (CvFILE(cv) && CvDYNFILE(cv))
10008 Safefree(CvFILE(cv));
10009 CvFILE_set_from_cop(cv, PL_curcop);
10010 CvSTASH_set(cv, PL_curstash);
10013 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10015 SvUTF8_on(MUTABLE_SV(cv));
10019 /* If we assign an optree to a PVCV, then we've defined a
10020 * subroutine that the debugger could be able to set a breakpoint
10021 * in, so signal to pp_entereval that it should not throw away any
10022 * saved lines at scope exit. */
10024 PL_breakable_sub_gen++;
10025 CvROOT(cv) = block;
10026 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10027 itself has a refcount. */
10029 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10030 #ifdef PERL_DEBUG_READONLY_OPS
10031 slab = (OPSLAB *)CvSTART(cv);
10033 S_process_optree(aTHX_ cv, block, start);
10038 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10039 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
10043 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10044 SV * const tmpstr = sv_newmortal();
10045 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10046 GV_ADDMULTI, SVt_PVHV);
10048 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10049 CopFILE(PL_curcop),
10051 (long)CopLINE(PL_curcop));
10052 if (HvNAME_HEK(PL_curstash)) {
10053 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
10054 sv_catpvs(tmpstr, "::");
10057 sv_setpvs(tmpstr, "__ANON__::");
10059 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
10060 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
10061 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10062 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10063 hv = GvHVn(db_postponed);
10064 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10065 CV * const pcv = GvCV(db_postponed);
10071 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10079 assert(CvDEPTH(outcv));
10081 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
10083 cv_clone_into(clonee, *spot);
10084 else *spot = cv_clone(clonee);
10085 SvREFCNT_dec_NN(clonee);
10089 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
10090 PADOFFSET depth = CvDEPTH(outcv);
10093 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
10095 *svspot = SvREFCNT_inc_simple_NN(cv);
10096 SvREFCNT_dec(oldcv);
10102 PL_parser->copline = NOLINE;
10103 LEAVE_SCOPE(floor);
10104 #ifdef PERL_DEBUG_READONLY_OPS
10113 =for apidoc newATTRSUB_x
10115 Construct a Perl subroutine, also performing some surrounding jobs.
10117 This function is expected to be called in a Perl compilation context,
10118 and some aspects of the subroutine are taken from global variables
10119 associated with compilation. In particular, C<PL_compcv> represents
10120 the subroutine that is currently being compiled. It must be non-null
10121 when this function is called, and some aspects of the subroutine being
10122 constructed are taken from it. The constructed subroutine may actually
10123 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
10125 If C<block> is null then the subroutine will have no body, and for the
10126 time being it will be an error to call it. This represents a forward
10127 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
10128 non-null then it provides the Perl code of the subroutine body, which
10129 will be executed when the subroutine is called. This body includes
10130 any argument unwrapping code resulting from a subroutine signature or
10131 similar. The pad use of the code must correspond to the pad attached
10132 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
10133 C<leavesublv> op; this function will add such an op. C<block> is consumed
10134 by this function and will become part of the constructed subroutine.
10136 C<proto> specifies the subroutine's prototype, unless one is supplied
10137 as an attribute (see below). If C<proto> is null, then the subroutine
10138 will not have a prototype. If C<proto> is non-null, it must point to a
10139 C<const> op whose value is a string, and the subroutine will have that
10140 string as its prototype. If a prototype is supplied as an attribute, the
10141 attribute takes precedence over C<proto>, but in that case C<proto> should
10142 preferably be null. In any case, C<proto> is consumed by this function.
10144 C<attrs> supplies attributes to be applied the subroutine. A handful of
10145 attributes take effect by built-in means, being applied to C<PL_compcv>
10146 immediately when seen. Other attributes are collected up and attached
10147 to the subroutine by this route. C<attrs> may be null to supply no
10148 attributes, or point to a C<const> op for a single attribute, or point
10149 to a C<list> op whose children apart from the C<pushmark> are C<const>
10150 ops for one or more attributes. Each C<const> op must be a string,
10151 giving the attribute name optionally followed by parenthesised arguments,
10152 in the manner in which attributes appear in Perl source. The attributes
10153 will be applied to the sub by this function. C<attrs> is consumed by
10156 If C<o_is_gv> is false and C<o> is null, then the subroutine will
10157 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
10158 must point to a C<const> op, which will be consumed by this function,
10159 and its string value supplies a name for the subroutine. The name may
10160 be qualified or unqualified, and if it is unqualified then a default
10161 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
10162 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
10163 by which the subroutine will be named.
10165 If there is already a subroutine of the specified name, then the new
10166 sub will either replace the existing one in the glob or be merged with
10167 the existing one. A warning may be generated about redefinition.
10169 If the subroutine has one of a few special names, such as C<BEGIN> or
10170 C<END>, then it will be claimed by the appropriate queue for automatic
10171 running of phase-related subroutines. In this case the relevant glob will
10172 be left not containing any subroutine, even if it did contain one before.
10173 In the case of C<BEGIN>, the subroutine will be executed and the reference
10174 to it disposed of before this function returns.
10176 The function returns a pointer to the constructed subroutine. If the sub
10177 is anonymous then ownership of one counted reference to the subroutine
10178 is transferred to the caller. If the sub is named then the caller does
10179 not get ownership of a reference. In most such cases, where the sub
10180 has a non-phase name, the sub will be alive at the point it is returned
10181 by virtue of being contained in the glob that names it. A phase-named
10182 subroutine will usually be alive by virtue of the reference owned by the
10183 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10184 been executed, will quite likely have been destroyed already by the
10185 time this function returns, making it erroneous for the caller to make
10186 any use of the returned pointer. It is the caller's responsibility to
10187 ensure that it knows which of these situations applies.
10192 /* _x = extended */
10194 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
10195 OP *block, bool o_is_gv)
10199 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10201 CV *cv = NULL; /* the previous CV with this name, if any */
10203 const bool ec = PL_parser && PL_parser->error_count;
10204 /* If the subroutine has no body, no attributes, and no builtin attributes
10205 then it's just a sub declaration, and we may be able to get away with
10206 storing with a placeholder scalar in the symbol table, rather than a
10207 full CV. If anything is present then it will take a full CV to
10209 const I32 gv_fetch_flags
10210 = ec ? GV_NOADD_NOINIT :
10211 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
10212 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
10214 const char * const name =
10215 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
10217 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
10218 bool evanescent = FALSE;
10220 #ifdef PERL_DEBUG_READONLY_OPS
10221 OPSLAB *slab = NULL;
10229 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
10230 hek and CvSTASH pointer together can imply the GV. If the name
10231 contains a package name, then GvSTASH(CvGV(cv)) may differ from
10232 CvSTASH, so forego the optimisation if we find any.
10233 Also, we may be called from load_module at run time, so
10234 PL_curstash (which sets CvSTASH) may not point to the stash the
10235 sub is stored in. */
10236 /* XXX This optimization is currently disabled for packages other
10237 than main, since there was too much CPAN breakage. */
10239 ec ? GV_NOADD_NOINIT
10240 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
10241 || PL_curstash != PL_defstash
10242 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
10244 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
10245 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
10247 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
10248 SV * const sv = sv_newmortal();
10249 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
10250 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10251 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10252 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
10254 } else if (PL_curstash) {
10255 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10258 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10264 move_proto_attr(&proto, &attrs, gv, 0);
10267 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10272 assert(proto->op_type == OP_CONST);
10273 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10274 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10290 SvREFCNT_dec(PL_compcv);
10295 if (name && block) {
10296 const char *s = (char *) my_memrchr(name, ':', namlen);
10297 s = s ? s+1 : name;
10298 if (strEQ(s, "BEGIN")) {
10299 if (PL_in_eval & EVAL_KEEPERR)
10300 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10302 SV * const errsv = ERRSV;
10303 /* force display of errors found but not reported */
10304 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10305 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10312 if (!block && SvTYPE(gv) != SVt_PVGV) {
10313 /* If we are not defining a new sub and the existing one is not a
10315 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10316 /* We are applying attributes to an existing sub, so we need it
10317 upgraded if it is a constant. */
10318 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10319 gv_init_pvn(gv, PL_curstash, name, namlen,
10320 SVf_UTF8 * name_is_utf8);
10322 else { /* Maybe prototype now, and had at maximum
10323 a prototype or const/sub ref before. */
10324 if (SvTYPE(gv) > SVt_NULL) {
10325 cv_ckproto_len_flags((const CV *)gv,
10326 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10332 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10334 SvUTF8_on(MUTABLE_SV(gv));
10337 sv_setiv(MUTABLE_SV(gv), -1);
10340 SvREFCNT_dec(PL_compcv);
10341 cv = PL_compcv = NULL;
10346 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10350 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10356 /* This makes sub {}; work as expected. */
10357 if (block->op_type == OP_STUB) {
10358 const line_t l = PL_parser->copline;
10360 block = newSTATEOP(0, NULL, 0);
10361 PL_parser->copline = l;
10363 block = CvLVALUE(PL_compcv)
10364 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10365 && (!isGV(gv) || !GvASSUMECV(gv)))
10366 ? newUNOP(OP_LEAVESUBLV, 0,
10367 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10368 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10369 start = LINKLIST(block);
10370 block->op_next = 0;
10371 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10373 S_op_const_sv(aTHX_ start, PL_compcv,
10374 cBOOL(CvCLONE(PL_compcv)));
10381 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10382 cv_ckproto_len_flags((const CV *)gv,
10383 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10384 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10386 /* All the other code for sub redefinition warnings expects the
10387 clobbered sub to be a CV. Instead of making all those code
10388 paths more complex, just inline the RV version here. */
10389 const line_t oldline = CopLINE(PL_curcop);
10390 assert(IN_PERL_COMPILETIME);
10391 if (PL_parser && PL_parser->copline != NOLINE)
10392 /* This ensures that warnings are reported at the first
10393 line of a redefinition, not the last. */
10394 CopLINE_set(PL_curcop, PL_parser->copline);
10395 /* protect against fatal warnings leaking compcv */
10396 SAVEFREESV(PL_compcv);
10398 if (ckWARN(WARN_REDEFINE)
10399 || ( ckWARN_d(WARN_REDEFINE)
10400 && ( !const_sv || SvRV(gv) == const_sv
10401 || sv_cmp(SvRV(gv), const_sv) ))) {
10403 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10404 "Constant subroutine %" SVf " redefined",
10405 SVfARG(cSVOPo->op_sv));
10408 SvREFCNT_inc_simple_void_NN(PL_compcv);
10409 CopLINE_set(PL_curcop, oldline);
10410 SvREFCNT_dec(SvRV(gv));
10415 const bool exists = CvROOT(cv) || CvXSUB(cv);
10417 /* if the subroutine doesn't exist and wasn't pre-declared
10418 * with a prototype, assume it will be AUTOLOADed,
10419 * skipping the prototype check
10421 if (exists || SvPOK(cv))
10422 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10423 /* already defined (or promised)? */
10424 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10425 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10431 /* just a "sub foo;" when &foo is already defined */
10432 SAVEFREESV(PL_compcv);
10439 SvREFCNT_inc_simple_void_NN(const_sv);
10440 SvFLAGS(const_sv) |= SVs_PADTMP;
10442 assert(!CvROOT(cv) && !CvCONST(cv));
10443 cv_forget_slab(cv);
10444 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10445 CvXSUBANY(cv).any_ptr = const_sv;
10446 CvXSUB(cv) = const_sv_xsub;
10450 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10453 if (isGV(gv) || CvMETHOD(PL_compcv)) {
10454 if (name && isGV(gv))
10455 GvCV_set(gv, NULL);
10456 cv = newCONSTSUB_flags(
10457 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10461 assert(SvREFCNT((SV*)cv) != 0);
10462 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10466 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10467 prepare_SV_for_RV((SV *)gv);
10468 SvOK_off((SV *)gv);
10471 SvRV_set(gv, const_sv);
10475 SvREFCNT_dec(PL_compcv);
10480 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10481 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10484 if (cv) { /* must reuse cv if autoloaded */
10485 /* transfer PL_compcv to cv */
10487 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10488 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10489 PADLIST *const temp_av = CvPADLIST(cv);
10490 CV *const temp_cv = CvOUTSIDE(cv);
10491 const cv_flags_t other_flags =
10492 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10493 OP * const cvstart = CvSTART(cv);
10497 assert(!CvCVGV_RC(cv));
10498 assert(CvGV(cv) == gv);
10503 PERL_HASH(hash, name, namlen);
10513 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10515 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10516 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10517 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10518 CvOUTSIDE(PL_compcv) = temp_cv;
10519 CvPADLIST_set(PL_compcv, temp_av);
10520 CvSTART(cv) = CvSTART(PL_compcv);
10521 CvSTART(PL_compcv) = cvstart;
10522 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10523 CvFLAGS(PL_compcv) |= other_flags;
10526 Safefree(CvFILE(cv));
10528 CvFILE_set_from_cop(cv, PL_curcop);
10529 CvSTASH_set(cv, PL_curstash);
10531 /* inner references to PL_compcv must be fixed up ... */
10532 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10533 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10534 ++PL_sub_generation;
10537 /* Might have had built-in attributes applied -- propagate them. */
10538 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10540 /* ... before we throw it away */
10541 SvREFCNT_dec(PL_compcv);
10546 if (name && isGV(gv)) {
10549 if (HvENAME_HEK(GvSTASH(gv)))
10550 /* sub Foo::bar { (shift)+1 } */
10551 gv_method_changed(gv);
10555 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10556 prepare_SV_for_RV((SV *)gv);
10557 SvOK_off((SV *)gv);
10560 SvRV_set(gv, (SV *)cv);
10561 if (HvENAME_HEK(PL_curstash))
10562 mro_method_changed_in(PL_curstash);
10566 assert(SvREFCNT((SV*)cv) != 0);
10568 if (!CvHASGV(cv)) {
10574 PERL_HASH(hash, name, namlen);
10575 CvNAME_HEK_set(cv, share_hek(name,
10581 CvFILE_set_from_cop(cv, PL_curcop);
10582 CvSTASH_set(cv, PL_curstash);
10586 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10588 SvUTF8_on(MUTABLE_SV(cv));
10592 /* If we assign an optree to a PVCV, then we've defined a
10593 * subroutine that the debugger could be able to set a breakpoint
10594 * in, so signal to pp_entereval that it should not throw away any
10595 * saved lines at scope exit. */
10597 PL_breakable_sub_gen++;
10598 CvROOT(cv) = block;
10599 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10600 itself has a refcount. */
10602 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10603 #ifdef PERL_DEBUG_READONLY_OPS
10604 slab = (OPSLAB *)CvSTART(cv);
10606 S_process_optree(aTHX_ cv, block, start);
10611 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10612 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10613 ? GvSTASH(CvGV(cv))
10617 apply_attrs(stash, MUTABLE_SV(cv), attrs);
10619 SvREFCNT_inc_simple_void_NN(cv);
10622 if (block && has_name) {
10623 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10624 SV * const tmpstr = cv_name(cv,NULL,0);
10625 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10626 GV_ADDMULTI, SVt_PVHV);
10628 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10629 CopFILE(PL_curcop),
10631 (long)CopLINE(PL_curcop));
10632 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10633 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10634 hv = GvHVn(db_postponed);
10635 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10636 CV * const pcv = GvCV(db_postponed);
10642 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10648 if (PL_parser && PL_parser->error_count)
10649 clear_special_blocks(name, gv, cv);
10652 process_special_blocks(floor, name, gv, cv);
10658 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10660 PL_parser->copline = NOLINE;
10661 LEAVE_SCOPE(floor);
10663 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10665 #ifdef PERL_DEBUG_READONLY_OPS
10669 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10670 pad_add_weakref(cv);
10676 S_clear_special_blocks(pTHX_ const char *const fullname,
10677 GV *const gv, CV *const cv) {
10681 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10683 colon = strrchr(fullname,':');
10684 name = colon ? colon + 1 : fullname;
10686 if ((*name == 'B' && strEQ(name, "BEGIN"))
10687 || (*name == 'E' && strEQ(name, "END"))
10688 || (*name == 'U' && strEQ(name, "UNITCHECK"))
10689 || (*name == 'C' && strEQ(name, "CHECK"))
10690 || (*name == 'I' && strEQ(name, "INIT"))) {
10695 GvCV_set(gv, NULL);
10696 SvREFCNT_dec_NN(MUTABLE_SV(cv));
10700 /* Returns true if the sub has been freed. */
10702 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10706 const char *const colon = strrchr(fullname,':');
10707 const char *const name = colon ? colon + 1 : fullname;
10709 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10711 if (*name == 'B') {
10712 if (strEQ(name, "BEGIN")) {
10713 const I32 oldscope = PL_scopestack_ix;
10716 if (floor) LEAVE_SCOPE(floor);
10718 PUSHSTACKi(PERLSI_REQUIRE);
10719 SAVECOPFILE(&PL_compiling);
10720 SAVECOPLINE(&PL_compiling);
10721 SAVEVPTR(PL_curcop);
10723 DEBUG_x( dump_sub(gv) );
10724 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10725 GvCV_set(gv,0); /* cv has been hijacked */
10726 call_list(oldscope, PL_beginav);
10730 return !PL_savebegin;
10735 if (*name == 'E') {
10736 if (strEQ(name, "END")) {
10737 DEBUG_x( dump_sub(gv) );
10738 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10741 } else if (*name == 'U') {
10742 if (strEQ(name, "UNITCHECK")) {
10743 /* It's never too late to run a unitcheck block */
10744 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10748 } else if (*name == 'C') {
10749 if (strEQ(name, "CHECK")) {
10751 /* diag_listed_as: Too late to run %s block */
10752 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10753 "Too late to run CHECK block");
10754 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10758 } else if (*name == 'I') {
10759 if (strEQ(name, "INIT")) {
10761 /* diag_listed_as: Too late to run %s block */
10762 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10763 "Too late to run INIT block");
10764 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10770 DEBUG_x( dump_sub(gv) );
10772 GvCV_set(gv,0); /* cv has been hijacked */
10778 =for apidoc newCONSTSUB
10780 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10781 rather than of counted length, and no flags are set. (This means that
10782 C<name> is always interpreted as Latin-1.)
10788 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10790 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10794 =for apidoc newCONSTSUB_flags
10796 Construct a constant subroutine, also performing some surrounding
10797 jobs. A scalar constant-valued subroutine is eligible for inlining
10798 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10799 123 }>>. Other kinds of constant subroutine have other treatment.
10801 The subroutine will have an empty prototype and will ignore any arguments
10802 when called. Its constant behaviour is determined by C<sv>. If C<sv>
10803 is null, the subroutine will yield an empty list. If C<sv> points to a
10804 scalar, the subroutine will always yield that scalar. If C<sv> points
10805 to an array, the subroutine will always yield a list of the elements of
10806 that array in list context, or the number of elements in the array in
10807 scalar context. This function takes ownership of one counted reference
10808 to the scalar or array, and will arrange for the object to live as long
10809 as the subroutine does. If C<sv> points to a scalar then the inlining
10810 assumes that the value of the scalar will never change, so the caller
10811 must ensure that the scalar is not subsequently written to. If C<sv>
10812 points to an array then no such assumption is made, so it is ostensibly
10813 safe to mutate the array or its elements, but whether this is really
10814 supported has not been determined.
10816 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10817 Other aspects of the subroutine will be left in their default state.
10818 The caller is free to mutate the subroutine beyond its initial state
10819 after this function has returned.
10821 If C<name> is null then the subroutine will be anonymous, with its
10822 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10823 subroutine will be named accordingly, referenced by the appropriate glob.
10824 C<name> is a string of length C<len> bytes giving a sigilless symbol
10825 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10826 otherwise. The name may be either qualified or unqualified. If the
10827 name is unqualified then it defaults to being in the stash specified by
10828 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10829 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10832 C<flags> should not have bits set other than C<SVf_UTF8>.
10834 If there is already a subroutine of the specified name, then the new sub
10835 will replace the existing one in the glob. A warning may be generated
10836 about the redefinition.
10838 If the subroutine has one of a few special names, such as C<BEGIN> or
10839 C<END>, then it will be claimed by the appropriate queue for automatic
10840 running of phase-related subroutines. In this case the relevant glob will
10841 be left not containing any subroutine, even if it did contain one before.
10842 Execution of the subroutine will likely be a no-op, unless C<sv> was
10843 a tied array or the caller modified the subroutine in some interesting
10844 way before it was executed. In the case of C<BEGIN>, the treatment is
10845 buggy: the sub will be executed when only half built, and may be deleted
10846 prematurely, possibly causing a crash.
10848 The function returns a pointer to the constructed subroutine. If the sub
10849 is anonymous then ownership of one counted reference to the subroutine
10850 is transferred to the caller. If the sub is named then the caller does
10851 not get ownership of a reference. In most such cases, where the sub
10852 has a non-phase name, the sub will be alive at the point it is returned
10853 by virtue of being contained in the glob that names it. A phase-named
10854 subroutine will usually be alive by virtue of the reference owned by
10855 the phase's automatic run queue. A C<BEGIN> subroutine may have been
10856 destroyed already by the time this function returns, but currently bugs
10857 occur in that case before the caller gets control. It is the caller's
10858 responsibility to ensure that it knows which of these situations applies.
10864 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10868 const char *const file = CopFILE(PL_curcop);
10872 if (IN_PERL_RUNTIME) {
10873 /* at runtime, it's not safe to manipulate PL_curcop: it may be
10874 * an op shared between threads. Use a non-shared COP for our
10876 SAVEVPTR(PL_curcop);
10877 SAVECOMPILEWARNINGS();
10878 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10879 PL_curcop = &PL_compiling;
10881 SAVECOPLINE(PL_curcop);
10882 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10885 PL_hints &= ~HINT_BLOCK_SCOPE;
10888 SAVEGENERICSV(PL_curstash);
10889 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10892 /* Protect sv against leakage caused by fatal warnings. */
10893 if (sv) SAVEFREESV(sv);
10895 /* file becomes the CvFILE. For an XS, it's usually static storage,
10896 and so doesn't get free()d. (It's expected to be from the C pre-
10897 processor __FILE__ directive). But we need a dynamically allocated one,
10898 and we need it to get freed. */
10899 cv = newXS_len_flags(name, len,
10900 sv && SvTYPE(sv) == SVt_PVAV
10903 file ? file : "", "",
10904 &sv, XS_DYNAMIC_FILENAME | flags);
10906 assert(SvREFCNT((SV*)cv) != 0);
10907 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10918 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
10919 static storage, as it is used directly as CvFILE(), without a copy being made.
10925 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10927 PERL_ARGS_ASSERT_NEWXS;
10928 return newXS_len_flags(
10929 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10934 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10935 const char *const filename, const char *const proto,
10938 PERL_ARGS_ASSERT_NEWXS_FLAGS;
10939 return newXS_len_flags(
10940 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10945 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10947 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10948 return newXS_len_flags(
10949 name, strlen(name), subaddr, NULL, NULL, NULL, 0
10954 =for apidoc newXS_len_flags
10956 Construct an XS subroutine, also performing some surrounding jobs.
10958 The subroutine will have the entry point C<subaddr>. It will have
10959 the prototype specified by the nul-terminated string C<proto>, or
10960 no prototype if C<proto> is null. The prototype string is copied;
10961 the caller can mutate the supplied string afterwards. If C<filename>
10962 is non-null, it must be a nul-terminated filename, and the subroutine
10963 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
10964 point directly to the supplied string, which must be static. If C<flags>
10965 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10968 Other aspects of the subroutine will be left in their default state.
10969 If anything else needs to be done to the subroutine for it to function
10970 correctly, it is the caller's responsibility to do that after this
10971 function has constructed it. However, beware of the subroutine
10972 potentially being destroyed before this function returns, as described
10975 If C<name> is null then the subroutine will be anonymous, with its
10976 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10977 subroutine will be named accordingly, referenced by the appropriate glob.
10978 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10979 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10980 The name may be either qualified or unqualified, with the stash defaulting
10981 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
10982 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10983 they have there, such as C<GV_ADDWARN>. The symbol is always added to
10984 the stash if necessary, with C<GV_ADDMULTI> semantics.
10986 If there is already a subroutine of the specified name, then the new sub
10987 will replace the existing one in the glob. A warning may be generated
10988 about the redefinition. If the old subroutine was C<CvCONST> then the
10989 decision about whether to warn is influenced by an expectation about
10990 whether the new subroutine will become a constant of similar value.
10991 That expectation is determined by C<const_svp>. (Note that the call to
10992 this function doesn't make the new subroutine C<CvCONST> in any case;
10993 that is left to the caller.) If C<const_svp> is null then it indicates
10994 that the new subroutine will not become a constant. If C<const_svp>
10995 is non-null then it indicates that the new subroutine will become a
10996 constant, and it points to an C<SV*> that provides the constant value
10997 that the subroutine will have.
10999 If the subroutine has one of a few special names, such as C<BEGIN> or
11000 C<END>, then it will be claimed by the appropriate queue for automatic
11001 running of phase-related subroutines. In this case the relevant glob will
11002 be left not containing any subroutine, even if it did contain one before.
11003 In the case of C<BEGIN>, the subroutine will be executed and the reference
11004 to it disposed of before this function returns, and also before its
11005 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
11006 constructed by this function to be ready for execution then the caller
11007 must prevent this happening by giving the subroutine a different name.
11009 The function returns a pointer to the constructed subroutine. If the sub
11010 is anonymous then ownership of one counted reference to the subroutine
11011 is transferred to the caller. If the sub is named then the caller does
11012 not get ownership of a reference. In most such cases, where the sub
11013 has a non-phase name, the sub will be alive at the point it is returned
11014 by virtue of being contained in the glob that names it. A phase-named
11015 subroutine will usually be alive by virtue of the reference owned by the
11016 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11017 been executed, will quite likely have been destroyed already by the
11018 time this function returns, making it erroneous for the caller to make
11019 any use of the returned pointer. It is the caller's responsibility to
11020 ensure that it knows which of these situations applies.
11026 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
11027 XSUBADDR_t subaddr, const char *const filename,
11028 const char *const proto, SV **const_svp,
11032 bool interleave = FALSE;
11033 bool evanescent = FALSE;
11035 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
11038 GV * const gv = gv_fetchpvn(
11039 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11040 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
11041 sizeof("__ANON__::__ANON__") - 1,
11042 GV_ADDMULTI | flags, SVt_PVCV);
11044 if ((cv = (name ? GvCV(gv) : NULL))) {
11046 /* just a cached method */
11050 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
11051 /* already defined (or promised) */
11052 /* Redundant check that allows us to avoid creating an SV
11053 most of the time: */
11054 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11055 report_redefined_cv(newSVpvn_flags(
11056 name,len,(flags&SVf_UTF8)|SVs_TEMP
11067 if (cv) /* must reuse cv if autoloaded */
11070 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11074 if (HvENAME_HEK(GvSTASH(gv)))
11075 gv_method_changed(gv); /* newXS */
11079 assert(SvREFCNT((SV*)cv) != 0);
11083 /* XSUBs can't be perl lang/perl5db.pl debugged
11084 if (PERLDB_LINE_OR_SAVESRC)
11085 (void)gv_fetchfile(filename); */
11086 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
11087 if (flags & XS_DYNAMIC_FILENAME) {
11089 CvFILE(cv) = savepv(filename);
11091 /* NOTE: not copied, as it is expected to be an external constant string */
11092 CvFILE(cv) = (char *)filename;
11095 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
11096 CvFILE(cv) = (char*)PL_xsubfilename;
11099 CvXSUB(cv) = subaddr;
11100 #ifndef PERL_IMPLICIT_CONTEXT
11101 CvHSCXT(cv) = &PL_stack_sp;
11107 evanescent = process_special_blocks(0, name, gv, cv);
11110 } /* <- not a conditional branch */
11113 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11115 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
11116 if (interleave) LEAVE;
11117 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11121 /* Add a stub CV to a typeglob.
11122 * This is the implementation of a forward declaration, 'sub foo';'
11126 Perl_newSTUB(pTHX_ GV *gv, bool fake)
11128 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11130 PERL_ARGS_ASSERT_NEWSTUB;
11131 assert(!GvCVu(gv));
11134 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
11135 gv_method_changed(gv);
11137 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
11141 CvGV_set(cv, cvgv);
11142 CvFILE_set_from_cop(cv, PL_curcop);
11143 CvSTASH_set(cv, PL_curstash);
11149 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
11156 if (PL_parser && PL_parser->error_count) {
11162 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
11163 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
11166 if ((cv = GvFORM(gv))) {
11167 if (ckWARN(WARN_REDEFINE)) {
11168 const line_t oldline = CopLINE(PL_curcop);
11169 if (PL_parser && PL_parser->copline != NOLINE)
11170 CopLINE_set(PL_curcop, PL_parser->copline);
11172 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11173 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
11175 /* diag_listed_as: Format %s redefined */
11176 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11177 "Format STDOUT redefined");
11179 CopLINE_set(PL_curcop, oldline);
11184 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
11186 CvFILE_set_from_cop(cv, PL_curcop);
11189 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
11191 start = LINKLIST(root);
11193 S_process_optree(aTHX_ cv, root, start);
11194 cv_forget_slab(cv);
11199 PL_parser->copline = NOLINE;
11200 LEAVE_SCOPE(floor);
11201 PL_compiling.cop_seq = 0;
11205 Perl_newANONLIST(pTHX_ OP *o)
11207 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
11211 Perl_newANONHASH(pTHX_ OP *o)
11213 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
11217 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
11219 return newANONATTRSUB(floor, proto, NULL, block);
11223 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
11225 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
11227 newSVOP(OP_ANONCODE, 0,
11229 if (CvANONCONST(cv))
11230 anoncode = newUNOP(OP_ANONCONST, 0,
11231 op_convert_list(OP_ENTERSUB,
11232 OPf_STACKED|OPf_WANT_SCALAR,
11234 return newUNOP(OP_REFGEN, 0, anoncode);
11238 Perl_oopsAV(pTHX_ OP *o)
11242 PERL_ARGS_ASSERT_OOPSAV;
11244 switch (o->op_type) {
11247 OpTYPE_set(o, OP_PADAV);
11248 return ref(o, OP_RV2AV);
11252 OpTYPE_set(o, OP_RV2AV);
11257 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11264 Perl_oopsHV(pTHX_ OP *o)
11268 PERL_ARGS_ASSERT_OOPSHV;
11270 switch (o->op_type) {
11273 OpTYPE_set(o, OP_PADHV);
11274 return ref(o, OP_RV2HV);
11278 OpTYPE_set(o, OP_RV2HV);
11279 /* rv2hv steals the bottom bit for its own uses */
11280 o->op_private &= ~OPpARG1_MASK;
11285 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11292 Perl_newAVREF(pTHX_ OP *o)
11296 PERL_ARGS_ASSERT_NEWAVREF;
11298 if (o->op_type == OP_PADANY) {
11299 OpTYPE_set(o, OP_PADAV);
11302 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11303 Perl_croak(aTHX_ "Can't use an array as a reference");
11305 return newUNOP(OP_RV2AV, 0, scalar(o));
11309 Perl_newGVREF(pTHX_ I32 type, OP *o)
11311 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11312 return newUNOP(OP_NULL, 0, o);
11313 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11317 Perl_newHVREF(pTHX_ OP *o)
11321 PERL_ARGS_ASSERT_NEWHVREF;
11323 if (o->op_type == OP_PADANY) {
11324 OpTYPE_set(o, OP_PADHV);
11327 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11328 Perl_croak(aTHX_ "Can't use a hash as a reference");
11330 return newUNOP(OP_RV2HV, 0, scalar(o));
11334 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11336 if (o->op_type == OP_PADANY) {
11338 OpTYPE_set(o, OP_PADCV);
11340 return newUNOP(OP_RV2CV, flags, scalar(o));
11344 Perl_newSVREF(pTHX_ OP *o)
11348 PERL_ARGS_ASSERT_NEWSVREF;
11350 if (o->op_type == OP_PADANY) {
11351 OpTYPE_set(o, OP_PADSV);
11355 return newUNOP(OP_RV2SV, 0, scalar(o));
11358 /* Check routines. See the comments at the top of this file for details
11359 * on when these are called */
11362 Perl_ck_anoncode(pTHX_ OP *o)
11364 PERL_ARGS_ASSERT_CK_ANONCODE;
11366 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11367 cSVOPo->op_sv = NULL;
11372 S_io_hints(pTHX_ OP *o)
11374 #if O_BINARY != 0 || O_TEXT != 0
11376 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11378 SV **svp = hv_fetchs(table, "open_IN", FALSE);
11381 const char *d = SvPV_const(*svp, len);
11382 const I32 mode = mode_from_discipline(d, len);
11383 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11385 if (mode & O_BINARY)
11386 o->op_private |= OPpOPEN_IN_RAW;
11390 o->op_private |= OPpOPEN_IN_CRLF;
11394 svp = hv_fetchs(table, "open_OUT", FALSE);
11397 const char *d = SvPV_const(*svp, len);
11398 const I32 mode = mode_from_discipline(d, len);
11399 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11401 if (mode & O_BINARY)
11402 o->op_private |= OPpOPEN_OUT_RAW;
11406 o->op_private |= OPpOPEN_OUT_CRLF;
11411 PERL_UNUSED_CONTEXT;
11412 PERL_UNUSED_ARG(o);
11417 Perl_ck_backtick(pTHX_ OP *o)
11422 PERL_ARGS_ASSERT_CK_BACKTICK;
11424 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11425 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11426 && (gv = gv_override("readpipe",8)))
11428 /* detach rest of siblings from o and its first child */
11429 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11430 newop = S_new_entersubop(aTHX_ gv, sibl);
11432 else if (!(o->op_flags & OPf_KIDS))
11433 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11438 S_io_hints(aTHX_ o);
11443 Perl_ck_bitop(pTHX_ OP *o)
11445 PERL_ARGS_ASSERT_CK_BITOP;
11447 o->op_private = (U8)(PL_hints & HINT_INTEGER);
11449 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11450 && OP_IS_INFIX_BIT(o->op_type))
11452 const OP * const left = cBINOPo->op_first;
11453 const OP * const right = OpSIBLING(left);
11454 if ((OP_IS_NUMCOMPARE(left->op_type) &&
11455 (left->op_flags & OPf_PARENS) == 0) ||
11456 (OP_IS_NUMCOMPARE(right->op_type) &&
11457 (right->op_flags & OPf_PARENS) == 0))
11458 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11459 "Possible precedence problem on bitwise %s operator",
11460 o->op_type == OP_BIT_OR
11461 ||o->op_type == OP_NBIT_OR ? "|"
11462 : o->op_type == OP_BIT_AND
11463 ||o->op_type == OP_NBIT_AND ? "&"
11464 : o->op_type == OP_BIT_XOR
11465 ||o->op_type == OP_NBIT_XOR ? "^"
11466 : o->op_type == OP_SBIT_OR ? "|."
11467 : o->op_type == OP_SBIT_AND ? "&." : "^."
11473 PERL_STATIC_INLINE bool
11474 is_dollar_bracket(pTHX_ const OP * const o)
11477 PERL_UNUSED_CONTEXT;
11478 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11479 && (kid = cUNOPx(o)->op_first)
11480 && kid->op_type == OP_GV
11481 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11484 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11487 Perl_ck_cmp(pTHX_ OP *o)
11493 OP *indexop, *constop, *start;
11497 PERL_ARGS_ASSERT_CK_CMP;
11499 is_eq = ( o->op_type == OP_EQ
11500 || o->op_type == OP_NE
11501 || o->op_type == OP_I_EQ
11502 || o->op_type == OP_I_NE);
11504 if (!is_eq && ckWARN(WARN_SYNTAX)) {
11505 const OP *kid = cUNOPo->op_first;
11508 ( is_dollar_bracket(aTHX_ kid)
11509 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11511 || ( kid->op_type == OP_CONST
11512 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11516 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11517 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11520 /* convert (index(...) == -1) and variations into
11521 * (r)index/BOOL(,NEG)
11526 indexop = cUNOPo->op_first;
11527 constop = OpSIBLING(indexop);
11529 if (indexop->op_type == OP_CONST) {
11531 indexop = OpSIBLING(constop);
11536 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11539 /* ($lex = index(....)) == -1 */
11540 if (indexop->op_private & OPpTARGET_MY)
11543 if (constop->op_type != OP_CONST)
11546 sv = cSVOPx_sv(constop);
11547 if (!(sv && SvIOK_notUV(sv)))
11551 if (iv != -1 && iv != 0)
11555 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11556 if (!(iv0 ^ reverse))
11560 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11565 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11566 if (!(iv0 ^ reverse))
11570 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11575 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11581 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11587 indexop->op_flags &= ~OPf_PARENS;
11588 indexop->op_flags |= (o->op_flags & OPf_PARENS);
11589 indexop->op_private |= OPpTRUEBOOL;
11591 indexop->op_private |= OPpINDEX_BOOLNEG;
11592 /* cut out the index op and free the eq,const ops */
11593 (void)op_sibling_splice(o, start, 1, NULL);
11601 Perl_ck_concat(pTHX_ OP *o)
11603 const OP * const kid = cUNOPo->op_first;
11605 PERL_ARGS_ASSERT_CK_CONCAT;
11606 PERL_UNUSED_CONTEXT;
11608 /* reuse the padtmp returned by the concat child */
11609 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11610 !(kUNOP->op_first->op_flags & OPf_MOD))
11612 o->op_flags |= OPf_STACKED;
11613 o->op_private |= OPpCONCAT_NESTED;
11619 Perl_ck_spair(pTHX_ OP *o)
11623 PERL_ARGS_ASSERT_CK_SPAIR;
11625 if (o->op_flags & OPf_KIDS) {
11629 const OPCODE type = o->op_type;
11630 o = modkids(ck_fun(o), type);
11631 kid = cUNOPo->op_first;
11632 kidkid = kUNOP->op_first;
11633 newop = OpSIBLING(kidkid);
11635 const OPCODE type = newop->op_type;
11636 if (OpHAS_SIBLING(newop))
11638 if (o->op_type == OP_REFGEN
11639 && ( type == OP_RV2CV
11640 || ( !(newop->op_flags & OPf_PARENS)
11641 && ( type == OP_RV2AV || type == OP_PADAV
11642 || type == OP_RV2HV || type == OP_PADHV))))
11643 NOOP; /* OK (allow srefgen for \@a and \%h) */
11644 else if (OP_GIMME(newop,0) != G_SCALAR)
11647 /* excise first sibling */
11648 op_sibling_splice(kid, NULL, 1, NULL);
11651 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11652 * and OP_CHOMP into OP_SCHOMP */
11653 o->op_ppaddr = PL_ppaddr[++o->op_type];
11658 Perl_ck_delete(pTHX_ OP *o)
11660 PERL_ARGS_ASSERT_CK_DELETE;
11664 if (o->op_flags & OPf_KIDS) {
11665 OP * const kid = cUNOPo->op_first;
11666 switch (kid->op_type) {
11668 o->op_flags |= OPf_SPECIAL;
11671 o->op_private |= OPpSLICE;
11674 o->op_flags |= OPf_SPECIAL;
11679 o->op_flags |= OPf_SPECIAL;
11682 o->op_private |= OPpKVSLICE;
11685 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11686 "element or slice");
11688 if (kid->op_private & OPpLVAL_INTRO)
11689 o->op_private |= OPpLVAL_INTRO;
11696 Perl_ck_eof(pTHX_ OP *o)
11698 PERL_ARGS_ASSERT_CK_EOF;
11700 if (o->op_flags & OPf_KIDS) {
11702 if (cLISTOPo->op_first->op_type == OP_STUB) {
11704 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11709 kid = cLISTOPo->op_first;
11710 if (kid->op_type == OP_RV2GV)
11711 kid->op_private |= OPpALLOW_FAKE;
11718 Perl_ck_eval(pTHX_ OP *o)
11722 PERL_ARGS_ASSERT_CK_EVAL;
11724 PL_hints |= HINT_BLOCK_SCOPE;
11725 if (o->op_flags & OPf_KIDS) {
11726 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11729 if (o->op_type == OP_ENTERTRY) {
11732 /* cut whole sibling chain free from o */
11733 op_sibling_splice(o, NULL, -1, NULL);
11736 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11738 /* establish postfix order */
11739 enter->op_next = (OP*)enter;
11741 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11742 OpTYPE_set(o, OP_LEAVETRY);
11743 enter->op_other = o;
11748 S_set_haseval(aTHX);
11752 const U8 priv = o->op_private;
11754 /* the newUNOP will recursively call ck_eval(), which will handle
11755 * all the stuff at the end of this function, like adding
11758 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11760 o->op_targ = (PADOFFSET)PL_hints;
11761 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11762 if ((PL_hints & HINT_LOCALIZE_HH) != 0
11763 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11764 /* Store a copy of %^H that pp_entereval can pick up. */
11765 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11766 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11767 /* append hhop to only child */
11768 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11770 o->op_private |= OPpEVAL_HAS_HH;
11772 if (!(o->op_private & OPpEVAL_BYTES)
11773 && FEATURE_UNIEVAL_IS_ENABLED)
11774 o->op_private |= OPpEVAL_UNICODE;
11779 Perl_ck_exec(pTHX_ OP *o)
11781 PERL_ARGS_ASSERT_CK_EXEC;
11783 if (o->op_flags & OPf_STACKED) {
11786 kid = OpSIBLING(cUNOPo->op_first);
11787 if (kid->op_type == OP_RV2GV)
11796 Perl_ck_exists(pTHX_ OP *o)
11798 PERL_ARGS_ASSERT_CK_EXISTS;
11801 if (o->op_flags & OPf_KIDS) {
11802 OP * const kid = cUNOPo->op_first;
11803 if (kid->op_type == OP_ENTERSUB) {
11804 (void) ref(kid, o->op_type);
11805 if (kid->op_type != OP_RV2CV
11806 && !(PL_parser && PL_parser->error_count))
11808 "exists argument is not a subroutine name");
11809 o->op_private |= OPpEXISTS_SUB;
11811 else if (kid->op_type == OP_AELEM)
11812 o->op_flags |= OPf_SPECIAL;
11813 else if (kid->op_type != OP_HELEM)
11814 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11815 "element or a subroutine");
11822 Perl_ck_rvconst(pTHX_ OP *o)
11825 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11827 PERL_ARGS_ASSERT_CK_RVCONST;
11829 if (o->op_type == OP_RV2HV)
11830 /* rv2hv steals the bottom bit for its own uses */
11831 o->op_private &= ~OPpARG1_MASK;
11833 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11835 if (kid->op_type == OP_CONST) {
11838 SV * const kidsv = kid->op_sv;
11840 /* Is it a constant from cv_const_sv()? */
11841 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11844 if (SvTYPE(kidsv) == SVt_PVAV) return o;
11845 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11846 const char *badthing;
11847 switch (o->op_type) {
11849 badthing = "a SCALAR";
11852 badthing = "an ARRAY";
11855 badthing = "a HASH";
11863 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11864 SVfARG(kidsv), badthing);
11867 * This is a little tricky. We only want to add the symbol if we
11868 * didn't add it in the lexer. Otherwise we get duplicate strict
11869 * warnings. But if we didn't add it in the lexer, we must at
11870 * least pretend like we wanted to add it even if it existed before,
11871 * or we get possible typo warnings. OPpCONST_ENTERED says
11872 * whether the lexer already added THIS instance of this symbol.
11874 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11875 gv = gv_fetchsv(kidsv,
11876 o->op_type == OP_RV2CV
11877 && o->op_private & OPpMAY_RETURN_CONSTANT
11879 : iscv | !(kid->op_private & OPpCONST_ENTERED),
11882 : o->op_type == OP_RV2SV
11884 : o->op_type == OP_RV2AV
11886 : o->op_type == OP_RV2HV
11893 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11894 && SvTYPE(SvRV(gv)) != SVt_PVCV)
11895 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11897 OpTYPE_set(kid, OP_GV);
11898 SvREFCNT_dec(kid->op_sv);
11899 #ifdef USE_ITHREADS
11900 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11901 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11902 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11903 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11904 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11906 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11908 kid->op_private = 0;
11909 /* FAKE globs in the symbol table cause weird bugs (#77810) */
11917 Perl_ck_ftst(pTHX_ OP *o)
11920 const I32 type = o->op_type;
11922 PERL_ARGS_ASSERT_CK_FTST;
11924 if (o->op_flags & OPf_REF) {
11927 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11928 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11929 const OPCODE kidtype = kid->op_type;
11931 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11932 && !kid->op_folded) {
11933 OP * const newop = newGVOP(type, OPf_REF,
11934 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11939 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11940 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11942 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11943 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11944 array_passed_to_stat, name);
11947 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11948 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11951 scalar((OP *) kid);
11952 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11953 o->op_private |= OPpFT_ACCESS;
11954 if (OP_IS_FILETEST(type)
11955 && OP_IS_FILETEST(kidtype)
11957 o->op_private |= OPpFT_STACKED;
11958 kid->op_private |= OPpFT_STACKING;
11959 if (kidtype == OP_FTTTY && (
11960 !(kid->op_private & OPpFT_STACKED)
11961 || kid->op_private & OPpFT_AFTER_t
11963 o->op_private |= OPpFT_AFTER_t;
11968 if (type == OP_FTTTY)
11969 o = newGVOP(type, OPf_REF, PL_stdingv);
11971 o = newUNOP(type, 0, newDEFSVOP());
11977 Perl_ck_fun(pTHX_ OP *o)
11979 const int type = o->op_type;
11980 I32 oa = PL_opargs[type] >> OASHIFT;
11982 PERL_ARGS_ASSERT_CK_FUN;
11984 if (o->op_flags & OPf_STACKED) {
11985 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11986 oa &= ~OA_OPTIONAL;
11988 return no_fh_allowed(o);
11991 if (o->op_flags & OPf_KIDS) {
11992 OP *prev_kid = NULL;
11993 OP *kid = cLISTOPo->op_first;
11995 bool seen_optional = FALSE;
11997 if (kid->op_type == OP_PUSHMARK ||
11998 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
12001 kid = OpSIBLING(kid);
12003 if (kid && kid->op_type == OP_COREARGS) {
12004 bool optional = FALSE;
12007 if (oa & OA_OPTIONAL) optional = TRUE;
12010 if (optional) o->op_private |= numargs;
12015 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
12016 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
12017 kid = newDEFSVOP();
12018 /* append kid to chain */
12019 op_sibling_splice(o, prev_kid, 0, kid);
12021 seen_optional = TRUE;
12028 /* list seen where single (scalar) arg expected? */
12029 if (numargs == 1 && !(oa >> 4)
12030 && kid->op_type == OP_LIST && type != OP_SCALAR)
12032 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12034 if (type != OP_DELETE) scalar(kid);
12045 if ((type == OP_PUSH || type == OP_UNSHIFT)
12046 && !OpHAS_SIBLING(kid))
12047 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12048 "Useless use of %s with no values",
12051 if (kid->op_type == OP_CONST
12052 && ( !SvROK(cSVOPx_sv(kid))
12053 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
12055 bad_type_pv(numargs, "array", o, kid);
12056 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
12057 || kid->op_type == OP_RV2GV) {
12058 bad_type_pv(1, "array", o, kid);
12060 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
12061 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
12062 PL_op_desc[type]), 0);
12065 op_lvalue(kid, type);
12069 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
12070 bad_type_pv(numargs, "hash", o, kid);
12071 op_lvalue(kid, type);
12075 /* replace kid with newop in chain */
12077 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
12078 newop->op_next = newop;
12083 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
12084 if (kid->op_type == OP_CONST &&
12085 (kid->op_private & OPpCONST_BARE))
12087 OP * const newop = newGVOP(OP_GV, 0,
12088 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
12089 /* replace kid with newop in chain */
12090 op_sibling_splice(o, prev_kid, 1, newop);
12094 else if (kid->op_type == OP_READLINE) {
12095 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
12096 bad_type_pv(numargs, "HANDLE", o, kid);
12099 I32 flags = OPf_SPECIAL;
12101 PADOFFSET targ = 0;
12103 /* is this op a FH constructor? */
12104 if (is_handle_constructor(o,numargs)) {
12105 const char *name = NULL;
12108 bool want_dollar = TRUE;
12111 /* Set a flag to tell rv2gv to vivify
12112 * need to "prove" flag does not mean something
12113 * else already - NI-S 1999/05/07
12116 if (kid->op_type == OP_PADSV) {
12118 = PAD_COMPNAME_SV(kid->op_targ);
12119 name = PadnamePV (pn);
12120 len = PadnameLEN(pn);
12121 name_utf8 = PadnameUTF8(pn);
12123 else if (kid->op_type == OP_RV2SV
12124 && kUNOP->op_first->op_type == OP_GV)
12126 GV * const gv = cGVOPx_gv(kUNOP->op_first);
12128 len = GvNAMELEN(gv);
12129 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
12131 else if (kid->op_type == OP_AELEM
12132 || kid->op_type == OP_HELEM)
12135 OP *op = ((BINOP*)kid)->op_first;
12139 const char * const a =
12140 kid->op_type == OP_AELEM ?
12142 if (((op->op_type == OP_RV2AV) ||
12143 (op->op_type == OP_RV2HV)) &&
12144 (firstop = ((UNOP*)op)->op_first) &&
12145 (firstop->op_type == OP_GV)) {
12146 /* packagevar $a[] or $h{} */
12147 GV * const gv = cGVOPx_gv(firstop);
12150 Perl_newSVpvf(aTHX_
12155 else if (op->op_type == OP_PADAV
12156 || op->op_type == OP_PADHV) {
12157 /* lexicalvar $a[] or $h{} */
12158 const char * const padname =
12159 PAD_COMPNAME_PV(op->op_targ);
12162 Perl_newSVpvf(aTHX_
12168 name = SvPV_const(tmpstr, len);
12169 name_utf8 = SvUTF8(tmpstr);
12170 sv_2mortal(tmpstr);
12174 name = "__ANONIO__";
12176 want_dollar = FALSE;
12178 op_lvalue(kid, type);
12182 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
12183 namesv = PAD_SVl(targ);
12184 if (want_dollar && *name != '$')
12185 sv_setpvs(namesv, "$");
12188 sv_catpvn(namesv, name, len);
12189 if ( name_utf8 ) SvUTF8_on(namesv);
12193 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
12195 kid->op_targ = targ;
12196 kid->op_private |= priv;
12202 if ((type == OP_UNDEF || type == OP_POS)
12203 && numargs == 1 && !(oa >> 4)
12204 && kid->op_type == OP_LIST)
12205 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12206 op_lvalue(scalar(kid), type);
12211 kid = OpSIBLING(kid);
12213 /* FIXME - should the numargs or-ing move after the too many
12214 * arguments check? */
12215 o->op_private |= numargs;
12217 return too_many_arguments_pv(o,OP_DESC(o), 0);
12220 else if (PL_opargs[type] & OA_DEFGV) {
12221 /* Ordering of these two is important to keep f_map.t passing. */
12223 return newUNOP(type, 0, newDEFSVOP());
12227 while (oa & OA_OPTIONAL)
12229 if (oa && oa != OA_LIST)
12230 return too_few_arguments_pv(o,OP_DESC(o), 0);
12236 Perl_ck_glob(pTHX_ OP *o)
12240 PERL_ARGS_ASSERT_CK_GLOB;
12243 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
12244 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
12246 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
12250 * \ null - const(wildcard)
12255 * \ mark - glob - rv2cv
12256 * | \ gv(CORE::GLOBAL::glob)
12258 * \ null - const(wildcard)
12260 o->op_flags |= OPf_SPECIAL;
12261 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12262 o = S_new_entersubop(aTHX_ gv, o);
12263 o = newUNOP(OP_NULL, 0, o);
12264 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12267 else o->op_flags &= ~OPf_SPECIAL;
12268 #if !defined(PERL_EXTERNAL_GLOB)
12269 if (!PL_globhook) {
12271 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12272 newSVpvs("File::Glob"), NULL, NULL, NULL);
12275 #endif /* !PERL_EXTERNAL_GLOB */
12276 gv = (GV *)newSV(0);
12277 gv_init(gv, 0, "", 0, 0);
12279 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12280 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12286 Perl_ck_grep(pTHX_ OP *o)
12290 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12292 PERL_ARGS_ASSERT_CK_GREP;
12294 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12296 if (o->op_flags & OPf_STACKED) {
12297 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12298 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12299 return no_fh_allowed(o);
12300 o->op_flags &= ~OPf_STACKED;
12302 kid = OpSIBLING(cLISTOPo->op_first);
12303 if (type == OP_MAPWHILE)
12308 if (PL_parser && PL_parser->error_count)
12310 kid = OpSIBLING(cLISTOPo->op_first);
12311 if (kid->op_type != OP_NULL)
12312 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12313 kid = kUNOP->op_first;
12315 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12316 kid->op_next = (OP*)gwop;
12317 o->op_private = gwop->op_private = 0;
12318 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12320 kid = OpSIBLING(cLISTOPo->op_first);
12321 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12322 op_lvalue(kid, OP_GREPSTART);
12328 Perl_ck_index(pTHX_ OP *o)
12330 PERL_ARGS_ASSERT_CK_INDEX;
12332 if (o->op_flags & OPf_KIDS) {
12333 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12335 kid = OpSIBLING(kid); /* get past "big" */
12336 if (kid && kid->op_type == OP_CONST) {
12337 const bool save_taint = TAINT_get;
12338 SV *sv = kSVOP->op_sv;
12339 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12340 && SvOK(sv) && !SvROK(sv))
12343 sv_copypv(sv, kSVOP->op_sv);
12344 SvREFCNT_dec_NN(kSVOP->op_sv);
12347 if (SvOK(sv)) fbm_compile(sv, 0);
12348 TAINT_set(save_taint);
12349 #ifdef NO_TAINT_SUPPORT
12350 PERL_UNUSED_VAR(save_taint);
12358 Perl_ck_lfun(pTHX_ OP *o)
12360 const OPCODE type = o->op_type;
12362 PERL_ARGS_ASSERT_CK_LFUN;
12364 return modkids(ck_fun(o), type);
12368 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
12370 PERL_ARGS_ASSERT_CK_DEFINED;
12372 if ((o->op_flags & OPf_KIDS)) {
12373 switch (cUNOPo->op_first->op_type) {
12376 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12377 " (Maybe you should just omit the defined()?)");
12378 NOT_REACHED; /* NOTREACHED */
12382 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12383 " (Maybe you should just omit the defined()?)");
12384 NOT_REACHED; /* NOTREACHED */
12395 Perl_ck_readline(pTHX_ OP *o)
12397 PERL_ARGS_ASSERT_CK_READLINE;
12399 if (o->op_flags & OPf_KIDS) {
12400 OP *kid = cLISTOPo->op_first;
12401 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12406 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12414 Perl_ck_rfun(pTHX_ OP *o)
12416 const OPCODE type = o->op_type;
12418 PERL_ARGS_ASSERT_CK_RFUN;
12420 return refkids(ck_fun(o), type);
12424 Perl_ck_listiob(pTHX_ OP *o)
12428 PERL_ARGS_ASSERT_CK_LISTIOB;
12430 kid = cLISTOPo->op_first;
12432 o = force_list(o, 1);
12433 kid = cLISTOPo->op_first;
12435 if (kid->op_type == OP_PUSHMARK)
12436 kid = OpSIBLING(kid);
12437 if (kid && o->op_flags & OPf_STACKED)
12438 kid = OpSIBLING(kid);
12439 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
12440 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12441 && !kid->op_folded) {
12442 o->op_flags |= OPf_STACKED; /* make it a filehandle */
12444 /* replace old const op with new OP_RV2GV parent */
12445 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12446 OP_RV2GV, OPf_REF);
12447 kid = OpSIBLING(kid);
12452 op_append_elem(o->op_type, o, newDEFSVOP());
12454 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12455 return listkids(o);
12459 Perl_ck_smartmatch(pTHX_ OP *o)
12462 PERL_ARGS_ASSERT_CK_SMARTMATCH;
12463 if (0 == (o->op_flags & OPf_SPECIAL)) {
12464 OP *first = cBINOPo->op_first;
12465 OP *second = OpSIBLING(first);
12467 /* Implicitly take a reference to an array or hash */
12469 /* remove the original two siblings, then add back the
12470 * (possibly different) first and second sibs.
12472 op_sibling_splice(o, NULL, 1, NULL);
12473 op_sibling_splice(o, NULL, 1, NULL);
12474 first = ref_array_or_hash(first);
12475 second = ref_array_or_hash(second);
12476 op_sibling_splice(o, NULL, 0, second);
12477 op_sibling_splice(o, NULL, 0, first);
12479 /* Implicitly take a reference to a regular expression */
12480 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12481 OpTYPE_set(first, OP_QR);
12483 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12484 OpTYPE_set(second, OP_QR);
12493 S_maybe_targlex(pTHX_ OP *o)
12495 OP * const kid = cLISTOPo->op_first;
12496 /* has a disposable target? */
12497 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12498 && !(kid->op_flags & OPf_STACKED)
12499 /* Cannot steal the second time! */
12500 && !(kid->op_private & OPpTARGET_MY)
12503 OP * const kkid = OpSIBLING(kid);
12505 /* Can just relocate the target. */
12506 if (kkid && kkid->op_type == OP_PADSV
12507 && (!(kkid->op_private & OPpLVAL_INTRO)
12508 || kkid->op_private & OPpPAD_STATE))
12510 kid->op_targ = kkid->op_targ;
12512 /* Now we do not need PADSV and SASSIGN.
12513 * Detach kid and free the rest. */
12514 op_sibling_splice(o, NULL, 1, NULL);
12516 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
12524 Perl_ck_sassign(pTHX_ OP *o)
12527 OP * const kid = cBINOPo->op_first;
12529 PERL_ARGS_ASSERT_CK_SASSIGN;
12531 if (OpHAS_SIBLING(kid)) {
12532 OP *kkid = OpSIBLING(kid);
12533 /* For state variable assignment with attributes, kkid is a list op
12534 whose op_last is a padsv. */
12535 if ((kkid->op_type == OP_PADSV ||
12536 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12537 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12540 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12541 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12542 return S_newONCEOP(aTHX_ o, kkid);
12545 return S_maybe_targlex(aTHX_ o);
12550 Perl_ck_match(pTHX_ OP *o)
12552 PERL_UNUSED_CONTEXT;
12553 PERL_ARGS_ASSERT_CK_MATCH;
12559 Perl_ck_method(pTHX_ OP *o)
12561 SV *sv, *methsv, *rclass;
12562 const char* method;
12565 STRLEN len, nsplit = 0, i;
12567 OP * const kid = cUNOPo->op_first;
12569 PERL_ARGS_ASSERT_CK_METHOD;
12570 if (kid->op_type != OP_CONST) return o;
12574 /* replace ' with :: */
12575 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12576 SvEND(sv) - SvPVX(sv) )))
12579 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12582 method = SvPVX_const(sv);
12584 utf8 = SvUTF8(sv) ? -1 : 1;
12586 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12591 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12593 if (!nsplit) { /* $proto->method() */
12595 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12598 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12600 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12603 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12604 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12605 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12606 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12608 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12609 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12611 #ifdef USE_ITHREADS
12612 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12614 cMETHOPx(new_op)->op_rclass_sv = rclass;
12621 Perl_ck_null(pTHX_ OP *o)
12623 PERL_ARGS_ASSERT_CK_NULL;
12624 PERL_UNUSED_CONTEXT;
12629 Perl_ck_open(pTHX_ OP *o)
12631 PERL_ARGS_ASSERT_CK_OPEN;
12633 S_io_hints(aTHX_ o);
12635 /* In case of three-arg dup open remove strictness
12636 * from the last arg if it is a bareword. */
12637 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12638 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
12642 if ((last->op_type == OP_CONST) && /* The bareword. */
12643 (last->op_private & OPpCONST_BARE) &&
12644 (last->op_private & OPpCONST_STRICT) &&
12645 (oa = OpSIBLING(first)) && /* The fh. */
12646 (oa = OpSIBLING(oa)) && /* The mode. */
12647 (oa->op_type == OP_CONST) &&
12648 SvPOK(((SVOP*)oa)->op_sv) &&
12649 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12650 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
12651 (last == OpSIBLING(oa))) /* The bareword. */
12652 last->op_private &= ~OPpCONST_STRICT;
12658 Perl_ck_prototype(pTHX_ OP *o)
12660 PERL_ARGS_ASSERT_CK_PROTOTYPE;
12661 if (!(o->op_flags & OPf_KIDS)) {
12663 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12669 Perl_ck_refassign(pTHX_ OP *o)
12671 OP * const right = cLISTOPo->op_first;
12672 OP * const left = OpSIBLING(right);
12673 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12676 PERL_ARGS_ASSERT_CK_REFASSIGN;
12678 assert (left->op_type == OP_SREFGEN);
12681 /* we use OPpPAD_STATE in refassign to mean either of those things,
12682 * and the code assumes the two flags occupy the same bit position
12683 * in the various ops below */
12684 assert(OPpPAD_STATE == OPpOUR_INTRO);
12686 switch (varop->op_type) {
12688 o->op_private |= OPpLVREF_AV;
12691 o->op_private |= OPpLVREF_HV;
12695 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12696 o->op_targ = varop->op_targ;
12697 varop->op_targ = 0;
12698 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12702 o->op_private |= OPpLVREF_AV;
12704 NOT_REACHED; /* NOTREACHED */
12706 o->op_private |= OPpLVREF_HV;
12710 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12711 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12713 /* Point varop to its GV kid, detached. */
12714 varop = op_sibling_splice(varop, NULL, -1, NULL);
12718 OP * const kidparent =
12719 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12720 OP * const kid = cUNOPx(kidparent)->op_first;
12721 o->op_private |= OPpLVREF_CV;
12722 if (kid->op_type == OP_GV) {
12723 SV *sv = (SV*)cGVOPx_gv(kid);
12725 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
12726 /* a CVREF here confuses pp_refassign, so make sure
12728 CV *const cv = (CV*)SvRV(sv);
12729 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
12730 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
12731 assert(SvTYPE(sv) == SVt_PVGV);
12733 goto detach_and_stack;
12735 if (kid->op_type != OP_PADCV) goto bad;
12736 o->op_targ = kid->op_targ;
12742 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12743 o->op_private |= OPpLVREF_ELEM;
12746 /* Detach varop. */
12747 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12751 /* diag_listed_as: Can't modify reference to %s in %s assignment */
12752 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12757 if (!FEATURE_REFALIASING_IS_ENABLED)
12759 "Experimental aliasing via reference not enabled");
12760 Perl_ck_warner_d(aTHX_
12761 packWARN(WARN_EXPERIMENTAL__REFALIASING),
12762 "Aliasing via reference is experimental");
12764 o->op_flags |= OPf_STACKED;
12765 op_sibling_splice(o, right, 1, varop);
12768 o->op_flags &=~ OPf_STACKED;
12769 op_sibling_splice(o, right, 1, NULL);
12776 Perl_ck_repeat(pTHX_ OP *o)
12778 PERL_ARGS_ASSERT_CK_REPEAT;
12780 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12782 o->op_private |= OPpREPEAT_DOLIST;
12783 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12784 kids = force_list(kids, 1); /* promote it to a list */
12785 op_sibling_splice(o, NULL, 0, kids); /* and add back */
12793 Perl_ck_require(pTHX_ OP *o)
12797 PERL_ARGS_ASSERT_CK_REQUIRE;
12799 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
12800 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12804 if (kid->op_type == OP_CONST) {
12805 SV * const sv = kid->op_sv;
12806 U32 const was_readonly = SvREADONLY(sv);
12807 if (kid->op_private & OPpCONST_BARE) {
12812 if (was_readonly) {
12813 SvREADONLY_off(sv);
12815 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12820 /* treat ::foo::bar as foo::bar */
12821 if (len >= 2 && s[0] == ':' && s[1] == ':')
12822 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12824 DIE(aTHX_ "Bareword in require maps to empty filename");
12826 for (; s < end; s++) {
12827 if (*s == ':' && s[1] == ':') {
12829 Move(s+2, s+1, end - s - 1, char);
12833 SvEND_set(sv, end);
12834 sv_catpvs(sv, ".pm");
12835 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12836 hek = share_hek(SvPVX(sv),
12837 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12839 sv_sethek(sv, hek);
12841 SvFLAGS(sv) |= was_readonly;
12843 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12846 if (SvREFCNT(sv) > 1) {
12847 kid->op_sv = newSVpvn_share(
12848 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12849 SvREFCNT_dec_NN(sv);
12854 if (was_readonly) SvREADONLY_off(sv);
12855 PERL_HASH(hash, s, len);
12857 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12859 sv_sethek(sv, hek);
12861 SvFLAGS(sv) |= was_readonly;
12867 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12868 /* handle override, if any */
12869 && (gv = gv_override("require", 7))) {
12871 if (o->op_flags & OPf_KIDS) {
12872 kid = cUNOPo->op_first;
12873 op_sibling_splice(o, NULL, -1, NULL);
12876 kid = newDEFSVOP();
12879 newop = S_new_entersubop(aTHX_ gv, kid);
12887 Perl_ck_return(pTHX_ OP *o)
12891 PERL_ARGS_ASSERT_CK_RETURN;
12893 kid = OpSIBLING(cLISTOPo->op_first);
12894 if (PL_compcv && CvLVALUE(PL_compcv)) {
12895 for (; kid; kid = OpSIBLING(kid))
12896 op_lvalue(kid, OP_LEAVESUBLV);
12903 Perl_ck_select(pTHX_ OP *o)
12908 PERL_ARGS_ASSERT_CK_SELECT;
12910 if (o->op_flags & OPf_KIDS) {
12911 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12912 if (kid && OpHAS_SIBLING(kid)) {
12913 OpTYPE_set(o, OP_SSELECT);
12915 return fold_constants(op_integerize(op_std_init(o)));
12919 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12920 if (kid && kid->op_type == OP_RV2GV)
12921 kid->op_private &= ~HINT_STRICT_REFS;
12926 Perl_ck_shift(pTHX_ OP *o)
12928 const I32 type = o->op_type;
12930 PERL_ARGS_ASSERT_CK_SHIFT;
12932 if (!(o->op_flags & OPf_KIDS)) {
12935 if (!CvUNIQUE(PL_compcv)) {
12936 o->op_flags |= OPf_SPECIAL;
12940 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12942 return newUNOP(type, 0, scalar(argop));
12944 return scalar(ck_fun(o));
12948 Perl_ck_sort(pTHX_ OP *o)
12952 HV * const hinthv =
12953 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12956 PERL_ARGS_ASSERT_CK_SORT;
12959 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12961 const I32 sorthints = (I32)SvIV(*svp);
12962 if ((sorthints & HINT_SORT_STABLE) != 0)
12963 o->op_private |= OPpSORT_STABLE;
12964 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12965 o->op_private |= OPpSORT_UNSTABLE;
12969 if (o->op_flags & OPf_STACKED)
12971 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12973 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
12974 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
12976 /* if the first arg is a code block, process it and mark sort as
12978 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12980 if (kid->op_type == OP_LEAVE)
12981 op_null(kid); /* wipe out leave */
12982 /* Prevent execution from escaping out of the sort block. */
12985 /* provide scalar context for comparison function/block */
12986 kid = scalar(firstkid);
12987 kid->op_next = kid;
12988 o->op_flags |= OPf_SPECIAL;
12990 else if (kid->op_type == OP_CONST
12991 && kid->op_private & OPpCONST_BARE) {
12995 const char * const name = SvPV(kSVOP_sv, len);
12997 assert (len < 256);
12998 Copy(name, tmpbuf+1, len, char);
12999 off = pad_findmy_pvn(tmpbuf, len+1, 0);
13000 if (off != NOT_IN_PAD) {
13001 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
13003 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
13004 sv_catpvs(fq, "::");
13005 sv_catsv(fq, kSVOP_sv);
13006 SvREFCNT_dec_NN(kSVOP_sv);
13010 OP * const padop = newOP(OP_PADCV, 0);
13011 padop->op_targ = off;
13012 /* replace the const op with the pad op */
13013 op_sibling_splice(firstkid, NULL, 1, padop);
13019 firstkid = OpSIBLING(firstkid);
13022 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13023 /* provide list context for arguments */
13026 op_lvalue(kid, OP_GREPSTART);
13032 /* for sort { X } ..., where X is one of
13033 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
13034 * elide the second child of the sort (the one containing X),
13035 * and set these flags as appropriate
13039 * Also, check and warn on lexical $a, $b.
13043 S_simplify_sort(pTHX_ OP *o)
13045 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13049 const char *gvname;
13052 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
13054 kid = kUNOP->op_first; /* get past null */
13055 if (!(have_scopeop = kid->op_type == OP_SCOPE)
13056 && kid->op_type != OP_LEAVE)
13058 kid = kLISTOP->op_last; /* get past scope */
13059 switch(kid->op_type) {
13063 if (!have_scopeop) goto padkids;
13068 k = kid; /* remember this node*/
13069 if (kBINOP->op_first->op_type != OP_RV2SV
13070 || kBINOP->op_last ->op_type != OP_RV2SV)
13073 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
13074 then used in a comparison. This catches most, but not
13075 all cases. For instance, it catches
13076 sort { my($a); $a <=> $b }
13078 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
13079 (although why you'd do that is anyone's guess).
13083 if (!ckWARN(WARN_SYNTAX)) return;
13084 kid = kBINOP->op_first;
13086 if (kid->op_type == OP_PADSV) {
13087 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
13088 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
13089 && ( PadnamePV(name)[1] == 'a'
13090 || PadnamePV(name)[1] == 'b' ))
13091 /* diag_listed_as: "my %s" used in sort comparison */
13092 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13093 "\"%s %s\" used in sort comparison",
13094 PadnameIsSTATE(name)
13099 } while ((kid = OpSIBLING(kid)));
13102 kid = kBINOP->op_first; /* get past cmp */
13103 if (kUNOP->op_first->op_type != OP_GV)
13105 kid = kUNOP->op_first; /* get past rv2sv */
13107 if (GvSTASH(gv) != PL_curstash)
13109 gvname = GvNAME(gv);
13110 if (*gvname == 'a' && gvname[1] == '\0')
13112 else if (*gvname == 'b' && gvname[1] == '\0')
13117 kid = k; /* back to cmp */
13118 /* already checked above that it is rv2sv */
13119 kid = kBINOP->op_last; /* down to 2nd arg */
13120 if (kUNOP->op_first->op_type != OP_GV)
13122 kid = kUNOP->op_first; /* get past rv2sv */
13124 if (GvSTASH(gv) != PL_curstash)
13126 gvname = GvNAME(gv);
13128 ? !(*gvname == 'a' && gvname[1] == '\0')
13129 : !(*gvname == 'b' && gvname[1] == '\0'))
13131 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
13133 o->op_private |= OPpSORT_DESCEND;
13134 if (k->op_type == OP_NCMP)
13135 o->op_private |= OPpSORT_NUMERIC;
13136 if (k->op_type == OP_I_NCMP)
13137 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
13138 kid = OpSIBLING(cLISTOPo->op_first);
13139 /* cut out and delete old block (second sibling) */
13140 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
13145 Perl_ck_split(pTHX_ OP *o)
13151 PERL_ARGS_ASSERT_CK_SPLIT;
13153 assert(o->op_type == OP_LIST);
13155 if (o->op_flags & OPf_STACKED)
13156 return no_fh_allowed(o);
13158 kid = cLISTOPo->op_first;
13159 /* delete leading NULL node, then add a CONST if no other nodes */
13160 assert(kid->op_type == OP_NULL);
13161 op_sibling_splice(o, NULL, 1,
13162 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
13164 kid = cLISTOPo->op_first;
13166 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
13167 /* remove match expression, and replace with new optree with
13168 * a match op at its head */
13169 op_sibling_splice(o, NULL, 1, NULL);
13170 /* pmruntime will handle split " " behavior with flag==2 */
13171 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
13172 op_sibling_splice(o, NULL, 0, kid);
13175 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
13177 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
13178 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
13179 "Use of /g modifier is meaningless in split");
13182 /* eliminate the split op, and move the match op (plus any children)
13183 * into its place, then convert the match op into a split op. i.e.
13185 * SPLIT MATCH SPLIT(ex-MATCH)
13187 * MATCH - A - B - C => R - A - B - C => R - A - B - C
13193 * (R, if it exists, will be a regcomp op)
13196 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
13197 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
13198 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
13199 OpTYPE_set(kid, OP_SPLIT);
13200 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
13201 kid->op_private = o->op_private;
13204 kid = sibs; /* kid is now the string arg of the split */
13207 kid = newDEFSVOP();
13208 op_append_elem(OP_SPLIT, o, kid);
13212 kid = OpSIBLING(kid);
13214 kid = newSVOP(OP_CONST, 0, newSViv(0));
13215 op_append_elem(OP_SPLIT, o, kid);
13216 o->op_private |= OPpSPLIT_IMPLIM;
13220 if (OpHAS_SIBLING(kid))
13221 return too_many_arguments_pv(o,OP_DESC(o), 0);
13227 Perl_ck_stringify(pTHX_ OP *o)
13229 OP * const kid = OpSIBLING(cUNOPo->op_first);
13230 PERL_ARGS_ASSERT_CK_STRINGIFY;
13231 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
13232 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
13233 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
13234 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
13236 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
13244 Perl_ck_join(pTHX_ OP *o)
13246 OP * const kid = OpSIBLING(cLISTOPo->op_first);
13248 PERL_ARGS_ASSERT_CK_JOIN;
13250 if (kid && kid->op_type == OP_MATCH) {
13251 if (ckWARN(WARN_SYNTAX)) {
13252 const REGEXP *re = PM_GETRE(kPMOP);
13254 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
13255 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
13256 : newSVpvs_flags( "STRING", SVs_TEMP );
13257 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13258 "/%" SVf "/ should probably be written as \"%" SVf "\"",
13259 SVfARG(msg), SVfARG(msg));
13263 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
13264 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
13265 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
13266 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
13268 const OP * const bairn = OpSIBLING(kid); /* the list */
13269 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
13270 && OP_GIMME(bairn,0) == G_SCALAR)
13272 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13273 op_sibling_splice(o, kid, 1, NULL));
13283 =for apidoc rv2cv_op_cv
13285 Examines an op, which is expected to identify a subroutine at runtime,
13286 and attempts to determine at compile time which subroutine it identifies.
13287 This is normally used during Perl compilation to determine whether
13288 a prototype can be applied to a function call. C<cvop> is the op
13289 being considered, normally an C<rv2cv> op. A pointer to the identified
13290 subroutine is returned, if it could be determined statically, and a null
13291 pointer is returned if it was not possible to determine statically.
13293 Currently, the subroutine can be identified statically if the RV that the
13294 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13295 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
13296 suitable if the constant value must be an RV pointing to a CV. Details of
13297 this process may change in future versions of Perl. If the C<rv2cv> op
13298 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13299 the subroutine statically: this flag is used to suppress compile-time
13300 magic on a subroutine call, forcing it to use default runtime behaviour.
13302 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13303 of a GV reference is modified. If a GV was examined and its CV slot was
13304 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13305 If the op is not optimised away, and the CV slot is later populated with
13306 a subroutine having a prototype, that flag eventually triggers the warning
13307 "called too early to check prototype".
13309 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13310 of returning a pointer to the subroutine it returns a pointer to the
13311 GV giving the most appropriate name for the subroutine in this context.
13312 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13313 (C<CvANON>) subroutine that is referenced through a GV it will be the
13314 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
13315 A null pointer is returned as usual if there is no statically-determinable
13321 /* shared by toke.c:yylex */
13323 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13325 PADNAME *name = PAD_COMPNAME(off);
13326 CV *compcv = PL_compcv;
13327 while (PadnameOUTER(name)) {
13328 assert(PARENT_PAD_INDEX(name));
13329 compcv = CvOUTSIDE(compcv);
13330 name = PadlistNAMESARRAY(CvPADLIST(compcv))
13331 [off = PARENT_PAD_INDEX(name)];
13333 assert(!PadnameIsOUR(name));
13334 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13335 return PadnamePROTOCV(name);
13337 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13341 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13346 PERL_ARGS_ASSERT_RV2CV_OP_CV;
13347 if (flags & ~RV2CVOPCV_FLAG_MASK)
13348 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13349 if (cvop->op_type != OP_RV2CV)
13351 if (cvop->op_private & OPpENTERSUB_AMPER)
13353 if (!(cvop->op_flags & OPf_KIDS))
13355 rvop = cUNOPx(cvop)->op_first;
13356 switch (rvop->op_type) {
13358 gv = cGVOPx_gv(rvop);
13360 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13361 cv = MUTABLE_CV(SvRV(gv));
13365 if (flags & RV2CVOPCV_RETURN_STUB)
13371 if (flags & RV2CVOPCV_MARK_EARLY)
13372 rvop->op_private |= OPpEARLY_CV;
13377 SV *rv = cSVOPx_sv(rvop);
13380 cv = (CV*)SvRV(rv);
13384 cv = find_lexical_cv(rvop->op_targ);
13389 } NOT_REACHED; /* NOTREACHED */
13391 if (SvTYPE((SV*)cv) != SVt_PVCV)
13393 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13394 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13398 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13399 if (CvLEXICAL(cv) || CvNAMED(cv))
13401 if (!CvANON(cv) || !gv)
13411 =for apidoc ck_entersub_args_list
13413 Performs the default fixup of the arguments part of an C<entersub>
13414 op tree. This consists of applying list context to each of the
13415 argument ops. This is the standard treatment used on a call marked
13416 with C<&>, or a method call, or a call through a subroutine reference,
13417 or any other call where the callee can't be identified at compile time,
13418 or a call where the callee has no prototype.
13424 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13428 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13430 aop = cUNOPx(entersubop)->op_first;
13431 if (!OpHAS_SIBLING(aop))
13432 aop = cUNOPx(aop)->op_first;
13433 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13434 /* skip the extra attributes->import() call implicitly added in
13435 * something like foo(my $x : bar)
13437 if ( aop->op_type == OP_ENTERSUB
13438 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13442 op_lvalue(aop, OP_ENTERSUB);
13448 =for apidoc ck_entersub_args_proto
13450 Performs the fixup of the arguments part of an C<entersub> op tree
13451 based on a subroutine prototype. This makes various modifications to
13452 the argument ops, from applying context up to inserting C<refgen> ops,
13453 and checking the number and syntactic types of arguments, as directed by
13454 the prototype. This is the standard treatment used on a subroutine call,
13455 not marked with C<&>, where the callee can be identified at compile time
13456 and has a prototype.
13458 C<protosv> supplies the subroutine prototype to be applied to the call.
13459 It may be a normal defined scalar, of which the string value will be used.
13460 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13461 that has been cast to C<SV*>) which has a prototype. The prototype
13462 supplied, in whichever form, does not need to match the actual callee
13463 referenced by the op tree.
13465 If the argument ops disagree with the prototype, for example by having
13466 an unacceptable number of arguments, a valid op tree is returned anyway.
13467 The error is reflected in the parser state, normally resulting in a single
13468 exception at the top level of parsing which covers all the compilation
13469 errors that occurred. In the error message, the callee is referred to
13470 by the name defined by the C<namegv> parameter.
13476 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13479 const char *proto, *proto_end;
13480 OP *aop, *prev, *cvop, *parent;
13483 I32 contextclass = 0;
13484 const char *e = NULL;
13485 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13486 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13487 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13488 "flags=%lx", (unsigned long) SvFLAGS(protosv));
13489 if (SvTYPE(protosv) == SVt_PVCV)
13490 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13491 else proto = SvPV(protosv, proto_len);
13492 proto = S_strip_spaces(aTHX_ proto, &proto_len);
13493 proto_end = proto + proto_len;
13494 parent = entersubop;
13495 aop = cUNOPx(entersubop)->op_first;
13496 if (!OpHAS_SIBLING(aop)) {
13498 aop = cUNOPx(aop)->op_first;
13501 aop = OpSIBLING(aop);
13502 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13503 while (aop != cvop) {
13506 if (proto >= proto_end)
13508 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13509 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13510 SVfARG(namesv)), SvUTF8(namesv));
13520 /* _ must be at the end */
13521 if (proto[1] && !strchr(";@%", proto[1]))
13537 if ( o3->op_type != OP_UNDEF
13538 && (o3->op_type != OP_SREFGEN
13539 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13541 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13543 bad_type_gv(arg, namegv, o3,
13544 arg == 1 ? "block or sub {}" : "sub {}");
13547 /* '*' allows any scalar type, including bareword */
13550 if (o3->op_type == OP_RV2GV)
13551 goto wrapref; /* autoconvert GLOB -> GLOBref */
13552 else if (o3->op_type == OP_CONST)
13553 o3->op_private &= ~OPpCONST_STRICT;
13559 if (o3->op_type == OP_RV2AV ||
13560 o3->op_type == OP_PADAV ||
13561 o3->op_type == OP_RV2HV ||
13562 o3->op_type == OP_PADHV
13568 case '[': case ']':
13575 switch (*proto++) {
13577 if (contextclass++ == 0) {
13578 e = (char *) memchr(proto, ']', proto_end - proto);
13579 if (!e || e == proto)
13587 if (contextclass) {
13588 const char *p = proto;
13589 const char *const end = proto;
13591 while (*--p != '[')
13592 /* \[$] accepts any scalar lvalue */
13594 && Perl_op_lvalue_flags(aTHX_
13596 OP_READ, /* not entersub */
13599 bad_type_gv(arg, namegv, o3,
13600 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13605 if (o3->op_type == OP_RV2GV)
13608 bad_type_gv(arg, namegv, o3, "symbol");
13611 if (o3->op_type == OP_ENTERSUB
13612 && !(o3->op_flags & OPf_STACKED))
13615 bad_type_gv(arg, namegv, o3, "subroutine");
13618 if (o3->op_type == OP_RV2SV ||
13619 o3->op_type == OP_PADSV ||
13620 o3->op_type == OP_HELEM ||
13621 o3->op_type == OP_AELEM)
13623 if (!contextclass) {
13624 /* \$ accepts any scalar lvalue */
13625 if (Perl_op_lvalue_flags(aTHX_
13627 OP_READ, /* not entersub */
13630 bad_type_gv(arg, namegv, o3, "scalar");
13634 if (o3->op_type == OP_RV2AV ||
13635 o3->op_type == OP_PADAV)
13637 o3->op_flags &=~ OPf_PARENS;
13641 bad_type_gv(arg, namegv, o3, "array");
13644 if (o3->op_type == OP_RV2HV ||
13645 o3->op_type == OP_PADHV)
13647 o3->op_flags &=~ OPf_PARENS;
13651 bad_type_gv(arg, namegv, o3, "hash");
13654 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13656 if (contextclass && e) {
13661 default: goto oops;
13671 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13672 SVfARG(cv_name((CV *)namegv, NULL, 0)),
13677 op_lvalue(aop, OP_ENTERSUB);
13679 aop = OpSIBLING(aop);
13681 if (aop == cvop && *proto == '_') {
13682 /* generate an access to $_ */
13683 op_sibling_splice(parent, prev, 0, newDEFSVOP());
13685 if (!optional && proto_end > proto &&
13686 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13688 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13689 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13690 SVfARG(namesv)), SvUTF8(namesv));
13696 =for apidoc ck_entersub_args_proto_or_list
13698 Performs the fixup of the arguments part of an C<entersub> op tree either
13699 based on a subroutine prototype or using default list-context processing.
13700 This is the standard treatment used on a subroutine call, not marked
13701 with C<&>, where the callee can be identified at compile time.
13703 C<protosv> supplies the subroutine prototype to be applied to the call,
13704 or indicates that there is no prototype. It may be a normal scalar,
13705 in which case if it is defined then the string value will be used
13706 as a prototype, and if it is undefined then there is no prototype.
13707 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13708 that has been cast to C<SV*>), of which the prototype will be used if it
13709 has one. The prototype (or lack thereof) supplied, in whichever form,
13710 does not need to match the actual callee referenced by the op tree.
13712 If the argument ops disagree with the prototype, for example by having
13713 an unacceptable number of arguments, a valid op tree is returned anyway.
13714 The error is reflected in the parser state, normally resulting in a single
13715 exception at the top level of parsing which covers all the compilation
13716 errors that occurred. In the error message, the callee is referred to
13717 by the name defined by the C<namegv> parameter.
13723 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13724 GV *namegv, SV *protosv)
13726 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13727 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13728 return ck_entersub_args_proto(entersubop, namegv, protosv);
13730 return ck_entersub_args_list(entersubop);
13734 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13736 IV cvflags = SvIVX(protosv);
13737 int opnum = cvflags & 0xffff;
13738 OP *aop = cUNOPx(entersubop)->op_first;
13740 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13744 if (!OpHAS_SIBLING(aop))
13745 aop = cUNOPx(aop)->op_first;
13746 aop = OpSIBLING(aop);
13747 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13749 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13750 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13751 SVfARG(namesv)), SvUTF8(namesv));
13754 op_free(entersubop);
13755 switch(cvflags >> 16) {
13756 case 'F': return newSVOP(OP_CONST, 0,
13757 newSVpv(CopFILE(PL_curcop),0));
13758 case 'L': return newSVOP(
13760 Perl_newSVpvf(aTHX_
13761 "%" IVdf, (IV)CopLINE(PL_curcop)
13764 case 'P': return newSVOP(OP_CONST, 0,
13766 ? newSVhek(HvNAME_HEK(PL_curstash))
13771 NOT_REACHED; /* NOTREACHED */
13774 OP *prev, *cvop, *first, *parent;
13777 parent = entersubop;
13778 if (!OpHAS_SIBLING(aop)) {
13780 aop = cUNOPx(aop)->op_first;
13783 first = prev = aop;
13784 aop = OpSIBLING(aop);
13785 /* find last sibling */
13787 OpHAS_SIBLING(cvop);
13788 prev = cvop, cvop = OpSIBLING(cvop))
13790 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13791 /* Usually, OPf_SPECIAL on an op with no args means that it had
13792 * parens, but these have their own meaning for that flag: */
13793 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13794 && opnum != OP_DELETE && opnum != OP_EXISTS)
13795 flags |= OPf_SPECIAL;
13796 /* excise cvop from end of sibling chain */
13797 op_sibling_splice(parent, prev, 1, NULL);
13799 if (aop == cvop) aop = NULL;
13801 /* detach remaining siblings from the first sibling, then
13802 * dispose of original optree */
13805 op_sibling_splice(parent, first, -1, NULL);
13806 op_free(entersubop);
13808 if (cvflags == (OP_ENTEREVAL | (1<<16)))
13809 flags |= OPpEVAL_BYTES <<8;
13811 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13813 case OA_BASEOP_OR_UNOP:
13814 case OA_FILESTATOP:
13816 return newOP(opnum,flags); /* zero args */
13818 return newUNOP(opnum,flags,aop); /* one arg */
13819 /* too many args */
13826 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13827 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13828 SVfARG(namesv)), SvUTF8(namesv));
13830 nextop = OpSIBLING(aop);
13836 return opnum == OP_RUNCV
13837 ? newPVOP(OP_RUNCV,0,NULL)
13840 return op_convert_list(opnum,0,aop);
13843 NOT_REACHED; /* NOTREACHED */
13848 =for apidoc cv_get_call_checker_flags
13850 Retrieves the function that will be used to fix up a call to C<cv>.
13851 Specifically, the function is applied to an C<entersub> op tree for a
13852 subroutine call, not marked with C<&>, where the callee can be identified
13853 at compile time as C<cv>.
13855 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13856 for it is returned in C<*ckobj_p>, and control flags are returned in
13857 C<*ckflags_p>. The function is intended to be called in this manner:
13859 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13861 In this call, C<entersubop> is a pointer to the C<entersub> op,
13862 which may be replaced by the check function, and C<namegv> supplies
13863 the name that should be used by the check function to refer
13864 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13865 It is permitted to apply the check function in non-standard situations,
13866 such as to a call to a different subroutine or to a method call.
13868 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
13869 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13870 instead, anything that can be used as the first argument to L</cv_name>.
13871 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13872 check function requires C<namegv> to be a genuine GV.
13874 By default, the check function is
13875 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13876 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13877 flag is clear. This implements standard prototype processing. It can
13878 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13880 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13881 indicates that the caller only knows about the genuine GV version of
13882 C<namegv>, and accordingly the corresponding bit will always be set in
13883 C<*ckflags_p>, regardless of the check function's recorded requirements.
13884 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13885 indicates the caller knows about the possibility of passing something
13886 other than a GV as C<namegv>, and accordingly the corresponding bit may
13887 be either set or clear in C<*ckflags_p>, indicating the check function's
13888 recorded requirements.
13890 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13891 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13892 (for which see above). All other bits should be clear.
13894 =for apidoc cv_get_call_checker
13896 The original form of L</cv_get_call_checker_flags>, which does not return
13897 checker flags. When using a checker function returned by this function,
13898 it is only safe to call it with a genuine GV as its C<namegv> argument.
13904 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13905 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13908 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13909 PERL_UNUSED_CONTEXT;
13910 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13912 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13913 *ckobj_p = callmg->mg_obj;
13914 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13916 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13917 *ckobj_p = (SV*)cv;
13918 *ckflags_p = gflags & MGf_REQUIRE_GV;
13923 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13926 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13927 PERL_UNUSED_CONTEXT;
13928 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13933 =for apidoc cv_set_call_checker_flags
13935 Sets the function that will be used to fix up a call to C<cv>.
13936 Specifically, the function is applied to an C<entersub> op tree for a
13937 subroutine call, not marked with C<&>, where the callee can be identified
13938 at compile time as C<cv>.
13940 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13941 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13942 The function should be defined like this:
13944 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13946 It is intended to be called in this manner:
13948 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13950 In this call, C<entersubop> is a pointer to the C<entersub> op,
13951 which may be replaced by the check function, and C<namegv> supplies
13952 the name that should be used by the check function to refer
13953 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13954 It is permitted to apply the check function in non-standard situations,
13955 such as to a call to a different subroutine or to a method call.
13957 C<namegv> may not actually be a GV. For efficiency, perl may pass a
13958 CV or other SV instead. Whatever is passed can be used as the first
13959 argument to L</cv_name>. You can force perl to pass a GV by including
13960 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13962 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13963 bit currently has a defined meaning (for which see above). All other
13964 bits should be clear.
13966 The current setting for a particular CV can be retrieved by
13967 L</cv_get_call_checker_flags>.
13969 =for apidoc cv_set_call_checker
13971 The original form of L</cv_set_call_checker_flags>, which passes it the
13972 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
13973 of that flag setting is that the check function is guaranteed to get a
13974 genuine GV as its C<namegv> argument.
13980 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13982 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13983 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13987 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13988 SV *ckobj, U32 ckflags)
13990 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13991 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13992 if (SvMAGICAL((SV*)cv))
13993 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13996 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13997 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13999 if (callmg->mg_flags & MGf_REFCOUNTED) {
14000 SvREFCNT_dec(callmg->mg_obj);
14001 callmg->mg_flags &= ~MGf_REFCOUNTED;
14003 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
14004 callmg->mg_obj = ckobj;
14005 if (ckobj != (SV*)cv) {
14006 SvREFCNT_inc_simple_void_NN(ckobj);
14007 callmg->mg_flags |= MGf_REFCOUNTED;
14009 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
14010 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
14015 S_entersub_alloc_targ(pTHX_ OP * const o)
14017 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14018 o->op_private |= OPpENTERSUB_HASTARG;
14022 Perl_ck_subr(pTHX_ OP *o)
14027 SV **const_class = NULL;
14029 PERL_ARGS_ASSERT_CK_SUBR;
14031 aop = cUNOPx(o)->op_first;
14032 if (!OpHAS_SIBLING(aop))
14033 aop = cUNOPx(aop)->op_first;
14034 aop = OpSIBLING(aop);
14035 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14036 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
14037 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
14039 o->op_private &= ~1;
14040 o->op_private |= (PL_hints & HINT_STRICT_REFS);
14041 if (PERLDB_SUB && PL_curstash != PL_debstash)
14042 o->op_private |= OPpENTERSUB_DB;
14043 switch (cvop->op_type) {
14045 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
14049 case OP_METHOD_NAMED:
14050 case OP_METHOD_SUPER:
14051 case OP_METHOD_REDIR:
14052 case OP_METHOD_REDIR_SUPER:
14053 o->op_flags |= OPf_REF;
14054 if (aop->op_type == OP_CONST) {
14055 aop->op_private &= ~OPpCONST_STRICT;
14056 const_class = &cSVOPx(aop)->op_sv;
14058 else if (aop->op_type == OP_LIST) {
14059 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
14060 if (sib && sib->op_type == OP_CONST) {
14061 sib->op_private &= ~OPpCONST_STRICT;
14062 const_class = &cSVOPx(sib)->op_sv;
14065 /* make class name a shared cow string to speedup method calls */
14066 /* constant string might be replaced with object, f.e. bigint */
14067 if (const_class && SvPOK(*const_class)) {
14069 const char* str = SvPV(*const_class, len);
14071 SV* const shared = newSVpvn_share(
14072 str, SvUTF8(*const_class)
14073 ? -(SSize_t)len : (SSize_t)len,
14076 if (SvREADONLY(*const_class))
14077 SvREADONLY_on(shared);
14078 SvREFCNT_dec(*const_class);
14079 *const_class = shared;
14086 S_entersub_alloc_targ(aTHX_ o);
14087 return ck_entersub_args_list(o);
14089 Perl_call_checker ckfun;
14092 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
14093 if (CvISXSUB(cv) || !CvROOT(cv))
14094 S_entersub_alloc_targ(aTHX_ o);
14096 /* The original call checker API guarantees that a GV will be
14097 be provided with the right name. So, if the old API was
14098 used (or the REQUIRE_GV flag was passed), we have to reify
14099 the CV’s GV, unless this is an anonymous sub. This is not
14100 ideal for lexical subs, as its stringification will include
14101 the package. But it is the best we can do. */
14102 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
14103 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
14106 else namegv = MUTABLE_GV(cv);
14107 /* After a syntax error in a lexical sub, the cv that
14108 rv2cv_op_cv returns may be a nameless stub. */
14109 if (!namegv) return ck_entersub_args_list(o);
14112 return ckfun(aTHX_ o, namegv, ckobj);
14117 Perl_ck_svconst(pTHX_ OP *o)
14119 SV * const sv = cSVOPo->op_sv;
14120 PERL_ARGS_ASSERT_CK_SVCONST;
14121 PERL_UNUSED_CONTEXT;
14122 #ifdef PERL_COPY_ON_WRITE
14123 /* Since the read-only flag may be used to protect a string buffer, we
14124 cannot do copy-on-write with existing read-only scalars that are not
14125 already copy-on-write scalars. To allow $_ = "hello" to do COW with
14126 that constant, mark the constant as COWable here, if it is not
14127 already read-only. */
14128 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
14131 # ifdef PERL_DEBUG_READONLY_COW
14141 Perl_ck_trunc(pTHX_ OP *o)
14143 PERL_ARGS_ASSERT_CK_TRUNC;
14145 if (o->op_flags & OPf_KIDS) {
14146 SVOP *kid = (SVOP*)cUNOPo->op_first;
14148 if (kid->op_type == OP_NULL)
14149 kid = (SVOP*)OpSIBLING(kid);
14150 if (kid && kid->op_type == OP_CONST &&
14151 (kid->op_private & OPpCONST_BARE) &&
14154 o->op_flags |= OPf_SPECIAL;
14155 kid->op_private &= ~OPpCONST_STRICT;
14162 Perl_ck_substr(pTHX_ OP *o)
14164 PERL_ARGS_ASSERT_CK_SUBSTR;
14167 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
14168 OP *kid = cLISTOPo->op_first;
14170 if (kid->op_type == OP_NULL)
14171 kid = OpSIBLING(kid);
14173 /* Historically, substr(delete $foo{bar},...) has been allowed
14174 with 4-arg substr. Keep it working by applying entersub
14176 op_lvalue(kid, OP_ENTERSUB);
14183 Perl_ck_tell(pTHX_ OP *o)
14185 PERL_ARGS_ASSERT_CK_TELL;
14187 if (o->op_flags & OPf_KIDS) {
14188 OP *kid = cLISTOPo->op_first;
14189 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
14190 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
14196 Perl_ck_each(pTHX_ OP *o)
14199 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
14200 const unsigned orig_type = o->op_type;
14202 PERL_ARGS_ASSERT_CK_EACH;
14205 switch (kid->op_type) {
14211 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
14212 : orig_type == OP_KEYS ? OP_AKEYS
14216 if (kid->op_private == OPpCONST_BARE
14217 || !SvROK(cSVOPx_sv(kid))
14218 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
14219 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
14224 qerror(Perl_mess(aTHX_
14225 "Experimental %s on scalar is now forbidden",
14226 PL_op_desc[orig_type]));
14228 bad_type_pv(1, "hash or array", o, kid);
14236 Perl_ck_length(pTHX_ OP *o)
14238 PERL_ARGS_ASSERT_CK_LENGTH;
14242 if (ckWARN(WARN_SYNTAX)) {
14243 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
14247 const bool hash = kid->op_type == OP_PADHV
14248 || kid->op_type == OP_RV2HV;
14249 switch (kid->op_type) {
14254 name = S_op_varname(aTHX_ kid);
14260 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14261 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
14263 SVfARG(name), hash ? "keys " : "", SVfARG(name)
14266 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14267 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14268 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
14270 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14271 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14272 "length() used on @array (did you mean \"scalar(@array)\"?)");
14282 ---------------------------------------------------------
14284 Common vars in list assignment
14286 There now follows some enums and static functions for detecting
14287 common variables in list assignments. Here is a little essay I wrote
14288 for myself when trying to get my head around this. DAPM.
14292 First some random observations:
14294 * If a lexical var is an alias of something else, e.g.
14295 for my $x ($lex, $pkg, $a[0]) {...}
14296 then the act of aliasing will increase the reference count of the SV
14298 * If a package var is an alias of something else, it may still have a
14299 reference count of 1, depending on how the alias was created, e.g.
14300 in *a = *b, $a may have a refcount of 1 since the GP is shared
14301 with a single GvSV pointer to the SV. So If it's an alias of another
14302 package var, then RC may be 1; if it's an alias of another scalar, e.g.
14303 a lexical var or an array element, then it will have RC > 1.
14305 * There are many ways to create a package alias; ultimately, XS code
14306 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
14307 run-time tracing mechanisms are unlikely to be able to catch all cases.
14309 * When the LHS is all my declarations, the same vars can't appear directly
14310 on the RHS, but they can indirectly via closures, aliasing and lvalue
14311 subs. But those techniques all involve an increase in the lexical
14312 scalar's ref count.
14314 * When the LHS is all lexical vars (but not necessarily my declarations),
14315 it is possible for the same lexicals to appear directly on the RHS, and
14316 without an increased ref count, since the stack isn't refcounted.
14317 This case can be detected at compile time by scanning for common lex
14318 vars with PL_generation.
14320 * lvalue subs defeat common var detection, but they do at least
14321 return vars with a temporary ref count increment. Also, you can't
14322 tell at compile time whether a sub call is lvalue.
14327 A: There are a few circumstances where there definitely can't be any
14330 LHS empty: () = (...);
14331 RHS empty: (....) = ();
14332 RHS contains only constants or other 'can't possibly be shared'
14333 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
14334 i.e. they only contain ops not marked as dangerous, whose children
14335 are also not dangerous;
14337 LHS contains a single scalar element: e.g. ($x) = (....); because
14338 after $x has been modified, it won't be used again on the RHS;
14339 RHS contains a single element with no aggregate on LHS: e.g.
14340 ($a,$b,$c) = ($x); again, once $a has been modified, its value
14341 won't be used again.
14343 B: If LHS are all 'my' lexical var declarations (or safe ops, which
14346 my ($a, $b, @c) = ...;
14348 Due to closure and goto tricks, these vars may already have content.
14349 For the same reason, an element on the RHS may be a lexical or package
14350 alias of one of the vars on the left, or share common elements, for
14353 my ($x,$y) = f(); # $x and $y on both sides
14354 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14359 my @a = @$ra; # elements of @a on both sides
14360 sub f { @a = 1..4; \@a }
14363 First, just consider scalar vars on LHS:
14365 RHS is safe only if (A), or in addition,
14366 * contains only lexical *scalar* vars, where neither side's
14367 lexicals have been flagged as aliases
14369 If RHS is not safe, then it's always legal to check LHS vars for
14370 RC==1, since the only RHS aliases will always be associated
14373 Note that in particular, RHS is not safe if:
14375 * it contains package scalar vars; e.g.:
14378 my ($x, $y) = (2, $x_alias);
14379 sub f { $x = 1; *x_alias = \$x; }
14381 * It contains other general elements, such as flattened or
14382 * spliced or single array or hash elements, e.g.
14385 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14389 use feature 'refaliasing';
14390 \($a[0], $a[1]) = \($y,$x);
14393 It doesn't matter if the array/hash is lexical or package.
14395 * it contains a function call that happens to be an lvalue
14396 sub which returns one or more of the above, e.g.
14407 (so a sub call on the RHS should be treated the same
14408 as having a package var on the RHS).
14410 * any other "dangerous" thing, such an op or built-in that
14411 returns one of the above, e.g. pp_preinc
14414 If RHS is not safe, what we can do however is at compile time flag
14415 that the LHS are all my declarations, and at run time check whether
14416 all the LHS have RC == 1, and if so skip the full scan.
14418 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14420 Here the issue is whether there can be elements of @a on the RHS
14421 which will get prematurely freed when @a is cleared prior to
14422 assignment. This is only a problem if the aliasing mechanism
14423 is one which doesn't increase the refcount - only if RC == 1
14424 will the RHS element be prematurely freed.
14426 Because the array/hash is being INTROed, it or its elements
14427 can't directly appear on the RHS:
14429 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14431 but can indirectly, e.g.:
14435 sub f { @a = 1..3; \@a }
14437 So if the RHS isn't safe as defined by (A), we must always
14438 mortalise and bump the ref count of any remaining RHS elements
14439 when assigning to a non-empty LHS aggregate.
14441 Lexical scalars on the RHS aren't safe if they've been involved in
14444 use feature 'refaliasing';
14447 \(my $lex) = \$pkg;
14448 my @a = ($lex,3); # equivalent to ($a[0],3)
14455 Similarly with lexical arrays and hashes on the RHS:
14469 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14470 my $a; ($a, my $b) = (....);
14472 The difference between (B) and (C) is that it is now physically
14473 possible for the LHS vars to appear on the RHS too, where they
14474 are not reference counted; but in this case, the compile-time
14475 PL_generation sweep will detect such common vars.
14477 So the rules for (C) differ from (B) in that if common vars are
14478 detected, the runtime "test RC==1" optimisation can no longer be used,
14479 and a full mark and sweep is required
14481 D: As (C), but in addition the LHS may contain package vars.
14483 Since package vars can be aliased without a corresponding refcount
14484 increase, all bets are off. It's only safe if (A). E.g.
14486 my ($x, $y) = (1,2);
14488 for $x_alias ($x) {
14489 ($x_alias, $y) = (3, $x); # whoops
14492 Ditto for LHS aggregate package vars.
14494 E: Any other dangerous ops on LHS, e.g.
14495 (f(), $a[0], @$r) = (...);
14497 this is similar to (E) in that all bets are off. In addition, it's
14498 impossible to determine at compile time whether the LHS
14499 contains a scalar or an aggregate, e.g.
14501 sub f : lvalue { @a }
14504 * ---------------------------------------------------------
14508 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14509 * that at least one of the things flagged was seen.
14513 AAS_MY_SCALAR = 0x001, /* my $scalar */
14514 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
14515 AAS_LEX_SCALAR = 0x004, /* $lexical */
14516 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
14517 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14518 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
14519 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
14520 AAS_DANGEROUS = 0x080, /* an op (other than the above)
14521 that's flagged OA_DANGEROUS */
14522 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
14523 not in any of the categories above */
14524 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
14529 /* helper function for S_aassign_scan().
14530 * check a PAD-related op for commonality and/or set its generation number.
14531 * Returns a boolean indicating whether its shared */
14534 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14536 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14537 /* lexical used in aliasing */
14541 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14543 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14550 Helper function for OPpASSIGN_COMMON* detection in rpeep().
14551 It scans the left or right hand subtree of the aassign op, and returns a
14552 set of flags indicating what sorts of things it found there.
14553 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14554 set PL_generation on lexical vars; if the latter, we see if
14555 PL_generation matches.
14556 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14557 This fn will increment it by the number seen. It's not intended to
14558 be an accurate count (especially as many ops can push a variable
14559 number of SVs onto the stack); rather it's used as to test whether there
14560 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14564 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
14567 OP *effective_top_op = o;
14571 bool top = o == effective_top_op;
14573 OP* next_kid = NULL;
14575 /* first, look for a solitary @_ on the RHS */
14578 && (o->op_flags & OPf_KIDS)
14579 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14581 OP *kid = cUNOPo->op_first;
14582 if ( ( kid->op_type == OP_PUSHMARK
14583 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14584 && ((kid = OpSIBLING(kid)))
14585 && !OpHAS_SIBLING(kid)
14586 && kid->op_type == OP_RV2AV
14587 && !(kid->op_flags & OPf_REF)
14588 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14589 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14590 && ((kid = cUNOPx(kid)->op_first))
14591 && kid->op_type == OP_GV
14592 && cGVOPx_gv(kid) == PL_defgv
14597 switch (o->op_type) {
14600 all_flags |= AAS_PKG_SCALAR;
14606 /* if !top, could be e.g. @a[0,1] */
14607 all_flags |= (top && (o->op_flags & OPf_REF))
14608 ? ((o->op_private & OPpLVAL_INTRO)
14609 ? AAS_MY_AGG : AAS_LEX_AGG)
14615 int comm = S_aassign_padcheck(aTHX_ o, rhs)
14616 ? AAS_LEX_SCALAR_COMM : 0;
14618 all_flags |= (o->op_private & OPpLVAL_INTRO)
14619 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14627 if (cUNOPx(o)->op_first->op_type != OP_GV)
14628 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
14630 /* if !top, could be e.g. @a[0,1] */
14631 else if (top && (o->op_flags & OPf_REF))
14632 all_flags |= AAS_PKG_AGG;
14634 all_flags |= AAS_DANGEROUS;
14639 if (cUNOPx(o)->op_first->op_type != OP_GV) {
14641 all_flags |= AAS_DANGEROUS; /* ${expr} */
14644 all_flags |= AAS_PKG_SCALAR; /* $pkg */
14648 if (o->op_private & OPpSPLIT_ASSIGN) {
14649 /* the assign in @a = split() has been optimised away
14650 * and the @a attached directly to the split op
14651 * Treat the array as appearing on the RHS, i.e.
14652 * ... = (@a = split)
14657 if (o->op_flags & OPf_STACKED) {
14658 /* @{expr} = split() - the array expression is tacked
14659 * on as an extra child to split - process kid */
14660 next_kid = cLISTOPo->op_last;
14664 /* ... else array is directly attached to split op */
14666 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
14667 ? ((o->op_private & OPpLVAL_INTRO)
14668 ? AAS_MY_AGG : AAS_LEX_AGG)
14673 /* other args of split can't be returned */
14674 all_flags |= AAS_SAFE_SCALAR;
14678 /* undef counts as a scalar on the RHS:
14679 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
14680 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
14684 flags = AAS_SAFE_SCALAR;
14689 /* these are all no-ops; they don't push a potentially common SV
14690 * onto the stack, so they are neither AAS_DANGEROUS nor
14691 * AAS_SAFE_SCALAR */
14694 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14699 /* these do nothing, but may have children */
14703 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14705 flags = AAS_DANGEROUS;
14709 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
14710 && (o->op_private & OPpTARGET_MY))
14713 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
14714 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14718 /* if its an unrecognised, non-dangerous op, assume that it
14719 * it the cause of at least one safe scalar */
14721 flags = AAS_SAFE_SCALAR;
14725 all_flags |= flags;
14727 /* by default, process all kids next
14728 * XXX this assumes that all other ops are "transparent" - i.e. that
14729 * they can return some of their children. While this true for e.g.
14730 * sort and grep, it's not true for e.g. map. We really need a
14731 * 'transparent' flag added to regen/opcodes
14733 if (o->op_flags & OPf_KIDS) {
14734 next_kid = cUNOPo->op_first;
14735 /* these ops do nothing but may have children; but their
14736 * children should also be treated as top-level */
14737 if ( o == effective_top_op
14738 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
14740 effective_top_op = next_kid;
14744 /* If next_kid is set, someone in the code above wanted us to process
14745 * that kid and all its remaining siblings. Otherwise, work our way
14746 * back up the tree */
14748 while (!next_kid) {
14750 return all_flags; /* at top; no parents/siblings to try */
14751 if (OpHAS_SIBLING(o)) {
14752 next_kid = o->op_sibparent;
14753 if (o == effective_top_op)
14754 effective_top_op = next_kid;
14757 if (o == effective_top_op)
14758 effective_top_op = o->op_sibparent;
14759 o = o->op_sibparent; /* try parent's next sibling */
14768 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14769 and modify the optree to make them work inplace */
14772 S_inplace_aassign(pTHX_ OP *o) {
14774 OP *modop, *modop_pushmark;
14776 OP *oleft, *oleft_pushmark;
14778 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14780 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14782 assert(cUNOPo->op_first->op_type == OP_NULL);
14783 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14784 assert(modop_pushmark->op_type == OP_PUSHMARK);
14785 modop = OpSIBLING(modop_pushmark);
14787 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14790 /* no other operation except sort/reverse */
14791 if (OpHAS_SIBLING(modop))
14794 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14795 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14797 if (modop->op_flags & OPf_STACKED) {
14798 /* skip sort subroutine/block */
14799 assert(oright->op_type == OP_NULL);
14800 oright = OpSIBLING(oright);
14803 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14804 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14805 assert(oleft_pushmark->op_type == OP_PUSHMARK);
14806 oleft = OpSIBLING(oleft_pushmark);
14808 /* Check the lhs is an array */
14810 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14811 || OpHAS_SIBLING(oleft)
14812 || (oleft->op_private & OPpLVAL_INTRO)
14816 /* Only one thing on the rhs */
14817 if (OpHAS_SIBLING(oright))
14820 /* check the array is the same on both sides */
14821 if (oleft->op_type == OP_RV2AV) {
14822 if (oright->op_type != OP_RV2AV
14823 || !cUNOPx(oright)->op_first
14824 || cUNOPx(oright)->op_first->op_type != OP_GV
14825 || cUNOPx(oleft )->op_first->op_type != OP_GV
14826 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14827 cGVOPx_gv(cUNOPx(oright)->op_first)
14831 else if (oright->op_type != OP_PADAV
14832 || oright->op_targ != oleft->op_targ
14836 /* This actually is an inplace assignment */
14838 modop->op_private |= OPpSORT_INPLACE;
14840 /* transfer MODishness etc from LHS arg to RHS arg */
14841 oright->op_flags = oleft->op_flags;
14843 /* remove the aassign op and the lhs */
14845 op_null(oleft_pushmark);
14846 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14847 op_null(cUNOPx(oleft)->op_first);
14853 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14854 * that potentially represent a series of one or more aggregate derefs
14855 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14856 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14857 * additional ops left in too).
14859 * The caller will have already verified that the first few ops in the
14860 * chain following 'start' indicate a multideref candidate, and will have
14861 * set 'orig_o' to the point further on in the chain where the first index
14862 * expression (if any) begins. 'orig_action' specifies what type of
14863 * beginning has already been determined by the ops between start..orig_o
14864 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
14866 * 'hints' contains any hints flags that need adding (currently just
14867 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14871 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14875 UNOP_AUX_item *arg_buf = NULL;
14876 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
14877 int index_skip = -1; /* don't output index arg on this action */
14879 /* similar to regex compiling, do two passes; the first pass
14880 * determines whether the op chain is convertible and calculates the
14881 * buffer size; the second pass populates the buffer and makes any
14882 * changes necessary to ops (such as moving consts to the pad on
14883 * threaded builds).
14885 * NB: for things like Coverity, note that both passes take the same
14886 * path through the logic tree (except for 'if (pass)' bits), since
14887 * both passes are following the same op_next chain; and in
14888 * particular, if it would return early on the second pass, it would
14889 * already have returned early on the first pass.
14891 for (pass = 0; pass < 2; pass++) {
14893 UV action = orig_action;
14894 OP *first_elem_op = NULL; /* first seen aelem/helem */
14895 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
14896 int action_count = 0; /* number of actions seen so far */
14897 int action_ix = 0; /* action_count % (actions per IV) */
14898 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
14899 bool is_last = FALSE; /* no more derefs to follow */
14900 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14901 UNOP_AUX_item *arg = arg_buf;
14902 UNOP_AUX_item *action_ptr = arg_buf;
14905 action_ptr->uv = 0;
14909 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14910 case MDEREF_HV_gvhv_helem:
14911 next_is_hash = TRUE;
14913 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14914 case MDEREF_AV_gvav_aelem:
14916 #ifdef USE_ITHREADS
14917 arg->pad_offset = cPADOPx(start)->op_padix;
14918 /* stop it being swiped when nulled */
14919 cPADOPx(start)->op_padix = 0;
14921 arg->sv = cSVOPx(start)->op_sv;
14922 cSVOPx(start)->op_sv = NULL;
14928 case MDEREF_HV_padhv_helem:
14929 case MDEREF_HV_padsv_vivify_rv2hv_helem:
14930 next_is_hash = TRUE;
14932 case MDEREF_AV_padav_aelem:
14933 case MDEREF_AV_padsv_vivify_rv2av_aelem:
14935 arg->pad_offset = start->op_targ;
14936 /* we skip setting op_targ = 0 for now, since the intact
14937 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14938 reset_start_targ = TRUE;
14943 case MDEREF_HV_pop_rv2hv_helem:
14944 next_is_hash = TRUE;
14946 case MDEREF_AV_pop_rv2av_aelem:
14950 NOT_REACHED; /* NOTREACHED */
14955 /* look for another (rv2av/hv; get index;
14956 * aelem/helem/exists/delele) sequence */
14961 UV index_type = MDEREF_INDEX_none;
14963 if (action_count) {
14964 /* if this is not the first lookup, consume the rv2av/hv */
14966 /* for N levels of aggregate lookup, we normally expect
14967 * that the first N-1 [ah]elem ops will be flagged as
14968 * /DEREF (so they autovivifiy if necessary), and the last
14969 * lookup op not to be.
14970 * For other things (like @{$h{k1}{k2}}) extra scope or
14971 * leave ops can appear, so abandon the effort in that
14973 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14976 /* rv2av or rv2hv sKR/1 */
14978 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14979 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14980 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14983 /* at this point, we wouldn't expect any of these
14984 * possible private flags:
14985 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14986 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14988 ASSUME(!(o->op_private &
14989 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14991 hints = (o->op_private & OPpHINT_STRICT_REFS);
14993 /* make sure the type of the previous /DEREF matches the
14994 * type of the next lookup */
14995 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14998 action = next_is_hash
14999 ? MDEREF_HV_vivify_rv2hv_helem
15000 : MDEREF_AV_vivify_rv2av_aelem;
15004 /* if this is the second pass, and we're at the depth where
15005 * previously we encountered a non-simple index expression,
15006 * stop processing the index at this point */
15007 if (action_count != index_skip) {
15009 /* look for one or more simple ops that return an array
15010 * index or hash key */
15012 switch (o->op_type) {
15014 /* it may be a lexical var index */
15015 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
15016 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15017 ASSUME(!(o->op_private &
15018 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15020 if ( OP_GIMME(o,0) == G_SCALAR
15021 && !(o->op_flags & (OPf_REF|OPf_MOD))
15022 && o->op_private == 0)
15025 arg->pad_offset = o->op_targ;
15027 index_type = MDEREF_INDEX_padsv;
15033 if (next_is_hash) {
15034 /* it's a constant hash index */
15035 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
15036 /* "use constant foo => FOO; $h{+foo}" for
15037 * some weird FOO, can leave you with constants
15038 * that aren't simple strings. It's not worth
15039 * the extra hassle for those edge cases */
15044 OP * helem_op = o->op_next;
15046 ASSUME( helem_op->op_type == OP_HELEM
15047 || helem_op->op_type == OP_NULL
15049 if (helem_op->op_type == OP_HELEM) {
15050 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
15051 if ( helem_op->op_private & OPpLVAL_INTRO
15052 || rop->op_type != OP_RV2HV
15056 /* on first pass just check; on second pass
15058 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
15063 #ifdef USE_ITHREADS
15064 /* Relocate sv to the pad for thread safety */
15065 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
15066 arg->pad_offset = o->op_targ;
15069 arg->sv = cSVOPx_sv(o);
15074 /* it's a constant array index */
15076 SV *ix_sv = cSVOPo->op_sv;
15081 if ( action_count == 0
15084 && ( action == MDEREF_AV_padav_aelem
15085 || action == MDEREF_AV_gvav_aelem)
15087 maybe_aelemfast = TRUE;
15091 SvREFCNT_dec_NN(cSVOPo->op_sv);
15095 /* we've taken ownership of the SV */
15096 cSVOPo->op_sv = NULL;
15098 index_type = MDEREF_INDEX_const;
15103 /* it may be a package var index */
15105 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
15106 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
15107 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
15108 || o->op_private != 0
15113 if (kid->op_type != OP_RV2SV)
15116 ASSUME(!(kid->op_flags &
15117 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
15118 |OPf_SPECIAL|OPf_PARENS)));
15119 ASSUME(!(kid->op_private &
15121 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
15122 |OPpDEREF|OPpLVAL_INTRO)));
15123 if( (kid->op_flags &~ OPf_PARENS)
15124 != (OPf_WANT_SCALAR|OPf_KIDS)
15125 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
15130 #ifdef USE_ITHREADS
15131 arg->pad_offset = cPADOPx(o)->op_padix;
15132 /* stop it being swiped when nulled */
15133 cPADOPx(o)->op_padix = 0;
15135 arg->sv = cSVOPx(o)->op_sv;
15136 cSVOPo->op_sv = NULL;
15140 index_type = MDEREF_INDEX_gvsv;
15145 } /* action_count != index_skip */
15147 action |= index_type;
15150 /* at this point we have either:
15151 * * detected what looks like a simple index expression,
15152 * and expect the next op to be an [ah]elem, or
15153 * an nulled [ah]elem followed by a delete or exists;
15154 * * found a more complex expression, so something other
15155 * than the above follows.
15158 /* possibly an optimised away [ah]elem (where op_next is
15159 * exists or delete) */
15160 if (o->op_type == OP_NULL)
15163 /* at this point we're looking for an OP_AELEM, OP_HELEM,
15164 * OP_EXISTS or OP_DELETE */
15166 /* if a custom array/hash access checker is in scope,
15167 * abandon optimisation attempt */
15168 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
15169 && PL_check[o->op_type] != Perl_ck_null)
15171 /* similarly for customised exists and delete */
15172 if ( (o->op_type == OP_EXISTS)
15173 && PL_check[o->op_type] != Perl_ck_exists)
15175 if ( (o->op_type == OP_DELETE)
15176 && PL_check[o->op_type] != Perl_ck_delete)
15179 if ( o->op_type != OP_AELEM
15180 || (o->op_private &
15181 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
15183 maybe_aelemfast = FALSE;
15185 /* look for aelem/helem/exists/delete. If it's not the last elem
15186 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
15187 * flags; if it's the last, then it mustn't have
15188 * OPpDEREF_AV/HV, but may have lots of other flags, like
15189 * OPpLVAL_INTRO etc
15192 if ( index_type == MDEREF_INDEX_none
15193 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
15194 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
15198 /* we have aelem/helem/exists/delete with valid simple index */
15200 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
15201 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
15202 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
15204 /* This doesn't make much sense but is legal:
15205 * @{ local $x[0][0] } = 1
15206 * Since scope exit will undo the autovivification,
15207 * don't bother in the first place. The OP_LEAVE
15208 * assertion is in case there are other cases of both
15209 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
15210 * exit that would undo the local - in which case this
15211 * block of code would need rethinking.
15213 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
15215 OP *n = o->op_next;
15216 while (n && ( n->op_type == OP_NULL
15217 || n->op_type == OP_LIST
15218 || n->op_type == OP_SCALAR))
15220 assert(n && n->op_type == OP_LEAVE);
15222 o->op_private &= ~OPpDEREF;
15227 ASSUME(!(o->op_flags &
15228 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
15229 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
15231 ok = (o->op_flags &~ OPf_PARENS)
15232 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
15233 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
15235 else if (o->op_type == OP_EXISTS) {
15236 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15237 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15238 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
15239 ok = !(o->op_private & ~OPpARG1_MASK);
15241 else if (o->op_type == OP_DELETE) {
15242 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15243 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15244 ASSUME(!(o->op_private &
15245 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
15246 /* don't handle slices or 'local delete'; the latter
15247 * is fairly rare, and has a complex runtime */
15248 ok = !(o->op_private & ~OPpARG1_MASK);
15249 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
15250 /* skip handling run-tome error */
15251 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
15254 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
15255 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
15256 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
15257 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
15258 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
15259 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
15264 if (!first_elem_op)
15268 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
15273 action |= MDEREF_FLAG_last;
15277 /* at this point we have something that started
15278 * promisingly enough (with rv2av or whatever), but failed
15279 * to find a simple index followed by an
15280 * aelem/helem/exists/delete. If this is the first action,
15281 * give up; but if we've already seen at least one
15282 * aelem/helem, then keep them and add a new action with
15283 * MDEREF_INDEX_none, which causes it to do the vivify
15284 * from the end of the previous lookup, and do the deref,
15285 * but stop at that point. So $a[0][expr] will do one
15286 * av_fetch, vivify and deref, then continue executing at
15291 index_skip = action_count;
15292 action |= MDEREF_FLAG_last;
15293 if (index_type != MDEREF_INDEX_none)
15298 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
15301 /* if there's no space for the next action, create a new slot
15302 * for it *before* we start adding args for that action */
15303 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
15310 } /* while !is_last */
15318 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
15319 if (index_skip == -1) {
15320 mderef->op_flags = o->op_flags
15321 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
15322 if (o->op_type == OP_EXISTS)
15323 mderef->op_private = OPpMULTIDEREF_EXISTS;
15324 else if (o->op_type == OP_DELETE)
15325 mderef->op_private = OPpMULTIDEREF_DELETE;
15327 mderef->op_private = o->op_private
15328 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
15330 /* accumulate strictness from every level (although I don't think
15331 * they can actually vary) */
15332 mderef->op_private |= hints;
15334 /* integrate the new multideref op into the optree and the
15337 * In general an op like aelem or helem has two child
15338 * sub-trees: the aggregate expression (a_expr) and the
15339 * index expression (i_expr):
15345 * The a_expr returns an AV or HV, while the i-expr returns an
15346 * index. In general a multideref replaces most or all of a
15347 * multi-level tree, e.g.
15363 * With multideref, all the i_exprs will be simple vars or
15364 * constants, except that i_expr1 may be arbitrary in the case
15365 * of MDEREF_INDEX_none.
15367 * The bottom-most a_expr will be either:
15368 * 1) a simple var (so padXv or gv+rv2Xv);
15369 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
15370 * so a simple var with an extra rv2Xv;
15371 * 3) or an arbitrary expression.
15373 * 'start', the first op in the execution chain, will point to
15374 * 1),2): the padXv or gv op;
15375 * 3): the rv2Xv which forms the last op in the a_expr
15376 * execution chain, and the top-most op in the a_expr
15379 * For all cases, the 'start' node is no longer required,
15380 * but we can't free it since one or more external nodes
15381 * may point to it. E.g. consider
15382 * $h{foo} = $a ? $b : $c
15383 * Here, both the op_next and op_other branches of the
15384 * cond_expr point to the gv[*h] of the hash expression, so
15385 * we can't free the 'start' op.
15387 * For expr->[...], we need to save the subtree containing the
15388 * expression; for the other cases, we just need to save the
15390 * So in all cases, we null the start op and keep it around by
15391 * making it the child of the multideref op; for the expr->
15392 * case, the expr will be a subtree of the start node.
15394 * So in the simple 1,2 case the optree above changes to
15400 * ex-gv (or ex-padxv)
15402 * with the op_next chain being
15404 * -> ex-gv -> multideref -> op-following-ex-exists ->
15406 * In the 3 case, we have
15419 * -> rest-of-a_expr subtree ->
15420 * ex-rv2xv -> multideref -> op-following-ex-exists ->
15423 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15424 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15425 * multideref attached as the child, e.g.
15431 * ex-rv2av - i_expr1
15439 /* if we free this op, don't free the pad entry */
15440 if (reset_start_targ)
15441 start->op_targ = 0;
15444 /* Cut the bit we need to save out of the tree and attach to
15445 * the multideref op, then free the rest of the tree */
15447 /* find parent of node to be detached (for use by splice) */
15449 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
15450 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15452 /* there is an arbitrary expression preceding us, e.g.
15453 * expr->[..]? so we need to save the 'expr' subtree */
15454 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15455 p = cUNOPx(p)->op_first;
15456 ASSUME( start->op_type == OP_RV2AV
15457 || start->op_type == OP_RV2HV);
15460 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15461 * above for exists/delete. */
15462 while ( (p->op_flags & OPf_KIDS)
15463 && cUNOPx(p)->op_first != start
15465 p = cUNOPx(p)->op_first;
15467 ASSUME(cUNOPx(p)->op_first == start);
15469 /* detach from main tree, and re-attach under the multideref */
15470 op_sibling_splice(mderef, NULL, 0,
15471 op_sibling_splice(p, NULL, 1, NULL));
15474 start->op_next = mderef;
15476 mderef->op_next = index_skip == -1 ? o->op_next : o;
15478 /* excise and free the original tree, and replace with
15479 * the multideref op */
15480 p = op_sibling_splice(top_op, NULL, -1, mderef);
15489 Size_t size = arg - arg_buf;
15491 if (maybe_aelemfast && action_count == 1)
15494 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15495 sizeof(UNOP_AUX_item) * (size + 1));
15496 /* for dumping etc: store the length in a hidden first slot;
15497 * we set the op_aux pointer to the second slot */
15498 arg_buf->uv = size;
15501 } /* for (pass = ...) */
15504 /* See if the ops following o are such that o will always be executed in
15505 * boolean context: that is, the SV which o pushes onto the stack will
15506 * only ever be consumed by later ops via SvTRUE(sv) or similar.
15507 * If so, set a suitable private flag on o. Normally this will be
15508 * bool_flag; but see below why maybe_flag is needed too.
15510 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15511 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15512 * already be taken, so you'll have to give that op two different flags.
15514 * More explanation of 'maybe_flag' and 'safe_and' parameters.
15515 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15516 * those underlying ops) short-circuit, which means that rather than
15517 * necessarily returning a truth value, they may return the LH argument,
15518 * which may not be boolean. For example in $x = (keys %h || -1), keys
15519 * should return a key count rather than a boolean, even though its
15520 * sort-of being used in boolean context.
15522 * So we only consider such logical ops to provide boolean context to
15523 * their LH argument if they themselves are in void or boolean context.
15524 * However, sometimes the context isn't known until run-time. In this
15525 * case the op is marked with the maybe_flag flag it.
15527 * Consider the following.
15529 * sub f { ....; if (%h) { .... } }
15531 * This is actually compiled as
15533 * sub f { ....; %h && do { .... } }
15535 * Here we won't know until runtime whether the final statement (and hence
15536 * the &&) is in void context and so is safe to return a boolean value.
15537 * So mark o with maybe_flag rather than the bool_flag.
15538 * Note that there is cost associated with determining context at runtime
15539 * (e.g. a call to block_gimme()), so it may not be worth setting (at
15540 * compile time) and testing (at runtime) maybe_flag if the scalar verses
15541 * boolean costs savings are marginal.
15543 * However, we can do slightly better with && (compared to || and //):
15544 * this op only returns its LH argument when that argument is false. In
15545 * this case, as long as the op promises to return a false value which is
15546 * valid in both boolean and scalar contexts, we can mark an op consumed
15547 * by && with bool_flag rather than maybe_flag.
15548 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15549 * than &PL_sv_no for a false result in boolean context, then it's safe. An
15550 * op which promises to handle this case is indicated by setting safe_and
15555 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15560 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15562 /* OPpTARGET_MY and boolean context probably don't mix well.
15563 * If someone finds a valid use case, maybe add an extra flag to this
15564 * function which indicates its safe to do so for this op? */
15565 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
15566 && (o->op_private & OPpTARGET_MY)));
15571 switch (lop->op_type) {
15576 /* these two consume the stack argument in the scalar case,
15577 * and treat it as a boolean in the non linenumber case */
15580 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15581 || (lop->op_private & OPpFLIP_LINENUM))
15587 /* these never leave the original value on the stack */
15596 /* OR DOR and AND evaluate their arg as a boolean, but then may
15597 * leave the original scalar value on the stack when following the
15598 * op_next route. If not in void context, we need to ensure
15599 * that whatever follows consumes the arg only in boolean context
15611 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15615 else if (!(lop->op_flags & OPf_WANT)) {
15616 /* unknown context - decide at runtime */
15628 lop = lop->op_next;
15631 o->op_private |= flag;
15636 /* mechanism for deferring recursion in rpeep() */
15638 #define MAX_DEFERRED 4
15642 if (defer_ix == (MAX_DEFERRED-1)) { \
15643 OP **defer = defer_queue[defer_base]; \
15644 CALL_RPEEP(*defer); \
15645 S_prune_chain_head(defer); \
15646 defer_base = (defer_base + 1) % MAX_DEFERRED; \
15649 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15652 #define IS_AND_OP(o) (o->op_type == OP_AND)
15653 #define IS_OR_OP(o) (o->op_type == OP_OR)
15656 /* A peephole optimizer. We visit the ops in the order they're to execute.
15657 * See the comments at the top of this file for more details about when
15658 * peep() is called */
15661 Perl_rpeep(pTHX_ OP *o)
15665 OP* oldoldop = NULL;
15666 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15667 int defer_base = 0;
15670 if (!o || o->op_opt)
15673 assert(o->op_type != OP_FREED);
15677 SAVEVPTR(PL_curcop);
15678 for (;; o = o->op_next) {
15679 if (o && o->op_opt)
15682 while (defer_ix >= 0) {
15684 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15685 CALL_RPEEP(*defer);
15686 S_prune_chain_head(defer);
15693 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15694 assert(!oldoldop || oldoldop->op_next == oldop);
15695 assert(!oldop || oldop->op_next == o);
15697 /* By default, this op has now been optimised. A couple of cases below
15698 clear this again. */
15702 /* look for a series of 1 or more aggregate derefs, e.g.
15703 * $a[1]{foo}[$i]{$k}
15704 * and replace with a single OP_MULTIDEREF op.
15705 * Each index must be either a const, or a simple variable,
15707 * First, look for likely combinations of starting ops,
15708 * corresponding to (global and lexical variants of)
15710 * $r->[...] $r->{...}
15711 * (preceding expression)->[...]
15712 * (preceding expression)->{...}
15713 * and if so, call maybe_multideref() to do a full inspection
15714 * of the op chain and if appropriate, replace with an
15722 switch (o2->op_type) {
15724 /* $pkg[..] : gv[*pkg]
15725 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
15727 /* Fail if there are new op flag combinations that we're
15728 * not aware of, rather than:
15729 * * silently failing to optimise, or
15730 * * silently optimising the flag away.
15731 * If this ASSUME starts failing, examine what new flag
15732 * has been added to the op, and decide whether the
15733 * optimisation should still occur with that flag, then
15734 * update the code accordingly. This applies to all the
15735 * other ASSUMEs in the block of code too.
15737 ASSUME(!(o2->op_flags &
15738 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15739 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15743 if (o2->op_type == OP_RV2AV) {
15744 action = MDEREF_AV_gvav_aelem;
15748 if (o2->op_type == OP_RV2HV) {
15749 action = MDEREF_HV_gvhv_helem;
15753 if (o2->op_type != OP_RV2SV)
15756 /* at this point we've seen gv,rv2sv, so the only valid
15757 * construct left is $pkg->[] or $pkg->{} */
15759 ASSUME(!(o2->op_flags & OPf_STACKED));
15760 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15761 != (OPf_WANT_SCALAR|OPf_MOD))
15764 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15765 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15766 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15768 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
15769 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15773 if (o2->op_type == OP_RV2AV) {
15774 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15777 if (o2->op_type == OP_RV2HV) {
15778 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15784 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15786 ASSUME(!(o2->op_flags &
15787 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15788 if ((o2->op_flags &
15789 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15790 != (OPf_WANT_SCALAR|OPf_MOD))
15793 ASSUME(!(o2->op_private &
15794 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15795 /* skip if state or intro, or not a deref */
15796 if ( o2->op_private != OPpDEREF_AV
15797 && o2->op_private != OPpDEREF_HV)
15801 if (o2->op_type == OP_RV2AV) {
15802 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15805 if (o2->op_type == OP_RV2HV) {
15806 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15813 /* $lex[..]: padav[@lex:1,2] sR *
15814 * or $lex{..}: padhv[%lex:1,2] sR */
15815 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15816 OPf_REF|OPf_SPECIAL)));
15817 if ((o2->op_flags &
15818 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15819 != (OPf_WANT_SCALAR|OPf_REF))
15821 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15823 /* OPf_PARENS isn't currently used in this case;
15824 * if that changes, let us know! */
15825 ASSUME(!(o2->op_flags & OPf_PARENS));
15827 /* at this point, we wouldn't expect any of the remaining
15828 * possible private flags:
15829 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15830 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15832 * OPpSLICEWARNING shouldn't affect runtime
15834 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15836 action = o2->op_type == OP_PADAV
15837 ? MDEREF_AV_padav_aelem
15838 : MDEREF_HV_padhv_helem;
15840 S_maybe_multideref(aTHX_ o, o2, action, 0);
15846 action = o2->op_type == OP_RV2AV
15847 ? MDEREF_AV_pop_rv2av_aelem
15848 : MDEREF_HV_pop_rv2hv_helem;
15851 /* (expr)->[...]: rv2av sKR/1;
15852 * (expr)->{...}: rv2hv sKR/1; */
15854 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15856 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15857 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15858 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15861 /* at this point, we wouldn't expect any of these
15862 * possible private flags:
15863 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15864 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15866 ASSUME(!(o2->op_private &
15867 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15869 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15873 S_maybe_multideref(aTHX_ o, o2, action, hints);
15882 switch (o->op_type) {
15884 PL_curcop = ((COP*)o); /* for warnings */
15887 PL_curcop = ((COP*)o); /* for warnings */
15889 /* Optimise a "return ..." at the end of a sub to just be "...".
15890 * This saves 2 ops. Before:
15891 * 1 <;> nextstate(main 1 -e:1) v ->2
15892 * 4 <@> return K ->5
15893 * 2 <0> pushmark s ->3
15894 * - <1> ex-rv2sv sK/1 ->4
15895 * 3 <#> gvsv[*cat] s ->4
15898 * - <@> return K ->-
15899 * - <0> pushmark s ->2
15900 * - <1> ex-rv2sv sK/1 ->-
15901 * 2 <$> gvsv(*cat) s ->3
15904 OP *next = o->op_next;
15905 OP *sibling = OpSIBLING(o);
15906 if ( OP_TYPE_IS(next, OP_PUSHMARK)
15907 && OP_TYPE_IS(sibling, OP_RETURN)
15908 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15909 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15910 ||OP_TYPE_IS(sibling->op_next->op_next,
15912 && cUNOPx(sibling)->op_first == next
15913 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15916 /* Look through the PUSHMARK's siblings for one that
15917 * points to the RETURN */
15918 OP *top = OpSIBLING(next);
15919 while (top && top->op_next) {
15920 if (top->op_next == sibling) {
15921 top->op_next = sibling->op_next;
15922 o->op_next = next->op_next;
15925 top = OpSIBLING(top);
15930 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15932 * This latter form is then suitable for conversion into padrange
15933 * later on. Convert:
15935 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15939 * nextstate1 -> listop -> nextstate3
15941 * pushmark -> padop1 -> padop2
15943 if (o->op_next && (
15944 o->op_next->op_type == OP_PADSV
15945 || o->op_next->op_type == OP_PADAV
15946 || o->op_next->op_type == OP_PADHV
15948 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15949 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15950 && o->op_next->op_next->op_next && (
15951 o->op_next->op_next->op_next->op_type == OP_PADSV
15952 || o->op_next->op_next->op_next->op_type == OP_PADAV
15953 || o->op_next->op_next->op_next->op_type == OP_PADHV
15955 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15956 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15957 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15958 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15960 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15963 ns2 = pad1->op_next;
15964 pad2 = ns2->op_next;
15965 ns3 = pad2->op_next;
15967 /* we assume here that the op_next chain is the same as
15968 * the op_sibling chain */
15969 assert(OpSIBLING(o) == pad1);
15970 assert(OpSIBLING(pad1) == ns2);
15971 assert(OpSIBLING(ns2) == pad2);
15972 assert(OpSIBLING(pad2) == ns3);
15974 /* excise and delete ns2 */
15975 op_sibling_splice(NULL, pad1, 1, NULL);
15978 /* excise pad1 and pad2 */
15979 op_sibling_splice(NULL, o, 2, NULL);
15981 /* create new listop, with children consisting of:
15982 * a new pushmark, pad1, pad2. */
15983 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15984 newop->op_flags |= OPf_PARENS;
15985 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15987 /* insert newop between o and ns3 */
15988 op_sibling_splice(NULL, o, 0, newop);
15990 /*fixup op_next chain */
15991 newpm = cUNOPx(newop)->op_first; /* pushmark */
15992 o ->op_next = newpm;
15993 newpm->op_next = pad1;
15994 pad1 ->op_next = pad2;
15995 pad2 ->op_next = newop; /* listop */
15996 newop->op_next = ns3;
15998 /* Ensure pushmark has this flag if padops do */
15999 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
16000 newpm->op_flags |= OPf_MOD;
16006 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
16007 to carry two labels. For now, take the easier option, and skip
16008 this optimisation if the first NEXTSTATE has a label. */
16009 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
16010 OP *nextop = o->op_next;
16011 while (nextop && nextop->op_type == OP_NULL)
16012 nextop = nextop->op_next;
16014 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
16017 oldop->op_next = nextop;
16019 /* Skip (old)oldop assignment since the current oldop's
16020 op_next already points to the next op. */
16027 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
16028 if (o->op_next->op_private & OPpTARGET_MY) {
16029 if (o->op_flags & OPf_STACKED) /* chained concats */
16030 break; /* ignore_optimization */
16032 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
16033 o->op_targ = o->op_next->op_targ;
16034 o->op_next->op_targ = 0;
16035 o->op_private |= OPpTARGET_MY;
16038 op_null(o->op_next);
16042 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
16043 break; /* Scalar stub must produce undef. List stub is noop */
16047 if (o->op_targ == OP_NEXTSTATE
16048 || o->op_targ == OP_DBSTATE)
16050 PL_curcop = ((COP*)o);
16052 /* XXX: We avoid setting op_seq here to prevent later calls
16053 to rpeep() from mistakenly concluding that optimisation
16054 has already occurred. This doesn't fix the real problem,
16055 though (See 20010220.007 (#5874)). AMS 20010719 */
16056 /* op_seq functionality is now replaced by op_opt */
16064 oldop->op_next = o->op_next;
16078 convert repeat into a stub with no kids.
16080 if (o->op_next->op_type == OP_CONST
16081 || ( o->op_next->op_type == OP_PADSV
16082 && !(o->op_next->op_private & OPpLVAL_INTRO))
16083 || ( o->op_next->op_type == OP_GV
16084 && o->op_next->op_next->op_type == OP_RV2SV
16085 && !(o->op_next->op_next->op_private
16086 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
16088 const OP *kid = o->op_next->op_next;
16089 if (o->op_next->op_type == OP_GV)
16090 kid = kid->op_next;
16091 /* kid is now the ex-list. */
16092 if (kid->op_type == OP_NULL
16093 && (kid = kid->op_next)->op_type == OP_CONST
16094 /* kid is now the repeat count. */
16095 && kid->op_next->op_type == OP_REPEAT
16096 && kid->op_next->op_private & OPpREPEAT_DOLIST
16097 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
16098 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
16101 o = kid->op_next; /* repeat */
16102 oldop->op_next = o;
16103 op_free(cBINOPo->op_first);
16104 op_free(cBINOPo->op_last );
16105 o->op_flags &=~ OPf_KIDS;
16106 /* stub is a baseop; repeat is a binop */
16107 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
16108 OpTYPE_set(o, OP_STUB);
16114 /* Convert a series of PAD ops for my vars plus support into a
16115 * single padrange op. Basically
16117 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
16119 * becomes, depending on circumstances, one of
16121 * padrange ----------------------------------> (list) -> rest
16122 * padrange --------------------------------------------> rest
16124 * where all the pad indexes are sequential and of the same type
16126 * We convert the pushmark into a padrange op, then skip
16127 * any other pad ops, and possibly some trailing ops.
16128 * Note that we don't null() the skipped ops, to make it
16129 * easier for Deparse to undo this optimisation (and none of
16130 * the skipped ops are holding any resourses). It also makes
16131 * it easier for find_uninit_var(), as it can just ignore
16132 * padrange, and examine the original pad ops.
16136 OP *followop = NULL; /* the op that will follow the padrange op */
16139 PADOFFSET base = 0; /* init only to stop compiler whining */
16140 bool gvoid = 0; /* init only to stop compiler whining */
16141 bool defav = 0; /* seen (...) = @_ */
16142 bool reuse = 0; /* reuse an existing padrange op */
16144 /* look for a pushmark -> gv[_] -> rv2av */
16149 if ( p->op_type == OP_GV
16150 && cGVOPx_gv(p) == PL_defgv
16151 && (rv2av = p->op_next)
16152 && rv2av->op_type == OP_RV2AV
16153 && !(rv2av->op_flags & OPf_REF)
16154 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
16155 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
16157 q = rv2av->op_next;
16158 if (q->op_type == OP_NULL)
16160 if (q->op_type == OP_PUSHMARK) {
16170 /* scan for PAD ops */
16172 for (p = p->op_next; p; p = p->op_next) {
16173 if (p->op_type == OP_NULL)
16176 if (( p->op_type != OP_PADSV
16177 && p->op_type != OP_PADAV
16178 && p->op_type != OP_PADHV
16180 /* any private flag other than INTRO? e.g. STATE */
16181 || (p->op_private & ~OPpLVAL_INTRO)
16185 /* let $a[N] potentially be optimised into AELEMFAST_LEX
16187 if ( p->op_type == OP_PADAV
16189 && p->op_next->op_type == OP_CONST
16190 && p->op_next->op_next
16191 && p->op_next->op_next->op_type == OP_AELEM
16195 /* for 1st padop, note what type it is and the range
16196 * start; for the others, check that it's the same type
16197 * and that the targs are contiguous */
16199 intro = (p->op_private & OPpLVAL_INTRO);
16201 gvoid = OP_GIMME(p,0) == G_VOID;
16204 if ((p->op_private & OPpLVAL_INTRO) != intro)
16206 /* Note that you'd normally expect targs to be
16207 * contiguous in my($a,$b,$c), but that's not the case
16208 * when external modules start doing things, e.g.
16209 * Function::Parameters */
16210 if (p->op_targ != base + count)
16212 assert(p->op_targ == base + count);
16213 /* Either all the padops or none of the padops should
16214 be in void context. Since we only do the optimisa-
16215 tion for av/hv when the aggregate itself is pushed
16216 on to the stack (one item), there is no need to dis-
16217 tinguish list from scalar context. */
16218 if (gvoid != (OP_GIMME(p,0) == G_VOID))
16222 /* for AV, HV, only when we're not flattening */
16223 if ( p->op_type != OP_PADSV
16225 && !(p->op_flags & OPf_REF)
16229 if (count >= OPpPADRANGE_COUNTMASK)
16232 /* there's a biggest base we can fit into a
16233 * SAVEt_CLEARPADRANGE in pp_padrange.
16234 * (The sizeof() stuff will be constant-folded, and is
16235 * intended to avoid getting "comparison is always false"
16236 * compiler warnings. See the comments above
16237 * MEM_WRAP_CHECK for more explanation on why we do this
16238 * in a weird way to avoid compiler warnings.)
16241 && (8*sizeof(base) >
16242 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
16244 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
16246 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
16250 /* Success! We've got another valid pad op to optimise away */
16252 followop = p->op_next;
16255 if (count < 1 || (count == 1 && !defav))
16258 /* pp_padrange in specifically compile-time void context
16259 * skips pushing a mark and lexicals; in all other contexts
16260 * (including unknown till runtime) it pushes a mark and the
16261 * lexicals. We must be very careful then, that the ops we
16262 * optimise away would have exactly the same effect as the
16264 * In particular in void context, we can only optimise to
16265 * a padrange if we see the complete sequence
16266 * pushmark, pad*v, ...., list
16267 * which has the net effect of leaving the markstack as it
16268 * was. Not pushing onto the stack (whereas padsv does touch
16269 * the stack) makes no difference in void context.
16273 if (followop->op_type == OP_LIST
16274 && OP_GIMME(followop,0) == G_VOID
16277 followop = followop->op_next; /* skip OP_LIST */
16279 /* consolidate two successive my(...);'s */
16282 && oldoldop->op_type == OP_PADRANGE
16283 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
16284 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
16285 && !(oldoldop->op_flags & OPf_SPECIAL)
16288 assert(oldoldop->op_next == oldop);
16289 assert( oldop->op_type == OP_NEXTSTATE
16290 || oldop->op_type == OP_DBSTATE);
16291 assert(oldop->op_next == o);
16294 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
16296 /* Do not assume pad offsets for $c and $d are con-
16301 if ( oldoldop->op_targ + old_count == base
16302 && old_count < OPpPADRANGE_COUNTMASK - count) {
16303 base = oldoldop->op_targ;
16304 count += old_count;
16309 /* if there's any immediately following singleton
16310 * my var's; then swallow them and the associated
16312 * my ($a,$b); my $c; my $d;
16314 * my ($a,$b,$c,$d);
16317 while ( ((p = followop->op_next))
16318 && ( p->op_type == OP_PADSV
16319 || p->op_type == OP_PADAV
16320 || p->op_type == OP_PADHV)
16321 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
16322 && (p->op_private & OPpLVAL_INTRO) == intro
16323 && !(p->op_private & ~OPpLVAL_INTRO)
16325 && ( p->op_next->op_type == OP_NEXTSTATE
16326 || p->op_next->op_type == OP_DBSTATE)
16327 && count < OPpPADRANGE_COUNTMASK
16328 && base + count == p->op_targ
16331 followop = p->op_next;
16339 assert(oldoldop->op_type == OP_PADRANGE);
16340 oldoldop->op_next = followop;
16341 oldoldop->op_private = (intro | count);
16347 /* Convert the pushmark into a padrange.
16348 * To make Deparse easier, we guarantee that a padrange was
16349 * *always* formerly a pushmark */
16350 assert(o->op_type == OP_PUSHMARK);
16351 o->op_next = followop;
16352 OpTYPE_set(o, OP_PADRANGE);
16354 /* bit 7: INTRO; bit 6..0: count */
16355 o->op_private = (intro | count);
16356 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
16357 | gvoid * OPf_WANT_VOID
16358 | (defav ? OPf_SPECIAL : 0));
16364 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16365 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16370 /*'keys %h' in void or scalar context: skip the OP_KEYS
16371 * and perform the functionality directly in the RV2HV/PADHV
16374 if (o->op_flags & OPf_REF) {
16375 OP *k = o->op_next;
16376 U8 want = (k->op_flags & OPf_WANT);
16378 && k->op_type == OP_KEYS
16379 && ( want == OPf_WANT_VOID
16380 || want == OPf_WANT_SCALAR)
16381 && !(k->op_private & OPpMAYBE_LVSUB)
16382 && !(k->op_flags & OPf_MOD)
16384 o->op_next = k->op_next;
16385 o->op_flags &= ~(OPf_REF|OPf_WANT);
16386 o->op_flags |= want;
16387 o->op_private |= (o->op_type == OP_PADHV ?
16388 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
16389 /* for keys(%lex), hold onto the OP_KEYS's targ
16390 * since padhv doesn't have its own targ to return
16392 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16397 /* see if %h is used in boolean context */
16398 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16399 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16402 if (o->op_type != OP_PADHV)
16406 if ( o->op_type == OP_PADAV
16407 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16409 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16412 /* Skip over state($x) in void context. */
16413 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16414 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16416 oldop->op_next = o->op_next;
16417 goto redo_nextstate;
16419 if (o->op_type != OP_PADAV)
16423 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16424 OP* const pop = (o->op_type == OP_PADAV) ?
16425 o->op_next : o->op_next->op_next;
16427 if (pop && pop->op_type == OP_CONST &&
16428 ((PL_op = pop->op_next)) &&
16429 pop->op_next->op_type == OP_AELEM &&
16430 !(pop->op_next->op_private &
16431 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16432 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16435 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16436 no_bareword_allowed(pop);
16437 if (o->op_type == OP_GV)
16438 op_null(o->op_next);
16439 op_null(pop->op_next);
16441 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16442 o->op_next = pop->op_next->op_next;
16443 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16444 o->op_private = (U8)i;
16445 if (o->op_type == OP_GV) {
16448 o->op_type = OP_AELEMFAST;
16451 o->op_type = OP_AELEMFAST_LEX;
16453 if (o->op_type != OP_GV)
16457 /* Remove $foo from the op_next chain in void context. */
16459 && ( o->op_next->op_type == OP_RV2SV
16460 || o->op_next->op_type == OP_RV2AV
16461 || o->op_next->op_type == OP_RV2HV )
16462 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16463 && !(o->op_next->op_private & OPpLVAL_INTRO))
16465 oldop->op_next = o->op_next->op_next;
16466 /* Reprocess the previous op if it is a nextstate, to
16467 allow double-nextstate optimisation. */
16469 if (oldop->op_type == OP_NEXTSTATE) {
16476 o = oldop->op_next;
16479 else if (o->op_next->op_type == OP_RV2SV) {
16480 if (!(o->op_next->op_private & OPpDEREF)) {
16481 op_null(o->op_next);
16482 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16484 o->op_next = o->op_next->op_next;
16485 OpTYPE_set(o, OP_GVSV);
16488 else if (o->op_next->op_type == OP_READLINE
16489 && o->op_next->op_next->op_type == OP_CONCAT
16490 && (o->op_next->op_next->op_flags & OPf_STACKED))
16492 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16493 OpTYPE_set(o, OP_RCATLINE);
16494 o->op_flags |= OPf_STACKED;
16495 op_null(o->op_next->op_next);
16496 op_null(o->op_next);
16507 while (cLOGOP->op_other->op_type == OP_NULL)
16508 cLOGOP->op_other = cLOGOP->op_other->op_next;
16509 while (o->op_next && ( o->op_type == o->op_next->op_type
16510 || o->op_next->op_type == OP_NULL))
16511 o->op_next = o->op_next->op_next;
16513 /* If we're an OR and our next is an AND in void context, we'll
16514 follow its op_other on short circuit, same for reverse.
16515 We can't do this with OP_DOR since if it's true, its return
16516 value is the underlying value which must be evaluated
16520 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16521 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16523 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16525 o->op_next = ((LOGOP*)o->op_next)->op_other;
16527 DEFER(cLOGOP->op_other);
16532 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16533 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16542 case OP_ARGDEFELEM:
16543 while (cLOGOP->op_other->op_type == OP_NULL)
16544 cLOGOP->op_other = cLOGOP->op_other->op_next;
16545 DEFER(cLOGOP->op_other);
16550 while (cLOOP->op_redoop->op_type == OP_NULL)
16551 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16552 while (cLOOP->op_nextop->op_type == OP_NULL)
16553 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16554 while (cLOOP->op_lastop->op_type == OP_NULL)
16555 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16556 /* a while(1) loop doesn't have an op_next that escapes the
16557 * loop, so we have to explicitly follow the op_lastop to
16558 * process the rest of the code */
16559 DEFER(cLOOP->op_lastop);
16563 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16564 DEFER(cLOGOPo->op_other);
16568 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16569 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16570 assert(!(cPMOP->op_pmflags & PMf_ONCE));
16571 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16572 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16573 cPMOP->op_pmstashstartu.op_pmreplstart
16574 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16575 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16581 if (o->op_flags & OPf_SPECIAL) {
16582 /* first arg is a code block */
16583 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16584 OP * kid = cUNOPx(nullop)->op_first;
16586 assert(nullop->op_type == OP_NULL);
16587 assert(kid->op_type == OP_SCOPE
16588 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16589 /* since OP_SORT doesn't have a handy op_other-style
16590 * field that can point directly to the start of the code
16591 * block, store it in the otherwise-unused op_next field
16592 * of the top-level OP_NULL. This will be quicker at
16593 * run-time, and it will also allow us to remove leading
16594 * OP_NULLs by just messing with op_nexts without
16595 * altering the basic op_first/op_sibling layout. */
16596 kid = kLISTOP->op_first;
16598 (kid->op_type == OP_NULL
16599 && ( kid->op_targ == OP_NEXTSTATE
16600 || kid->op_targ == OP_DBSTATE ))
16601 || kid->op_type == OP_STUB
16602 || kid->op_type == OP_ENTER
16603 || (PL_parser && PL_parser->error_count));
16604 nullop->op_next = kid->op_next;
16605 DEFER(nullop->op_next);
16608 /* check that RHS of sort is a single plain array */
16609 oright = cUNOPo->op_first;
16610 if (!oright || oright->op_type != OP_PUSHMARK)
16613 if (o->op_private & OPpSORT_INPLACE)
16616 /* reverse sort ... can be optimised. */
16617 if (!OpHAS_SIBLING(cUNOPo)) {
16618 /* Nothing follows us on the list. */
16619 OP * const reverse = o->op_next;
16621 if (reverse->op_type == OP_REVERSE &&
16622 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16623 OP * const pushmark = cUNOPx(reverse)->op_first;
16624 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16625 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16626 /* reverse -> pushmark -> sort */
16627 o->op_private |= OPpSORT_REVERSE;
16629 pushmark->op_next = oright->op_next;
16639 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16641 LISTOP *enter, *exlist;
16643 if (o->op_private & OPpSORT_INPLACE)
16646 enter = (LISTOP *) o->op_next;
16649 if (enter->op_type == OP_NULL) {
16650 enter = (LISTOP *) enter->op_next;
16654 /* for $a (...) will have OP_GV then OP_RV2GV here.
16655 for (...) just has an OP_GV. */
16656 if (enter->op_type == OP_GV) {
16657 gvop = (OP *) enter;
16658 enter = (LISTOP *) enter->op_next;
16661 if (enter->op_type == OP_RV2GV) {
16662 enter = (LISTOP *) enter->op_next;
16668 if (enter->op_type != OP_ENTERITER)
16671 iter = enter->op_next;
16672 if (!iter || iter->op_type != OP_ITER)
16675 expushmark = enter->op_first;
16676 if (!expushmark || expushmark->op_type != OP_NULL
16677 || expushmark->op_targ != OP_PUSHMARK)
16680 exlist = (LISTOP *) OpSIBLING(expushmark);
16681 if (!exlist || exlist->op_type != OP_NULL
16682 || exlist->op_targ != OP_LIST)
16685 if (exlist->op_last != o) {
16686 /* Mmm. Was expecting to point back to this op. */
16689 theirmark = exlist->op_first;
16690 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16693 if (OpSIBLING(theirmark) != o) {
16694 /* There's something between the mark and the reverse, eg
16695 for (1, reverse (...))
16700 ourmark = ((LISTOP *)o)->op_first;
16701 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16704 ourlast = ((LISTOP *)o)->op_last;
16705 if (!ourlast || ourlast->op_next != o)
16708 rv2av = OpSIBLING(ourmark);
16709 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16710 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16711 /* We're just reversing a single array. */
16712 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16713 enter->op_flags |= OPf_STACKED;
16716 /* We don't have control over who points to theirmark, so sacrifice
16718 theirmark->op_next = ourmark->op_next;
16719 theirmark->op_flags = ourmark->op_flags;
16720 ourlast->op_next = gvop ? gvop : (OP *) enter;
16723 enter->op_private |= OPpITER_REVERSED;
16724 iter->op_private |= OPpITER_REVERSED;
16728 o = oldop->op_next;
16730 NOT_REACHED; /* NOTREACHED */
16736 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16737 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16742 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16743 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16746 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16748 sv = newRV((SV *)PL_compcv);
16752 OpTYPE_set(o, OP_CONST);
16753 o->op_flags |= OPf_SPECIAL;
16754 cSVOPo->op_sv = sv;
16759 if (OP_GIMME(o,0) == G_VOID
16760 || ( o->op_next->op_type == OP_LINESEQ
16761 && ( o->op_next->op_next->op_type == OP_LEAVESUB
16762 || ( o->op_next->op_next->op_type == OP_RETURN
16763 && !CvLVALUE(PL_compcv)))))
16765 OP *right = cBINOP->op_first;
16784 OP *left = OpSIBLING(right);
16785 if (left->op_type == OP_SUBSTR
16786 && (left->op_private & 7) < 4) {
16788 /* cut out right */
16789 op_sibling_splice(o, NULL, 1, NULL);
16790 /* and insert it as second child of OP_SUBSTR */
16791 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16793 left->op_private |= OPpSUBSTR_REPL_FIRST;
16795 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16802 int l, r, lr, lscalars, rscalars;
16804 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16805 Note that we do this now rather than in newASSIGNOP(),
16806 since only by now are aliased lexicals flagged as such
16808 See the essay "Common vars in list assignment" above for
16809 the full details of the rationale behind all the conditions
16812 PL_generation sorcery:
16813 To detect whether there are common vars, the global var
16814 PL_generation is incremented for each assign op we scan.
16815 Then we run through all the lexical variables on the LHS,
16816 of the assignment, setting a spare slot in each of them to
16817 PL_generation. Then we scan the RHS, and if any lexicals
16818 already have that value, we know we've got commonality.
16819 Also, if the generation number is already set to
16820 PERL_INT_MAX, then the variable is involved in aliasing, so
16821 we also have potential commonality in that case.
16827 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
16830 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
16834 /* After looking for things which are *always* safe, this main
16835 * if/else chain selects primarily based on the type of the
16836 * LHS, gradually working its way down from the more dangerous
16837 * to the more restrictive and thus safer cases */
16839 if ( !l /* () = ....; */
16840 || !r /* .... = (); */
16841 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16842 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16843 || (lscalars < 2) /* ($x, undef) = ... */
16845 NOOP; /* always safe */
16847 else if (l & AAS_DANGEROUS) {
16848 /* always dangerous */
16849 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16850 o->op_private |= OPpASSIGN_COMMON_AGG;
16852 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16853 /* package vars are always dangerous - too many
16854 * aliasing possibilities */
16855 if (l & AAS_PKG_SCALAR)
16856 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16857 if (l & AAS_PKG_AGG)
16858 o->op_private |= OPpASSIGN_COMMON_AGG;
16860 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16861 |AAS_LEX_SCALAR|AAS_LEX_AGG))
16863 /* LHS contains only lexicals and safe ops */
16865 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16866 o->op_private |= OPpASSIGN_COMMON_AGG;
16868 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16869 if (lr & AAS_LEX_SCALAR_COMM)
16870 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16871 else if ( !(l & AAS_LEX_SCALAR)
16872 && (r & AAS_DEFAV))
16876 * as scalar-safe for performance reasons.
16877 * (it will still have been marked _AGG if necessary */
16880 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16881 /* if there are only lexicals on the LHS and no
16882 * common ones on the RHS, then we assume that the
16883 * only way those lexicals could also get
16884 * on the RHS is via some sort of dereffing or
16887 * ($lex, $x) = (1, $$r)
16888 * and in this case we assume the var must have
16889 * a bumped ref count. So if its ref count is 1,
16890 * it must only be on the LHS.
16892 o->op_private |= OPpASSIGN_COMMON_RC1;
16897 * may have to handle aggregate on LHS, but we can't
16898 * have common scalars. */
16901 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16903 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16904 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16909 /* see if ref() is used in boolean context */
16910 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16911 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16915 /* see if the op is used in known boolean context,
16916 * but not if OA_TARGLEX optimisation is enabled */
16917 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16918 && !(o->op_private & OPpTARGET_MY)
16920 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16924 /* see if the op is used in known boolean context */
16925 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16926 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16930 Perl_cpeep_t cpeep =
16931 XopENTRYCUSTOM(o, xop_peep);
16933 cpeep(aTHX_ o, oldop);
16938 /* did we just null the current op? If so, re-process it to handle
16939 * eliding "empty" ops from the chain */
16940 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16953 Perl_peep(pTHX_ OP *o)
16959 =head1 Custom Operators
16961 =for apidoc custom_op_xop
16962 Return the XOP structure for a given custom op. This macro should be
16963 considered internal to C<OP_NAME> and the other access macros: use them instead.
16964 This macro does call a function. Prior
16965 to 5.19.6, this was implemented as a
16972 /* use PERL_MAGIC_ext to call a function to free the xop structure when
16973 * freeing PL_custom_ops */
16976 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
16980 PERL_UNUSED_ARG(mg);
16981 xop = INT2PTR(XOP *, SvIV(sv));
16982 Safefree(xop->xop_name);
16983 Safefree(xop->xop_desc);
16989 static const MGVTBL custom_op_register_vtbl = {
16994 custom_op_register_free, /* free */
17004 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
17010 static const XOP xop_null = { 0, 0, 0, 0, 0 };
17012 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
17013 assert(o->op_type == OP_CUSTOM);
17015 /* This is wrong. It assumes a function pointer can be cast to IV,
17016 * which isn't guaranteed, but this is what the old custom OP code
17017 * did. In principle it should be safer to Copy the bytes of the
17018 * pointer into a PV: since the new interface is hidden behind
17019 * functions, this can be changed later if necessary. */
17020 /* Change custom_op_xop if this ever happens */
17021 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
17024 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
17026 /* See if the op isn't registered, but its name *is* registered.
17027 * That implies someone is using the pre-5.14 API,where only name and
17028 * description could be registered. If so, fake up a real
17030 * We only check for an existing name, and assume no one will have
17031 * just registered a desc */
17032 if (!he && PL_custom_op_names &&
17033 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
17038 /* XXX does all this need to be shared mem? */
17039 Newxz(xop, 1, XOP);
17040 pv = SvPV(HeVAL(he), l);
17041 XopENTRY_set(xop, xop_name, savepvn(pv, l));
17042 if (PL_custom_op_descs &&
17043 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
17045 pv = SvPV(HeVAL(he), l);
17046 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
17048 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
17049 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
17050 /* add magic to the SV so that the xop struct (pointed to by
17051 * SvIV(sv)) is freed. Normally a static xop is registered, but
17052 * for this backcompat hack, we've alloced one */
17053 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
17054 &custom_op_register_vtbl, NULL, 0);
17059 xop = (XOP *)&xop_null;
17061 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
17065 if(field == XOPe_xop_ptr) {
17068 const U32 flags = XopFLAGS(xop);
17069 if(flags & field) {
17071 case XOPe_xop_name:
17072 any.xop_name = xop->xop_name;
17074 case XOPe_xop_desc:
17075 any.xop_desc = xop->xop_desc;
17077 case XOPe_xop_class:
17078 any.xop_class = xop->xop_class;
17080 case XOPe_xop_peep:
17081 any.xop_peep = xop->xop_peep;
17084 NOT_REACHED; /* NOTREACHED */
17089 case XOPe_xop_name:
17090 any.xop_name = XOPd_xop_name;
17092 case XOPe_xop_desc:
17093 any.xop_desc = XOPd_xop_desc;
17095 case XOPe_xop_class:
17096 any.xop_class = XOPd_xop_class;
17098 case XOPe_xop_peep:
17099 any.xop_peep = XOPd_xop_peep;
17102 NOT_REACHED; /* NOTREACHED */
17107 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
17108 * op.c: In function 'Perl_custom_op_get_field':
17109 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
17110 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
17111 * expands to assert(0), which expands to ((0) ? (void)0 :
17112 * __assert(...)), and gcc doesn't know that __assert can never return. */
17118 =for apidoc custom_op_register
17119 Register a custom op. See L<perlguts/"Custom Operators">.
17125 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
17129 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
17131 /* see the comment in custom_op_xop */
17132 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
17134 if (!PL_custom_ops)
17135 PL_custom_ops = newHV();
17137 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
17138 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
17143 =for apidoc core_prototype
17145 This function assigns the prototype of the named core function to C<sv>, or
17146 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
17147 C<NULL> if the core function has no prototype. C<code> is a code as returned
17148 by C<keyword()>. It must not be equal to 0.
17154 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
17157 int i = 0, n = 0, seen_question = 0, defgv = 0;
17159 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
17160 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
17161 bool nullret = FALSE;
17163 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
17167 if (!sv) sv = sv_newmortal();
17169 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
17171 switch (code < 0 ? -code : code) {
17172 case KEY_and : case KEY_chop: case KEY_chomp:
17173 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
17174 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
17175 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
17176 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
17177 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
17178 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
17179 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
17180 case KEY_x : case KEY_xor :
17181 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
17182 case KEY_glob: retsetpvs("_;", OP_GLOB);
17183 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
17184 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
17185 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
17186 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
17187 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
17189 case KEY_evalbytes:
17190 name = "entereval"; break;
17198 while (i < MAXO) { /* The slow way. */
17199 if (strEQ(name, PL_op_name[i])
17200 || strEQ(name, PL_op_desc[i]))
17202 if (nullret) { assert(opnum); *opnum = i; return NULL; }
17209 defgv = PL_opargs[i] & OA_DEFGV;
17210 oa = PL_opargs[i] >> OASHIFT;
17212 if (oa & OA_OPTIONAL && !seen_question && (
17213 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
17218 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
17219 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
17220 /* But globs are already references (kinda) */
17221 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
17225 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
17226 && !scalar_mod_type(NULL, i)) {
17231 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
17235 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
17236 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
17237 str[n-1] = '_'; defgv = 0;
17241 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
17243 sv_setpvn(sv, str, n - 1);
17244 if (opnum) *opnum = i;
17249 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
17252 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
17253 newSVOP(OP_COREARGS,0,coreargssv);
17256 PERL_ARGS_ASSERT_CORESUB_OP;
17260 return op_append_elem(OP_LINESEQ,
17263 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
17270 o = newUNOP(OP_AVHVSWITCH,0,argop);
17271 o->op_private = opnum-OP_EACH;
17273 case OP_SELECT: /* which represents OP_SSELECT as well */
17278 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
17279 newSVOP(OP_CONST, 0, newSVuv(1))
17281 coresub_op(newSVuv((UV)OP_SSELECT), 0,
17283 coresub_op(coreargssv, 0, OP_SELECT)
17287 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
17289 return op_append_elem(
17292 opnum == OP_WANTARRAY || opnum == OP_RUNCV
17293 ? OPpOFFBYONE << 8 : 0)
17295 case OA_BASEOP_OR_UNOP:
17296 if (opnum == OP_ENTEREVAL) {
17297 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
17298 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
17300 else o = newUNOP(opnum,0,argop);
17301 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
17304 if (is_handle_constructor(o, 1))
17305 argop->op_private |= OPpCOREARGS_DEREF1;
17306 if (scalar_mod_type(NULL, opnum))
17307 argop->op_private |= OPpCOREARGS_SCALARMOD;
17311 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
17312 if (is_handle_constructor(o, 2))
17313 argop->op_private |= OPpCOREARGS_DEREF2;
17314 if (opnum == OP_SUBSTR) {
17315 o->op_private |= OPpMAYBE_LVSUB;
17324 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
17325 SV * const *new_const_svp)
17327 const char *hvname;
17328 bool is_const = !!CvCONST(old_cv);
17329 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
17331 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
17333 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
17335 /* They are 2 constant subroutines generated from
17336 the same constant. This probably means that
17337 they are really the "same" proxy subroutine
17338 instantiated in 2 places. Most likely this is
17339 when a constant is exported twice. Don't warn.
17342 (ckWARN(WARN_REDEFINE)
17344 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
17345 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
17346 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
17347 strEQ(hvname, "autouse"))
17351 && ckWARN_d(WARN_REDEFINE)
17352 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
17355 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
17357 ? "Constant subroutine %" SVf " redefined"
17358 : "Subroutine %" SVf " redefined",
17363 =head1 Hook manipulation
17365 These functions provide convenient and thread-safe means of manipulating
17372 =for apidoc wrap_op_checker
17374 Puts a C function into the chain of check functions for a specified op
17375 type. This is the preferred way to manipulate the L</PL_check> array.
17376 C<opcode> specifies which type of op is to be affected. C<new_checker>
17377 is a pointer to the C function that is to be added to that opcode's
17378 check chain, and C<old_checker_p> points to the storage location where a
17379 pointer to the next function in the chain will be stored. The value of
17380 C<new_checker> is written into the L</PL_check> array, while the value
17381 previously stored there is written to C<*old_checker_p>.
17383 L</PL_check> is global to an entire process, and a module wishing to
17384 hook op checking may find itself invoked more than once per process,
17385 typically in different threads. To handle that situation, this function
17386 is idempotent. The location C<*old_checker_p> must initially (once
17387 per process) contain a null pointer. A C variable of static duration
17388 (declared at file scope, typically also marked C<static> to give
17389 it internal linkage) will be implicitly initialised appropriately,
17390 if it does not have an explicit initialiser. This function will only
17391 actually modify the check chain if it finds C<*old_checker_p> to be null.
17392 This function is also thread safe on the small scale. It uses appropriate
17393 locking to avoid race conditions in accessing L</PL_check>.
17395 When this function is called, the function referenced by C<new_checker>
17396 must be ready to be called, except for C<*old_checker_p> being unfilled.
17397 In a threading situation, C<new_checker> may be called immediately,
17398 even before this function has returned. C<*old_checker_p> will always
17399 be appropriately set before C<new_checker> is called. If C<new_checker>
17400 decides not to do anything special with an op that it is given (which
17401 is the usual case for most uses of op check hooking), it must chain the
17402 check function referenced by C<*old_checker_p>.
17404 Taken all together, XS code to hook an op checker should typically look
17405 something like this:
17407 static Perl_check_t nxck_frob;
17408 static OP *myck_frob(pTHX_ OP *op) {
17410 op = nxck_frob(aTHX_ op);
17415 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
17417 If you want to influence compilation of calls to a specific subroutine,
17418 then use L</cv_set_call_checker_flags> rather than hooking checking of
17419 all C<entersub> ops.
17425 Perl_wrap_op_checker(pTHX_ Optype opcode,
17426 Perl_check_t new_checker, Perl_check_t *old_checker_p)
17430 PERL_UNUSED_CONTEXT;
17431 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
17432 if (*old_checker_p) return;
17433 OP_CHECK_MUTEX_LOCK;
17434 if (!*old_checker_p) {
17435 *old_checker_p = PL_check[opcode];
17436 PL_check[opcode] = new_checker;
17438 OP_CHECK_MUTEX_UNLOCK;
17443 /* Efficient sub that returns a constant scalar value. */
17445 const_sv_xsub(pTHX_ CV* cv)
17448 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17449 PERL_UNUSED_ARG(items);
17459 const_av_xsub(pTHX_ CV* cv)
17462 AV * const av = MUTABLE_AV(XSANY.any_ptr);
17470 if (SvRMAGICAL(av))
17471 Perl_croak(aTHX_ "Magical list constants are not supported");
17472 if (GIMME_V != G_ARRAY) {
17474 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17477 EXTEND(SP, AvFILLp(av)+1);
17478 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17479 XSRETURN(AvFILLp(av)+1);
17482 /* Copy an existing cop->cop_warnings field.
17483 * If it's one of the standard addresses, just re-use the address.
17484 * This is the e implementation for the DUP_WARNINGS() macro
17488 Perl_dup_warnings(pTHX_ STRLEN* warnings)
17491 STRLEN *new_warnings;
17493 if (warnings == NULL || specialWARN(warnings))
17496 size = sizeof(*warnings) + *warnings;
17498 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
17499 Copy(warnings, new_warnings, size, char);
17500 return new_warnings;
17504 * ex: set ts=8 sts=4 sw=4 et: