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 =for apidoc op_lvalue
3954 Propagate lvalue ("modifiable") context to an op and its children.
3955 C<type> represents the context type, roughly based on the type of op that
3956 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3957 because it has no op type of its own (it is signalled by a flag on
3960 This function detects things that can't be modified, such as C<$x+1>, and
3961 generates errors for them. For example, C<$x+1 = 2> would cause it to be
3962 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3964 It also flags things that need to behave specially in an lvalue context,
3965 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3971 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3974 PadnameLVALUE_on(pn);
3975 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3977 /* RT #127786: cv can be NULL due to an eval within the DB package
3978 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3979 * unless they contain an eval, but calling eval within DB
3980 * pretends the eval was done in the caller's scope.
3984 assert(CvPADLIST(cv));
3986 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3987 assert(PadnameLEN(pn));
3988 PadnameLVALUE_on(pn);
3993 S_vivifies(const OPCODE type)
3996 case OP_RV2AV: case OP_ASLICE:
3997 case OP_RV2HV: case OP_KVASLICE:
3998 case OP_RV2SV: case OP_HSLICE:
3999 case OP_AELEMFAST: case OP_KVHSLICE:
4008 /* apply lvalue reference (aliasing) context to the optree o.
4011 * o would be the list ($x,$y) and type would be OP_AASSIGN.
4012 * It may descend and apply this to children too, for example in
4013 * \( $cond ? $x, $y) = (...)
4017 S_lvref(pTHX_ OP *o, I32 type)
4024 switch (o->op_type) {
4026 o = OpSIBLING(cUNOPo->op_first);
4031 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4032 o->op_flags |= OPf_STACKED;
4033 if (o->op_flags & OPf_PARENS) {
4034 if (o->op_private & OPpLVAL_INTRO) {
4035 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4036 "localized parenthesized array in list assignment"));
4040 OpTYPE_set(o, OP_LVAVREF);
4041 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4042 o->op_flags |= OPf_MOD|OPf_REF;
4045 o->op_private |= OPpLVREF_AV;
4048 kid = cUNOPo->op_first;
4049 if (kid->op_type == OP_NULL)
4050 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4052 o->op_private = OPpLVREF_CV;
4053 if (kid->op_type == OP_GV)
4054 o->op_flags |= OPf_STACKED;
4055 else if (kid->op_type == OP_PADCV) {
4056 o->op_targ = kid->op_targ;
4058 op_free(cUNOPo->op_first);
4059 cUNOPo->op_first = NULL;
4060 o->op_flags &=~ OPf_KIDS;
4065 if (o->op_flags & OPf_PARENS) {
4067 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4068 "parenthesized hash in list assignment"));
4071 o->op_private |= OPpLVREF_HV;
4075 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4076 o->op_flags |= OPf_STACKED;
4079 if (o->op_flags & OPf_PARENS) goto parenhash;
4080 o->op_private |= OPpLVREF_HV;
4083 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4086 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4087 if (o->op_flags & OPf_PARENS) goto slurpy;
4088 o->op_private |= OPpLVREF_AV;
4092 o->op_private |= OPpLVREF_ELEM;
4093 o->op_flags |= OPf_STACKED;
4097 OpTYPE_set(o, OP_LVREFSLICE);
4098 o->op_private &= OPpLVAL_INTRO;
4101 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4103 else if (!(o->op_flags & OPf_KIDS))
4106 /* the code formerly only recursed into the first child of
4107 * a non ex-list OP_NULL. if we ever encounter such a null op with
4108 * more than one child, need to decide whether its ok to process
4109 * *all* its kids or not */
4110 assert(o->op_targ == OP_LIST
4111 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4114 o = cLISTOPo->op_first;
4117 if (o->op_flags & OPf_PARENS)
4122 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4123 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4124 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4130 OpTYPE_set(o, OP_LVREF);
4132 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4133 if (type == OP_ENTERLOOP)
4134 o->op_private |= OPpLVREF_ITER;
4139 return; /* at top; no parents/siblings to try */
4140 if (OpHAS_SIBLING(o)) {
4141 o = o->op_sibparent;
4144 o = o->op_sibparent; /*try parent's next sibling */
4149 PERL_STATIC_INLINE bool
4150 S_potential_mod_type(I32 type)
4152 /* Types that only potentially result in modification. */
4153 return type == OP_GREPSTART || type == OP_ENTERSUB
4154 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4158 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4162 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4165 if (!o || (PL_parser && PL_parser->error_count))
4168 if ((o->op_private & OPpTARGET_MY)
4169 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4174 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
4176 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4178 switch (o->op_type) {
4183 if ((o->op_flags & OPf_PARENS))
4187 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4188 !(o->op_flags & OPf_STACKED)) {
4189 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4190 assert(cUNOPo->op_first->op_type == OP_NULL);
4191 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4194 else { /* lvalue subroutine call */
4195 o->op_private |= OPpLVAL_INTRO;
4196 PL_modcount = RETURN_UNLIMITED_NUMBER;
4197 if (S_potential_mod_type(type)) {
4198 o->op_private |= OPpENTERSUB_INARGS;
4201 else { /* Compile-time error message: */
4202 OP *kid = cUNOPo->op_first;
4207 if (kid->op_type != OP_PUSHMARK) {
4208 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4210 "panic: unexpected lvalue entersub "
4211 "args: type/targ %ld:%" UVuf,
4212 (long)kid->op_type, (UV)kid->op_targ);
4213 kid = kLISTOP->op_first;
4215 while (OpHAS_SIBLING(kid))
4216 kid = OpSIBLING(kid);
4217 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4218 break; /* Postpone until runtime */
4221 kid = kUNOP->op_first;
4222 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4223 kid = kUNOP->op_first;
4224 if (kid->op_type == OP_NULL)
4226 "Unexpected constant lvalue entersub "
4227 "entry via type/targ %ld:%" UVuf,
4228 (long)kid->op_type, (UV)kid->op_targ);
4229 if (kid->op_type != OP_GV) {
4236 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4237 ? MUTABLE_CV(SvRV(gv))
4243 if (flags & OP_LVALUE_NO_CROAK)
4246 namesv = cv_name(cv, NULL, 0);
4247 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4248 "subroutine call of &%" SVf " in %s",
4249 SVfARG(namesv), PL_op_desc[type]),
4257 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4258 /* grep, foreach, subcalls, refgen */
4259 if (S_potential_mod_type(type))
4261 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4262 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4265 type ? PL_op_desc[type] : "local"));
4278 case OP_RIGHT_SHIFT:
4287 if (!(o->op_flags & OPf_STACKED))
4293 if (o->op_flags & OPf_STACKED) {
4297 if (!(o->op_private & OPpREPEAT_DOLIST))
4300 const I32 mods = PL_modcount;
4301 modkids(cBINOPo->op_first, type);
4302 if (type != OP_AASSIGN)
4304 kid = cBINOPo->op_last;
4305 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4306 const IV iv = SvIV(kSVOP_sv);
4307 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4309 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4312 PL_modcount = RETURN_UNLIMITED_NUMBER;
4318 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4319 op_lvalue(kid, type);
4324 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4325 PL_modcount = RETURN_UNLIMITED_NUMBER;
4326 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4327 fiable since some contexts need to know. */
4328 o->op_flags |= OPf_MOD;
4333 if (scalar_mod_type(o, type))
4335 ref(cUNOPo->op_first, o->op_type);
4342 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4343 if (type == OP_LEAVESUBLV && (
4344 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4345 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4347 o->op_private |= OPpMAYBE_LVSUB;
4351 PL_modcount = RETURN_UNLIMITED_NUMBER;
4356 if (type == OP_LEAVESUBLV)
4357 o->op_private |= OPpMAYBE_LVSUB;
4360 if (type == OP_LEAVESUBLV
4361 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4362 o->op_private |= OPpMAYBE_LVSUB;
4365 PL_hints |= HINT_BLOCK_SCOPE;
4366 if (type == OP_LEAVESUBLV)
4367 o->op_private |= OPpMAYBE_LVSUB;
4371 ref(cUNOPo->op_first, o->op_type);
4375 PL_hints |= HINT_BLOCK_SCOPE;
4385 case OP_AELEMFAST_LEX:
4392 PL_modcount = RETURN_UNLIMITED_NUMBER;
4393 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4395 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4396 fiable since some contexts need to know. */
4397 o->op_flags |= OPf_MOD;
4400 if (scalar_mod_type(o, type))
4402 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4403 && type == OP_LEAVESUBLV)
4404 o->op_private |= OPpMAYBE_LVSUB;
4408 if (!type) /* local() */
4409 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4410 PNfARG(PAD_COMPNAME(o->op_targ)));
4411 if (!(o->op_private & OPpLVAL_INTRO)
4412 || ( type != OP_SASSIGN && type != OP_AASSIGN
4413 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4414 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4422 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4426 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4432 if (type == OP_LEAVESUBLV)
4433 o->op_private |= OPpMAYBE_LVSUB;
4434 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4435 /* substr and vec */
4436 /* If this op is in merely potential (non-fatal) modifiable
4437 context, then apply OP_ENTERSUB context to
4438 the kid op (to avoid croaking). Other-
4439 wise pass this op’s own type so the correct op is mentioned
4440 in error messages. */
4441 op_lvalue(OpSIBLING(cBINOPo->op_first),
4442 S_potential_mod_type(type)
4450 ref(cBINOPo->op_first, o->op_type);
4451 if (type == OP_ENTERSUB &&
4452 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4453 o->op_private |= OPpLVAL_DEFER;
4454 if (type == OP_LEAVESUBLV)
4455 o->op_private |= OPpMAYBE_LVSUB;
4462 o->op_private |= OPpLVALUE;
4468 if (o->op_flags & OPf_KIDS)
4469 op_lvalue(cLISTOPo->op_last, type);
4474 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4476 else if (!(o->op_flags & OPf_KIDS))
4479 if (o->op_targ != OP_LIST) {
4480 OP *sib = OpSIBLING(cLISTOPo->op_first);
4481 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4488 * compared with things like OP_MATCH which have the argument
4494 * so handle specially to correctly get "Can't modify" croaks etc
4497 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4499 /* this should trigger a "Can't modify transliteration" err */
4500 op_lvalue(sib, type);
4502 op_lvalue(cBINOPo->op_first, type);
4508 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4509 /* elements might be in void context because the list is
4510 in scalar context or because they are attribute sub calls */
4511 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4512 op_lvalue(kid, type);
4520 if (type == OP_LEAVESUBLV
4521 || !S_vivifies(cLOGOPo->op_first->op_type))
4522 op_lvalue(cLOGOPo->op_first, type);
4523 if (type == OP_LEAVESUBLV
4524 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4525 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4529 if (type == OP_NULL) { /* local */
4531 if (!FEATURE_MYREF_IS_ENABLED)
4532 Perl_croak(aTHX_ "The experimental declared_refs "
4533 "feature is not enabled");
4534 Perl_ck_warner_d(aTHX_
4535 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4536 "Declaring references is experimental");
4537 op_lvalue(cUNOPo->op_first, OP_NULL);
4540 if (type != OP_AASSIGN && type != OP_SASSIGN
4541 && type != OP_ENTERLOOP)
4543 /* Don’t bother applying lvalue context to the ex-list. */
4544 kid = cUNOPx(cUNOPo->op_first)->op_first;
4545 assert (!OpHAS_SIBLING(kid));
4548 if (type == OP_NULL) /* local */
4550 if (type != OP_AASSIGN) goto nomod;
4551 kid = cUNOPo->op_first;
4554 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4555 S_lvref(aTHX_ kid, type);
4556 if (!PL_parser || PL_parser->error_count == ec) {
4557 if (!FEATURE_REFALIASING_IS_ENABLED)
4559 "Experimental aliasing via reference not enabled");
4560 Perl_ck_warner_d(aTHX_
4561 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4562 "Aliasing via reference is experimental");
4565 if (o->op_type == OP_REFGEN)
4566 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4571 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4572 /* This is actually @array = split. */
4573 PL_modcount = RETURN_UNLIMITED_NUMBER;
4579 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4583 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4584 their argument is a filehandle; thus \stat(".") should not set
4586 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4589 if (type != OP_LEAVESUBLV)
4590 o->op_flags |= OPf_MOD;
4592 if (type == OP_AASSIGN || type == OP_SASSIGN)
4593 o->op_flags |= OPf_SPECIAL
4594 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4595 else if (!type) { /* local() */
4598 o->op_private |= OPpLVAL_INTRO;
4599 o->op_flags &= ~OPf_SPECIAL;
4600 PL_hints |= HINT_BLOCK_SCOPE;
4605 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4606 "Useless localization of %s", OP_DESC(o));
4609 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4610 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4611 o->op_flags |= OPf_REF;
4616 S_scalar_mod_type(const OP *o, I32 type)
4621 if (o && o->op_type == OP_RV2GV)
4645 case OP_RIGHT_SHIFT:
4674 S_is_handle_constructor(const OP *o, I32 numargs)
4676 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4678 switch (o->op_type) {
4686 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4699 S_refkids(pTHX_ OP *o, I32 type)
4701 if (o && o->op_flags & OPf_KIDS) {
4703 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4710 /* Apply reference (autovivification) context to the subtree at o.
4712 * push @{expression}, ....;
4713 * o will be the head of 'expression' and type will be OP_RV2AV.
4714 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4716 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4717 * set_op_ref is true.
4719 * Also calls scalar(o).
4723 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4728 PERL_ARGS_ASSERT_DOREF;
4730 if (PL_parser && PL_parser->error_count)
4734 switch (o->op_type) {
4736 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4737 !(o->op_flags & OPf_STACKED)) {
4738 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4739 assert(cUNOPo->op_first->op_type == OP_NULL);
4740 /* disable pushmark */
4741 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4742 o->op_flags |= OPf_SPECIAL;
4744 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4745 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4746 : type == OP_RV2HV ? OPpDEREF_HV
4748 o->op_flags |= OPf_MOD;
4754 o = OpSIBLING(cUNOPo->op_first);
4758 if (type == OP_DEFINED)
4759 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4762 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;
4768 if (o->op_flags & OPf_KIDS) {
4770 o = cUNOPo->op_first;
4778 o->op_flags |= OPf_REF;
4781 if (type == OP_DEFINED)
4782 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4784 o = cUNOPo->op_first;
4790 o->op_flags |= OPf_REF;
4795 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4797 o = cBINOPo->op_first;
4802 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4803 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4804 : type == OP_RV2HV ? OPpDEREF_HV
4806 o->op_flags |= OPf_MOD;
4809 o = cBINOPo->op_first;
4818 if (!(o->op_flags & OPf_KIDS))
4820 o = cLISTOPo->op_last;
4829 return scalar(top_op); /* at top; no parents/siblings to try */
4830 if (OpHAS_SIBLING(o)) {
4831 o = o->op_sibparent;
4832 /* Normally skip all siblings and go straight to the parent;
4833 * the only op that requires two children to be processed
4834 * is OP_COND_EXPR */
4835 if (!OpHAS_SIBLING(o)
4836 && o->op_sibparent->op_type == OP_COND_EXPR)
4840 o = o->op_sibparent; /*try parent's next sibling */
4847 S_dup_attrlist(pTHX_ OP *o)
4851 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4853 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4854 * where the first kid is OP_PUSHMARK and the remaining ones
4855 * are OP_CONST. We need to push the OP_CONST values.
4857 if (o->op_type == OP_CONST)
4858 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4860 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4862 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4863 if (o->op_type == OP_CONST)
4864 rop = op_append_elem(OP_LIST, rop,
4865 newSVOP(OP_CONST, o->op_flags,
4866 SvREFCNT_inc_NN(cSVOPo->op_sv)));
4873 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4875 PERL_ARGS_ASSERT_APPLY_ATTRS;
4877 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4879 /* fake up C<use attributes $pkg,$rv,@attrs> */
4881 #define ATTRSMODULE "attributes"
4882 #define ATTRSMODULE_PM "attributes.pm"
4885 aTHX_ PERL_LOADMOD_IMPORT_OPS,
4886 newSVpvs(ATTRSMODULE),
4888 op_prepend_elem(OP_LIST,
4889 newSVOP(OP_CONST, 0, stashsv),
4890 op_prepend_elem(OP_LIST,
4891 newSVOP(OP_CONST, 0,
4893 dup_attrlist(attrs))));
4898 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4900 OP *pack, *imop, *arg;
4901 SV *meth, *stashsv, **svp;
4903 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4908 assert(target->op_type == OP_PADSV ||
4909 target->op_type == OP_PADHV ||
4910 target->op_type == OP_PADAV);
4912 /* Ensure that attributes.pm is loaded. */
4913 /* Don't force the C<use> if we don't need it. */
4914 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4915 if (svp && *svp != &PL_sv_undef)
4916 NOOP; /* already in %INC */
4918 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4919 newSVpvs(ATTRSMODULE), NULL);
4921 /* Need package name for method call. */
4922 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4924 /* Build up the real arg-list. */
4925 stashsv = newSVhek(HvNAME_HEK(stash));
4927 arg = newOP(OP_PADSV, 0);
4928 arg->op_targ = target->op_targ;
4929 arg = op_prepend_elem(OP_LIST,
4930 newSVOP(OP_CONST, 0, stashsv),
4931 op_prepend_elem(OP_LIST,
4932 newUNOP(OP_REFGEN, 0,
4934 dup_attrlist(attrs)));
4936 /* Fake up a method call to import */
4937 meth = newSVpvs_share("import");
4938 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4939 op_append_elem(OP_LIST,
4940 op_prepend_elem(OP_LIST, pack, arg),
4941 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4943 /* Combine the ops. */
4944 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4948 =notfor apidoc apply_attrs_string
4950 Attempts to apply a list of attributes specified by the C<attrstr> and
4951 C<len> arguments to the subroutine identified by the C<cv> argument which
4952 is expected to be associated with the package identified by the C<stashpv>
4953 argument (see L<attributes>). It gets this wrong, though, in that it
4954 does not correctly identify the boundaries of the individual attribute
4955 specifications within C<attrstr>. This is not really intended for the
4956 public API, but has to be listed here for systems such as AIX which
4957 need an explicit export list for symbols. (It's called from XS code
4958 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
4959 to respect attribute syntax properly would be welcome.
4965 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4966 const char *attrstr, STRLEN len)
4970 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4973 len = strlen(attrstr);
4977 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4979 const char * const sstr = attrstr;
4980 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4981 attrs = op_append_elem(OP_LIST, attrs,
4982 newSVOP(OP_CONST, 0,
4983 newSVpvn(sstr, attrstr-sstr)));
4987 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4988 newSVpvs(ATTRSMODULE),
4989 NULL, op_prepend_elem(OP_LIST,
4990 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4991 op_prepend_elem(OP_LIST,
4992 newSVOP(OP_CONST, 0,
4993 newRV(MUTABLE_SV(cv))),
4998 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5001 OP *new_proto = NULL;
5006 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5012 if (o->op_type == OP_CONST) {
5013 pv = SvPV(cSVOPo_sv, pvlen);
5014 if (memBEGINs(pv, pvlen, "prototype(")) {
5015 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5016 SV ** const tmpo = cSVOPx_svp(o);
5017 SvREFCNT_dec(cSVOPo_sv);
5022 } else if (o->op_type == OP_LIST) {
5024 assert(o->op_flags & OPf_KIDS);
5025 lasto = cLISTOPo->op_first;
5026 assert(lasto->op_type == OP_PUSHMARK);
5027 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5028 if (o->op_type == OP_CONST) {
5029 pv = SvPV(cSVOPo_sv, pvlen);
5030 if (memBEGINs(pv, pvlen, "prototype(")) {
5031 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5032 SV ** const tmpo = cSVOPx_svp(o);
5033 SvREFCNT_dec(cSVOPo_sv);
5035 if (new_proto && ckWARN(WARN_MISC)) {
5037 const char * newp = SvPV(cSVOPo_sv, new_len);
5038 Perl_warner(aTHX_ packWARN(WARN_MISC),
5039 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5040 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5046 /* excise new_proto from the list */
5047 op_sibling_splice(*attrs, lasto, 1, NULL);
5054 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5055 would get pulled in with no real need */
5056 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5065 svname = sv_newmortal();
5066 gv_efullname3(svname, name, NULL);
5068 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5069 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5071 svname = (SV *)name;
5072 if (ckWARN(WARN_ILLEGALPROTO))
5073 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5075 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5076 STRLEN old_len, new_len;
5077 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5078 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5080 if (curstash && svname == (SV *)name
5081 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5082 svname = sv_2mortal(newSVsv(PL_curstname));
5083 sv_catpvs(svname, "::");
5084 sv_catsv(svname, (SV *)name);
5087 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5088 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5090 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5091 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5101 S_cant_declare(pTHX_ OP *o)
5103 if (o->op_type == OP_NULL
5104 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5105 o = cUNOPo->op_first;
5106 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5107 o->op_type == OP_NULL
5108 && o->op_flags & OPf_SPECIAL
5111 PL_parser->in_my == KEY_our ? "our" :
5112 PL_parser->in_my == KEY_state ? "state" :
5117 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5120 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5122 PERL_ARGS_ASSERT_MY_KID;
5124 if (!o || (PL_parser && PL_parser->error_count))
5129 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5131 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5132 my_kid(kid, attrs, imopsp);
5134 } else if (type == OP_UNDEF || type == OP_STUB) {
5136 } else if (type == OP_RV2SV || /* "our" declaration */
5139 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5140 S_cant_declare(aTHX_ o);
5142 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5144 PL_parser->in_my = FALSE;
5145 PL_parser->in_my_stash = NULL;
5146 apply_attrs(GvSTASH(gv),
5147 (type == OP_RV2SV ? GvSVn(gv) :
5148 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5149 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5152 o->op_private |= OPpOUR_INTRO;
5155 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5156 if (!FEATURE_MYREF_IS_ENABLED)
5157 Perl_croak(aTHX_ "The experimental declared_refs "
5158 "feature is not enabled");
5159 Perl_ck_warner_d(aTHX_
5160 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5161 "Declaring references is experimental");
5162 /* Kid is a nulled OP_LIST, handled above. */
5163 my_kid(cUNOPo->op_first, attrs, imopsp);
5166 else if (type != OP_PADSV &&
5169 type != OP_PUSHMARK)
5171 S_cant_declare(aTHX_ o);
5174 else if (attrs && type != OP_PUSHMARK) {
5178 PL_parser->in_my = FALSE;
5179 PL_parser->in_my_stash = NULL;
5181 /* check for C<my Dog $spot> when deciding package */
5182 stash = PAD_COMPNAME_TYPE(o->op_targ);
5184 stash = PL_curstash;
5185 apply_attrs_my(stash, o, attrs, imopsp);
5187 o->op_flags |= OPf_MOD;
5188 o->op_private |= OPpLVAL_INTRO;
5190 o->op_private |= OPpPAD_STATE;
5195 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5198 int maybe_scalar = 0;
5200 PERL_ARGS_ASSERT_MY_ATTRS;
5202 /* [perl #17376]: this appears to be premature, and results in code such as
5203 C< our(%x); > executing in list mode rather than void mode */
5205 if (o->op_flags & OPf_PARENS)
5215 o = my_kid(o, attrs, &rops);
5217 if (maybe_scalar && o->op_type == OP_PADSV) {
5218 o = scalar(op_append_list(OP_LIST, rops, o));
5219 o->op_private |= OPpLVAL_INTRO;
5222 /* The listop in rops might have a pushmark at the beginning,
5223 which will mess up list assignment. */
5224 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5225 if (rops->op_type == OP_LIST &&
5226 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5228 OP * const pushmark = lrops->op_first;
5229 /* excise pushmark */
5230 op_sibling_splice(rops, NULL, 1, NULL);
5233 o = op_append_list(OP_LIST, o, rops);
5236 PL_parser->in_my = FALSE;
5237 PL_parser->in_my_stash = NULL;
5242 Perl_sawparens(pTHX_ OP *o)
5244 PERL_UNUSED_CONTEXT;
5246 o->op_flags |= OPf_PARENS;
5251 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5255 const OPCODE ltype = left->op_type;
5256 const OPCODE rtype = right->op_type;
5258 PERL_ARGS_ASSERT_BIND_MATCH;
5260 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5261 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5263 const char * const desc
5265 rtype == OP_SUBST || rtype == OP_TRANS
5266 || rtype == OP_TRANSR
5268 ? (int)rtype : OP_MATCH];
5269 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5271 S_op_varname(aTHX_ left);
5273 Perl_warner(aTHX_ packWARN(WARN_MISC),
5274 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5275 desc, SVfARG(name), SVfARG(name));
5277 const char * const sample = (isary
5278 ? "@array" : "%hash");
5279 Perl_warner(aTHX_ packWARN(WARN_MISC),
5280 "Applying %s to %s will act on scalar(%s)",
5281 desc, sample, sample);
5285 if (rtype == OP_CONST &&
5286 cSVOPx(right)->op_private & OPpCONST_BARE &&
5287 cSVOPx(right)->op_private & OPpCONST_STRICT)
5289 no_bareword_allowed(right);
5292 /* !~ doesn't make sense with /r, so error on it for now */
5293 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5295 /* diag_listed_as: Using !~ with %s doesn't make sense */
5296 yyerror("Using !~ with s///r doesn't make sense");
5297 if (rtype == OP_TRANSR && type == OP_NOT)
5298 /* diag_listed_as: Using !~ with %s doesn't make sense */
5299 yyerror("Using !~ with tr///r doesn't make sense");
5301 ismatchop = (rtype == OP_MATCH ||
5302 rtype == OP_SUBST ||
5303 rtype == OP_TRANS || rtype == OP_TRANSR)
5304 && !(right->op_flags & OPf_SPECIAL);
5305 if (ismatchop && right->op_private & OPpTARGET_MY) {
5307 right->op_private &= ~OPpTARGET_MY;
5309 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5310 if (left->op_type == OP_PADSV
5311 && !(left->op_private & OPpLVAL_INTRO))
5313 right->op_targ = left->op_targ;
5318 right->op_flags |= OPf_STACKED;
5319 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5320 ! (rtype == OP_TRANS &&
5321 right->op_private & OPpTRANS_IDENTICAL) &&
5322 ! (rtype == OP_SUBST &&
5323 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5324 left = op_lvalue(left, rtype);
5325 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5326 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5328 o = op_prepend_elem(rtype, scalar(left), right);
5331 return newUNOP(OP_NOT, 0, scalar(o));
5335 return bind_match(type, left,
5336 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5340 Perl_invert(pTHX_ OP *o)
5344 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5348 =for apidoc op_scope
5350 Wraps up an op tree with some additional ops so that at runtime a dynamic
5351 scope will be created. The original ops run in the new dynamic scope,
5352 and then, provided that they exit normally, the scope will be unwound.
5353 The additional ops used to create and unwind the dynamic scope will
5354 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5355 instead if the ops are simple enough to not need the full dynamic scope
5362 Perl_op_scope(pTHX_ OP *o)
5366 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5367 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5368 OpTYPE_set(o, OP_LEAVE);
5370 else if (o->op_type == OP_LINESEQ) {
5372 OpTYPE_set(o, OP_SCOPE);
5373 kid = ((LISTOP*)o)->op_first;
5374 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5377 /* The following deals with things like 'do {1 for 1}' */
5378 kid = OpSIBLING(kid);
5380 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5385 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5391 Perl_op_unscope(pTHX_ OP *o)
5393 if (o && o->op_type == OP_LINESEQ) {
5394 OP *kid = cLISTOPo->op_first;
5395 for(; kid; kid = OpSIBLING(kid))
5396 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5403 =for apidoc block_start
5405 Handles compile-time scope entry.
5406 Arranges for hints to be restored on block
5407 exit and also handles pad sequence numbers to make lexical variables scope
5408 right. Returns a savestack index for use with C<block_end>.
5414 Perl_block_start(pTHX_ int full)
5416 const int retval = PL_savestack_ix;
5418 PL_compiling.cop_seq = PL_cop_seqmax;
5420 pad_block_start(full);
5422 PL_hints &= ~HINT_BLOCK_SCOPE;
5423 SAVECOMPILEWARNINGS();
5424 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5425 SAVEI32(PL_compiling.cop_seq);
5426 PL_compiling.cop_seq = 0;
5428 CALL_BLOCK_HOOKS(bhk_start, full);
5434 =for apidoc block_end
5436 Handles compile-time scope exit. C<floor>
5437 is the savestack index returned by
5438 C<block_start>, and C<seq> is the body of the block. Returns the block,
5445 Perl_block_end(pTHX_ I32 floor, OP *seq)
5447 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5448 OP* retval = scalarseq(seq);
5451 /* XXX Is the null PL_parser check necessary here? */
5452 assert(PL_parser); /* Let’s find out under debugging builds. */
5453 if (PL_parser && PL_parser->parsed_sub) {
5454 o = newSTATEOP(0, NULL, NULL);
5456 retval = op_append_elem(OP_LINESEQ, retval, o);
5459 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5463 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5467 /* pad_leavemy has created a sequence of introcv ops for all my
5468 subs declared in the block. We have to replicate that list with
5469 clonecv ops, to deal with this situation:
5474 sub s1 { state sub foo { \&s2 } }
5477 Originally, I was going to have introcv clone the CV and turn
5478 off the stale flag. Since &s1 is declared before &s2, the
5479 introcv op for &s1 is executed (on sub entry) before the one for
5480 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5481 cloned, since it is a state sub) closes over &s2 and expects
5482 to see it in its outer CV’s pad. If the introcv op clones &s1,
5483 then &s2 is still marked stale. Since &s1 is not active, and
5484 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5485 ble will not stay shared’ warning. Because it is the same stub
5486 that will be used when the introcv op for &s2 is executed, clos-
5487 ing over it is safe. Hence, we have to turn off the stale flag
5488 on all lexical subs in the block before we clone any of them.
5489 Hence, having introcv clone the sub cannot work. So we create a
5490 list of ops like this:
5514 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5515 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5516 for (;; kid = OpSIBLING(kid)) {
5517 OP *newkid = newOP(OP_CLONECV, 0);
5518 newkid->op_targ = kid->op_targ;
5519 o = op_append_elem(OP_LINESEQ, o, newkid);
5520 if (kid == last) break;
5522 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5525 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5531 =head1 Compile-time scope hooks
5533 =for apidoc blockhook_register
5535 Register a set of hooks to be called when the Perl lexical scope changes
5536 at compile time. See L<perlguts/"Compile-time scope hooks">.
5542 Perl_blockhook_register(pTHX_ BHK *hk)
5544 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5546 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5550 Perl_newPROG(pTHX_ OP *o)
5554 PERL_ARGS_ASSERT_NEWPROG;
5561 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5562 ((PL_in_eval & EVAL_KEEPERR)
5563 ? OPf_SPECIAL : 0), o);
5566 assert(CxTYPE(cx) == CXt_EVAL);
5568 if ((cx->blk_gimme & G_WANT) == G_VOID)
5569 scalarvoid(PL_eval_root);
5570 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5573 scalar(PL_eval_root);
5575 start = op_linklist(PL_eval_root);
5576 PL_eval_root->op_next = 0;
5577 i = PL_savestack_ix;
5580 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5582 PL_savestack_ix = i;
5585 if (o->op_type == OP_STUB) {
5586 /* This block is entered if nothing is compiled for the main
5587 program. This will be the case for an genuinely empty main
5588 program, or one which only has BEGIN blocks etc, so already
5591 Historically (5.000) the guard above was !o. However, commit
5592 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5593 c71fccf11fde0068, changed perly.y so that newPROG() is now
5594 called with the output of block_end(), which returns a new
5595 OP_STUB for the case of an empty optree. ByteLoader (and
5596 maybe other things) also take this path, because they set up
5597 PL_main_start and PL_main_root directly, without generating an
5600 If the parsing the main program aborts (due to parse errors,
5601 or due to BEGIN or similar calling exit), then newPROG()
5602 isn't even called, and hence this code path and its cleanups
5603 are skipped. This shouldn't make a make a difference:
5604 * a non-zero return from perl_parse is a failure, and
5605 perl_destruct() should be called immediately.
5606 * however, if exit(0) is called during the parse, then
5607 perl_parse() returns 0, and perl_run() is called. As
5608 PL_main_start will be NULL, perl_run() will return
5609 promptly, and the exit code will remain 0.
5612 PL_comppad_name = 0;
5614 S_op_destroy(aTHX_ o);
5617 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5618 PL_curcop = &PL_compiling;
5619 start = LINKLIST(PL_main_root);
5620 PL_main_root->op_next = 0;
5621 S_process_optree(aTHX_ NULL, PL_main_root, start);
5622 if (!PL_parser->error_count)
5623 /* on error, leave CV slabbed so that ops left lying around
5624 * will eb cleaned up. Else unslab */
5625 cv_forget_slab(PL_compcv);
5628 /* Register with debugger */
5630 CV * const cv = get_cvs("DB::postponed", 0);
5634 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5636 call_sv(MUTABLE_SV(cv), G_DISCARD);
5643 Perl_localize(pTHX_ OP *o, I32 lex)
5645 PERL_ARGS_ASSERT_LOCALIZE;
5647 if (o->op_flags & OPf_PARENS)
5648 /* [perl #17376]: this appears to be premature, and results in code such as
5649 C< our(%x); > executing in list mode rather than void mode */
5656 if ( PL_parser->bufptr > PL_parser->oldbufptr
5657 && PL_parser->bufptr[-1] == ','
5658 && ckWARN(WARN_PARENTHESIS))
5660 char *s = PL_parser->bufptr;
5663 /* some heuristics to detect a potential error */
5664 while (*s && (strchr(", \t\n", *s)))
5668 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5670 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5673 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5675 while (*s && (strchr(", \t\n", *s)))
5681 if (sigil && (*s == ';' || *s == '=')) {
5682 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5683 "Parentheses missing around \"%s\" list",
5685 ? (PL_parser->in_my == KEY_our
5687 : PL_parser->in_my == KEY_state
5697 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5698 PL_parser->in_my = FALSE;
5699 PL_parser->in_my_stash = NULL;
5704 Perl_jmaybe(pTHX_ OP *o)
5706 PERL_ARGS_ASSERT_JMAYBE;
5708 if (o->op_type == OP_LIST) {
5710 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5711 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5716 PERL_STATIC_INLINE OP *
5717 S_op_std_init(pTHX_ OP *o)
5719 I32 type = o->op_type;
5721 PERL_ARGS_ASSERT_OP_STD_INIT;
5723 if (PL_opargs[type] & OA_RETSCALAR)
5725 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5726 o->op_targ = pad_alloc(type, SVs_PADTMP);
5731 PERL_STATIC_INLINE OP *
5732 S_op_integerize(pTHX_ OP *o)
5734 I32 type = o->op_type;
5736 PERL_ARGS_ASSERT_OP_INTEGERIZE;
5738 /* integerize op. */
5739 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5742 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5745 if (type == OP_NEGATE)
5746 /* XXX might want a ck_negate() for this */
5747 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5752 /* This function exists solely to provide a scope to limit
5753 setjmp/longjmp() messing with auto variables.
5755 PERL_STATIC_INLINE int
5756 S_fold_constants_eval(pTHX) {
5772 S_fold_constants(pTHX_ OP *const o)
5777 I32 type = o->op_type;
5782 SV * const oldwarnhook = PL_warnhook;
5783 SV * const olddiehook = PL_diehook;
5785 U8 oldwarn = PL_dowarn;
5788 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5790 if (!(PL_opargs[type] & OA_FOLDCONST))
5799 #ifdef USE_LOCALE_CTYPE
5800 if (IN_LC_COMPILETIME(LC_CTYPE))
5809 #ifdef USE_LOCALE_COLLATE
5810 if (IN_LC_COMPILETIME(LC_COLLATE))
5815 /* XXX what about the numeric ops? */
5816 #ifdef USE_LOCALE_NUMERIC
5817 if (IN_LC_COMPILETIME(LC_NUMERIC))
5822 if (!OpHAS_SIBLING(cLISTOPo->op_first)
5823 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5826 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5827 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5829 const char *s = SvPVX_const(sv);
5830 while (s < SvEND(sv)) {
5831 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5838 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5841 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5842 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5846 if (PL_parser && PL_parser->error_count)
5847 goto nope; /* Don't try to run w/ errors */
5849 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5850 switch (curop->op_type) {
5852 if ( (curop->op_private & OPpCONST_BARE)
5853 && (curop->op_private & OPpCONST_STRICT)) {
5854 no_bareword_allowed(curop);
5862 /* Foldable; move to next op in list */
5866 /* No other op types are considered foldable */
5871 curop = LINKLIST(o);
5872 old_next = o->op_next;
5876 old_cxix = cxstack_ix;
5877 create_eval_scope(NULL, G_FAKINGEVAL);
5879 /* Verify that we don't need to save it: */
5880 assert(PL_curcop == &PL_compiling);
5881 StructCopy(&PL_compiling, ¬_compiling, COP);
5882 PL_curcop = ¬_compiling;
5883 /* The above ensures that we run with all the correct hints of the
5884 currently compiling COP, but that IN_PERL_RUNTIME is true. */
5885 assert(IN_PERL_RUNTIME);
5886 PL_warnhook = PERL_WARNHOOK_FATAL;
5889 /* Effective $^W=1. */
5890 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5891 PL_dowarn |= G_WARN_ON;
5893 ret = S_fold_constants_eval(aTHX);
5897 sv = *(PL_stack_sp--);
5898 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
5899 pad_swipe(o->op_targ, FALSE);
5901 else if (SvTEMP(sv)) { /* grab mortal temp? */
5902 SvREFCNT_inc_simple_void(sv);
5905 else { assert(SvIMMORTAL(sv)); }
5908 /* Something tried to die. Abandon constant folding. */
5909 /* Pretend the error never happened. */
5911 o->op_next = old_next;
5914 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
5915 PL_warnhook = oldwarnhook;
5916 PL_diehook = olddiehook;
5917 /* XXX note that this croak may fail as we've already blown away
5918 * the stack - eg any nested evals */
5919 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5921 PL_dowarn = oldwarn;
5922 PL_warnhook = oldwarnhook;
5923 PL_diehook = olddiehook;
5924 PL_curcop = &PL_compiling;
5926 /* if we croaked, depending on how we croaked the eval scope
5927 * may or may not have already been popped */
5928 if (cxstack_ix > old_cxix) {
5929 assert(cxstack_ix == old_cxix + 1);
5930 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5931 delete_eval_scope();
5936 /* OP_STRINGIFY and constant folding are used to implement qq.
5937 Here the constant folding is an implementation detail that we
5938 want to hide. If the stringify op is itself already marked
5939 folded, however, then it is actually a folded join. */
5940 is_stringify = type == OP_STRINGIFY && !o->op_folded;
5945 else if (!SvIMMORTAL(sv)) {
5949 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5950 if (!is_stringify) newop->op_folded = 1;
5957 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
5958 * the constant value being an AV holding the flattened range.
5962 S_gen_constant_list(pTHX_ OP *o)
5965 OP *curop, *old_next;
5966 SV * const oldwarnhook = PL_warnhook;
5967 SV * const olddiehook = PL_diehook;
5969 U8 oldwarn = PL_dowarn;
5979 if (PL_parser && PL_parser->error_count)
5980 return; /* Don't attempt to run with errors */
5982 curop = LINKLIST(o);
5983 old_next = o->op_next;
5985 op_was_null = o->op_type == OP_NULL;
5986 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5987 o->op_type = OP_CUSTOM;
5990 o->op_type = OP_NULL;
5991 S_prune_chain_head(&curop);
5994 old_cxix = cxstack_ix;
5995 create_eval_scope(NULL, G_FAKINGEVAL);
5997 old_curcop = PL_curcop;
5998 StructCopy(old_curcop, ¬_compiling, COP);
5999 PL_curcop = ¬_compiling;
6000 /* The above ensures that we run with all the correct hints of the
6001 current COP, but that IN_PERL_RUNTIME is true. */
6002 assert(IN_PERL_RUNTIME);
6003 PL_warnhook = PERL_WARNHOOK_FATAL;
6007 /* Effective $^W=1. */
6008 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6009 PL_dowarn |= G_WARN_ON;
6013 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6014 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6016 Perl_pp_pushmark(aTHX);
6019 assert (!(curop->op_flags & OPf_SPECIAL));
6020 assert(curop->op_type == OP_RANGE);
6021 Perl_pp_anonlist(aTHX);
6025 o->op_next = old_next;
6029 PL_warnhook = oldwarnhook;
6030 PL_diehook = olddiehook;
6031 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6036 PL_dowarn = oldwarn;
6037 PL_warnhook = oldwarnhook;
6038 PL_diehook = olddiehook;
6039 PL_curcop = old_curcop;
6041 if (cxstack_ix > old_cxix) {
6042 assert(cxstack_ix == old_cxix + 1);
6043 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6044 delete_eval_scope();
6049 OpTYPE_set(o, OP_RV2AV);
6050 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6051 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6052 o->op_opt = 0; /* needs to be revisited in rpeep() */
6053 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6055 /* replace subtree with an OP_CONST */
6056 curop = ((UNOP*)o)->op_first;
6057 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6060 if (AvFILLp(av) != -1)
6061 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6064 SvREADONLY_on(*svp);
6072 =head1 Optree Manipulation Functions
6075 /* List constructors */
6078 =for apidoc op_append_elem
6080 Append an item to the list of ops contained directly within a list-type
6081 op, returning the lengthened list. C<first> is the list-type op,
6082 and C<last> is the op to append to the list. C<optype> specifies the
6083 intended opcode for the list. If C<first> is not already a list of the
6084 right type, it will be upgraded into one. If either C<first> or C<last>
6085 is null, the other is returned unchanged.
6091 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6099 if (first->op_type != (unsigned)type
6100 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6102 return newLISTOP(type, 0, first, last);
6105 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6106 first->op_flags |= OPf_KIDS;
6111 =for apidoc op_append_list
6113 Concatenate the lists of ops contained directly within two list-type ops,
6114 returning the combined list. C<first> and C<last> are the list-type ops
6115 to concatenate. C<optype> specifies the intended opcode for the list.
6116 If either C<first> or C<last> is not already a list of the right type,
6117 it will be upgraded into one. If either C<first> or C<last> is null,
6118 the other is returned unchanged.
6124 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6132 if (first->op_type != (unsigned)type)
6133 return op_prepend_elem(type, first, last);
6135 if (last->op_type != (unsigned)type)
6136 return op_append_elem(type, first, last);
6138 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6139 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6140 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6141 first->op_flags |= (last->op_flags & OPf_KIDS);
6143 S_op_destroy(aTHX_ last);
6149 =for apidoc op_prepend_elem
6151 Prepend an item to the list of ops contained directly within a list-type
6152 op, returning the lengthened list. C<first> is the op to prepend to the
6153 list, and C<last> is the list-type op. C<optype> specifies the intended
6154 opcode for the list. If C<last> is not already a list of the right type,
6155 it will be upgraded into one. If either C<first> or C<last> is null,
6156 the other is returned unchanged.
6162 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6170 if (last->op_type == (unsigned)type) {
6171 if (type == OP_LIST) { /* already a PUSHMARK there */
6172 /* insert 'first' after pushmark */
6173 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6174 if (!(first->op_flags & OPf_PARENS))
6175 last->op_flags &= ~OPf_PARENS;
6178 op_sibling_splice(last, NULL, 0, first);
6179 last->op_flags |= OPf_KIDS;
6183 return newLISTOP(type, 0, first, last);
6187 =for apidoc op_convert_list
6189 Converts C<o> into a list op if it is not one already, and then converts it
6190 into the specified C<type>, calling its check function, allocating a target if
6191 it needs one, and folding constants.
6193 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6194 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6195 C<op_convert_list> to make it the right type.
6201 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6204 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6205 if (!o || o->op_type != OP_LIST)
6206 o = force_list(o, 0);
6209 o->op_flags &= ~OPf_WANT;
6210 o->op_private &= ~OPpLVAL_INTRO;
6213 if (!(PL_opargs[type] & OA_MARK))
6214 op_null(cLISTOPo->op_first);
6216 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6217 if (kid2 && kid2->op_type == OP_COREARGS) {
6218 op_null(cLISTOPo->op_first);
6219 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6223 if (type != OP_SPLIT)
6224 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6225 * ck_split() create a real PMOP and leave the op's type as listop
6226 * for now. Otherwise op_free() etc will crash.
6228 OpTYPE_set(o, type);
6230 o->op_flags |= flags;
6231 if (flags & OPf_FOLDED)
6234 o = CHECKOP(type, o);
6235 if (o->op_type != (unsigned)type)
6238 return fold_constants(op_integerize(op_std_init(o)));
6245 =head1 Optree construction
6247 =for apidoc newNULLLIST
6249 Constructs, checks, and returns a new C<stub> op, which represents an
6250 empty list expression.
6256 Perl_newNULLLIST(pTHX)
6258 return newOP(OP_STUB, 0);
6261 /* promote o and any siblings to be a list if its not already; i.e.
6269 * pushmark - o - A - B
6271 * If nullit it true, the list op is nulled.
6275 S_force_list(pTHX_ OP *o, bool nullit)
6277 if (!o || o->op_type != OP_LIST) {
6280 /* manually detach any siblings then add them back later */
6281 rest = OpSIBLING(o);
6282 OpLASTSIB_set(o, NULL);
6284 o = newLISTOP(OP_LIST, 0, o, NULL);
6286 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6294 =for apidoc newLISTOP
6296 Constructs, checks, and returns an op of any list type. C<type> is
6297 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6298 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6299 supply up to two ops to be direct children of the list op; they are
6300 consumed by this function and become part of the constructed op tree.
6302 For most list operators, the check function expects all the kid ops to be
6303 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6304 appropriate. What you want to do in that case is create an op of type
6305 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6306 See L</op_convert_list> for more information.
6313 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6317 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6318 * pushmark is banned. So do it now while existing ops are in a
6319 * consistent state, in case they suddenly get freed */
6320 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6322 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6323 || type == OP_CUSTOM);
6325 NewOp(1101, listop, 1, LISTOP);
6326 OpTYPE_set(listop, type);
6329 listop->op_flags = (U8)flags;
6333 else if (!first && last)
6336 OpMORESIB_set(first, last);
6337 listop->op_first = first;
6338 listop->op_last = last;
6341 OpMORESIB_set(pushop, first);
6342 listop->op_first = pushop;
6343 listop->op_flags |= OPf_KIDS;
6345 listop->op_last = pushop;
6347 if (listop->op_last)
6348 OpLASTSIB_set(listop->op_last, (OP*)listop);
6350 return CHECKOP(type, listop);
6356 Constructs, checks, and returns an op of any base type (any type that
6357 has no extra fields). C<type> is the opcode. C<flags> gives the
6358 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6365 Perl_newOP(pTHX_ I32 type, I32 flags)
6370 if (type == -OP_ENTEREVAL) {
6371 type = OP_ENTEREVAL;
6372 flags |= OPpEVAL_BYTES<<8;
6375 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6376 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6377 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6378 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6380 NewOp(1101, o, 1, OP);
6381 OpTYPE_set(o, type);
6382 o->op_flags = (U8)flags;
6385 o->op_private = (U8)(0 | (flags >> 8));
6386 if (PL_opargs[type] & OA_RETSCALAR)
6388 if (PL_opargs[type] & OA_TARGET)
6389 o->op_targ = pad_alloc(type, SVs_PADTMP);
6390 return CHECKOP(type, o);
6396 Constructs, checks, and returns an op of any unary type. C<type> is
6397 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6398 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6399 bits, the eight bits of C<op_private>, except that the bit with value 1
6400 is automatically set. C<first> supplies an optional op to be the direct
6401 child of the unary op; it is consumed by this function and become part
6402 of the constructed op tree.
6408 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6413 if (type == -OP_ENTEREVAL) {
6414 type = OP_ENTEREVAL;
6415 flags |= OPpEVAL_BYTES<<8;
6418 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6419 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6420 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6421 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6422 || type == OP_SASSIGN
6423 || type == OP_ENTERTRY
6424 || type == OP_CUSTOM
6425 || type == OP_NULL );
6428 first = newOP(OP_STUB, 0);
6429 if (PL_opargs[type] & OA_MARK)
6430 first = force_list(first, 1);
6432 NewOp(1101, unop, 1, UNOP);
6433 OpTYPE_set(unop, type);
6434 unop->op_first = first;
6435 unop->op_flags = (U8)(flags | OPf_KIDS);
6436 unop->op_private = (U8)(1 | (flags >> 8));
6438 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6439 OpLASTSIB_set(first, (OP*)unop);
6441 unop = (UNOP*) CHECKOP(type, unop);
6445 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6449 =for apidoc newUNOP_AUX
6451 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6452 initialised to C<aux>
6458 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6463 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6464 || type == OP_CUSTOM);
6466 NewOp(1101, unop, 1, UNOP_AUX);
6467 unop->op_type = (OPCODE)type;
6468 unop->op_ppaddr = PL_ppaddr[type];
6469 unop->op_first = first;
6470 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6471 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6474 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6475 OpLASTSIB_set(first, (OP*)unop);
6477 unop = (UNOP_AUX*) CHECKOP(type, unop);
6479 return op_std_init((OP *) unop);
6483 =for apidoc newMETHOP
6485 Constructs, checks, and returns an op of method type with a method name
6486 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6487 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6488 and, shifted up eight bits, the eight bits of C<op_private>, except that
6489 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6490 op which evaluates method name; it is consumed by this function and
6491 become part of the constructed op tree.
6492 Supported optypes: C<OP_METHOD>.
6498 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6502 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6503 || type == OP_CUSTOM);
6505 NewOp(1101, methop, 1, METHOP);
6507 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6508 methop->op_flags = (U8)(flags | OPf_KIDS);
6509 methop->op_u.op_first = dynamic_meth;
6510 methop->op_private = (U8)(1 | (flags >> 8));
6512 if (!OpHAS_SIBLING(dynamic_meth))
6513 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6517 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6518 methop->op_u.op_meth_sv = const_meth;
6519 methop->op_private = (U8)(0 | (flags >> 8));
6520 methop->op_next = (OP*)methop;
6524 methop->op_rclass_targ = 0;
6526 methop->op_rclass_sv = NULL;
6529 OpTYPE_set(methop, type);
6530 return CHECKOP(type, methop);
6534 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6535 PERL_ARGS_ASSERT_NEWMETHOP;
6536 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6540 =for apidoc newMETHOP_named
6542 Constructs, checks, and returns an op of method type with a constant
6543 method name. C<type> is the opcode. C<flags> gives the eight bits of
6544 C<op_flags>, and, shifted up eight bits, the eight bits of
6545 C<op_private>. C<const_meth> supplies a constant method name;
6546 it must be a shared COW string.
6547 Supported optypes: C<OP_METHOD_NAMED>.
6553 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6554 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6555 return newMETHOP_internal(type, flags, NULL, const_meth);
6559 =for apidoc newBINOP
6561 Constructs, checks, and returns an op of any binary type. C<type>
6562 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6563 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6564 the eight bits of C<op_private>, except that the bit with value 1 or
6565 2 is automatically set as required. C<first> and C<last> supply up to
6566 two ops to be the direct children of the binary op; they are consumed
6567 by this function and become part of the constructed op tree.
6573 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6578 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6579 || type == OP_NULL || type == OP_CUSTOM);
6581 NewOp(1101, binop, 1, BINOP);
6584 first = newOP(OP_NULL, 0);
6586 OpTYPE_set(binop, type);
6587 binop->op_first = first;
6588 binop->op_flags = (U8)(flags | OPf_KIDS);
6591 binop->op_private = (U8)(1 | (flags >> 8));
6594 binop->op_private = (U8)(2 | (flags >> 8));
6595 OpMORESIB_set(first, last);
6598 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6599 OpLASTSIB_set(last, (OP*)binop);
6601 binop->op_last = OpSIBLING(binop->op_first);
6603 OpLASTSIB_set(binop->op_last, (OP*)binop);
6605 binop = (BINOP*)CHECKOP(type, binop);
6606 if (binop->op_next || binop->op_type != (OPCODE)type)
6609 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6612 /* Helper function for S_pmtrans(): comparison function to sort an array
6613 * of codepoint range pairs. Sorts by start point, or if equal, by end
6616 static int uvcompare(const void *a, const void *b)
6617 __attribute__nonnull__(1)
6618 __attribute__nonnull__(2)
6619 __attribute__pure__;
6620 static int uvcompare(const void *a, const void *b)
6622 if (*((const UV *)a) < (*(const UV *)b))
6624 if (*((const UV *)a) > (*(const UV *)b))
6626 if (*((const UV *)a+1) < (*(const UV *)b+1))
6628 if (*((const UV *)a+1) > (*(const UV *)b+1))
6633 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6634 * containing the search and replacement strings, assemble into
6635 * a translation table attached as o->op_pv.
6636 * Free expr and repl.
6637 * It expects the toker to have already set the
6638 * OPpTRANS_COMPLEMENT
6641 * flags as appropriate; this function may add
6644 * OPpTRANS_IDENTICAL
6650 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6652 SV * const tstr = ((SVOP*)expr)->op_sv;
6653 SV * const rstr = ((SVOP*)repl)->op_sv;
6656 const U8 *t = (U8*)SvPV_const(tstr, tlen);
6657 const U8 *r = (U8*)SvPV_const(rstr, rlen);
6661 SSize_t struct_size; /* malloced size of table struct */
6663 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6664 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6665 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6668 PERL_ARGS_ASSERT_PMTRANS;
6670 PL_hints |= HINT_BLOCK_SCOPE;
6673 o->op_private |= OPpTRANS_FROM_UTF;
6676 o->op_private |= OPpTRANS_TO_UTF;
6678 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6680 /* for utf8 translations, op_sv will be set to point to a swash
6681 * containing codepoint ranges. This is done by first assembling
6682 * a textual representation of the ranges in listsv then compiling
6683 * it using swash_init(). For more details of the textual format,
6684 * see L<perlunicode.pod/"User-Defined Character Properties"> .
6687 SV* const listsv = newSVpvs("# comment\n");
6689 const U8* tend = t + tlen;
6690 const U8* rend = r + rlen;
6706 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
6707 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
6710 const U32 flags = UTF8_ALLOW_DEFAULT;
6714 t = tsave = bytes_to_utf8(t, &len);
6717 if (!to_utf && rlen) {
6719 r = rsave = bytes_to_utf8(r, &len);
6723 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6724 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6729 * replace t/tlen/tend with a version that has the ranges
6732 U8 tmpbuf[UTF8_MAXBYTES+1];
6735 Newx(cp, 2*tlen, UV);
6737 transv = newSVpvs("");
6739 /* convert search string into array of (start,end) range
6740 * codepoint pairs stored in cp[]. Most "ranges" will start
6741 * and end at the same char */
6743 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6745 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6746 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6748 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6752 cp[2*i+1] = cp[2*i];
6757 /* sort the ranges */
6758 qsort(cp, i, 2*sizeof(UV), uvcompare);
6760 /* Create a utf8 string containing the complement of the
6761 * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6762 * then transv will contain the equivalent of:
6763 * join '', map chr, 0, ILLEGAL_UTF8_BYTE, A - 1,
6764 * B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6765 * D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6766 * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6769 for (j = 0; j < i; j++) {
6771 diff = val - nextmin;
6773 t = uvchr_to_utf8(tmpbuf,nextmin);
6774 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6776 U8 range_mark = ILLEGAL_UTF8_BYTE;
6777 t = uvchr_to_utf8(tmpbuf, val - 1);
6778 sv_catpvn(transv, (char *)&range_mark, 1);
6779 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6787 t = uvchr_to_utf8(tmpbuf,nextmin);
6788 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6790 U8 range_mark = ILLEGAL_UTF8_BYTE;
6791 sv_catpvn(transv, (char *)&range_mark, 1);
6793 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6794 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6795 t = (const U8*)SvPVX_const(transv);
6796 tlen = SvCUR(transv);
6800 else if (!rlen && !del) {
6801 r = t; rlen = tlen; rend = tend;
6805 if ((!rlen && !del) || t == r ||
6806 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6808 o->op_private |= OPpTRANS_IDENTICAL;
6812 /* extract char ranges from t and r and append them to listsv */
6814 while (t < tend || tfirst <= tlast) {
6815 /* see if we need more "t" chars */
6816 if (tfirst > tlast) {
6817 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6819 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6821 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6828 /* now see if we need more "r" chars */
6829 if (rfirst > rlast) {
6831 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6833 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6835 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6844 rfirst = rlast = 0xffffffff;
6848 /* now see which range will peter out first, if either. */
6849 tdiff = tlast - tfirst;
6850 rdiff = rlast - rfirst;
6851 tcount += tdiff + 1;
6852 rcount += rdiff + 1;
6859 if (rfirst == 0xffffffff) {
6860 diff = tdiff; /* oops, pretend rdiff is infinite */
6862 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6863 (long)tfirst, (long)tlast);
6865 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6869 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6870 (long)tfirst, (long)(tfirst + diff),
6873 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6874 (long)tfirst, (long)rfirst);
6876 if (rfirst + diff > max)
6877 max = rfirst + diff;
6879 grows = (tfirst < rfirst &&
6880 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6886 /* compile listsv into a swash and attach to o */
6894 else if (max > 0xff)
6899 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6901 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6902 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6903 PAD_SETSV(cPADOPo->op_padix, swash);
6905 SvREADONLY_on(swash);
6907 cSVOPo->op_sv = swash;
6909 SvREFCNT_dec(listsv);
6910 SvREFCNT_dec(transv);
6912 if (!del && havefinal && rlen)
6913 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6914 newSVuv((UV)final), 0);
6923 else if (rlast == 0xffffffff)
6929 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6930 * table. Entries with the value -1 indicate chars not to be
6931 * translated, while -2 indicates a search char without a
6932 * corresponding replacement char under /d.
6934 * Normally, the table has 256 slots. However, in the presence of
6935 * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6936 * added, and if there are enough replacement chars to start pairing
6937 * with the \x{100},... search chars, then a larger (> 256) table
6940 * In addition, regardless of whether under /c, an extra slot at the
6941 * end is used to store the final repeating char, or -3 under an empty
6942 * replacement list, or -2 under /d; which makes the runtime code
6945 * The toker will have already expanded char ranges in t and r.
6948 /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6949 * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6950 * The OPtrans_map struct already contains one slot; hence the -1.
6952 struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6953 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6955 cPVOPo->op_pv = (char*)tbl;
6960 /* in this branch, j is a count of 'consumed' (i.e. paired off
6961 * with a search char) replacement chars (so j <= rlen always)
6963 for (i = 0; i < tlen; i++)
6964 tbl->map[t[i]] = -1;
6966 for (i = 0, j = 0; i < 256; i++) {
6972 tbl->map[i] = r[j-1];
6974 tbl->map[i] = (short)i;
6977 tbl->map[i] = r[j++];
6979 if ( tbl->map[i] >= 0
6980 && UVCHR_IS_INVARIANT((UV)i)
6981 && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6991 /* More replacement chars than search chars:
6992 * store excess replacement chars at end of main table.
6995 struct_size += excess;
6996 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6997 struct_size + excess * sizeof(short));
6998 tbl->size += excess;
6999 cPVOPo->op_pv = (char*)tbl;
7001 for (i = 0; i < excess; i++)
7002 tbl->map[i + 256] = r[j+i];
7005 /* no more replacement chars than search chars */
7006 if (!rlen && !del && !squash)
7007 o->op_private |= OPpTRANS_IDENTICAL;
7010 tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
7013 if (!rlen && !del) {
7016 o->op_private |= OPpTRANS_IDENTICAL;
7018 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
7019 o->op_private |= OPpTRANS_IDENTICAL;
7022 for (i = 0; i < 256; i++)
7024 for (i = 0, j = 0; i < tlen; i++,j++) {
7027 if (tbl->map[t[i]] == -1)
7028 tbl->map[t[i]] = -2;
7033 if (tbl->map[t[i]] == -1) {
7034 if ( UVCHR_IS_INVARIANT(t[i])
7035 && ! UVCHR_IS_INVARIANT(r[j]))
7037 tbl->map[t[i]] = r[j];
7040 tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
7043 /* both non-utf8 and utf8 code paths end up here */
7046 if(del && rlen == tlen) {
7047 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
7048 } else if(rlen > tlen && !complement) {
7049 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
7053 o->op_private |= OPpTRANS_GROWS;
7064 Constructs, checks, and returns an op of any pattern matching type.
7065 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
7066 and, shifted up eight bits, the eight bits of C<op_private>.
7072 Perl_newPMOP(pTHX_ I32 type, I32 flags)
7077 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
7078 || type == OP_CUSTOM);
7080 NewOp(1101, pmop, 1, PMOP);
7081 OpTYPE_set(pmop, type);
7082 pmop->op_flags = (U8)flags;
7083 pmop->op_private = (U8)(0 | (flags >> 8));
7084 if (PL_opargs[type] & OA_RETSCALAR)
7087 if (PL_hints & HINT_RE_TAINT)
7088 pmop->op_pmflags |= PMf_RETAINT;
7089 #ifdef USE_LOCALE_CTYPE
7090 if (IN_LC_COMPILETIME(LC_CTYPE)) {
7091 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
7096 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
7098 if (PL_hints & HINT_RE_FLAGS) {
7099 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7100 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
7102 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
7103 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7104 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
7106 if (reflags && SvOK(reflags)) {
7107 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
7113 assert(SvPOK(PL_regex_pad[0]));
7114 if (SvCUR(PL_regex_pad[0])) {
7115 /* Pop off the "packed" IV from the end. */
7116 SV *const repointer_list = PL_regex_pad[0];
7117 const char *p = SvEND(repointer_list) - sizeof(IV);
7118 const IV offset = *((IV*)p);
7120 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
7122 SvEND_set(repointer_list, p);
7124 pmop->op_pmoffset = offset;
7125 /* This slot should be free, so assert this: */
7126 assert(PL_regex_pad[offset] == &PL_sv_undef);
7128 SV * const repointer = &PL_sv_undef;
7129 av_push(PL_regex_padav, repointer);
7130 pmop->op_pmoffset = av_tindex(PL_regex_padav);
7131 PL_regex_pad = AvARRAY(PL_regex_padav);
7135 return CHECKOP(type, pmop);
7143 /* Any pad names in scope are potentially lvalues. */
7144 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
7145 PADNAME *pn = PAD_COMPNAME_SV(i);
7146 if (!pn || !PadnameLEN(pn))
7148 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
7149 S_mark_padname_lvalue(aTHX_ pn);
7153 /* Given some sort of match op o, and an expression expr containing a
7154 * pattern, either compile expr into a regex and attach it to o (if it's
7155 * constant), or convert expr into a runtime regcomp op sequence (if it's
7158 * Flags currently has 2 bits of meaning:
7159 * 1: isreg indicates that the pattern is part of a regex construct, eg
7160 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
7161 * split "pattern", which aren't. In the former case, expr will be a list
7162 * if the pattern contains more than one term (eg /a$b/).
7163 * 2: The pattern is for a split.
7165 * When the pattern has been compiled within a new anon CV (for
7166 * qr/(?{...})/ ), then floor indicates the savestack level just before
7167 * the new sub was created
7171 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
7175 I32 repl_has_vars = 0;
7176 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
7177 bool is_compiletime;
7179 bool isreg = cBOOL(flags & 1);
7180 bool is_split = cBOOL(flags & 2);
7182 PERL_ARGS_ASSERT_PMRUNTIME;
7185 return pmtrans(o, expr, repl);
7188 /* find whether we have any runtime or code elements;
7189 * at the same time, temporarily set the op_next of each DO block;
7190 * then when we LINKLIST, this will cause the DO blocks to be excluded
7191 * from the op_next chain (and from having LINKLIST recursively
7192 * applied to them). We fix up the DOs specially later */
7196 if (expr->op_type == OP_LIST) {
7198 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7199 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
7201 assert(!o->op_next);
7202 if (UNLIKELY(!OpHAS_SIBLING(o))) {
7203 assert(PL_parser && PL_parser->error_count);
7204 /* This can happen with qr/ (?{(^{})/. Just fake up
7205 the op we were expecting to see, to avoid crashing
7207 op_sibling_splice(expr, o, 0,
7208 newSVOP(OP_CONST, 0, &PL_sv_no));
7210 o->op_next = OpSIBLING(o);
7212 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
7216 else if (expr->op_type != OP_CONST)
7221 /* fix up DO blocks; treat each one as a separate little sub;
7222 * also, mark any arrays as LIST/REF */
7224 if (expr->op_type == OP_LIST) {
7226 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7228 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
7229 assert( !(o->op_flags & OPf_WANT));
7230 /* push the array rather than its contents. The regex
7231 * engine will retrieve and join the elements later */
7232 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
7236 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
7238 o->op_next = NULL; /* undo temporary hack from above */
7241 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
7242 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
7244 assert(leaveop->op_first->op_type == OP_ENTER);
7245 assert(OpHAS_SIBLING(leaveop->op_first));
7246 o->op_next = OpSIBLING(leaveop->op_first);
7248 assert(leaveop->op_flags & OPf_KIDS);
7249 assert(leaveop->op_last->op_next == (OP*)leaveop);
7250 leaveop->op_next = NULL; /* stop on last op */
7251 op_null((OP*)leaveop);
7255 OP *scope = cLISTOPo->op_first;
7256 assert(scope->op_type == OP_SCOPE);
7257 assert(scope->op_flags & OPf_KIDS);
7258 scope->op_next = NULL; /* stop on last op */
7262 /* XXX optimize_optree() must be called on o before
7263 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7264 * currently cope with a peephole-optimised optree.
7265 * Calling optimize_optree() here ensures that condition
7266 * is met, but may mean optimize_optree() is applied
7267 * to the same optree later (where hopefully it won't do any
7268 * harm as it can't convert an op to multiconcat if it's
7269 * already been converted */
7272 /* have to peep the DOs individually as we've removed it from
7273 * the op_next chain */
7275 S_prune_chain_head(&(o->op_next));
7277 /* runtime finalizes as part of finalizing whole tree */
7281 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7282 assert( !(expr->op_flags & OPf_WANT));
7283 /* push the array rather than its contents. The regex
7284 * engine will retrieve and join the elements later */
7285 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7288 PL_hints |= HINT_BLOCK_SCOPE;
7290 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7292 if (is_compiletime) {
7293 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7294 regexp_engine const *eng = current_re_engine();
7297 /* make engine handle split ' ' specially */
7298 pm->op_pmflags |= PMf_SPLIT;
7299 rx_flags |= RXf_SPLIT;
7302 if (!has_code || !eng->op_comp) {
7303 /* compile-time simple constant pattern */
7305 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7306 /* whoops! we guessed that a qr// had a code block, but we
7307 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7308 * that isn't required now. Note that we have to be pretty
7309 * confident that nothing used that CV's pad while the
7310 * regex was parsed, except maybe op targets for \Q etc.
7311 * If there were any op targets, though, they should have
7312 * been stolen by constant folding.
7316 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7317 while (++i <= AvFILLp(PL_comppad)) {
7318 # ifdef USE_PAD_RESET
7319 /* under USE_PAD_RESET, pad swipe replaces a swiped
7320 * folded constant with a fresh padtmp */
7321 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7323 assert(!PL_curpad[i]);
7327 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7328 * outer CV (the one whose slab holds the pm op). The
7329 * inner CV (which holds expr) will be freed later, once
7330 * all the entries on the parse stack have been popped on
7331 * return from this function. Which is why its safe to
7332 * call op_free(expr) below.
7335 pm->op_pmflags &= ~PMf_HAS_CV;
7338 /* Skip compiling if parser found an error for this pattern */
7339 if (pm->op_pmflags & PMf_HAS_ERROR) {
7345 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7346 rx_flags, pm->op_pmflags)
7347 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7348 rx_flags, pm->op_pmflags)
7353 /* compile-time pattern that includes literal code blocks */
7357 /* Skip compiling if parser found an error for this pattern */
7358 if (pm->op_pmflags & PMf_HAS_ERROR) {
7362 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7365 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7368 if (pm->op_pmflags & PMf_HAS_CV) {
7370 /* this QR op (and the anon sub we embed it in) is never
7371 * actually executed. It's just a placeholder where we can
7372 * squirrel away expr in op_code_list without the peephole
7373 * optimiser etc processing it for a second time */
7374 OP *qr = newPMOP(OP_QR, 0);
7375 ((PMOP*)qr)->op_code_list = expr;
7377 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7378 SvREFCNT_inc_simple_void(PL_compcv);
7379 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7380 ReANY(re)->qr_anoncv = cv;
7382 /* attach the anon CV to the pad so that
7383 * pad_fixup_inner_anons() can find it */
7384 (void)pad_add_anon(cv, o->op_type);
7385 SvREFCNT_inc_simple_void(cv);
7388 pm->op_code_list = expr;
7393 /* runtime pattern: build chain of regcomp etc ops */
7395 PADOFFSET cv_targ = 0;
7397 reglist = isreg && expr->op_type == OP_LIST;
7402 pm->op_code_list = expr;
7403 /* don't free op_code_list; its ops are embedded elsewhere too */
7404 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7408 /* make engine handle split ' ' specially */
7409 pm->op_pmflags |= PMf_SPLIT;
7411 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7412 * to allow its op_next to be pointed past the regcomp and
7413 * preceding stacking ops;
7414 * OP_REGCRESET is there to reset taint before executing the
7416 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7417 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7419 if (pm->op_pmflags & PMf_HAS_CV) {
7420 /* we have a runtime qr with literal code. This means
7421 * that the qr// has been wrapped in a new CV, which
7422 * means that runtime consts, vars etc will have been compiled
7423 * against a new pad. So... we need to execute those ops
7424 * within the environment of the new CV. So wrap them in a call
7425 * to a new anon sub. i.e. for
7429 * we build an anon sub that looks like
7431 * sub { "a", $b, '(?{...})' }
7433 * and call it, passing the returned list to regcomp.
7434 * Or to put it another way, the list of ops that get executed
7438 * ------ -------------------
7439 * pushmark (for regcomp)
7440 * pushmark (for entersub)
7444 * regcreset regcreset
7446 * const("a") const("a")
7448 * const("(?{...})") const("(?{...})")
7453 SvREFCNT_inc_simple_void(PL_compcv);
7454 CvLVALUE_on(PL_compcv);
7455 /* these lines are just an unrolled newANONATTRSUB */
7456 expr = newSVOP(OP_ANONCODE, 0,
7457 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7458 cv_targ = expr->op_targ;
7459 expr = newUNOP(OP_REFGEN, 0, expr);
7461 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7464 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7465 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7466 | (reglist ? OPf_STACKED : 0);
7467 rcop->op_targ = cv_targ;
7469 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
7470 if (PL_hints & HINT_RE_EVAL)
7471 S_set_haseval(aTHX);
7473 /* establish postfix order */
7474 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7476 rcop->op_next = expr;
7477 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7480 rcop->op_next = LINKLIST(expr);
7481 expr->op_next = (OP*)rcop;
7484 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7490 /* If we are looking at s//.../e with a single statement, get past
7491 the implicit do{}. */
7492 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7493 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7494 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7497 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7498 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7499 && !OpHAS_SIBLING(sib))
7502 if (curop->op_type == OP_CONST)
7504 else if (( (curop->op_type == OP_RV2SV ||
7505 curop->op_type == OP_RV2AV ||
7506 curop->op_type == OP_RV2HV ||
7507 curop->op_type == OP_RV2GV)
7508 && cUNOPx(curop)->op_first
7509 && cUNOPx(curop)->op_first->op_type == OP_GV )
7510 || curop->op_type == OP_PADSV
7511 || curop->op_type == OP_PADAV
7512 || curop->op_type == OP_PADHV
7513 || curop->op_type == OP_PADANY) {
7521 || !RX_PRELEN(PM_GETRE(pm))
7522 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7524 pm->op_pmflags |= PMf_CONST; /* const for long enough */
7525 op_prepend_elem(o->op_type, scalar(repl), o);
7528 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7529 rcop->op_private = 1;
7531 /* establish postfix order */
7532 rcop->op_next = LINKLIST(repl);
7533 repl->op_next = (OP*)rcop;
7535 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7536 assert(!(pm->op_pmflags & PMf_ONCE));
7537 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7548 Constructs, checks, and returns an op of any type that involves an
7549 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
7550 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
7551 takes ownership of one reference to it.
7557 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7562 PERL_ARGS_ASSERT_NEWSVOP;
7564 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7565 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7566 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7567 || type == OP_CUSTOM);
7569 NewOp(1101, svop, 1, SVOP);
7570 OpTYPE_set(svop, type);
7572 svop->op_next = (OP*)svop;
7573 svop->op_flags = (U8)flags;
7574 svop->op_private = (U8)(0 | (flags >> 8));
7575 if (PL_opargs[type] & OA_RETSCALAR)
7577 if (PL_opargs[type] & OA_TARGET)
7578 svop->op_targ = pad_alloc(type, SVs_PADTMP);
7579 return CHECKOP(type, svop);
7583 =for apidoc newDEFSVOP
7585 Constructs and returns an op to access C<$_>.
7591 Perl_newDEFSVOP(pTHX)
7593 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7599 =for apidoc newPADOP
7601 Constructs, checks, and returns an op of any type that involves a
7602 reference to a pad element. C<type> is the opcode. C<flags> gives the
7603 eight bits of C<op_flags>. A pad slot is automatically allocated, and
7604 is populated with C<sv>; this function takes ownership of one reference
7607 This function only exists if Perl has been compiled to use ithreads.
7613 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7618 PERL_ARGS_ASSERT_NEWPADOP;
7620 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7621 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7622 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7623 || type == OP_CUSTOM);
7625 NewOp(1101, padop, 1, PADOP);
7626 OpTYPE_set(padop, type);
7628 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7629 SvREFCNT_dec(PAD_SVl(padop->op_padix));
7630 PAD_SETSV(padop->op_padix, sv);
7632 padop->op_next = (OP*)padop;
7633 padop->op_flags = (U8)flags;
7634 if (PL_opargs[type] & OA_RETSCALAR)
7636 if (PL_opargs[type] & OA_TARGET)
7637 padop->op_targ = pad_alloc(type, SVs_PADTMP);
7638 return CHECKOP(type, padop);
7641 #endif /* USE_ITHREADS */
7646 Constructs, checks, and returns an op of any type that involves an
7647 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
7648 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
7649 reference; calling this function does not transfer ownership of any
7656 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7658 PERL_ARGS_ASSERT_NEWGVOP;
7661 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7663 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7670 Constructs, checks, and returns an op of any type that involves an
7671 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
7672 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
7673 Depending on the op type, the memory referenced by C<pv> may be freed
7674 when the op is destroyed. If the op is of a freeing type, C<pv> must
7675 have been allocated using C<PerlMemShared_malloc>.
7681 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7684 const bool utf8 = cBOOL(flags & SVf_UTF8);
7689 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7690 || type == OP_RUNCV || type == OP_CUSTOM
7691 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7693 NewOp(1101, pvop, 1, PVOP);
7694 OpTYPE_set(pvop, type);
7696 pvop->op_next = (OP*)pvop;
7697 pvop->op_flags = (U8)flags;
7698 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7699 if (PL_opargs[type] & OA_RETSCALAR)
7701 if (PL_opargs[type] & OA_TARGET)
7702 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7703 return CHECKOP(type, pvop);
7707 Perl_package(pTHX_ OP *o)
7709 SV *const sv = cSVOPo->op_sv;
7711 PERL_ARGS_ASSERT_PACKAGE;
7713 SAVEGENERICSV(PL_curstash);
7714 save_item(PL_curstname);
7716 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7718 sv_setsv(PL_curstname, sv);
7720 PL_hints |= HINT_BLOCK_SCOPE;
7721 PL_parser->copline = NOLINE;
7727 Perl_package_version( pTHX_ OP *v )
7729 U32 savehints = PL_hints;
7730 PERL_ARGS_ASSERT_PACKAGE_VERSION;
7731 PL_hints &= ~HINT_STRICT_VARS;
7732 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7733 PL_hints = savehints;
7738 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7743 SV *use_version = NULL;
7745 PERL_ARGS_ASSERT_UTILIZE;
7747 if (idop->op_type != OP_CONST)
7748 Perl_croak(aTHX_ "Module name must be constant");
7753 SV * const vesv = ((SVOP*)version)->op_sv;
7755 if (!arg && !SvNIOKp(vesv)) {
7762 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7763 Perl_croak(aTHX_ "Version number must be a constant number");
7765 /* Make copy of idop so we don't free it twice */
7766 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7768 /* Fake up a method call to VERSION */
7769 meth = newSVpvs_share("VERSION");
7770 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7771 op_append_elem(OP_LIST,
7772 op_prepend_elem(OP_LIST, pack, version),
7773 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7777 /* Fake up an import/unimport */
7778 if (arg && arg->op_type == OP_STUB) {
7779 imop = arg; /* no import on explicit () */
7781 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7782 imop = NULL; /* use 5.0; */
7784 use_version = ((SVOP*)idop)->op_sv;
7786 idop->op_private |= OPpCONST_NOVER;
7791 /* Make copy of idop so we don't free it twice */
7792 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7794 /* Fake up a method call to import/unimport */
7796 ? newSVpvs_share("import") : newSVpvs_share("unimport");
7797 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7798 op_append_elem(OP_LIST,
7799 op_prepend_elem(OP_LIST, pack, arg),
7800 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7804 /* Fake up the BEGIN {}, which does its thing immediately. */
7806 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7809 op_append_elem(OP_LINESEQ,
7810 op_append_elem(OP_LINESEQ,
7811 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7812 newSTATEOP(0, NULL, veop)),
7813 newSTATEOP(0, NULL, imop) ));
7817 * feature bundle that corresponds to the required version. */
7818 use_version = sv_2mortal(new_version(use_version));
7819 S_enable_feature_bundle(aTHX_ use_version);
7821 /* If a version >= 5.11.0 is requested, strictures are on by default! */
7822 if (vcmp(use_version,
7823 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7824 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7825 PL_hints |= HINT_STRICT_REFS;
7826 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7827 PL_hints |= HINT_STRICT_SUBS;
7828 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7829 PL_hints |= HINT_STRICT_VARS;
7831 /* otherwise they are off */
7833 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7834 PL_hints &= ~HINT_STRICT_REFS;
7835 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7836 PL_hints &= ~HINT_STRICT_SUBS;
7837 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7838 PL_hints &= ~HINT_STRICT_VARS;
7842 /* The "did you use incorrect case?" warning used to be here.
7843 * The problem is that on case-insensitive filesystems one
7844 * might get false positives for "use" (and "require"):
7845 * "use Strict" or "require CARP" will work. This causes
7846 * portability problems for the script: in case-strict
7847 * filesystems the script will stop working.
7849 * The "incorrect case" warning checked whether "use Foo"
7850 * imported "Foo" to your namespace, but that is wrong, too:
7851 * there is no requirement nor promise in the language that
7852 * a Foo.pm should or would contain anything in package "Foo".
7854 * There is very little Configure-wise that can be done, either:
7855 * the case-sensitivity of the build filesystem of Perl does not
7856 * help in guessing the case-sensitivity of the runtime environment.
7859 PL_hints |= HINT_BLOCK_SCOPE;
7860 PL_parser->copline = NOLINE;
7861 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7865 =head1 Embedding Functions
7867 =for apidoc load_module
7869 Loads the module whose name is pointed to by the string part of C<name>.
7870 Note that the actual module name, not its filename, should be given.
7871 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7872 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7873 trailing arguments can be used to specify arguments to the module's C<import()>
7874 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7875 on the flags. The flags argument is a bitwise-ORed collection of any of
7876 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7877 (or 0 for no flags).
7879 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7880 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7881 the trailing optional arguments may be omitted entirely. Otherwise, if
7882 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7883 exactly one C<OP*>, containing the op tree that produces the relevant import
7884 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7885 will be used as import arguments; and the list must be terminated with C<(SV*)
7886 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7887 set, the trailing C<NULL> pointer is needed even if no import arguments are
7888 desired. The reference count for each specified C<SV*> argument is
7889 decremented. In addition, the C<name> argument is modified.
7891 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7897 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7901 PERL_ARGS_ASSERT_LOAD_MODULE;
7903 va_start(args, ver);
7904 vload_module(flags, name, ver, &args);
7908 #ifdef PERL_IMPLICIT_CONTEXT
7910 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7914 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7915 va_start(args, ver);
7916 vload_module(flags, name, ver, &args);
7922 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7928 PERL_ARGS_ASSERT_VLOAD_MODULE;
7930 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7931 * that it has a PL_parser to play with while doing that, and also
7932 * that it doesn't mess with any existing parser, by creating a tmp
7933 * new parser with lex_start(). This won't actually be used for much,
7934 * since pp_require() will create another parser for the real work.
7935 * The ENTER/LEAVE pair protect callers from any side effects of use.
7937 * start_subparse() creates a new PL_compcv. This means that any ops
7938 * allocated below will be allocated from that CV's op slab, and so
7939 * will be automatically freed if the utilise() fails
7943 SAVEVPTR(PL_curcop);
7944 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7945 floor = start_subparse(FALSE, 0);
7947 modname = newSVOP(OP_CONST, 0, name);
7948 modname->op_private |= OPpCONST_BARE;
7950 veop = newSVOP(OP_CONST, 0, ver);
7954 if (flags & PERL_LOADMOD_NOIMPORT) {
7955 imop = sawparens(newNULLLIST());
7957 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7958 imop = va_arg(*args, OP*);
7963 sv = va_arg(*args, SV*);
7965 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7966 sv = va_arg(*args, SV*);
7970 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
7974 PERL_STATIC_INLINE OP *
7975 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7977 return newUNOP(OP_ENTERSUB, OPf_STACKED,
7978 newLISTOP(OP_LIST, 0, arg,
7979 newUNOP(OP_RV2CV, 0,
7980 newGVOP(OP_GV, 0, gv))));
7984 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7989 PERL_ARGS_ASSERT_DOFILE;
7991 if (!force_builtin && (gv = gv_override("do", 2))) {
7992 doop = S_new_entersubop(aTHX_ gv, term);
7995 doop = newUNOP(OP_DOFILE, 0, scalar(term));
8001 =head1 Optree construction
8003 =for apidoc newSLICEOP
8005 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
8006 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
8007 be set automatically, and, shifted up eight bits, the eight bits of
8008 C<op_private>, except that the bit with value 1 or 2 is automatically
8009 set as required. C<listval> and C<subscript> supply the parameters of
8010 the slice; they are consumed by this function and become part of the
8011 constructed op tree.
8017 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
8019 return newBINOP(OP_LSLICE, flags,
8020 list(force_list(subscript, 1)),
8021 list(force_list(listval, 1)) );
8024 #define ASSIGN_SCALAR 0
8025 #define ASSIGN_LIST 1
8026 #define ASSIGN_REF 2
8028 /* given the optree o on the LHS of an assignment, determine whether its:
8029 * ASSIGN_SCALAR $x = ...
8030 * ASSIGN_LIST ($x) = ...
8031 * ASSIGN_REF \$x = ...
8035 S_assignment_type(pTHX_ const OP *o)
8044 if (o->op_type == OP_SREFGEN)
8046 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
8047 type = kid->op_type;
8048 flags = o->op_flags | kid->op_flags;
8049 if (!(flags & OPf_PARENS)
8050 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
8051 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
8055 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
8056 o = cUNOPo->op_first;
8057 flags = o->op_flags;
8059 ret = ASSIGN_SCALAR;
8062 if (type == OP_COND_EXPR) {
8063 OP * const sib = OpSIBLING(cLOGOPo->op_first);
8064 const I32 t = assignment_type(sib);
8065 const I32 f = assignment_type(OpSIBLING(sib));
8067 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
8069 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
8070 yyerror("Assignment to both a list and a scalar");
8071 return ASSIGN_SCALAR;
8074 if (type == OP_LIST &&
8075 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
8076 o->op_private & OPpLVAL_INTRO)
8079 if (type == OP_LIST || flags & OPf_PARENS ||
8080 type == OP_RV2AV || type == OP_RV2HV ||
8081 type == OP_ASLICE || type == OP_HSLICE ||
8082 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
8085 if (type == OP_PADAV || type == OP_PADHV)
8088 if (type == OP_RV2SV)
8095 S_newONCEOP(pTHX_ OP *initop, OP *padop)
8098 const PADOFFSET target = padop->op_targ;
8099 OP *const other = newOP(OP_PADSV,
8101 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
8102 OP *const first = newOP(OP_NULL, 0);
8103 OP *const nullop = newCONDOP(0, first, initop, other);
8104 /* XXX targlex disabled for now; see ticket #124160
8105 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
8107 OP *const condop = first->op_next;
8109 OpTYPE_set(condop, OP_ONCE);
8110 other->op_targ = target;
8111 nullop->op_flags |= OPf_WANT_SCALAR;
8113 /* Store the initializedness of state vars in a separate
8116 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
8117 /* hijacking PADSTALE for uninitialized state variables */
8118 SvPADSTALE_on(PAD_SVl(condop->op_targ));
8124 =for apidoc newASSIGNOP
8126 Constructs, checks, and returns an assignment op. C<left> and C<right>
8127 supply the parameters of the assignment; they are consumed by this
8128 function and become part of the constructed op tree.
8130 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
8131 a suitable conditional optree is constructed. If C<optype> is the opcode
8132 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
8133 performs the binary operation and assigns the result to the left argument.
8134 Either way, if C<optype> is non-zero then C<flags> has no effect.
8136 If C<optype> is zero, then a plain scalar or list assignment is
8137 constructed. Which type of assignment it is is automatically determined.
8138 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8139 will be set automatically, and, shifted up eight bits, the eight bits
8140 of C<op_private>, except that the bit with value 1 or 2 is automatically
8147 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
8153 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
8154 right = scalar(right);
8155 return newLOGOP(optype, 0,
8156 op_lvalue(scalar(left), optype),
8157 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
8160 return newBINOP(optype, OPf_STACKED,
8161 op_lvalue(scalar(left), optype), scalar(right));
8165 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
8166 OP *state_var_op = NULL;
8167 static const char no_list_state[] = "Initialization of state variables"
8168 " in list currently forbidden";
8171 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
8172 left->op_private &= ~ OPpSLICEWARNING;
8175 left = op_lvalue(left, OP_AASSIGN);
8176 curop = list(force_list(left, 1));
8177 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
8178 o->op_private = (U8)(0 | (flags >> 8));
8180 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
8182 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
8183 if (!(left->op_flags & OPf_PARENS) &&
8184 lop->op_type == OP_PUSHMARK &&
8185 (vop = OpSIBLING(lop)) &&
8186 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
8187 !(vop->op_flags & OPf_PARENS) &&
8188 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
8189 (OPpLVAL_INTRO|OPpPAD_STATE) &&
8190 (eop = OpSIBLING(vop)) &&
8191 eop->op_type == OP_ENTERSUB &&
8192 !OpHAS_SIBLING(eop)) {
8196 if ((lop->op_type == OP_PADSV ||
8197 lop->op_type == OP_PADAV ||
8198 lop->op_type == OP_PADHV ||
8199 lop->op_type == OP_PADANY)
8200 && (lop->op_private & OPpPAD_STATE)
8202 yyerror(no_list_state);
8203 lop = OpSIBLING(lop);
8207 else if ( (left->op_private & OPpLVAL_INTRO)
8208 && (left->op_private & OPpPAD_STATE)
8209 && ( left->op_type == OP_PADSV
8210 || left->op_type == OP_PADAV
8211 || left->op_type == OP_PADHV
8212 || left->op_type == OP_PADANY)
8214 /* All single variable list context state assignments, hence
8224 if (left->op_flags & OPf_PARENS)
8225 yyerror(no_list_state);
8227 state_var_op = left;
8230 /* optimise @a = split(...) into:
8231 * @{expr}: split(..., @{expr}) (where @a is not flattened)
8232 * @a, my @a, local @a: split(...) (where @a is attached to
8233 * the split op itself)
8237 && right->op_type == OP_SPLIT
8238 /* don't do twice, e.g. @b = (@a = split) */
8239 && !(right->op_private & OPpSPLIT_ASSIGN))
8243 if ( ( left->op_type == OP_RV2AV
8244 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
8245 || left->op_type == OP_PADAV)
8247 /* @pkg or @lex or local @pkg' or 'my @lex' */
8251 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
8252 = cPADOPx(gvop)->op_padix;
8253 cPADOPx(gvop)->op_padix = 0; /* steal it */
8255 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
8256 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8257 cSVOPx(gvop)->op_sv = NULL; /* steal it */
8259 right->op_private |=
8260 left->op_private & OPpOUR_INTRO;
8263 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8264 left->op_targ = 0; /* steal it */
8265 right->op_private |= OPpSPLIT_LEX;
8267 right->op_private |= left->op_private & OPpLVAL_INTRO;
8270 tmpop = cUNOPo->op_first; /* to list (nulled) */
8271 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
8272 assert(OpSIBLING(tmpop) == right);
8273 assert(!OpHAS_SIBLING(right));
8274 /* detach the split subtreee from the o tree,
8275 * then free the residual o tree */
8276 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8277 op_free(o); /* blow off assign */
8278 right->op_private |= OPpSPLIT_ASSIGN;
8279 right->op_flags &= ~OPf_WANT;
8280 /* "I don't know and I don't care." */
8283 else if (left->op_type == OP_RV2AV) {
8286 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8287 assert(OpSIBLING(pushop) == left);
8288 /* Detach the array ... */
8289 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8290 /* ... and attach it to the split. */
8291 op_sibling_splice(right, cLISTOPx(right)->op_last,
8293 right->op_flags |= OPf_STACKED;
8294 /* Detach split and expunge aassign as above. */
8297 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8298 ((LISTOP*)right)->op_last->op_type == OP_CONST)
8300 /* convert split(...,0) to split(..., PL_modcount+1) */
8302 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8303 SV * const sv = *svp;
8304 if (SvIOK(sv) && SvIVX(sv) == 0)
8306 if (right->op_private & OPpSPLIT_IMPLIM) {
8307 /* our own SV, created in ck_split */
8309 sv_setiv(sv, PL_modcount+1);
8312 /* SV may belong to someone else */
8314 *svp = newSViv(PL_modcount+1);
8321 o = S_newONCEOP(aTHX_ o, state_var_op);
8324 if (assign_type == ASSIGN_REF)
8325 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8327 right = newOP(OP_UNDEF, 0);
8328 if (right->op_type == OP_READLINE) {
8329 right->op_flags |= OPf_STACKED;
8330 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8334 o = newBINOP(OP_SASSIGN, flags,
8335 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8341 =for apidoc newSTATEOP
8343 Constructs a state op (COP). The state op is normally a C<nextstate> op,
8344 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8345 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8346 If C<label> is non-null, it supplies the name of a label to attach to
8347 the state op; this function takes ownership of the memory pointed at by
8348 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
8351 If C<o> is null, the state op is returned. Otherwise the state op is
8352 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
8353 is consumed by this function and becomes part of the returned op tree.
8359 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8362 const U32 seq = intro_my();
8363 const U32 utf8 = flags & SVf_UTF8;
8366 PL_parser->parsed_sub = 0;
8370 NewOp(1101, cop, 1, COP);
8371 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8372 OpTYPE_set(cop, OP_DBSTATE);
8375 OpTYPE_set(cop, OP_NEXTSTATE);
8377 cop->op_flags = (U8)flags;
8378 CopHINTS_set(cop, PL_hints);
8380 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8382 cop->op_next = (OP*)cop;
8385 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8386 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8388 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8390 PL_hints |= HINT_BLOCK_SCOPE;
8391 /* It seems that we need to defer freeing this pointer, as other parts
8392 of the grammar end up wanting to copy it after this op has been
8397 if (PL_parser->preambling != NOLINE) {
8398 CopLINE_set(cop, PL_parser->preambling);
8399 PL_parser->copline = NOLINE;
8401 else if (PL_parser->copline == NOLINE)
8402 CopLINE_set(cop, CopLINE(PL_curcop));
8404 CopLINE_set(cop, PL_parser->copline);
8405 PL_parser->copline = NOLINE;
8408 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
8410 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8412 CopSTASH_set(cop, PL_curstash);
8414 if (cop->op_type == OP_DBSTATE) {
8415 /* this line can have a breakpoint - store the cop in IV */
8416 AV *av = CopFILEAVx(PL_curcop);
8418 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8419 if (svp && *svp != &PL_sv_undef ) {
8420 (void)SvIOK_on(*svp);
8421 SvIV_set(*svp, PTR2IV(cop));
8426 if (flags & OPf_SPECIAL)
8428 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8432 =for apidoc newLOGOP
8434 Constructs, checks, and returns a logical (flow control) op. C<type>
8435 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
8436 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8437 the eight bits of C<op_private>, except that the bit with value 1 is
8438 automatically set. C<first> supplies the expression controlling the
8439 flow, and C<other> supplies the side (alternate) chain of ops; they are
8440 consumed by this function and become part of the constructed op tree.
8446 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8448 PERL_ARGS_ASSERT_NEWLOGOP;
8450 return new_logop(type, flags, &first, &other);
8454 /* See if the optree o contains a single OP_CONST (plus possibly
8455 * surrounding enter/nextstate/null etc). If so, return it, else return
8460 S_search_const(pTHX_ OP *o)
8462 PERL_ARGS_ASSERT_SEARCH_CONST;
8465 switch (o->op_type) {
8469 if (o->op_flags & OPf_KIDS) {
8470 o = cUNOPo->op_first;
8479 if (!(o->op_flags & OPf_KIDS))
8481 kid = cLISTOPo->op_first;
8484 switch (kid->op_type) {
8488 kid = OpSIBLING(kid);
8491 if (kid != cLISTOPo->op_last)
8498 kid = cLISTOPo->op_last;
8510 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8518 int prepend_not = 0;
8520 PERL_ARGS_ASSERT_NEW_LOGOP;
8525 /* [perl #59802]: Warn about things like "return $a or $b", which
8526 is parsed as "(return $a) or $b" rather than "return ($a or
8527 $b)". NB: This also applies to xor, which is why we do it
8530 switch (first->op_type) {
8534 /* XXX: Perhaps we should emit a stronger warning for these.
8535 Even with the high-precedence operator they don't seem to do
8538 But until we do, fall through here.
8544 /* XXX: Currently we allow people to "shoot themselves in the
8545 foot" by explicitly writing "(return $a) or $b".
8547 Warn unless we are looking at the result from folding or if
8548 the programmer explicitly grouped the operators like this.
8549 The former can occur with e.g.
8551 use constant FEATURE => ( $] >= ... );
8552 sub { not FEATURE and return or do_stuff(); }
8554 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8555 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8556 "Possible precedence issue with control flow operator");
8557 /* XXX: Should we optimze this to "return $a;" (i.e. remove
8563 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8564 return newBINOP(type, flags, scalar(first), scalar(other));
8566 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8567 || type == OP_CUSTOM);
8569 scalarboolean(first);
8571 /* search for a constant op that could let us fold the test */
8572 if ((cstop = search_const(first))) {
8573 if (cstop->op_private & OPpCONST_STRICT)
8574 no_bareword_allowed(cstop);
8575 else if ((cstop->op_private & OPpCONST_BARE))
8576 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8577 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
8578 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8579 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8580 /* Elide the (constant) lhs, since it can't affect the outcome */
8582 if (other->op_type == OP_CONST)
8583 other->op_private |= OPpCONST_SHORTCIRCUIT;
8585 if (other->op_type == OP_LEAVE)
8586 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8587 else if (other->op_type == OP_MATCH
8588 || other->op_type == OP_SUBST
8589 || other->op_type == OP_TRANSR
8590 || other->op_type == OP_TRANS)
8591 /* Mark the op as being unbindable with =~ */
8592 other->op_flags |= OPf_SPECIAL;
8594 other->op_folded = 1;
8598 /* Elide the rhs, since the outcome is entirely determined by
8599 * the (constant) lhs */
8601 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8602 const OP *o2 = other;
8603 if ( ! (o2->op_type == OP_LIST
8604 && (( o2 = cUNOPx(o2)->op_first))
8605 && o2->op_type == OP_PUSHMARK
8606 && (( o2 = OpSIBLING(o2))) )
8609 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8610 || o2->op_type == OP_PADHV)
8611 && o2->op_private & OPpLVAL_INTRO
8612 && !(o2->op_private & OPpPAD_STATE))
8614 Perl_croak(aTHX_ "This use of my() in false conditional is "
8615 "no longer allowed");
8619 if (cstop->op_type == OP_CONST)
8620 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8625 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8626 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8628 const OP * const k1 = ((UNOP*)first)->op_first;
8629 const OP * const k2 = OpSIBLING(k1);
8631 switch (first->op_type)
8634 if (k2 && k2->op_type == OP_READLINE
8635 && (k2->op_flags & OPf_STACKED)
8636 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8638 warnop = k2->op_type;
8643 if (k1->op_type == OP_READDIR
8644 || k1->op_type == OP_GLOB
8645 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8646 || k1->op_type == OP_EACH
8647 || k1->op_type == OP_AEACH)
8649 warnop = ((k1->op_type == OP_NULL)
8650 ? (OPCODE)k1->op_targ : k1->op_type);
8655 const line_t oldline = CopLINE(PL_curcop);
8656 /* This ensures that warnings are reported at the first line
8657 of the construction, not the last. */
8658 CopLINE_set(PL_curcop, PL_parser->copline);
8659 Perl_warner(aTHX_ packWARN(WARN_MISC),
8660 "Value of %s%s can be \"0\"; test with defined()",
8662 ((warnop == OP_READLINE || warnop == OP_GLOB)
8663 ? " construct" : "() operator"));
8664 CopLINE_set(PL_curcop, oldline);
8668 /* optimize AND and OR ops that have NOTs as children */
8669 if (first->op_type == OP_NOT
8670 && (first->op_flags & OPf_KIDS)
8671 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8672 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8674 if (type == OP_AND || type == OP_OR) {
8680 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8682 prepend_not = 1; /* prepend a NOT op later */
8687 logop = alloc_LOGOP(type, first, LINKLIST(other));
8688 logop->op_flags |= (U8)flags;
8689 logop->op_private = (U8)(1 | (flags >> 8));
8691 /* establish postfix order */
8692 logop->op_next = LINKLIST(first);
8693 first->op_next = (OP*)logop;
8694 assert(!OpHAS_SIBLING(first));
8695 op_sibling_splice((OP*)logop, first, 0, other);
8697 CHECKOP(type,logop);
8699 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8700 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8708 =for apidoc newCONDOP
8710 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8711 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8712 will be set automatically, and, shifted up eight bits, the eight bits of
8713 C<op_private>, except that the bit with value 1 is automatically set.
8714 C<first> supplies the expression selecting between the two branches,
8715 and C<trueop> and C<falseop> supply the branches; they are consumed by
8716 this function and become part of the constructed op tree.
8722 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8730 PERL_ARGS_ASSERT_NEWCONDOP;
8733 return newLOGOP(OP_AND, 0, first, trueop);
8735 return newLOGOP(OP_OR, 0, first, falseop);
8737 scalarboolean(first);
8738 if ((cstop = search_const(first))) {
8739 /* Left or right arm of the conditional? */
8740 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8741 OP *live = left ? trueop : falseop;
8742 OP *const dead = left ? falseop : trueop;
8743 if (cstop->op_private & OPpCONST_BARE &&
8744 cstop->op_private & OPpCONST_STRICT) {
8745 no_bareword_allowed(cstop);
8749 if (live->op_type == OP_LEAVE)
8750 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8751 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8752 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8753 /* Mark the op as being unbindable with =~ */
8754 live->op_flags |= OPf_SPECIAL;
8755 live->op_folded = 1;
8758 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8759 logop->op_flags |= (U8)flags;
8760 logop->op_private = (U8)(1 | (flags >> 8));
8761 logop->op_next = LINKLIST(falseop);
8763 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8766 /* establish postfix order */
8767 start = LINKLIST(first);
8768 first->op_next = (OP*)logop;
8770 /* make first, trueop, falseop siblings */
8771 op_sibling_splice((OP*)logop, first, 0, trueop);
8772 op_sibling_splice((OP*)logop, trueop, 0, falseop);
8774 o = newUNOP(OP_NULL, 0, (OP*)logop);
8776 trueop->op_next = falseop->op_next = o;
8783 =for apidoc newRANGE
8785 Constructs and returns a C<range> op, with subordinate C<flip> and
8786 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
8787 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8788 for both the C<flip> and C<range> ops, except that the bit with value
8789 1 is automatically set. C<left> and C<right> supply the expressions
8790 controlling the endpoints of the range; they are consumed by this function
8791 and become part of the constructed op tree.
8797 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8805 PERL_ARGS_ASSERT_NEWRANGE;
8807 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8808 range->op_flags = OPf_KIDS;
8809 leftstart = LINKLIST(left);
8810 range->op_private = (U8)(1 | (flags >> 8));
8812 /* make left and right siblings */
8813 op_sibling_splice((OP*)range, left, 0, right);
8815 range->op_next = (OP*)range;
8816 flip = newUNOP(OP_FLIP, flags, (OP*)range);
8817 flop = newUNOP(OP_FLOP, 0, flip);
8818 o = newUNOP(OP_NULL, 0, flop);
8820 range->op_next = leftstart;
8822 left->op_next = flip;
8823 right->op_next = flop;
8826 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8827 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8829 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8830 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8831 SvPADTMP_on(PAD_SV(flip->op_targ));
8833 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8834 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8836 /* check barewords before they might be optimized aways */
8837 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8838 no_bareword_allowed(left);
8839 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8840 no_bareword_allowed(right);
8843 if (!flip->op_private || !flop->op_private)
8844 LINKLIST(o); /* blow off optimizer unless constant */
8850 =for apidoc newLOOPOP
8852 Constructs, checks, and returns an op tree expressing a loop. This is
8853 only a loop in the control flow through the op tree; it does not have
8854 the heavyweight loop structure that allows exiting the loop by C<last>
8855 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
8856 top-level op, except that some bits will be set automatically as required.
8857 C<expr> supplies the expression controlling loop iteration, and C<block>
8858 supplies the body of the loop; they are consumed by this function and
8859 become part of the constructed op tree. C<debuggable> is currently
8860 unused and should always be 1.
8866 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8870 const bool once = block && block->op_flags & OPf_SPECIAL &&
8871 block->op_type == OP_NULL;
8873 PERL_UNUSED_ARG(debuggable);
8877 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8878 || ( expr->op_type == OP_NOT
8879 && cUNOPx(expr)->op_first->op_type == OP_CONST
8880 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8883 /* Return the block now, so that S_new_logop does not try to
8887 return block; /* do {} while 0 does once */
8890 if (expr->op_type == OP_READLINE
8891 || expr->op_type == OP_READDIR
8892 || expr->op_type == OP_GLOB
8893 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8894 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8895 expr = newUNOP(OP_DEFINED, 0,
8896 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8897 } else if (expr->op_flags & OPf_KIDS) {
8898 const OP * const k1 = ((UNOP*)expr)->op_first;
8899 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8900 switch (expr->op_type) {
8902 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8903 && (k2->op_flags & OPf_STACKED)
8904 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8905 expr = newUNOP(OP_DEFINED, 0, expr);
8909 if (k1 && (k1->op_type == OP_READDIR
8910 || k1->op_type == OP_GLOB
8911 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8912 || k1->op_type == OP_EACH
8913 || k1->op_type == OP_AEACH))
8914 expr = newUNOP(OP_DEFINED, 0, expr);
8920 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8921 * op, in listop. This is wrong. [perl #27024] */
8923 block = newOP(OP_NULL, 0);
8924 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8925 o = new_logop(OP_AND, 0, &expr, &listop);
8932 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8934 if (once && o != listop)
8936 assert(cUNOPo->op_first->op_type == OP_AND
8937 || cUNOPo->op_first->op_type == OP_OR);
8938 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8942 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
8944 o->op_flags |= flags;
8946 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8951 =for apidoc newWHILEOP
8953 Constructs, checks, and returns an op tree expressing a C<while> loop.
8954 This is a heavyweight loop, with structure that allows exiting the loop
8955 by C<last> and suchlike.
8957 C<loop> is an optional preconstructed C<enterloop> op to use in the
8958 loop; if it is null then a suitable op will be constructed automatically.
8959 C<expr> supplies the loop's controlling expression. C<block> supplies the
8960 main body of the loop, and C<cont> optionally supplies a C<continue> block
8961 that operates as a second half of the body. All of these optree inputs
8962 are consumed by this function and become part of the constructed op tree.
8964 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8965 op and, shifted up eight bits, the eight bits of C<op_private> for
8966 the C<leaveloop> op, except that (in both cases) some bits will be set
8967 automatically. C<debuggable> is currently unused and should always be 1.
8968 C<has_my> can be supplied as true to force the
8969 loop body to be enclosed in its own scope.
8975 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8976 OP *expr, OP *block, OP *cont, I32 has_my)
8985 PERL_UNUSED_ARG(debuggable);
8988 if (expr->op_type == OP_READLINE
8989 || expr->op_type == OP_READDIR
8990 || expr->op_type == OP_GLOB
8991 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8992 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8993 expr = newUNOP(OP_DEFINED, 0,
8994 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8995 } else if (expr->op_flags & OPf_KIDS) {
8996 const OP * const k1 = ((UNOP*)expr)->op_first;
8997 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8998 switch (expr->op_type) {
9000 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9001 && (k2->op_flags & OPf_STACKED)
9002 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9003 expr = newUNOP(OP_DEFINED, 0, expr);
9007 if (k1 && (k1->op_type == OP_READDIR
9008 || k1->op_type == OP_GLOB
9009 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9010 || k1->op_type == OP_EACH
9011 || k1->op_type == OP_AEACH))
9012 expr = newUNOP(OP_DEFINED, 0, expr);
9019 block = newOP(OP_NULL, 0);
9020 else if (cont || has_my) {
9021 block = op_scope(block);
9025 next = LINKLIST(cont);
9028 OP * const unstack = newOP(OP_UNSTACK, 0);
9031 cont = op_append_elem(OP_LINESEQ, cont, unstack);
9035 listop = op_append_list(OP_LINESEQ, block, cont);
9037 redo = LINKLIST(listop);
9041 o = new_logop(OP_AND, 0, &expr, &listop);
9042 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
9044 return expr; /* listop already freed by new_logop */
9047 ((LISTOP*)listop)->op_last->op_next =
9048 (o == listop ? redo : LINKLIST(o));
9054 NewOp(1101,loop,1,LOOP);
9055 OpTYPE_set(loop, OP_ENTERLOOP);
9056 loop->op_private = 0;
9057 loop->op_next = (OP*)loop;
9060 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
9062 loop->op_redoop = redo;
9063 loop->op_lastop = o;
9064 o->op_private |= loopflags;
9067 loop->op_nextop = next;
9069 loop->op_nextop = o;
9071 o->op_flags |= flags;
9072 o->op_private |= (flags >> 8);
9077 =for apidoc newFOROP
9079 Constructs, checks, and returns an op tree expressing a C<foreach>
9080 loop (iteration through a list of values). This is a heavyweight loop,
9081 with structure that allows exiting the loop by C<last> and suchlike.
9083 C<sv> optionally supplies the variable that will be aliased to each
9084 item in turn; if null, it defaults to C<$_>.
9085 C<expr> supplies the list of values to iterate over. C<block> supplies
9086 the main body of the loop, and C<cont> optionally supplies a C<continue>
9087 block that operates as a second half of the body. All of these optree
9088 inputs are consumed by this function and become part of the constructed
9091 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9092 op and, shifted up eight bits, the eight bits of C<op_private> for
9093 the C<leaveloop> op, except that (in both cases) some bits will be set
9100 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
9105 PADOFFSET padoff = 0;
9109 PERL_ARGS_ASSERT_NEWFOROP;
9112 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
9113 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
9114 OpTYPE_set(sv, OP_RV2GV);
9116 /* The op_type check is needed to prevent a possible segfault
9117 * if the loop variable is undeclared and 'strict vars' is in
9118 * effect. This is illegal but is nonetheless parsed, so we
9119 * may reach this point with an OP_CONST where we're expecting
9122 if (cUNOPx(sv)->op_first->op_type == OP_GV
9123 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
9124 iterpflags |= OPpITER_DEF;
9126 else if (sv->op_type == OP_PADSV) { /* private variable */
9127 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
9128 padoff = sv->op_targ;
9132 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9134 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
9137 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
9139 PADNAME * const pn = PAD_COMPNAME(padoff);
9140 const char * const name = PadnamePV(pn);
9142 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
9143 iterpflags |= OPpITER_DEF;
9147 sv = newGVOP(OP_GV, 0, PL_defgv);
9148 iterpflags |= OPpITER_DEF;
9151 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
9152 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
9153 iterflags |= OPf_STACKED;
9155 else if (expr->op_type == OP_NULL &&
9156 (expr->op_flags & OPf_KIDS) &&
9157 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
9159 /* Basically turn for($x..$y) into the same as for($x,$y), but we
9160 * set the STACKED flag to indicate that these values are to be
9161 * treated as min/max values by 'pp_enteriter'.
9163 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
9164 LOGOP* const range = (LOGOP*) flip->op_first;
9165 OP* const left = range->op_first;
9166 OP* const right = OpSIBLING(left);
9169 range->op_flags &= ~OPf_KIDS;
9170 /* detach range's children */
9171 op_sibling_splice((OP*)range, NULL, -1, NULL);
9173 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
9174 listop->op_first->op_next = range->op_next;
9175 left->op_next = range->op_other;
9176 right->op_next = (OP*)listop;
9177 listop->op_next = listop->op_first;
9180 expr = (OP*)(listop);
9182 iterflags |= OPf_STACKED;
9185 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
9188 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
9189 op_append_elem(OP_LIST, list(expr),
9191 assert(!loop->op_next);
9192 /* for my $x () sets OPpLVAL_INTRO;
9193 * for our $x () sets OPpOUR_INTRO */
9194 loop->op_private = (U8)iterpflags;
9195 if (loop->op_slabbed
9196 && DIFF(loop, OpSLOT(loop)->opslot_next)
9197 < SIZE_TO_PSIZE(sizeof(LOOP)))
9200 NewOp(1234,tmp,1,LOOP);
9201 Copy(loop,tmp,1,LISTOP);
9202 assert(loop->op_last->op_sibparent == (OP*)loop);
9203 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
9204 S_op_destroy(aTHX_ (OP*)loop);
9207 else if (!loop->op_slabbed)
9209 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
9210 OpLASTSIB_set(loop->op_last, (OP*)loop);
9212 loop->op_targ = padoff;
9213 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
9218 =for apidoc newLOOPEX
9220 Constructs, checks, and returns a loop-exiting op (such as C<goto>
9221 or C<last>). C<type> is the opcode. C<label> supplies the parameter
9222 determining the target of the op; it is consumed by this function and
9223 becomes part of the constructed op tree.
9229 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
9233 PERL_ARGS_ASSERT_NEWLOOPEX;
9235 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9236 || type == OP_CUSTOM);
9238 if (type != OP_GOTO) {
9239 /* "last()" means "last" */
9240 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9241 o = newOP(type, OPf_SPECIAL);
9245 /* Check whether it's going to be a goto &function */
9246 if (label->op_type == OP_ENTERSUB
9247 && !(label->op_flags & OPf_STACKED))
9248 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9251 /* Check for a constant argument */
9252 if (label->op_type == OP_CONST) {
9253 SV * const sv = ((SVOP *)label)->op_sv;
9255 const char *s = SvPV_const(sv,l);
9256 if (l == strlen(s)) {
9258 SvUTF8(((SVOP*)label)->op_sv),
9260 SvPV_nolen_const(((SVOP*)label)->op_sv)));
9264 /* If we have already created an op, we do not need the label. */
9267 else o = newUNOP(type, OPf_STACKED, label);
9269 PL_hints |= HINT_BLOCK_SCOPE;
9273 /* if the condition is a literal array or hash
9274 (or @{ ... } etc), make a reference to it.
9277 S_ref_array_or_hash(pTHX_ OP *cond)
9280 && (cond->op_type == OP_RV2AV
9281 || cond->op_type == OP_PADAV
9282 || cond->op_type == OP_RV2HV
9283 || cond->op_type == OP_PADHV))
9285 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9288 && (cond->op_type == OP_ASLICE
9289 || cond->op_type == OP_KVASLICE
9290 || cond->op_type == OP_HSLICE
9291 || cond->op_type == OP_KVHSLICE)) {
9293 /* anonlist now needs a list from this op, was previously used in
9295 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9296 cond->op_flags |= OPf_WANT_LIST;
9298 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9305 /* These construct the optree fragments representing given()
9308 entergiven and enterwhen are LOGOPs; the op_other pointer
9309 points up to the associated leave op. We need this so we
9310 can put it in the context and make break/continue work.
9311 (Also, of course, pp_enterwhen will jump straight to
9312 op_other if the match fails.)
9316 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9317 I32 enter_opcode, I32 leave_opcode,
9318 PADOFFSET entertarg)
9324 PERL_ARGS_ASSERT_NEWGIVWHENOP;
9325 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9327 enterop = alloc_LOGOP(enter_opcode, block, NULL);
9328 enterop->op_targ = 0;
9329 enterop->op_private = 0;
9331 o = newUNOP(leave_opcode, 0, (OP *) enterop);
9334 /* prepend cond if we have one */
9335 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9337 o->op_next = LINKLIST(cond);
9338 cond->op_next = (OP *) enterop;
9341 /* This is a default {} block */
9342 enterop->op_flags |= OPf_SPECIAL;
9343 o ->op_flags |= OPf_SPECIAL;
9345 o->op_next = (OP *) enterop;
9348 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9349 entergiven and enterwhen both
9352 enterop->op_next = LINKLIST(block);
9353 block->op_next = enterop->op_other = o;
9359 /* For the purposes of 'when(implied_smartmatch)'
9360 * versus 'when(boolean_expression)',
9361 * does this look like a boolean operation? For these purposes
9362 a boolean operation is:
9363 - a subroutine call [*]
9364 - a logical connective
9365 - a comparison operator
9366 - a filetest operator, with the exception of -s -M -A -C
9367 - defined(), exists() or eof()
9368 - /$re/ or $foo =~ /$re/
9370 [*] possibly surprising
9373 S_looks_like_bool(pTHX_ const OP *o)
9375 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9377 switch(o->op_type) {
9380 return looks_like_bool(cLOGOPo->op_first);
9384 OP* sibl = OpSIBLING(cLOGOPo->op_first);
9387 looks_like_bool(cLOGOPo->op_first)
9388 && looks_like_bool(sibl));
9394 o->op_flags & OPf_KIDS
9395 && looks_like_bool(cUNOPo->op_first));
9399 case OP_NOT: case OP_XOR:
9401 case OP_EQ: case OP_NE: case OP_LT:
9402 case OP_GT: case OP_LE: case OP_GE:
9404 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
9405 case OP_I_GT: case OP_I_LE: case OP_I_GE:
9407 case OP_SEQ: case OP_SNE: case OP_SLT:
9408 case OP_SGT: case OP_SLE: case OP_SGE:
9412 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
9413 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
9414 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
9415 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
9416 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
9417 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
9418 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
9419 case OP_FTTEXT: case OP_FTBINARY:
9421 case OP_DEFINED: case OP_EXISTS:
9422 case OP_MATCH: case OP_EOF:
9430 /* optimised-away (index() != -1) or similar comparison */
9431 if (o->op_private & OPpTRUEBOOL)
9436 /* Detect comparisons that have been optimized away */
9437 if (cSVOPo->op_sv == &PL_sv_yes
9438 || cSVOPo->op_sv == &PL_sv_no)
9451 =for apidoc newGIVENOP
9453 Constructs, checks, and returns an op tree expressing a C<given> block.
9454 C<cond> supplies the expression to whose value C<$_> will be locally
9455 aliased, and C<block> supplies the body of the C<given> construct; they
9456 are consumed by this function and become part of the constructed op tree.
9457 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9463 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9465 PERL_ARGS_ASSERT_NEWGIVENOP;
9466 PERL_UNUSED_ARG(defsv_off);
9469 return newGIVWHENOP(
9470 ref_array_or_hash(cond),
9472 OP_ENTERGIVEN, OP_LEAVEGIVEN,
9477 =for apidoc newWHENOP
9479 Constructs, checks, and returns an op tree expressing a C<when> block.
9480 C<cond> supplies the test expression, and C<block> supplies the block
9481 that will be executed if the test evaluates to true; they are consumed
9482 by this function and become part of the constructed op tree. C<cond>
9483 will be interpreted DWIMically, often as a comparison against C<$_>,
9484 and may be null to generate a C<default> block.
9490 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9492 const bool cond_llb = (!cond || looks_like_bool(cond));
9495 PERL_ARGS_ASSERT_NEWWHENOP;
9500 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9502 scalar(ref_array_or_hash(cond)));
9505 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9508 /* must not conflict with SVf_UTF8 */
9509 #define CV_CKPROTO_CURSTASH 0x1
9512 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9513 const STRLEN len, const U32 flags)
9515 SV *name = NULL, *msg;
9516 const char * cvp = SvROK(cv)
9517 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9518 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9521 STRLEN clen = CvPROTOLEN(cv), plen = len;
9523 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9525 if (p == NULL && cvp == NULL)
9528 if (!ckWARN_d(WARN_PROTOTYPE))
9532 p = S_strip_spaces(aTHX_ p, &plen);
9533 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9534 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9535 if (plen == clen && memEQ(cvp, p, plen))
9538 if (flags & SVf_UTF8) {
9539 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9543 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9549 msg = sv_newmortal();
9554 gv_efullname3(name = sv_newmortal(), gv, NULL);
9555 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9556 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9557 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9558 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9559 sv_catpvs(name, "::");
9561 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9562 assert (CvNAMED(SvRV_const(gv)));
9563 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9565 else sv_catsv(name, (SV *)gv);
9567 else name = (SV *)gv;
9569 sv_setpvs(msg, "Prototype mismatch:");
9571 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9573 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9574 UTF8fARG(SvUTF8(cv),clen,cvp)
9577 sv_catpvs(msg, ": none");
9578 sv_catpvs(msg, " vs ");
9580 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9582 sv_catpvs(msg, "none");
9583 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9586 static void const_sv_xsub(pTHX_ CV* cv);
9587 static void const_av_xsub(pTHX_ CV* cv);
9591 =head1 Optree Manipulation Functions
9593 =for apidoc cv_const_sv
9595 If C<cv> is a constant sub eligible for inlining, returns the constant
9596 value returned by the sub. Otherwise, returns C<NULL>.
9598 Constant subs can be created with C<newCONSTSUB> or as described in
9599 L<perlsub/"Constant Functions">.
9604 Perl_cv_const_sv(const CV *const cv)
9609 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9611 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9612 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9617 Perl_cv_const_sv_or_av(const CV * const cv)
9621 if (SvROK(cv)) return SvRV((SV *)cv);
9622 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9623 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9626 /* op_const_sv: examine an optree to determine whether it's in-lineable.
9627 * Can be called in 2 ways:
9630 * look for a single OP_CONST with attached value: return the value
9632 * allow_lex && !CvCONST(cv);
9634 * examine the clone prototype, and if contains only a single
9635 * OP_CONST, return the value; or if it contains a single PADSV ref-
9636 * erencing an outer lexical, turn on CvCONST to indicate the CV is
9637 * a candidate for "constizing" at clone time, and return NULL.
9641 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9649 for (; o; o = o->op_next) {
9650 const OPCODE type = o->op_type;
9652 if (type == OP_NEXTSTATE || type == OP_LINESEQ
9654 || type == OP_PUSHMARK)
9656 if (type == OP_DBSTATE)
9658 if (type == OP_LEAVESUB)
9662 if (type == OP_CONST && cSVOPo->op_sv)
9664 else if (type == OP_UNDEF && !o->op_private) {
9668 else if (allow_lex && type == OP_PADSV) {
9669 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9671 sv = &PL_sv_undef; /* an arbitrary non-null value */
9689 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9690 PADNAME * const name, SV ** const const_svp)
9696 if (CvFLAGS(PL_compcv)) {
9697 /* might have had built-in attrs applied */
9698 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9699 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9700 && ckWARN(WARN_MISC))
9702 /* protect against fatal warnings leaking compcv */
9703 SAVEFREESV(PL_compcv);
9704 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9705 SvREFCNT_inc_simple_void_NN(PL_compcv);
9708 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9709 & ~(CVf_LVALUE * pureperl));
9714 /* redundant check for speed: */
9715 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9716 const line_t oldline = CopLINE(PL_curcop);
9719 : sv_2mortal(newSVpvn_utf8(
9720 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9722 if (PL_parser && PL_parser->copline != NOLINE)
9723 /* This ensures that warnings are reported at the first
9724 line of a redefinition, not the last. */
9725 CopLINE_set(PL_curcop, PL_parser->copline);
9726 /* protect against fatal warnings leaking compcv */
9727 SAVEFREESV(PL_compcv);
9728 report_redefined_cv(namesv, cv, const_svp);
9729 SvREFCNT_inc_simple_void_NN(PL_compcv);
9730 CopLINE_set(PL_curcop, oldline);
9737 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9742 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9745 CV *compcv = PL_compcv;
9748 PADOFFSET pax = o->op_targ;
9749 CV *outcv = CvOUTSIDE(PL_compcv);
9752 bool reusable = FALSE;
9754 #ifdef PERL_DEBUG_READONLY_OPS
9755 OPSLAB *slab = NULL;
9758 PERL_ARGS_ASSERT_NEWMYSUB;
9760 PL_hints |= HINT_BLOCK_SCOPE;
9762 /* Find the pad slot for storing the new sub.
9763 We cannot use PL_comppad, as it is the pad owned by the new sub. We
9764 need to look in CvOUTSIDE and find the pad belonging to the enclos-
9765 ing sub. And then we need to dig deeper if this is a lexical from
9767 my sub foo; sub { sub foo { } }
9770 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9771 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9772 pax = PARENT_PAD_INDEX(name);
9773 outcv = CvOUTSIDE(outcv);
9778 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9779 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9780 spot = (CV **)svspot;
9782 if (!(PL_parser && PL_parser->error_count))
9783 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9786 assert(proto->op_type == OP_CONST);
9787 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9788 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9798 if (PL_parser && PL_parser->error_count) {
9800 SvREFCNT_dec(PL_compcv);
9805 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9807 svspot = (SV **)(spot = &clonee);
9809 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9812 assert (SvTYPE(*spot) == SVt_PVCV);
9814 hek = CvNAME_HEK(*spot);
9818 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9819 CvNAME_HEK_set(*spot, hek =
9822 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9826 CvLEXICAL_on(*spot);
9828 cv = PadnamePROTOCV(name);
9829 svspot = (SV **)(spot = &PadnamePROTOCV(name));
9833 /* This makes sub {}; work as expected. */
9834 if (block->op_type == OP_STUB) {
9835 const line_t l = PL_parser->copline;
9837 block = newSTATEOP(0, NULL, 0);
9838 PL_parser->copline = l;
9840 block = CvLVALUE(compcv)
9841 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9842 ? newUNOP(OP_LEAVESUBLV, 0,
9843 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9844 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9845 start = LINKLIST(block);
9847 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9848 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9856 const bool exists = CvROOT(cv) || CvXSUB(cv);
9858 /* if the subroutine doesn't exist and wasn't pre-declared
9859 * with a prototype, assume it will be AUTOLOADed,
9860 * skipping the prototype check
9862 if (exists || SvPOK(cv))
9863 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9865 /* already defined? */
9867 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9873 /* just a "sub foo;" when &foo is already defined */
9878 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9885 SvREFCNT_inc_simple_void_NN(const_sv);
9886 SvFLAGS(const_sv) |= SVs_PADTMP;
9888 assert(!CvROOT(cv) && !CvCONST(cv));
9892 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9893 CvFILE_set_from_cop(cv, PL_curcop);
9894 CvSTASH_set(cv, PL_curstash);
9897 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
9898 CvXSUBANY(cv).any_ptr = const_sv;
9899 CvXSUB(cv) = const_sv_xsub;
9903 CvFLAGS(cv) |= CvMETHOD(compcv);
9905 SvREFCNT_dec(compcv);
9910 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9911 determine whether this sub definition is in the same scope as its
9912 declaration. If this sub definition is inside an inner named pack-
9913 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9914 the package sub. So check PadnameOUTER(name) too.
9916 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9917 assert(!CvWEAKOUTSIDE(compcv));
9918 SvREFCNT_dec(CvOUTSIDE(compcv));
9919 CvWEAKOUTSIDE_on(compcv);
9921 /* XXX else do we have a circular reference? */
9923 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
9924 /* transfer PL_compcv to cv */
9926 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
9927 cv_flags_t preserved_flags =
9928 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9929 PADLIST *const temp_padl = CvPADLIST(cv);
9930 CV *const temp_cv = CvOUTSIDE(cv);
9931 const cv_flags_t other_flags =
9932 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9933 OP * const cvstart = CvSTART(cv);
9937 CvFLAGS(compcv) | preserved_flags;
9938 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9939 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9940 CvPADLIST_set(cv, CvPADLIST(compcv));
9941 CvOUTSIDE(compcv) = temp_cv;
9942 CvPADLIST_set(compcv, temp_padl);
9943 CvSTART(cv) = CvSTART(compcv);
9944 CvSTART(compcv) = cvstart;
9945 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9946 CvFLAGS(compcv) |= other_flags;
9949 Safefree(CvFILE(cv));
9953 /* inner references to compcv must be fixed up ... */
9954 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9955 if (PERLDB_INTER)/* Advice debugger on the new sub. */
9956 ++PL_sub_generation;
9959 /* Might have had built-in attributes applied -- propagate them. */
9960 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9962 /* ... before we throw it away */
9963 SvREFCNT_dec(compcv);
9964 PL_compcv = compcv = cv;
9973 if (!CvNAME_HEK(cv)) {
9974 if (hek) (void)share_hek_hek(hek);
9978 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9979 hek = share_hek(PadnamePV(name)+1,
9980 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9983 CvNAME_HEK_set(cv, hek);
9989 if (CvFILE(cv) && CvDYNFILE(cv))
9990 Safefree(CvFILE(cv));
9991 CvFILE_set_from_cop(cv, PL_curcop);
9992 CvSTASH_set(cv, PL_curstash);
9995 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9997 SvUTF8_on(MUTABLE_SV(cv));
10001 /* If we assign an optree to a PVCV, then we've defined a
10002 * subroutine that the debugger could be able to set a breakpoint
10003 * in, so signal to pp_entereval that it should not throw away any
10004 * saved lines at scope exit. */
10006 PL_breakable_sub_gen++;
10007 CvROOT(cv) = block;
10008 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10009 itself has a refcount. */
10011 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10012 #ifdef PERL_DEBUG_READONLY_OPS
10013 slab = (OPSLAB *)CvSTART(cv);
10015 S_process_optree(aTHX_ cv, block, start);
10020 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10021 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
10025 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10026 SV * const tmpstr = sv_newmortal();
10027 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10028 GV_ADDMULTI, SVt_PVHV);
10030 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10031 CopFILE(PL_curcop),
10033 (long)CopLINE(PL_curcop));
10034 if (HvNAME_HEK(PL_curstash)) {
10035 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
10036 sv_catpvs(tmpstr, "::");
10039 sv_setpvs(tmpstr, "__ANON__::");
10041 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
10042 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
10043 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10044 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10045 hv = GvHVn(db_postponed);
10046 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10047 CV * const pcv = GvCV(db_postponed);
10053 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10061 assert(CvDEPTH(outcv));
10063 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
10065 cv_clone_into(clonee, *spot);
10066 else *spot = cv_clone(clonee);
10067 SvREFCNT_dec_NN(clonee);
10071 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
10072 PADOFFSET depth = CvDEPTH(outcv);
10075 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
10077 *svspot = SvREFCNT_inc_simple_NN(cv);
10078 SvREFCNT_dec(oldcv);
10084 PL_parser->copline = NOLINE;
10085 LEAVE_SCOPE(floor);
10086 #ifdef PERL_DEBUG_READONLY_OPS
10095 =for apidoc newATTRSUB_x
10097 Construct a Perl subroutine, also performing some surrounding jobs.
10099 This function is expected to be called in a Perl compilation context,
10100 and some aspects of the subroutine are taken from global variables
10101 associated with compilation. In particular, C<PL_compcv> represents
10102 the subroutine that is currently being compiled. It must be non-null
10103 when this function is called, and some aspects of the subroutine being
10104 constructed are taken from it. The constructed subroutine may actually
10105 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
10107 If C<block> is null then the subroutine will have no body, and for the
10108 time being it will be an error to call it. This represents a forward
10109 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
10110 non-null then it provides the Perl code of the subroutine body, which
10111 will be executed when the subroutine is called. This body includes
10112 any argument unwrapping code resulting from a subroutine signature or
10113 similar. The pad use of the code must correspond to the pad attached
10114 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
10115 C<leavesublv> op; this function will add such an op. C<block> is consumed
10116 by this function and will become part of the constructed subroutine.
10118 C<proto> specifies the subroutine's prototype, unless one is supplied
10119 as an attribute (see below). If C<proto> is null, then the subroutine
10120 will not have a prototype. If C<proto> is non-null, it must point to a
10121 C<const> op whose value is a string, and the subroutine will have that
10122 string as its prototype. If a prototype is supplied as an attribute, the
10123 attribute takes precedence over C<proto>, but in that case C<proto> should
10124 preferably be null. In any case, C<proto> is consumed by this function.
10126 C<attrs> supplies attributes to be applied the subroutine. A handful of
10127 attributes take effect by built-in means, being applied to C<PL_compcv>
10128 immediately when seen. Other attributes are collected up and attached
10129 to the subroutine by this route. C<attrs> may be null to supply no
10130 attributes, or point to a C<const> op for a single attribute, or point
10131 to a C<list> op whose children apart from the C<pushmark> are C<const>
10132 ops for one or more attributes. Each C<const> op must be a string,
10133 giving the attribute name optionally followed by parenthesised arguments,
10134 in the manner in which attributes appear in Perl source. The attributes
10135 will be applied to the sub by this function. C<attrs> is consumed by
10138 If C<o_is_gv> is false and C<o> is null, then the subroutine will
10139 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
10140 must point to a C<const> op, which will be consumed by this function,
10141 and its string value supplies a name for the subroutine. The name may
10142 be qualified or unqualified, and if it is unqualified then a default
10143 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
10144 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
10145 by which the subroutine will be named.
10147 If there is already a subroutine of the specified name, then the new
10148 sub will either replace the existing one in the glob or be merged with
10149 the existing one. A warning may be generated about redefinition.
10151 If the subroutine has one of a few special names, such as C<BEGIN> or
10152 C<END>, then it will be claimed by the appropriate queue for automatic
10153 running of phase-related subroutines. In this case the relevant glob will
10154 be left not containing any subroutine, even if it did contain one before.
10155 In the case of C<BEGIN>, the subroutine will be executed and the reference
10156 to it disposed of before this function returns.
10158 The function returns a pointer to the constructed subroutine. If the sub
10159 is anonymous then ownership of one counted reference to the subroutine
10160 is transferred to the caller. If the sub is named then the caller does
10161 not get ownership of a reference. In most such cases, where the sub
10162 has a non-phase name, the sub will be alive at the point it is returned
10163 by virtue of being contained in the glob that names it. A phase-named
10164 subroutine will usually be alive by virtue of the reference owned by the
10165 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10166 been executed, will quite likely have been destroyed already by the
10167 time this function returns, making it erroneous for the caller to make
10168 any use of the returned pointer. It is the caller's responsibility to
10169 ensure that it knows which of these situations applies.
10174 /* _x = extended */
10176 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
10177 OP *block, bool o_is_gv)
10181 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10183 CV *cv = NULL; /* the previous CV with this name, if any */
10185 const bool ec = PL_parser && PL_parser->error_count;
10186 /* If the subroutine has no body, no attributes, and no builtin attributes
10187 then it's just a sub declaration, and we may be able to get away with
10188 storing with a placeholder scalar in the symbol table, rather than a
10189 full CV. If anything is present then it will take a full CV to
10191 const I32 gv_fetch_flags
10192 = ec ? GV_NOADD_NOINIT :
10193 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
10194 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
10196 const char * const name =
10197 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
10199 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
10200 bool evanescent = FALSE;
10202 #ifdef PERL_DEBUG_READONLY_OPS
10203 OPSLAB *slab = NULL;
10211 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
10212 hek and CvSTASH pointer together can imply the GV. If the name
10213 contains a package name, then GvSTASH(CvGV(cv)) may differ from
10214 CvSTASH, so forego the optimisation if we find any.
10215 Also, we may be called from load_module at run time, so
10216 PL_curstash (which sets CvSTASH) may not point to the stash the
10217 sub is stored in. */
10218 /* XXX This optimization is currently disabled for packages other
10219 than main, since there was too much CPAN breakage. */
10221 ec ? GV_NOADD_NOINIT
10222 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
10223 || PL_curstash != PL_defstash
10224 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
10226 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
10227 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
10229 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
10230 SV * const sv = sv_newmortal();
10231 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
10232 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10233 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10234 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
10236 } else if (PL_curstash) {
10237 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10240 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10246 move_proto_attr(&proto, &attrs, gv, 0);
10249 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10254 assert(proto->op_type == OP_CONST);
10255 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10256 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10272 SvREFCNT_dec(PL_compcv);
10277 if (name && block) {
10278 const char *s = (char *) my_memrchr(name, ':', namlen);
10279 s = s ? s+1 : name;
10280 if (strEQ(s, "BEGIN")) {
10281 if (PL_in_eval & EVAL_KEEPERR)
10282 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10284 SV * const errsv = ERRSV;
10285 /* force display of errors found but not reported */
10286 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10287 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10294 if (!block && SvTYPE(gv) != SVt_PVGV) {
10295 /* If we are not defining a new sub and the existing one is not a
10297 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10298 /* We are applying attributes to an existing sub, so we need it
10299 upgraded if it is a constant. */
10300 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10301 gv_init_pvn(gv, PL_curstash, name, namlen,
10302 SVf_UTF8 * name_is_utf8);
10304 else { /* Maybe prototype now, and had at maximum
10305 a prototype or const/sub ref before. */
10306 if (SvTYPE(gv) > SVt_NULL) {
10307 cv_ckproto_len_flags((const CV *)gv,
10308 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10314 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10316 SvUTF8_on(MUTABLE_SV(gv));
10319 sv_setiv(MUTABLE_SV(gv), -1);
10322 SvREFCNT_dec(PL_compcv);
10323 cv = PL_compcv = NULL;
10328 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10332 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10338 /* This makes sub {}; work as expected. */
10339 if (block->op_type == OP_STUB) {
10340 const line_t l = PL_parser->copline;
10342 block = newSTATEOP(0, NULL, 0);
10343 PL_parser->copline = l;
10345 block = CvLVALUE(PL_compcv)
10346 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10347 && (!isGV(gv) || !GvASSUMECV(gv)))
10348 ? newUNOP(OP_LEAVESUBLV, 0,
10349 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10350 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10351 start = LINKLIST(block);
10352 block->op_next = 0;
10353 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10355 S_op_const_sv(aTHX_ start, PL_compcv,
10356 cBOOL(CvCLONE(PL_compcv)));
10363 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10364 cv_ckproto_len_flags((const CV *)gv,
10365 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10366 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10368 /* All the other code for sub redefinition warnings expects the
10369 clobbered sub to be a CV. Instead of making all those code
10370 paths more complex, just inline the RV version here. */
10371 const line_t oldline = CopLINE(PL_curcop);
10372 assert(IN_PERL_COMPILETIME);
10373 if (PL_parser && PL_parser->copline != NOLINE)
10374 /* This ensures that warnings are reported at the first
10375 line of a redefinition, not the last. */
10376 CopLINE_set(PL_curcop, PL_parser->copline);
10377 /* protect against fatal warnings leaking compcv */
10378 SAVEFREESV(PL_compcv);
10380 if (ckWARN(WARN_REDEFINE)
10381 || ( ckWARN_d(WARN_REDEFINE)
10382 && ( !const_sv || SvRV(gv) == const_sv
10383 || sv_cmp(SvRV(gv), const_sv) ))) {
10385 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10386 "Constant subroutine %" SVf " redefined",
10387 SVfARG(cSVOPo->op_sv));
10390 SvREFCNT_inc_simple_void_NN(PL_compcv);
10391 CopLINE_set(PL_curcop, oldline);
10392 SvREFCNT_dec(SvRV(gv));
10397 const bool exists = CvROOT(cv) || CvXSUB(cv);
10399 /* if the subroutine doesn't exist and wasn't pre-declared
10400 * with a prototype, assume it will be AUTOLOADed,
10401 * skipping the prototype check
10403 if (exists || SvPOK(cv))
10404 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10405 /* already defined (or promised)? */
10406 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10407 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10413 /* just a "sub foo;" when &foo is already defined */
10414 SAVEFREESV(PL_compcv);
10421 SvREFCNT_inc_simple_void_NN(const_sv);
10422 SvFLAGS(const_sv) |= SVs_PADTMP;
10424 assert(!CvROOT(cv) && !CvCONST(cv));
10425 cv_forget_slab(cv);
10426 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10427 CvXSUBANY(cv).any_ptr = const_sv;
10428 CvXSUB(cv) = const_sv_xsub;
10432 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10435 if (isGV(gv) || CvMETHOD(PL_compcv)) {
10436 if (name && isGV(gv))
10437 GvCV_set(gv, NULL);
10438 cv = newCONSTSUB_flags(
10439 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10443 assert(SvREFCNT((SV*)cv) != 0);
10444 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10448 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10449 prepare_SV_for_RV((SV *)gv);
10450 SvOK_off((SV *)gv);
10453 SvRV_set(gv, const_sv);
10457 SvREFCNT_dec(PL_compcv);
10462 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10463 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10466 if (cv) { /* must reuse cv if autoloaded */
10467 /* transfer PL_compcv to cv */
10469 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10470 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10471 PADLIST *const temp_av = CvPADLIST(cv);
10472 CV *const temp_cv = CvOUTSIDE(cv);
10473 const cv_flags_t other_flags =
10474 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10475 OP * const cvstart = CvSTART(cv);
10479 assert(!CvCVGV_RC(cv));
10480 assert(CvGV(cv) == gv);
10485 PERL_HASH(hash, name, namlen);
10495 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10497 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10498 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10499 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10500 CvOUTSIDE(PL_compcv) = temp_cv;
10501 CvPADLIST_set(PL_compcv, temp_av);
10502 CvSTART(cv) = CvSTART(PL_compcv);
10503 CvSTART(PL_compcv) = cvstart;
10504 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10505 CvFLAGS(PL_compcv) |= other_flags;
10508 Safefree(CvFILE(cv));
10510 CvFILE_set_from_cop(cv, PL_curcop);
10511 CvSTASH_set(cv, PL_curstash);
10513 /* inner references to PL_compcv must be fixed up ... */
10514 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10515 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10516 ++PL_sub_generation;
10519 /* Might have had built-in attributes applied -- propagate them. */
10520 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10522 /* ... before we throw it away */
10523 SvREFCNT_dec(PL_compcv);
10528 if (name && isGV(gv)) {
10531 if (HvENAME_HEK(GvSTASH(gv)))
10532 /* sub Foo::bar { (shift)+1 } */
10533 gv_method_changed(gv);
10537 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10538 prepare_SV_for_RV((SV *)gv);
10539 SvOK_off((SV *)gv);
10542 SvRV_set(gv, (SV *)cv);
10543 if (HvENAME_HEK(PL_curstash))
10544 mro_method_changed_in(PL_curstash);
10548 assert(SvREFCNT((SV*)cv) != 0);
10550 if (!CvHASGV(cv)) {
10556 PERL_HASH(hash, name, namlen);
10557 CvNAME_HEK_set(cv, share_hek(name,
10563 CvFILE_set_from_cop(cv, PL_curcop);
10564 CvSTASH_set(cv, PL_curstash);
10568 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10570 SvUTF8_on(MUTABLE_SV(cv));
10574 /* If we assign an optree to a PVCV, then we've defined a
10575 * subroutine that the debugger could be able to set a breakpoint
10576 * in, so signal to pp_entereval that it should not throw away any
10577 * saved lines at scope exit. */
10579 PL_breakable_sub_gen++;
10580 CvROOT(cv) = block;
10581 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10582 itself has a refcount. */
10584 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10585 #ifdef PERL_DEBUG_READONLY_OPS
10586 slab = (OPSLAB *)CvSTART(cv);
10588 S_process_optree(aTHX_ cv, block, start);
10593 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10594 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10595 ? GvSTASH(CvGV(cv))
10599 apply_attrs(stash, MUTABLE_SV(cv), attrs);
10601 SvREFCNT_inc_simple_void_NN(cv);
10604 if (block && has_name) {
10605 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10606 SV * const tmpstr = cv_name(cv,NULL,0);
10607 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10608 GV_ADDMULTI, SVt_PVHV);
10610 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10611 CopFILE(PL_curcop),
10613 (long)CopLINE(PL_curcop));
10614 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10615 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10616 hv = GvHVn(db_postponed);
10617 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10618 CV * const pcv = GvCV(db_postponed);
10624 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10630 if (PL_parser && PL_parser->error_count)
10631 clear_special_blocks(name, gv, cv);
10634 process_special_blocks(floor, name, gv, cv);
10640 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10642 PL_parser->copline = NOLINE;
10643 LEAVE_SCOPE(floor);
10645 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10647 #ifdef PERL_DEBUG_READONLY_OPS
10651 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10652 pad_add_weakref(cv);
10658 S_clear_special_blocks(pTHX_ const char *const fullname,
10659 GV *const gv, CV *const cv) {
10663 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10665 colon = strrchr(fullname,':');
10666 name = colon ? colon + 1 : fullname;
10668 if ((*name == 'B' && strEQ(name, "BEGIN"))
10669 || (*name == 'E' && strEQ(name, "END"))
10670 || (*name == 'U' && strEQ(name, "UNITCHECK"))
10671 || (*name == 'C' && strEQ(name, "CHECK"))
10672 || (*name == 'I' && strEQ(name, "INIT"))) {
10677 GvCV_set(gv, NULL);
10678 SvREFCNT_dec_NN(MUTABLE_SV(cv));
10682 /* Returns true if the sub has been freed. */
10684 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10688 const char *const colon = strrchr(fullname,':');
10689 const char *const name = colon ? colon + 1 : fullname;
10691 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10693 if (*name == 'B') {
10694 if (strEQ(name, "BEGIN")) {
10695 const I32 oldscope = PL_scopestack_ix;
10698 if (floor) LEAVE_SCOPE(floor);
10700 PUSHSTACKi(PERLSI_REQUIRE);
10701 SAVECOPFILE(&PL_compiling);
10702 SAVECOPLINE(&PL_compiling);
10703 SAVEVPTR(PL_curcop);
10705 DEBUG_x( dump_sub(gv) );
10706 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10707 GvCV_set(gv,0); /* cv has been hijacked */
10708 call_list(oldscope, PL_beginav);
10712 return !PL_savebegin;
10717 if (*name == 'E') {
10718 if (strEQ(name, "END")) {
10719 DEBUG_x( dump_sub(gv) );
10720 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10723 } else if (*name == 'U') {
10724 if (strEQ(name, "UNITCHECK")) {
10725 /* It's never too late to run a unitcheck block */
10726 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10730 } else if (*name == 'C') {
10731 if (strEQ(name, "CHECK")) {
10733 /* diag_listed_as: Too late to run %s block */
10734 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10735 "Too late to run CHECK block");
10736 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10740 } else if (*name == 'I') {
10741 if (strEQ(name, "INIT")) {
10743 /* diag_listed_as: Too late to run %s block */
10744 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10745 "Too late to run INIT block");
10746 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10752 DEBUG_x( dump_sub(gv) );
10754 GvCV_set(gv,0); /* cv has been hijacked */
10760 =for apidoc newCONSTSUB
10762 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10763 rather than of counted length, and no flags are set. (This means that
10764 C<name> is always interpreted as Latin-1.)
10770 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10772 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10776 =for apidoc newCONSTSUB_flags
10778 Construct a constant subroutine, also performing some surrounding
10779 jobs. A scalar constant-valued subroutine is eligible for inlining
10780 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10781 123 }>>. Other kinds of constant subroutine have other treatment.
10783 The subroutine will have an empty prototype and will ignore any arguments
10784 when called. Its constant behaviour is determined by C<sv>. If C<sv>
10785 is null, the subroutine will yield an empty list. If C<sv> points to a
10786 scalar, the subroutine will always yield that scalar. If C<sv> points
10787 to an array, the subroutine will always yield a list of the elements of
10788 that array in list context, or the number of elements in the array in
10789 scalar context. This function takes ownership of one counted reference
10790 to the scalar or array, and will arrange for the object to live as long
10791 as the subroutine does. If C<sv> points to a scalar then the inlining
10792 assumes that the value of the scalar will never change, so the caller
10793 must ensure that the scalar is not subsequently written to. If C<sv>
10794 points to an array then no such assumption is made, so it is ostensibly
10795 safe to mutate the array or its elements, but whether this is really
10796 supported has not been determined.
10798 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10799 Other aspects of the subroutine will be left in their default state.
10800 The caller is free to mutate the subroutine beyond its initial state
10801 after this function has returned.
10803 If C<name> is null then the subroutine will be anonymous, with its
10804 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10805 subroutine will be named accordingly, referenced by the appropriate glob.
10806 C<name> is a string of length C<len> bytes giving a sigilless symbol
10807 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10808 otherwise. The name may be either qualified or unqualified. If the
10809 name is unqualified then it defaults to being in the stash specified by
10810 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10811 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10814 C<flags> should not have bits set other than C<SVf_UTF8>.
10816 If there is already a subroutine of the specified name, then the new sub
10817 will replace the existing one in the glob. A warning may be generated
10818 about the redefinition.
10820 If the subroutine has one of a few special names, such as C<BEGIN> or
10821 C<END>, then it will be claimed by the appropriate queue for automatic
10822 running of phase-related subroutines. In this case the relevant glob will
10823 be left not containing any subroutine, even if it did contain one before.
10824 Execution of the subroutine will likely be a no-op, unless C<sv> was
10825 a tied array or the caller modified the subroutine in some interesting
10826 way before it was executed. In the case of C<BEGIN>, the treatment is
10827 buggy: the sub will be executed when only half built, and may be deleted
10828 prematurely, possibly causing a crash.
10830 The function returns a pointer to the constructed subroutine. If the sub
10831 is anonymous then ownership of one counted reference to the subroutine
10832 is transferred to the caller. If the sub is named then the caller does
10833 not get ownership of a reference. In most such cases, where the sub
10834 has a non-phase name, the sub will be alive at the point it is returned
10835 by virtue of being contained in the glob that names it. A phase-named
10836 subroutine will usually be alive by virtue of the reference owned by
10837 the phase's automatic run queue. A C<BEGIN> subroutine may have been
10838 destroyed already by the time this function returns, but currently bugs
10839 occur in that case before the caller gets control. It is the caller's
10840 responsibility to ensure that it knows which of these situations applies.
10846 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10850 const char *const file = CopFILE(PL_curcop);
10854 if (IN_PERL_RUNTIME) {
10855 /* at runtime, it's not safe to manipulate PL_curcop: it may be
10856 * an op shared between threads. Use a non-shared COP for our
10858 SAVEVPTR(PL_curcop);
10859 SAVECOMPILEWARNINGS();
10860 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10861 PL_curcop = &PL_compiling;
10863 SAVECOPLINE(PL_curcop);
10864 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10867 PL_hints &= ~HINT_BLOCK_SCOPE;
10870 SAVEGENERICSV(PL_curstash);
10871 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10874 /* Protect sv against leakage caused by fatal warnings. */
10875 if (sv) SAVEFREESV(sv);
10877 /* file becomes the CvFILE. For an XS, it's usually static storage,
10878 and so doesn't get free()d. (It's expected to be from the C pre-
10879 processor __FILE__ directive). But we need a dynamically allocated one,
10880 and we need it to get freed. */
10881 cv = newXS_len_flags(name, len,
10882 sv && SvTYPE(sv) == SVt_PVAV
10885 file ? file : "", "",
10886 &sv, XS_DYNAMIC_FILENAME | flags);
10888 assert(SvREFCNT((SV*)cv) != 0);
10889 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10900 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
10901 static storage, as it is used directly as CvFILE(), without a copy being made.
10907 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10909 PERL_ARGS_ASSERT_NEWXS;
10910 return newXS_len_flags(
10911 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10916 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10917 const char *const filename, const char *const proto,
10920 PERL_ARGS_ASSERT_NEWXS_FLAGS;
10921 return newXS_len_flags(
10922 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10927 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10929 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10930 return newXS_len_flags(
10931 name, strlen(name), subaddr, NULL, NULL, NULL, 0
10936 =for apidoc newXS_len_flags
10938 Construct an XS subroutine, also performing some surrounding jobs.
10940 The subroutine will have the entry point C<subaddr>. It will have
10941 the prototype specified by the nul-terminated string C<proto>, or
10942 no prototype if C<proto> is null. The prototype string is copied;
10943 the caller can mutate the supplied string afterwards. If C<filename>
10944 is non-null, it must be a nul-terminated filename, and the subroutine
10945 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
10946 point directly to the supplied string, which must be static. If C<flags>
10947 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10950 Other aspects of the subroutine will be left in their default state.
10951 If anything else needs to be done to the subroutine for it to function
10952 correctly, it is the caller's responsibility to do that after this
10953 function has constructed it. However, beware of the subroutine
10954 potentially being destroyed before this function returns, as described
10957 If C<name> is null then the subroutine will be anonymous, with its
10958 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10959 subroutine will be named accordingly, referenced by the appropriate glob.
10960 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10961 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10962 The name may be either qualified or unqualified, with the stash defaulting
10963 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
10964 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10965 they have there, such as C<GV_ADDWARN>. The symbol is always added to
10966 the stash if necessary, with C<GV_ADDMULTI> semantics.
10968 If there is already a subroutine of the specified name, then the new sub
10969 will replace the existing one in the glob. A warning may be generated
10970 about the redefinition. If the old subroutine was C<CvCONST> then the
10971 decision about whether to warn is influenced by an expectation about
10972 whether the new subroutine will become a constant of similar value.
10973 That expectation is determined by C<const_svp>. (Note that the call to
10974 this function doesn't make the new subroutine C<CvCONST> in any case;
10975 that is left to the caller.) If C<const_svp> is null then it indicates
10976 that the new subroutine will not become a constant. If C<const_svp>
10977 is non-null then it indicates that the new subroutine will become a
10978 constant, and it points to an C<SV*> that provides the constant value
10979 that the subroutine will have.
10981 If the subroutine has one of a few special names, such as C<BEGIN> or
10982 C<END>, then it will be claimed by the appropriate queue for automatic
10983 running of phase-related subroutines. In this case the relevant glob will
10984 be left not containing any subroutine, even if it did contain one before.
10985 In the case of C<BEGIN>, the subroutine will be executed and the reference
10986 to it disposed of before this function returns, and also before its
10987 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
10988 constructed by this function to be ready for execution then the caller
10989 must prevent this happening by giving the subroutine a different name.
10991 The function returns a pointer to the constructed subroutine. If the sub
10992 is anonymous then ownership of one counted reference to the subroutine
10993 is transferred to the caller. If the sub is named then the caller does
10994 not get ownership of a reference. In most such cases, where the sub
10995 has a non-phase name, the sub will be alive at the point it is returned
10996 by virtue of being contained in the glob that names it. A phase-named
10997 subroutine will usually be alive by virtue of the reference owned by the
10998 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10999 been executed, will quite likely have been destroyed already by the
11000 time this function returns, making it erroneous for the caller to make
11001 any use of the returned pointer. It is the caller's responsibility to
11002 ensure that it knows which of these situations applies.
11008 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
11009 XSUBADDR_t subaddr, const char *const filename,
11010 const char *const proto, SV **const_svp,
11014 bool interleave = FALSE;
11015 bool evanescent = FALSE;
11017 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
11020 GV * const gv = gv_fetchpvn(
11021 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11022 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
11023 sizeof("__ANON__::__ANON__") - 1,
11024 GV_ADDMULTI | flags, SVt_PVCV);
11026 if ((cv = (name ? GvCV(gv) : NULL))) {
11028 /* just a cached method */
11032 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
11033 /* already defined (or promised) */
11034 /* Redundant check that allows us to avoid creating an SV
11035 most of the time: */
11036 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11037 report_redefined_cv(newSVpvn_flags(
11038 name,len,(flags&SVf_UTF8)|SVs_TEMP
11049 if (cv) /* must reuse cv if autoloaded */
11052 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11056 if (HvENAME_HEK(GvSTASH(gv)))
11057 gv_method_changed(gv); /* newXS */
11061 assert(SvREFCNT((SV*)cv) != 0);
11065 /* XSUBs can't be perl lang/perl5db.pl debugged
11066 if (PERLDB_LINE_OR_SAVESRC)
11067 (void)gv_fetchfile(filename); */
11068 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
11069 if (flags & XS_DYNAMIC_FILENAME) {
11071 CvFILE(cv) = savepv(filename);
11073 /* NOTE: not copied, as it is expected to be an external constant string */
11074 CvFILE(cv) = (char *)filename;
11077 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
11078 CvFILE(cv) = (char*)PL_xsubfilename;
11081 CvXSUB(cv) = subaddr;
11082 #ifndef PERL_IMPLICIT_CONTEXT
11083 CvHSCXT(cv) = &PL_stack_sp;
11089 evanescent = process_special_blocks(0, name, gv, cv);
11092 } /* <- not a conditional branch */
11095 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11097 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
11098 if (interleave) LEAVE;
11099 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11103 /* Add a stub CV to a typeglob.
11104 * This is the implementation of a forward declaration, 'sub foo';'
11108 Perl_newSTUB(pTHX_ GV *gv, bool fake)
11110 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11112 PERL_ARGS_ASSERT_NEWSTUB;
11113 assert(!GvCVu(gv));
11116 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
11117 gv_method_changed(gv);
11119 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
11123 CvGV_set(cv, cvgv);
11124 CvFILE_set_from_cop(cv, PL_curcop);
11125 CvSTASH_set(cv, PL_curstash);
11131 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
11138 if (PL_parser && PL_parser->error_count) {
11144 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
11145 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
11148 if ((cv = GvFORM(gv))) {
11149 if (ckWARN(WARN_REDEFINE)) {
11150 const line_t oldline = CopLINE(PL_curcop);
11151 if (PL_parser && PL_parser->copline != NOLINE)
11152 CopLINE_set(PL_curcop, PL_parser->copline);
11154 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11155 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
11157 /* diag_listed_as: Format %s redefined */
11158 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11159 "Format STDOUT redefined");
11161 CopLINE_set(PL_curcop, oldline);
11166 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
11168 CvFILE_set_from_cop(cv, PL_curcop);
11171 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
11173 start = LINKLIST(root);
11175 S_process_optree(aTHX_ cv, root, start);
11176 cv_forget_slab(cv);
11181 PL_parser->copline = NOLINE;
11182 LEAVE_SCOPE(floor);
11183 PL_compiling.cop_seq = 0;
11187 Perl_newANONLIST(pTHX_ OP *o)
11189 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
11193 Perl_newANONHASH(pTHX_ OP *o)
11195 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
11199 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
11201 return newANONATTRSUB(floor, proto, NULL, block);
11205 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
11207 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
11209 newSVOP(OP_ANONCODE, 0,
11211 if (CvANONCONST(cv))
11212 anoncode = newUNOP(OP_ANONCONST, 0,
11213 op_convert_list(OP_ENTERSUB,
11214 OPf_STACKED|OPf_WANT_SCALAR,
11216 return newUNOP(OP_REFGEN, 0, anoncode);
11220 Perl_oopsAV(pTHX_ OP *o)
11224 PERL_ARGS_ASSERT_OOPSAV;
11226 switch (o->op_type) {
11229 OpTYPE_set(o, OP_PADAV);
11230 return ref(o, OP_RV2AV);
11234 OpTYPE_set(o, OP_RV2AV);
11239 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11246 Perl_oopsHV(pTHX_ OP *o)
11250 PERL_ARGS_ASSERT_OOPSHV;
11252 switch (o->op_type) {
11255 OpTYPE_set(o, OP_PADHV);
11256 return ref(o, OP_RV2HV);
11260 OpTYPE_set(o, OP_RV2HV);
11261 /* rv2hv steals the bottom bit for its own uses */
11262 o->op_private &= ~OPpARG1_MASK;
11267 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11274 Perl_newAVREF(pTHX_ OP *o)
11278 PERL_ARGS_ASSERT_NEWAVREF;
11280 if (o->op_type == OP_PADANY) {
11281 OpTYPE_set(o, OP_PADAV);
11284 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11285 Perl_croak(aTHX_ "Can't use an array as a reference");
11287 return newUNOP(OP_RV2AV, 0, scalar(o));
11291 Perl_newGVREF(pTHX_ I32 type, OP *o)
11293 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11294 return newUNOP(OP_NULL, 0, o);
11295 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11299 Perl_newHVREF(pTHX_ OP *o)
11303 PERL_ARGS_ASSERT_NEWHVREF;
11305 if (o->op_type == OP_PADANY) {
11306 OpTYPE_set(o, OP_PADHV);
11309 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11310 Perl_croak(aTHX_ "Can't use a hash as a reference");
11312 return newUNOP(OP_RV2HV, 0, scalar(o));
11316 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11318 if (o->op_type == OP_PADANY) {
11320 OpTYPE_set(o, OP_PADCV);
11322 return newUNOP(OP_RV2CV, flags, scalar(o));
11326 Perl_newSVREF(pTHX_ OP *o)
11330 PERL_ARGS_ASSERT_NEWSVREF;
11332 if (o->op_type == OP_PADANY) {
11333 OpTYPE_set(o, OP_PADSV);
11337 return newUNOP(OP_RV2SV, 0, scalar(o));
11340 /* Check routines. See the comments at the top of this file for details
11341 * on when these are called */
11344 Perl_ck_anoncode(pTHX_ OP *o)
11346 PERL_ARGS_ASSERT_CK_ANONCODE;
11348 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11349 cSVOPo->op_sv = NULL;
11354 S_io_hints(pTHX_ OP *o)
11356 #if O_BINARY != 0 || O_TEXT != 0
11358 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11360 SV **svp = hv_fetchs(table, "open_IN", FALSE);
11363 const char *d = SvPV_const(*svp, len);
11364 const I32 mode = mode_from_discipline(d, len);
11365 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11367 if (mode & O_BINARY)
11368 o->op_private |= OPpOPEN_IN_RAW;
11372 o->op_private |= OPpOPEN_IN_CRLF;
11376 svp = hv_fetchs(table, "open_OUT", FALSE);
11379 const char *d = SvPV_const(*svp, len);
11380 const I32 mode = mode_from_discipline(d, len);
11381 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11383 if (mode & O_BINARY)
11384 o->op_private |= OPpOPEN_OUT_RAW;
11388 o->op_private |= OPpOPEN_OUT_CRLF;
11393 PERL_UNUSED_CONTEXT;
11394 PERL_UNUSED_ARG(o);
11399 Perl_ck_backtick(pTHX_ OP *o)
11404 PERL_ARGS_ASSERT_CK_BACKTICK;
11406 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11407 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11408 && (gv = gv_override("readpipe",8)))
11410 /* detach rest of siblings from o and its first child */
11411 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11412 newop = S_new_entersubop(aTHX_ gv, sibl);
11414 else if (!(o->op_flags & OPf_KIDS))
11415 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11420 S_io_hints(aTHX_ o);
11425 Perl_ck_bitop(pTHX_ OP *o)
11427 PERL_ARGS_ASSERT_CK_BITOP;
11429 o->op_private = (U8)(PL_hints & HINT_INTEGER);
11431 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11432 && OP_IS_INFIX_BIT(o->op_type))
11434 const OP * const left = cBINOPo->op_first;
11435 const OP * const right = OpSIBLING(left);
11436 if ((OP_IS_NUMCOMPARE(left->op_type) &&
11437 (left->op_flags & OPf_PARENS) == 0) ||
11438 (OP_IS_NUMCOMPARE(right->op_type) &&
11439 (right->op_flags & OPf_PARENS) == 0))
11440 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11441 "Possible precedence problem on bitwise %s operator",
11442 o->op_type == OP_BIT_OR
11443 ||o->op_type == OP_NBIT_OR ? "|"
11444 : o->op_type == OP_BIT_AND
11445 ||o->op_type == OP_NBIT_AND ? "&"
11446 : o->op_type == OP_BIT_XOR
11447 ||o->op_type == OP_NBIT_XOR ? "^"
11448 : o->op_type == OP_SBIT_OR ? "|."
11449 : o->op_type == OP_SBIT_AND ? "&." : "^."
11455 PERL_STATIC_INLINE bool
11456 is_dollar_bracket(pTHX_ const OP * const o)
11459 PERL_UNUSED_CONTEXT;
11460 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11461 && (kid = cUNOPx(o)->op_first)
11462 && kid->op_type == OP_GV
11463 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11466 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11469 Perl_ck_cmp(pTHX_ OP *o)
11475 OP *indexop, *constop, *start;
11479 PERL_ARGS_ASSERT_CK_CMP;
11481 is_eq = ( o->op_type == OP_EQ
11482 || o->op_type == OP_NE
11483 || o->op_type == OP_I_EQ
11484 || o->op_type == OP_I_NE);
11486 if (!is_eq && ckWARN(WARN_SYNTAX)) {
11487 const OP *kid = cUNOPo->op_first;
11490 ( is_dollar_bracket(aTHX_ kid)
11491 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11493 || ( kid->op_type == OP_CONST
11494 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11498 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11499 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11502 /* convert (index(...) == -1) and variations into
11503 * (r)index/BOOL(,NEG)
11508 indexop = cUNOPo->op_first;
11509 constop = OpSIBLING(indexop);
11511 if (indexop->op_type == OP_CONST) {
11513 indexop = OpSIBLING(constop);
11518 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11521 /* ($lex = index(....)) == -1 */
11522 if (indexop->op_private & OPpTARGET_MY)
11525 if (constop->op_type != OP_CONST)
11528 sv = cSVOPx_sv(constop);
11529 if (!(sv && SvIOK_notUV(sv)))
11533 if (iv != -1 && iv != 0)
11537 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11538 if (!(iv0 ^ reverse))
11542 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11547 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11548 if (!(iv0 ^ reverse))
11552 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11557 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11563 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11569 indexop->op_flags &= ~OPf_PARENS;
11570 indexop->op_flags |= (o->op_flags & OPf_PARENS);
11571 indexop->op_private |= OPpTRUEBOOL;
11573 indexop->op_private |= OPpINDEX_BOOLNEG;
11574 /* cut out the index op and free the eq,const ops */
11575 (void)op_sibling_splice(o, start, 1, NULL);
11583 Perl_ck_concat(pTHX_ OP *o)
11585 const OP * const kid = cUNOPo->op_first;
11587 PERL_ARGS_ASSERT_CK_CONCAT;
11588 PERL_UNUSED_CONTEXT;
11590 /* reuse the padtmp returned by the concat child */
11591 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11592 !(kUNOP->op_first->op_flags & OPf_MOD))
11594 o->op_flags |= OPf_STACKED;
11595 o->op_private |= OPpCONCAT_NESTED;
11601 Perl_ck_spair(pTHX_ OP *o)
11605 PERL_ARGS_ASSERT_CK_SPAIR;
11607 if (o->op_flags & OPf_KIDS) {
11611 const OPCODE type = o->op_type;
11612 o = modkids(ck_fun(o), type);
11613 kid = cUNOPo->op_first;
11614 kidkid = kUNOP->op_first;
11615 newop = OpSIBLING(kidkid);
11617 const OPCODE type = newop->op_type;
11618 if (OpHAS_SIBLING(newop))
11620 if (o->op_type == OP_REFGEN
11621 && ( type == OP_RV2CV
11622 || ( !(newop->op_flags & OPf_PARENS)
11623 && ( type == OP_RV2AV || type == OP_PADAV
11624 || type == OP_RV2HV || type == OP_PADHV))))
11625 NOOP; /* OK (allow srefgen for \@a and \%h) */
11626 else if (OP_GIMME(newop,0) != G_SCALAR)
11629 /* excise first sibling */
11630 op_sibling_splice(kid, NULL, 1, NULL);
11633 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11634 * and OP_CHOMP into OP_SCHOMP */
11635 o->op_ppaddr = PL_ppaddr[++o->op_type];
11640 Perl_ck_delete(pTHX_ OP *o)
11642 PERL_ARGS_ASSERT_CK_DELETE;
11646 if (o->op_flags & OPf_KIDS) {
11647 OP * const kid = cUNOPo->op_first;
11648 switch (kid->op_type) {
11650 o->op_flags |= OPf_SPECIAL;
11653 o->op_private |= OPpSLICE;
11656 o->op_flags |= OPf_SPECIAL;
11661 o->op_flags |= OPf_SPECIAL;
11664 o->op_private |= OPpKVSLICE;
11667 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11668 "element or slice");
11670 if (kid->op_private & OPpLVAL_INTRO)
11671 o->op_private |= OPpLVAL_INTRO;
11678 Perl_ck_eof(pTHX_ OP *o)
11680 PERL_ARGS_ASSERT_CK_EOF;
11682 if (o->op_flags & OPf_KIDS) {
11684 if (cLISTOPo->op_first->op_type == OP_STUB) {
11686 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11691 kid = cLISTOPo->op_first;
11692 if (kid->op_type == OP_RV2GV)
11693 kid->op_private |= OPpALLOW_FAKE;
11700 Perl_ck_eval(pTHX_ OP *o)
11704 PERL_ARGS_ASSERT_CK_EVAL;
11706 PL_hints |= HINT_BLOCK_SCOPE;
11707 if (o->op_flags & OPf_KIDS) {
11708 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11711 if (o->op_type == OP_ENTERTRY) {
11714 /* cut whole sibling chain free from o */
11715 op_sibling_splice(o, NULL, -1, NULL);
11718 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11720 /* establish postfix order */
11721 enter->op_next = (OP*)enter;
11723 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11724 OpTYPE_set(o, OP_LEAVETRY);
11725 enter->op_other = o;
11730 S_set_haseval(aTHX);
11734 const U8 priv = o->op_private;
11736 /* the newUNOP will recursively call ck_eval(), which will handle
11737 * all the stuff at the end of this function, like adding
11740 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11742 o->op_targ = (PADOFFSET)PL_hints;
11743 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11744 if ((PL_hints & HINT_LOCALIZE_HH) != 0
11745 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11746 /* Store a copy of %^H that pp_entereval can pick up. */
11747 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11748 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11749 /* append hhop to only child */
11750 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11752 o->op_private |= OPpEVAL_HAS_HH;
11754 if (!(o->op_private & OPpEVAL_BYTES)
11755 && FEATURE_UNIEVAL_IS_ENABLED)
11756 o->op_private |= OPpEVAL_UNICODE;
11761 Perl_ck_exec(pTHX_ OP *o)
11763 PERL_ARGS_ASSERT_CK_EXEC;
11765 if (o->op_flags & OPf_STACKED) {
11768 kid = OpSIBLING(cUNOPo->op_first);
11769 if (kid->op_type == OP_RV2GV)
11778 Perl_ck_exists(pTHX_ OP *o)
11780 PERL_ARGS_ASSERT_CK_EXISTS;
11783 if (o->op_flags & OPf_KIDS) {
11784 OP * const kid = cUNOPo->op_first;
11785 if (kid->op_type == OP_ENTERSUB) {
11786 (void) ref(kid, o->op_type);
11787 if (kid->op_type != OP_RV2CV
11788 && !(PL_parser && PL_parser->error_count))
11790 "exists argument is not a subroutine name");
11791 o->op_private |= OPpEXISTS_SUB;
11793 else if (kid->op_type == OP_AELEM)
11794 o->op_flags |= OPf_SPECIAL;
11795 else if (kid->op_type != OP_HELEM)
11796 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11797 "element or a subroutine");
11804 Perl_ck_rvconst(pTHX_ OP *o)
11807 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11809 PERL_ARGS_ASSERT_CK_RVCONST;
11811 if (o->op_type == OP_RV2HV)
11812 /* rv2hv steals the bottom bit for its own uses */
11813 o->op_private &= ~OPpARG1_MASK;
11815 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11817 if (kid->op_type == OP_CONST) {
11820 SV * const kidsv = kid->op_sv;
11822 /* Is it a constant from cv_const_sv()? */
11823 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11826 if (SvTYPE(kidsv) == SVt_PVAV) return o;
11827 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11828 const char *badthing;
11829 switch (o->op_type) {
11831 badthing = "a SCALAR";
11834 badthing = "an ARRAY";
11837 badthing = "a HASH";
11845 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11846 SVfARG(kidsv), badthing);
11849 * This is a little tricky. We only want to add the symbol if we
11850 * didn't add it in the lexer. Otherwise we get duplicate strict
11851 * warnings. But if we didn't add it in the lexer, we must at
11852 * least pretend like we wanted to add it even if it existed before,
11853 * or we get possible typo warnings. OPpCONST_ENTERED says
11854 * whether the lexer already added THIS instance of this symbol.
11856 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11857 gv = gv_fetchsv(kidsv,
11858 o->op_type == OP_RV2CV
11859 && o->op_private & OPpMAY_RETURN_CONSTANT
11861 : iscv | !(kid->op_private & OPpCONST_ENTERED),
11864 : o->op_type == OP_RV2SV
11866 : o->op_type == OP_RV2AV
11868 : o->op_type == OP_RV2HV
11875 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11876 && SvTYPE(SvRV(gv)) != SVt_PVCV)
11877 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11879 OpTYPE_set(kid, OP_GV);
11880 SvREFCNT_dec(kid->op_sv);
11881 #ifdef USE_ITHREADS
11882 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11883 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11884 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11885 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11886 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11888 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11890 kid->op_private = 0;
11891 /* FAKE globs in the symbol table cause weird bugs (#77810) */
11899 Perl_ck_ftst(pTHX_ OP *o)
11902 const I32 type = o->op_type;
11904 PERL_ARGS_ASSERT_CK_FTST;
11906 if (o->op_flags & OPf_REF) {
11909 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11910 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11911 const OPCODE kidtype = kid->op_type;
11913 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11914 && !kid->op_folded) {
11915 OP * const newop = newGVOP(type, OPf_REF,
11916 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11921 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11922 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11924 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11925 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11926 array_passed_to_stat, name);
11929 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11930 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11933 scalar((OP *) kid);
11934 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11935 o->op_private |= OPpFT_ACCESS;
11936 if (OP_IS_FILETEST(type)
11937 && OP_IS_FILETEST(kidtype)
11939 o->op_private |= OPpFT_STACKED;
11940 kid->op_private |= OPpFT_STACKING;
11941 if (kidtype == OP_FTTTY && (
11942 !(kid->op_private & OPpFT_STACKED)
11943 || kid->op_private & OPpFT_AFTER_t
11945 o->op_private |= OPpFT_AFTER_t;
11950 if (type == OP_FTTTY)
11951 o = newGVOP(type, OPf_REF, PL_stdingv);
11953 o = newUNOP(type, 0, newDEFSVOP());
11959 Perl_ck_fun(pTHX_ OP *o)
11961 const int type = o->op_type;
11962 I32 oa = PL_opargs[type] >> OASHIFT;
11964 PERL_ARGS_ASSERT_CK_FUN;
11966 if (o->op_flags & OPf_STACKED) {
11967 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11968 oa &= ~OA_OPTIONAL;
11970 return no_fh_allowed(o);
11973 if (o->op_flags & OPf_KIDS) {
11974 OP *prev_kid = NULL;
11975 OP *kid = cLISTOPo->op_first;
11977 bool seen_optional = FALSE;
11979 if (kid->op_type == OP_PUSHMARK ||
11980 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11983 kid = OpSIBLING(kid);
11985 if (kid && kid->op_type == OP_COREARGS) {
11986 bool optional = FALSE;
11989 if (oa & OA_OPTIONAL) optional = TRUE;
11992 if (optional) o->op_private |= numargs;
11997 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11998 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11999 kid = newDEFSVOP();
12000 /* append kid to chain */
12001 op_sibling_splice(o, prev_kid, 0, kid);
12003 seen_optional = TRUE;
12010 /* list seen where single (scalar) arg expected? */
12011 if (numargs == 1 && !(oa >> 4)
12012 && kid->op_type == OP_LIST && type != OP_SCALAR)
12014 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12016 if (type != OP_DELETE) scalar(kid);
12027 if ((type == OP_PUSH || type == OP_UNSHIFT)
12028 && !OpHAS_SIBLING(kid))
12029 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12030 "Useless use of %s with no values",
12033 if (kid->op_type == OP_CONST
12034 && ( !SvROK(cSVOPx_sv(kid))
12035 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
12037 bad_type_pv(numargs, "array", o, kid);
12038 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
12039 || kid->op_type == OP_RV2GV) {
12040 bad_type_pv(1, "array", o, kid);
12042 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
12043 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
12044 PL_op_desc[type]), 0);
12047 op_lvalue(kid, type);
12051 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
12052 bad_type_pv(numargs, "hash", o, kid);
12053 op_lvalue(kid, type);
12057 /* replace kid with newop in chain */
12059 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
12060 newop->op_next = newop;
12065 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
12066 if (kid->op_type == OP_CONST &&
12067 (kid->op_private & OPpCONST_BARE))
12069 OP * const newop = newGVOP(OP_GV, 0,
12070 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
12071 /* replace kid with newop in chain */
12072 op_sibling_splice(o, prev_kid, 1, newop);
12076 else if (kid->op_type == OP_READLINE) {
12077 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
12078 bad_type_pv(numargs, "HANDLE", o, kid);
12081 I32 flags = OPf_SPECIAL;
12083 PADOFFSET targ = 0;
12085 /* is this op a FH constructor? */
12086 if (is_handle_constructor(o,numargs)) {
12087 const char *name = NULL;
12090 bool want_dollar = TRUE;
12093 /* Set a flag to tell rv2gv to vivify
12094 * need to "prove" flag does not mean something
12095 * else already - NI-S 1999/05/07
12098 if (kid->op_type == OP_PADSV) {
12100 = PAD_COMPNAME_SV(kid->op_targ);
12101 name = PadnamePV (pn);
12102 len = PadnameLEN(pn);
12103 name_utf8 = PadnameUTF8(pn);
12105 else if (kid->op_type == OP_RV2SV
12106 && kUNOP->op_first->op_type == OP_GV)
12108 GV * const gv = cGVOPx_gv(kUNOP->op_first);
12110 len = GvNAMELEN(gv);
12111 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
12113 else if (kid->op_type == OP_AELEM
12114 || kid->op_type == OP_HELEM)
12117 OP *op = ((BINOP*)kid)->op_first;
12121 const char * const a =
12122 kid->op_type == OP_AELEM ?
12124 if (((op->op_type == OP_RV2AV) ||
12125 (op->op_type == OP_RV2HV)) &&
12126 (firstop = ((UNOP*)op)->op_first) &&
12127 (firstop->op_type == OP_GV)) {
12128 /* packagevar $a[] or $h{} */
12129 GV * const gv = cGVOPx_gv(firstop);
12132 Perl_newSVpvf(aTHX_
12137 else if (op->op_type == OP_PADAV
12138 || op->op_type == OP_PADHV) {
12139 /* lexicalvar $a[] or $h{} */
12140 const char * const padname =
12141 PAD_COMPNAME_PV(op->op_targ);
12144 Perl_newSVpvf(aTHX_
12150 name = SvPV_const(tmpstr, len);
12151 name_utf8 = SvUTF8(tmpstr);
12152 sv_2mortal(tmpstr);
12156 name = "__ANONIO__";
12158 want_dollar = FALSE;
12160 op_lvalue(kid, type);
12164 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
12165 namesv = PAD_SVl(targ);
12166 if (want_dollar && *name != '$')
12167 sv_setpvs(namesv, "$");
12170 sv_catpvn(namesv, name, len);
12171 if ( name_utf8 ) SvUTF8_on(namesv);
12175 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
12177 kid->op_targ = targ;
12178 kid->op_private |= priv;
12184 if ((type == OP_UNDEF || type == OP_POS)
12185 && numargs == 1 && !(oa >> 4)
12186 && kid->op_type == OP_LIST)
12187 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12188 op_lvalue(scalar(kid), type);
12193 kid = OpSIBLING(kid);
12195 /* FIXME - should the numargs or-ing move after the too many
12196 * arguments check? */
12197 o->op_private |= numargs;
12199 return too_many_arguments_pv(o,OP_DESC(o), 0);
12202 else if (PL_opargs[type] & OA_DEFGV) {
12203 /* Ordering of these two is important to keep f_map.t passing. */
12205 return newUNOP(type, 0, newDEFSVOP());
12209 while (oa & OA_OPTIONAL)
12211 if (oa && oa != OA_LIST)
12212 return too_few_arguments_pv(o,OP_DESC(o), 0);
12218 Perl_ck_glob(pTHX_ OP *o)
12222 PERL_ARGS_ASSERT_CK_GLOB;
12225 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
12226 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
12228 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
12232 * \ null - const(wildcard)
12237 * \ mark - glob - rv2cv
12238 * | \ gv(CORE::GLOBAL::glob)
12240 * \ null - const(wildcard)
12242 o->op_flags |= OPf_SPECIAL;
12243 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12244 o = S_new_entersubop(aTHX_ gv, o);
12245 o = newUNOP(OP_NULL, 0, o);
12246 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12249 else o->op_flags &= ~OPf_SPECIAL;
12250 #if !defined(PERL_EXTERNAL_GLOB)
12251 if (!PL_globhook) {
12253 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12254 newSVpvs("File::Glob"), NULL, NULL, NULL);
12257 #endif /* !PERL_EXTERNAL_GLOB */
12258 gv = (GV *)newSV(0);
12259 gv_init(gv, 0, "", 0, 0);
12261 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12262 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12268 Perl_ck_grep(pTHX_ OP *o)
12272 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12274 PERL_ARGS_ASSERT_CK_GREP;
12276 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12278 if (o->op_flags & OPf_STACKED) {
12279 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12280 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12281 return no_fh_allowed(o);
12282 o->op_flags &= ~OPf_STACKED;
12284 kid = OpSIBLING(cLISTOPo->op_first);
12285 if (type == OP_MAPWHILE)
12290 if (PL_parser && PL_parser->error_count)
12292 kid = OpSIBLING(cLISTOPo->op_first);
12293 if (kid->op_type != OP_NULL)
12294 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12295 kid = kUNOP->op_first;
12297 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12298 kid->op_next = (OP*)gwop;
12299 o->op_private = gwop->op_private = 0;
12300 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12302 kid = OpSIBLING(cLISTOPo->op_first);
12303 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12304 op_lvalue(kid, OP_GREPSTART);
12310 Perl_ck_index(pTHX_ OP *o)
12312 PERL_ARGS_ASSERT_CK_INDEX;
12314 if (o->op_flags & OPf_KIDS) {
12315 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12317 kid = OpSIBLING(kid); /* get past "big" */
12318 if (kid && kid->op_type == OP_CONST) {
12319 const bool save_taint = TAINT_get;
12320 SV *sv = kSVOP->op_sv;
12321 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12322 && SvOK(sv) && !SvROK(sv))
12325 sv_copypv(sv, kSVOP->op_sv);
12326 SvREFCNT_dec_NN(kSVOP->op_sv);
12329 if (SvOK(sv)) fbm_compile(sv, 0);
12330 TAINT_set(save_taint);
12331 #ifdef NO_TAINT_SUPPORT
12332 PERL_UNUSED_VAR(save_taint);
12340 Perl_ck_lfun(pTHX_ OP *o)
12342 const OPCODE type = o->op_type;
12344 PERL_ARGS_ASSERT_CK_LFUN;
12346 return modkids(ck_fun(o), type);
12350 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
12352 PERL_ARGS_ASSERT_CK_DEFINED;
12354 if ((o->op_flags & OPf_KIDS)) {
12355 switch (cUNOPo->op_first->op_type) {
12358 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12359 " (Maybe you should just omit the defined()?)");
12360 NOT_REACHED; /* NOTREACHED */
12364 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12365 " (Maybe you should just omit the defined()?)");
12366 NOT_REACHED; /* NOTREACHED */
12377 Perl_ck_readline(pTHX_ OP *o)
12379 PERL_ARGS_ASSERT_CK_READLINE;
12381 if (o->op_flags & OPf_KIDS) {
12382 OP *kid = cLISTOPo->op_first;
12383 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12388 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12396 Perl_ck_rfun(pTHX_ OP *o)
12398 const OPCODE type = o->op_type;
12400 PERL_ARGS_ASSERT_CK_RFUN;
12402 return refkids(ck_fun(o), type);
12406 Perl_ck_listiob(pTHX_ OP *o)
12410 PERL_ARGS_ASSERT_CK_LISTIOB;
12412 kid = cLISTOPo->op_first;
12414 o = force_list(o, 1);
12415 kid = cLISTOPo->op_first;
12417 if (kid->op_type == OP_PUSHMARK)
12418 kid = OpSIBLING(kid);
12419 if (kid && o->op_flags & OPf_STACKED)
12420 kid = OpSIBLING(kid);
12421 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
12422 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12423 && !kid->op_folded) {
12424 o->op_flags |= OPf_STACKED; /* make it a filehandle */
12426 /* replace old const op with new OP_RV2GV parent */
12427 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12428 OP_RV2GV, OPf_REF);
12429 kid = OpSIBLING(kid);
12434 op_append_elem(o->op_type, o, newDEFSVOP());
12436 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12437 return listkids(o);
12441 Perl_ck_smartmatch(pTHX_ OP *o)
12444 PERL_ARGS_ASSERT_CK_SMARTMATCH;
12445 if (0 == (o->op_flags & OPf_SPECIAL)) {
12446 OP *first = cBINOPo->op_first;
12447 OP *second = OpSIBLING(first);
12449 /* Implicitly take a reference to an array or hash */
12451 /* remove the original two siblings, then add back the
12452 * (possibly different) first and second sibs.
12454 op_sibling_splice(o, NULL, 1, NULL);
12455 op_sibling_splice(o, NULL, 1, NULL);
12456 first = ref_array_or_hash(first);
12457 second = ref_array_or_hash(second);
12458 op_sibling_splice(o, NULL, 0, second);
12459 op_sibling_splice(o, NULL, 0, first);
12461 /* Implicitly take a reference to a regular expression */
12462 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12463 OpTYPE_set(first, OP_QR);
12465 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12466 OpTYPE_set(second, OP_QR);
12475 S_maybe_targlex(pTHX_ OP *o)
12477 OP * const kid = cLISTOPo->op_first;
12478 /* has a disposable target? */
12479 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12480 && !(kid->op_flags & OPf_STACKED)
12481 /* Cannot steal the second time! */
12482 && !(kid->op_private & OPpTARGET_MY)
12485 OP * const kkid = OpSIBLING(kid);
12487 /* Can just relocate the target. */
12488 if (kkid && kkid->op_type == OP_PADSV
12489 && (!(kkid->op_private & OPpLVAL_INTRO)
12490 || kkid->op_private & OPpPAD_STATE))
12492 kid->op_targ = kkid->op_targ;
12494 /* Now we do not need PADSV and SASSIGN.
12495 * Detach kid and free the rest. */
12496 op_sibling_splice(o, NULL, 1, NULL);
12498 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
12506 Perl_ck_sassign(pTHX_ OP *o)
12509 OP * const kid = cBINOPo->op_first;
12511 PERL_ARGS_ASSERT_CK_SASSIGN;
12513 if (OpHAS_SIBLING(kid)) {
12514 OP *kkid = OpSIBLING(kid);
12515 /* For state variable assignment with attributes, kkid is a list op
12516 whose op_last is a padsv. */
12517 if ((kkid->op_type == OP_PADSV ||
12518 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12519 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12522 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12523 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12524 return S_newONCEOP(aTHX_ o, kkid);
12527 return S_maybe_targlex(aTHX_ o);
12532 Perl_ck_match(pTHX_ OP *o)
12534 PERL_UNUSED_CONTEXT;
12535 PERL_ARGS_ASSERT_CK_MATCH;
12541 Perl_ck_method(pTHX_ OP *o)
12543 SV *sv, *methsv, *rclass;
12544 const char* method;
12547 STRLEN len, nsplit = 0, i;
12549 OP * const kid = cUNOPo->op_first;
12551 PERL_ARGS_ASSERT_CK_METHOD;
12552 if (kid->op_type != OP_CONST) return o;
12556 /* replace ' with :: */
12557 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12558 SvEND(sv) - SvPVX(sv) )))
12561 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12564 method = SvPVX_const(sv);
12566 utf8 = SvUTF8(sv) ? -1 : 1;
12568 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12573 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12575 if (!nsplit) { /* $proto->method() */
12577 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12580 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12582 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12585 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12586 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12587 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12588 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12590 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12591 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12593 #ifdef USE_ITHREADS
12594 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12596 cMETHOPx(new_op)->op_rclass_sv = rclass;
12603 Perl_ck_null(pTHX_ OP *o)
12605 PERL_ARGS_ASSERT_CK_NULL;
12606 PERL_UNUSED_CONTEXT;
12611 Perl_ck_open(pTHX_ OP *o)
12613 PERL_ARGS_ASSERT_CK_OPEN;
12615 S_io_hints(aTHX_ o);
12617 /* In case of three-arg dup open remove strictness
12618 * from the last arg if it is a bareword. */
12619 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12620 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
12624 if ((last->op_type == OP_CONST) && /* The bareword. */
12625 (last->op_private & OPpCONST_BARE) &&
12626 (last->op_private & OPpCONST_STRICT) &&
12627 (oa = OpSIBLING(first)) && /* The fh. */
12628 (oa = OpSIBLING(oa)) && /* The mode. */
12629 (oa->op_type == OP_CONST) &&
12630 SvPOK(((SVOP*)oa)->op_sv) &&
12631 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12632 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
12633 (last == OpSIBLING(oa))) /* The bareword. */
12634 last->op_private &= ~OPpCONST_STRICT;
12640 Perl_ck_prototype(pTHX_ OP *o)
12642 PERL_ARGS_ASSERT_CK_PROTOTYPE;
12643 if (!(o->op_flags & OPf_KIDS)) {
12645 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12651 Perl_ck_refassign(pTHX_ OP *o)
12653 OP * const right = cLISTOPo->op_first;
12654 OP * const left = OpSIBLING(right);
12655 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12658 PERL_ARGS_ASSERT_CK_REFASSIGN;
12660 assert (left->op_type == OP_SREFGEN);
12663 /* we use OPpPAD_STATE in refassign to mean either of those things,
12664 * and the code assumes the two flags occupy the same bit position
12665 * in the various ops below */
12666 assert(OPpPAD_STATE == OPpOUR_INTRO);
12668 switch (varop->op_type) {
12670 o->op_private |= OPpLVREF_AV;
12673 o->op_private |= OPpLVREF_HV;
12677 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12678 o->op_targ = varop->op_targ;
12679 varop->op_targ = 0;
12680 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12684 o->op_private |= OPpLVREF_AV;
12686 NOT_REACHED; /* NOTREACHED */
12688 o->op_private |= OPpLVREF_HV;
12692 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12693 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12695 /* Point varop to its GV kid, detached. */
12696 varop = op_sibling_splice(varop, NULL, -1, NULL);
12700 OP * const kidparent =
12701 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12702 OP * const kid = cUNOPx(kidparent)->op_first;
12703 o->op_private |= OPpLVREF_CV;
12704 if (kid->op_type == OP_GV) {
12705 SV *sv = (SV*)cGVOPx_gv(kid);
12707 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
12708 /* a CVREF here confuses pp_refassign, so make sure
12710 CV *const cv = (CV*)SvRV(sv);
12711 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
12712 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
12713 assert(SvTYPE(sv) == SVt_PVGV);
12715 goto detach_and_stack;
12717 if (kid->op_type != OP_PADCV) goto bad;
12718 o->op_targ = kid->op_targ;
12724 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12725 o->op_private |= OPpLVREF_ELEM;
12728 /* Detach varop. */
12729 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12733 /* diag_listed_as: Can't modify reference to %s in %s assignment */
12734 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12739 if (!FEATURE_REFALIASING_IS_ENABLED)
12741 "Experimental aliasing via reference not enabled");
12742 Perl_ck_warner_d(aTHX_
12743 packWARN(WARN_EXPERIMENTAL__REFALIASING),
12744 "Aliasing via reference is experimental");
12746 o->op_flags |= OPf_STACKED;
12747 op_sibling_splice(o, right, 1, varop);
12750 o->op_flags &=~ OPf_STACKED;
12751 op_sibling_splice(o, right, 1, NULL);
12758 Perl_ck_repeat(pTHX_ OP *o)
12760 PERL_ARGS_ASSERT_CK_REPEAT;
12762 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12764 o->op_private |= OPpREPEAT_DOLIST;
12765 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12766 kids = force_list(kids, 1); /* promote it to a list */
12767 op_sibling_splice(o, NULL, 0, kids); /* and add back */
12775 Perl_ck_require(pTHX_ OP *o)
12779 PERL_ARGS_ASSERT_CK_REQUIRE;
12781 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
12782 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12786 if (kid->op_type == OP_CONST) {
12787 SV * const sv = kid->op_sv;
12788 U32 const was_readonly = SvREADONLY(sv);
12789 if (kid->op_private & OPpCONST_BARE) {
12794 if (was_readonly) {
12795 SvREADONLY_off(sv);
12797 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12802 /* treat ::foo::bar as foo::bar */
12803 if (len >= 2 && s[0] == ':' && s[1] == ':')
12804 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12806 DIE(aTHX_ "Bareword in require maps to empty filename");
12808 for (; s < end; s++) {
12809 if (*s == ':' && s[1] == ':') {
12811 Move(s+2, s+1, end - s - 1, char);
12815 SvEND_set(sv, end);
12816 sv_catpvs(sv, ".pm");
12817 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12818 hek = share_hek(SvPVX(sv),
12819 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12821 sv_sethek(sv, hek);
12823 SvFLAGS(sv) |= was_readonly;
12825 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12828 if (SvREFCNT(sv) > 1) {
12829 kid->op_sv = newSVpvn_share(
12830 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12831 SvREFCNT_dec_NN(sv);
12836 if (was_readonly) SvREADONLY_off(sv);
12837 PERL_HASH(hash, s, len);
12839 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12841 sv_sethek(sv, hek);
12843 SvFLAGS(sv) |= was_readonly;
12849 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12850 /* handle override, if any */
12851 && (gv = gv_override("require", 7))) {
12853 if (o->op_flags & OPf_KIDS) {
12854 kid = cUNOPo->op_first;
12855 op_sibling_splice(o, NULL, -1, NULL);
12858 kid = newDEFSVOP();
12861 newop = S_new_entersubop(aTHX_ gv, kid);
12869 Perl_ck_return(pTHX_ OP *o)
12873 PERL_ARGS_ASSERT_CK_RETURN;
12875 kid = OpSIBLING(cLISTOPo->op_first);
12876 if (PL_compcv && CvLVALUE(PL_compcv)) {
12877 for (; kid; kid = OpSIBLING(kid))
12878 op_lvalue(kid, OP_LEAVESUBLV);
12885 Perl_ck_select(pTHX_ OP *o)
12890 PERL_ARGS_ASSERT_CK_SELECT;
12892 if (o->op_flags & OPf_KIDS) {
12893 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12894 if (kid && OpHAS_SIBLING(kid)) {
12895 OpTYPE_set(o, OP_SSELECT);
12897 return fold_constants(op_integerize(op_std_init(o)));
12901 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12902 if (kid && kid->op_type == OP_RV2GV)
12903 kid->op_private &= ~HINT_STRICT_REFS;
12908 Perl_ck_shift(pTHX_ OP *o)
12910 const I32 type = o->op_type;
12912 PERL_ARGS_ASSERT_CK_SHIFT;
12914 if (!(o->op_flags & OPf_KIDS)) {
12917 if (!CvUNIQUE(PL_compcv)) {
12918 o->op_flags |= OPf_SPECIAL;
12922 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12924 return newUNOP(type, 0, scalar(argop));
12926 return scalar(ck_fun(o));
12930 Perl_ck_sort(pTHX_ OP *o)
12934 HV * const hinthv =
12935 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12938 PERL_ARGS_ASSERT_CK_SORT;
12941 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12943 const I32 sorthints = (I32)SvIV(*svp);
12944 if ((sorthints & HINT_SORT_STABLE) != 0)
12945 o->op_private |= OPpSORT_STABLE;
12946 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12947 o->op_private |= OPpSORT_UNSTABLE;
12951 if (o->op_flags & OPf_STACKED)
12953 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12955 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
12956 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
12958 /* if the first arg is a code block, process it and mark sort as
12960 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12962 if (kid->op_type == OP_LEAVE)
12963 op_null(kid); /* wipe out leave */
12964 /* Prevent execution from escaping out of the sort block. */
12967 /* provide scalar context for comparison function/block */
12968 kid = scalar(firstkid);
12969 kid->op_next = kid;
12970 o->op_flags |= OPf_SPECIAL;
12972 else if (kid->op_type == OP_CONST
12973 && kid->op_private & OPpCONST_BARE) {
12977 const char * const name = SvPV(kSVOP_sv, len);
12979 assert (len < 256);
12980 Copy(name, tmpbuf+1, len, char);
12981 off = pad_findmy_pvn(tmpbuf, len+1, 0);
12982 if (off != NOT_IN_PAD) {
12983 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12985 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12986 sv_catpvs(fq, "::");
12987 sv_catsv(fq, kSVOP_sv);
12988 SvREFCNT_dec_NN(kSVOP_sv);
12992 OP * const padop = newOP(OP_PADCV, 0);
12993 padop->op_targ = off;
12994 /* replace the const op with the pad op */
12995 op_sibling_splice(firstkid, NULL, 1, padop);
13001 firstkid = OpSIBLING(firstkid);
13004 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13005 /* provide list context for arguments */
13008 op_lvalue(kid, OP_GREPSTART);
13014 /* for sort { X } ..., where X is one of
13015 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
13016 * elide the second child of the sort (the one containing X),
13017 * and set these flags as appropriate
13021 * Also, check and warn on lexical $a, $b.
13025 S_simplify_sort(pTHX_ OP *o)
13027 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13031 const char *gvname;
13034 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
13036 kid = kUNOP->op_first; /* get past null */
13037 if (!(have_scopeop = kid->op_type == OP_SCOPE)
13038 && kid->op_type != OP_LEAVE)
13040 kid = kLISTOP->op_last; /* get past scope */
13041 switch(kid->op_type) {
13045 if (!have_scopeop) goto padkids;
13050 k = kid; /* remember this node*/
13051 if (kBINOP->op_first->op_type != OP_RV2SV
13052 || kBINOP->op_last ->op_type != OP_RV2SV)
13055 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
13056 then used in a comparison. This catches most, but not
13057 all cases. For instance, it catches
13058 sort { my($a); $a <=> $b }
13060 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
13061 (although why you'd do that is anyone's guess).
13065 if (!ckWARN(WARN_SYNTAX)) return;
13066 kid = kBINOP->op_first;
13068 if (kid->op_type == OP_PADSV) {
13069 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
13070 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
13071 && ( PadnamePV(name)[1] == 'a'
13072 || PadnamePV(name)[1] == 'b' ))
13073 /* diag_listed_as: "my %s" used in sort comparison */
13074 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13075 "\"%s %s\" used in sort comparison",
13076 PadnameIsSTATE(name)
13081 } while ((kid = OpSIBLING(kid)));
13084 kid = kBINOP->op_first; /* get past cmp */
13085 if (kUNOP->op_first->op_type != OP_GV)
13087 kid = kUNOP->op_first; /* get past rv2sv */
13089 if (GvSTASH(gv) != PL_curstash)
13091 gvname = GvNAME(gv);
13092 if (*gvname == 'a' && gvname[1] == '\0')
13094 else if (*gvname == 'b' && gvname[1] == '\0')
13099 kid = k; /* back to cmp */
13100 /* already checked above that it is rv2sv */
13101 kid = kBINOP->op_last; /* down to 2nd arg */
13102 if (kUNOP->op_first->op_type != OP_GV)
13104 kid = kUNOP->op_first; /* get past rv2sv */
13106 if (GvSTASH(gv) != PL_curstash)
13108 gvname = GvNAME(gv);
13110 ? !(*gvname == 'a' && gvname[1] == '\0')
13111 : !(*gvname == 'b' && gvname[1] == '\0'))
13113 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
13115 o->op_private |= OPpSORT_DESCEND;
13116 if (k->op_type == OP_NCMP)
13117 o->op_private |= OPpSORT_NUMERIC;
13118 if (k->op_type == OP_I_NCMP)
13119 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
13120 kid = OpSIBLING(cLISTOPo->op_first);
13121 /* cut out and delete old block (second sibling) */
13122 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
13127 Perl_ck_split(pTHX_ OP *o)
13133 PERL_ARGS_ASSERT_CK_SPLIT;
13135 assert(o->op_type == OP_LIST);
13137 if (o->op_flags & OPf_STACKED)
13138 return no_fh_allowed(o);
13140 kid = cLISTOPo->op_first;
13141 /* delete leading NULL node, then add a CONST if no other nodes */
13142 assert(kid->op_type == OP_NULL);
13143 op_sibling_splice(o, NULL, 1,
13144 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
13146 kid = cLISTOPo->op_first;
13148 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
13149 /* remove match expression, and replace with new optree with
13150 * a match op at its head */
13151 op_sibling_splice(o, NULL, 1, NULL);
13152 /* pmruntime will handle split " " behavior with flag==2 */
13153 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
13154 op_sibling_splice(o, NULL, 0, kid);
13157 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
13159 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
13160 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
13161 "Use of /g modifier is meaningless in split");
13164 /* eliminate the split op, and move the match op (plus any children)
13165 * into its place, then convert the match op into a split op. i.e.
13167 * SPLIT MATCH SPLIT(ex-MATCH)
13169 * MATCH - A - B - C => R - A - B - C => R - A - B - C
13175 * (R, if it exists, will be a regcomp op)
13178 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
13179 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
13180 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
13181 OpTYPE_set(kid, OP_SPLIT);
13182 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
13183 kid->op_private = o->op_private;
13186 kid = sibs; /* kid is now the string arg of the split */
13189 kid = newDEFSVOP();
13190 op_append_elem(OP_SPLIT, o, kid);
13194 kid = OpSIBLING(kid);
13196 kid = newSVOP(OP_CONST, 0, newSViv(0));
13197 op_append_elem(OP_SPLIT, o, kid);
13198 o->op_private |= OPpSPLIT_IMPLIM;
13202 if (OpHAS_SIBLING(kid))
13203 return too_many_arguments_pv(o,OP_DESC(o), 0);
13209 Perl_ck_stringify(pTHX_ OP *o)
13211 OP * const kid = OpSIBLING(cUNOPo->op_first);
13212 PERL_ARGS_ASSERT_CK_STRINGIFY;
13213 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
13214 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
13215 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
13216 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
13218 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
13226 Perl_ck_join(pTHX_ OP *o)
13228 OP * const kid = OpSIBLING(cLISTOPo->op_first);
13230 PERL_ARGS_ASSERT_CK_JOIN;
13232 if (kid && kid->op_type == OP_MATCH) {
13233 if (ckWARN(WARN_SYNTAX)) {
13234 const REGEXP *re = PM_GETRE(kPMOP);
13236 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
13237 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
13238 : newSVpvs_flags( "STRING", SVs_TEMP );
13239 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13240 "/%" SVf "/ should probably be written as \"%" SVf "\"",
13241 SVfARG(msg), SVfARG(msg));
13245 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
13246 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
13247 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
13248 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
13250 const OP * const bairn = OpSIBLING(kid); /* the list */
13251 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
13252 && OP_GIMME(bairn,0) == G_SCALAR)
13254 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13255 op_sibling_splice(o, kid, 1, NULL));
13265 =for apidoc rv2cv_op_cv
13267 Examines an op, which is expected to identify a subroutine at runtime,
13268 and attempts to determine at compile time which subroutine it identifies.
13269 This is normally used during Perl compilation to determine whether
13270 a prototype can be applied to a function call. C<cvop> is the op
13271 being considered, normally an C<rv2cv> op. A pointer to the identified
13272 subroutine is returned, if it could be determined statically, and a null
13273 pointer is returned if it was not possible to determine statically.
13275 Currently, the subroutine can be identified statically if the RV that the
13276 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13277 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
13278 suitable if the constant value must be an RV pointing to a CV. Details of
13279 this process may change in future versions of Perl. If the C<rv2cv> op
13280 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13281 the subroutine statically: this flag is used to suppress compile-time
13282 magic on a subroutine call, forcing it to use default runtime behaviour.
13284 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13285 of a GV reference is modified. If a GV was examined and its CV slot was
13286 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13287 If the op is not optimised away, and the CV slot is later populated with
13288 a subroutine having a prototype, that flag eventually triggers the warning
13289 "called too early to check prototype".
13291 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13292 of returning a pointer to the subroutine it returns a pointer to the
13293 GV giving the most appropriate name for the subroutine in this context.
13294 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13295 (C<CvANON>) subroutine that is referenced through a GV it will be the
13296 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
13297 A null pointer is returned as usual if there is no statically-determinable
13303 /* shared by toke.c:yylex */
13305 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13307 PADNAME *name = PAD_COMPNAME(off);
13308 CV *compcv = PL_compcv;
13309 while (PadnameOUTER(name)) {
13310 assert(PARENT_PAD_INDEX(name));
13311 compcv = CvOUTSIDE(compcv);
13312 name = PadlistNAMESARRAY(CvPADLIST(compcv))
13313 [off = PARENT_PAD_INDEX(name)];
13315 assert(!PadnameIsOUR(name));
13316 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13317 return PadnamePROTOCV(name);
13319 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13323 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13328 PERL_ARGS_ASSERT_RV2CV_OP_CV;
13329 if (flags & ~RV2CVOPCV_FLAG_MASK)
13330 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13331 if (cvop->op_type != OP_RV2CV)
13333 if (cvop->op_private & OPpENTERSUB_AMPER)
13335 if (!(cvop->op_flags & OPf_KIDS))
13337 rvop = cUNOPx(cvop)->op_first;
13338 switch (rvop->op_type) {
13340 gv = cGVOPx_gv(rvop);
13342 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13343 cv = MUTABLE_CV(SvRV(gv));
13347 if (flags & RV2CVOPCV_RETURN_STUB)
13353 if (flags & RV2CVOPCV_MARK_EARLY)
13354 rvop->op_private |= OPpEARLY_CV;
13359 SV *rv = cSVOPx_sv(rvop);
13362 cv = (CV*)SvRV(rv);
13366 cv = find_lexical_cv(rvop->op_targ);
13371 } NOT_REACHED; /* NOTREACHED */
13373 if (SvTYPE((SV*)cv) != SVt_PVCV)
13375 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13376 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13380 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13381 if (CvLEXICAL(cv) || CvNAMED(cv))
13383 if (!CvANON(cv) || !gv)
13393 =for apidoc ck_entersub_args_list
13395 Performs the default fixup of the arguments part of an C<entersub>
13396 op tree. This consists of applying list context to each of the
13397 argument ops. This is the standard treatment used on a call marked
13398 with C<&>, or a method call, or a call through a subroutine reference,
13399 or any other call where the callee can't be identified at compile time,
13400 or a call where the callee has no prototype.
13406 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13410 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13412 aop = cUNOPx(entersubop)->op_first;
13413 if (!OpHAS_SIBLING(aop))
13414 aop = cUNOPx(aop)->op_first;
13415 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13416 /* skip the extra attributes->import() call implicitly added in
13417 * something like foo(my $x : bar)
13419 if ( aop->op_type == OP_ENTERSUB
13420 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13424 op_lvalue(aop, OP_ENTERSUB);
13430 =for apidoc ck_entersub_args_proto
13432 Performs the fixup of the arguments part of an C<entersub> op tree
13433 based on a subroutine prototype. This makes various modifications to
13434 the argument ops, from applying context up to inserting C<refgen> ops,
13435 and checking the number and syntactic types of arguments, as directed by
13436 the prototype. This is the standard treatment used on a subroutine call,
13437 not marked with C<&>, where the callee can be identified at compile time
13438 and has a prototype.
13440 C<protosv> supplies the subroutine prototype to be applied to the call.
13441 It may be a normal defined scalar, of which the string value will be used.
13442 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13443 that has been cast to C<SV*>) which has a prototype. The prototype
13444 supplied, in whichever form, does not need to match the actual callee
13445 referenced by the op tree.
13447 If the argument ops disagree with the prototype, for example by having
13448 an unacceptable number of arguments, a valid op tree is returned anyway.
13449 The error is reflected in the parser state, normally resulting in a single
13450 exception at the top level of parsing which covers all the compilation
13451 errors that occurred. In the error message, the callee is referred to
13452 by the name defined by the C<namegv> parameter.
13458 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13461 const char *proto, *proto_end;
13462 OP *aop, *prev, *cvop, *parent;
13465 I32 contextclass = 0;
13466 const char *e = NULL;
13467 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13468 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13469 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13470 "flags=%lx", (unsigned long) SvFLAGS(protosv));
13471 if (SvTYPE(protosv) == SVt_PVCV)
13472 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13473 else proto = SvPV(protosv, proto_len);
13474 proto = S_strip_spaces(aTHX_ proto, &proto_len);
13475 proto_end = proto + proto_len;
13476 parent = entersubop;
13477 aop = cUNOPx(entersubop)->op_first;
13478 if (!OpHAS_SIBLING(aop)) {
13480 aop = cUNOPx(aop)->op_first;
13483 aop = OpSIBLING(aop);
13484 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13485 while (aop != cvop) {
13488 if (proto >= proto_end)
13490 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13491 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13492 SVfARG(namesv)), SvUTF8(namesv));
13502 /* _ must be at the end */
13503 if (proto[1] && !strchr(";@%", proto[1]))
13519 if ( o3->op_type != OP_UNDEF
13520 && (o3->op_type != OP_SREFGEN
13521 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13523 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13525 bad_type_gv(arg, namegv, o3,
13526 arg == 1 ? "block or sub {}" : "sub {}");
13529 /* '*' allows any scalar type, including bareword */
13532 if (o3->op_type == OP_RV2GV)
13533 goto wrapref; /* autoconvert GLOB -> GLOBref */
13534 else if (o3->op_type == OP_CONST)
13535 o3->op_private &= ~OPpCONST_STRICT;
13541 if (o3->op_type == OP_RV2AV ||
13542 o3->op_type == OP_PADAV ||
13543 o3->op_type == OP_RV2HV ||
13544 o3->op_type == OP_PADHV
13550 case '[': case ']':
13557 switch (*proto++) {
13559 if (contextclass++ == 0) {
13560 e = (char *) memchr(proto, ']', proto_end - proto);
13561 if (!e || e == proto)
13569 if (contextclass) {
13570 const char *p = proto;
13571 const char *const end = proto;
13573 while (*--p != '[')
13574 /* \[$] accepts any scalar lvalue */
13576 && Perl_op_lvalue_flags(aTHX_
13578 OP_READ, /* not entersub */
13581 bad_type_gv(arg, namegv, o3,
13582 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13587 if (o3->op_type == OP_RV2GV)
13590 bad_type_gv(arg, namegv, o3, "symbol");
13593 if (o3->op_type == OP_ENTERSUB
13594 && !(o3->op_flags & OPf_STACKED))
13597 bad_type_gv(arg, namegv, o3, "subroutine");
13600 if (o3->op_type == OP_RV2SV ||
13601 o3->op_type == OP_PADSV ||
13602 o3->op_type == OP_HELEM ||
13603 o3->op_type == OP_AELEM)
13605 if (!contextclass) {
13606 /* \$ accepts any scalar lvalue */
13607 if (Perl_op_lvalue_flags(aTHX_
13609 OP_READ, /* not entersub */
13612 bad_type_gv(arg, namegv, o3, "scalar");
13616 if (o3->op_type == OP_RV2AV ||
13617 o3->op_type == OP_PADAV)
13619 o3->op_flags &=~ OPf_PARENS;
13623 bad_type_gv(arg, namegv, o3, "array");
13626 if (o3->op_type == OP_RV2HV ||
13627 o3->op_type == OP_PADHV)
13629 o3->op_flags &=~ OPf_PARENS;
13633 bad_type_gv(arg, namegv, o3, "hash");
13636 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13638 if (contextclass && e) {
13643 default: goto oops;
13653 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13654 SVfARG(cv_name((CV *)namegv, NULL, 0)),
13659 op_lvalue(aop, OP_ENTERSUB);
13661 aop = OpSIBLING(aop);
13663 if (aop == cvop && *proto == '_') {
13664 /* generate an access to $_ */
13665 op_sibling_splice(parent, prev, 0, newDEFSVOP());
13667 if (!optional && proto_end > proto &&
13668 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13670 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13671 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13672 SVfARG(namesv)), SvUTF8(namesv));
13678 =for apidoc ck_entersub_args_proto_or_list
13680 Performs the fixup of the arguments part of an C<entersub> op tree either
13681 based on a subroutine prototype or using default list-context processing.
13682 This is the standard treatment used on a subroutine call, not marked
13683 with C<&>, where the callee can be identified at compile time.
13685 C<protosv> supplies the subroutine prototype to be applied to the call,
13686 or indicates that there is no prototype. It may be a normal scalar,
13687 in which case if it is defined then the string value will be used
13688 as a prototype, and if it is undefined then there is no prototype.
13689 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13690 that has been cast to C<SV*>), of which the prototype will be used if it
13691 has one. The prototype (or lack thereof) supplied, in whichever form,
13692 does not need to match the actual callee referenced by the op tree.
13694 If the argument ops disagree with the prototype, for example by having
13695 an unacceptable number of arguments, a valid op tree is returned anyway.
13696 The error is reflected in the parser state, normally resulting in a single
13697 exception at the top level of parsing which covers all the compilation
13698 errors that occurred. In the error message, the callee is referred to
13699 by the name defined by the C<namegv> parameter.
13705 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13706 GV *namegv, SV *protosv)
13708 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13709 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13710 return ck_entersub_args_proto(entersubop, namegv, protosv);
13712 return ck_entersub_args_list(entersubop);
13716 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13718 IV cvflags = SvIVX(protosv);
13719 int opnum = cvflags & 0xffff;
13720 OP *aop = cUNOPx(entersubop)->op_first;
13722 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13726 if (!OpHAS_SIBLING(aop))
13727 aop = cUNOPx(aop)->op_first;
13728 aop = OpSIBLING(aop);
13729 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13731 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13732 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13733 SVfARG(namesv)), SvUTF8(namesv));
13736 op_free(entersubop);
13737 switch(cvflags >> 16) {
13738 case 'F': return newSVOP(OP_CONST, 0,
13739 newSVpv(CopFILE(PL_curcop),0));
13740 case 'L': return newSVOP(
13742 Perl_newSVpvf(aTHX_
13743 "%" IVdf, (IV)CopLINE(PL_curcop)
13746 case 'P': return newSVOP(OP_CONST, 0,
13748 ? newSVhek(HvNAME_HEK(PL_curstash))
13753 NOT_REACHED; /* NOTREACHED */
13756 OP *prev, *cvop, *first, *parent;
13759 parent = entersubop;
13760 if (!OpHAS_SIBLING(aop)) {
13762 aop = cUNOPx(aop)->op_first;
13765 first = prev = aop;
13766 aop = OpSIBLING(aop);
13767 /* find last sibling */
13769 OpHAS_SIBLING(cvop);
13770 prev = cvop, cvop = OpSIBLING(cvop))
13772 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13773 /* Usually, OPf_SPECIAL on an op with no args means that it had
13774 * parens, but these have their own meaning for that flag: */
13775 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13776 && opnum != OP_DELETE && opnum != OP_EXISTS)
13777 flags |= OPf_SPECIAL;
13778 /* excise cvop from end of sibling chain */
13779 op_sibling_splice(parent, prev, 1, NULL);
13781 if (aop == cvop) aop = NULL;
13783 /* detach remaining siblings from the first sibling, then
13784 * dispose of original optree */
13787 op_sibling_splice(parent, first, -1, NULL);
13788 op_free(entersubop);
13790 if (cvflags == (OP_ENTEREVAL | (1<<16)))
13791 flags |= OPpEVAL_BYTES <<8;
13793 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13795 case OA_BASEOP_OR_UNOP:
13796 case OA_FILESTATOP:
13798 return newOP(opnum,flags); /* zero args */
13800 return newUNOP(opnum,flags,aop); /* one arg */
13801 /* too many args */
13808 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13809 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13810 SVfARG(namesv)), SvUTF8(namesv));
13812 nextop = OpSIBLING(aop);
13818 return opnum == OP_RUNCV
13819 ? newPVOP(OP_RUNCV,0,NULL)
13822 return op_convert_list(opnum,0,aop);
13825 NOT_REACHED; /* NOTREACHED */
13830 =for apidoc cv_get_call_checker_flags
13832 Retrieves the function that will be used to fix up a call to C<cv>.
13833 Specifically, the function is applied to an C<entersub> op tree for a
13834 subroutine call, not marked with C<&>, where the callee can be identified
13835 at compile time as C<cv>.
13837 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13838 for it is returned in C<*ckobj_p>, and control flags are returned in
13839 C<*ckflags_p>. The function is intended to be called in this manner:
13841 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13843 In this call, C<entersubop> is a pointer to the C<entersub> op,
13844 which may be replaced by the check function, and C<namegv> supplies
13845 the name that should be used by the check function to refer
13846 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13847 It is permitted to apply the check function in non-standard situations,
13848 such as to a call to a different subroutine or to a method call.
13850 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
13851 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13852 instead, anything that can be used as the first argument to L</cv_name>.
13853 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13854 check function requires C<namegv> to be a genuine GV.
13856 By default, the check function is
13857 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13858 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13859 flag is clear. This implements standard prototype processing. It can
13860 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13862 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13863 indicates that the caller only knows about the genuine GV version of
13864 C<namegv>, and accordingly the corresponding bit will always be set in
13865 C<*ckflags_p>, regardless of the check function's recorded requirements.
13866 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13867 indicates the caller knows about the possibility of passing something
13868 other than a GV as C<namegv>, and accordingly the corresponding bit may
13869 be either set or clear in C<*ckflags_p>, indicating the check function's
13870 recorded requirements.
13872 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13873 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13874 (for which see above). All other bits should be clear.
13876 =for apidoc cv_get_call_checker
13878 The original form of L</cv_get_call_checker_flags>, which does not return
13879 checker flags. When using a checker function returned by this function,
13880 it is only safe to call it with a genuine GV as its C<namegv> argument.
13886 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13887 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13890 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13891 PERL_UNUSED_CONTEXT;
13892 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13894 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13895 *ckobj_p = callmg->mg_obj;
13896 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13898 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13899 *ckobj_p = (SV*)cv;
13900 *ckflags_p = gflags & MGf_REQUIRE_GV;
13905 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13908 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13909 PERL_UNUSED_CONTEXT;
13910 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13915 =for apidoc cv_set_call_checker_flags
13917 Sets the function that will be used to fix up a call to C<cv>.
13918 Specifically, the function is applied to an C<entersub> op tree for a
13919 subroutine call, not marked with C<&>, where the callee can be identified
13920 at compile time as C<cv>.
13922 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13923 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13924 The function should be defined like this:
13926 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13928 It is intended to be called in this manner:
13930 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13932 In this call, C<entersubop> is a pointer to the C<entersub> op,
13933 which may be replaced by the check function, and C<namegv> supplies
13934 the name that should be used by the check function to refer
13935 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13936 It is permitted to apply the check function in non-standard situations,
13937 such as to a call to a different subroutine or to a method call.
13939 C<namegv> may not actually be a GV. For efficiency, perl may pass a
13940 CV or other SV instead. Whatever is passed can be used as the first
13941 argument to L</cv_name>. You can force perl to pass a GV by including
13942 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13944 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13945 bit currently has a defined meaning (for which see above). All other
13946 bits should be clear.
13948 The current setting for a particular CV can be retrieved by
13949 L</cv_get_call_checker_flags>.
13951 =for apidoc cv_set_call_checker
13953 The original form of L</cv_set_call_checker_flags>, which passes it the
13954 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
13955 of that flag setting is that the check function is guaranteed to get a
13956 genuine GV as its C<namegv> argument.
13962 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13964 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13965 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13969 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13970 SV *ckobj, U32 ckflags)
13972 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13973 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13974 if (SvMAGICAL((SV*)cv))
13975 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13978 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13979 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13981 if (callmg->mg_flags & MGf_REFCOUNTED) {
13982 SvREFCNT_dec(callmg->mg_obj);
13983 callmg->mg_flags &= ~MGf_REFCOUNTED;
13985 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13986 callmg->mg_obj = ckobj;
13987 if (ckobj != (SV*)cv) {
13988 SvREFCNT_inc_simple_void_NN(ckobj);
13989 callmg->mg_flags |= MGf_REFCOUNTED;
13991 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13992 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13997 S_entersub_alloc_targ(pTHX_ OP * const o)
13999 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14000 o->op_private |= OPpENTERSUB_HASTARG;
14004 Perl_ck_subr(pTHX_ OP *o)
14009 SV **const_class = NULL;
14011 PERL_ARGS_ASSERT_CK_SUBR;
14013 aop = cUNOPx(o)->op_first;
14014 if (!OpHAS_SIBLING(aop))
14015 aop = cUNOPx(aop)->op_first;
14016 aop = OpSIBLING(aop);
14017 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14018 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
14019 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
14021 o->op_private &= ~1;
14022 o->op_private |= (PL_hints & HINT_STRICT_REFS);
14023 if (PERLDB_SUB && PL_curstash != PL_debstash)
14024 o->op_private |= OPpENTERSUB_DB;
14025 switch (cvop->op_type) {
14027 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
14031 case OP_METHOD_NAMED:
14032 case OP_METHOD_SUPER:
14033 case OP_METHOD_REDIR:
14034 case OP_METHOD_REDIR_SUPER:
14035 o->op_flags |= OPf_REF;
14036 if (aop->op_type == OP_CONST) {
14037 aop->op_private &= ~OPpCONST_STRICT;
14038 const_class = &cSVOPx(aop)->op_sv;
14040 else if (aop->op_type == OP_LIST) {
14041 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
14042 if (sib && sib->op_type == OP_CONST) {
14043 sib->op_private &= ~OPpCONST_STRICT;
14044 const_class = &cSVOPx(sib)->op_sv;
14047 /* make class name a shared cow string to speedup method calls */
14048 /* constant string might be replaced with object, f.e. bigint */
14049 if (const_class && SvPOK(*const_class)) {
14051 const char* str = SvPV(*const_class, len);
14053 SV* const shared = newSVpvn_share(
14054 str, SvUTF8(*const_class)
14055 ? -(SSize_t)len : (SSize_t)len,
14058 if (SvREADONLY(*const_class))
14059 SvREADONLY_on(shared);
14060 SvREFCNT_dec(*const_class);
14061 *const_class = shared;
14068 S_entersub_alloc_targ(aTHX_ o);
14069 return ck_entersub_args_list(o);
14071 Perl_call_checker ckfun;
14074 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
14075 if (CvISXSUB(cv) || !CvROOT(cv))
14076 S_entersub_alloc_targ(aTHX_ o);
14078 /* The original call checker API guarantees that a GV will be
14079 be provided with the right name. So, if the old API was
14080 used (or the REQUIRE_GV flag was passed), we have to reify
14081 the CV’s GV, unless this is an anonymous sub. This is not
14082 ideal for lexical subs, as its stringification will include
14083 the package. But it is the best we can do. */
14084 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
14085 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
14088 else namegv = MUTABLE_GV(cv);
14089 /* After a syntax error in a lexical sub, the cv that
14090 rv2cv_op_cv returns may be a nameless stub. */
14091 if (!namegv) return ck_entersub_args_list(o);
14094 return ckfun(aTHX_ o, namegv, ckobj);
14099 Perl_ck_svconst(pTHX_ OP *o)
14101 SV * const sv = cSVOPo->op_sv;
14102 PERL_ARGS_ASSERT_CK_SVCONST;
14103 PERL_UNUSED_CONTEXT;
14104 #ifdef PERL_COPY_ON_WRITE
14105 /* Since the read-only flag may be used to protect a string buffer, we
14106 cannot do copy-on-write with existing read-only scalars that are not
14107 already copy-on-write scalars. To allow $_ = "hello" to do COW with
14108 that constant, mark the constant as COWable here, if it is not
14109 already read-only. */
14110 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
14113 # ifdef PERL_DEBUG_READONLY_COW
14123 Perl_ck_trunc(pTHX_ OP *o)
14125 PERL_ARGS_ASSERT_CK_TRUNC;
14127 if (o->op_flags & OPf_KIDS) {
14128 SVOP *kid = (SVOP*)cUNOPo->op_first;
14130 if (kid->op_type == OP_NULL)
14131 kid = (SVOP*)OpSIBLING(kid);
14132 if (kid && kid->op_type == OP_CONST &&
14133 (kid->op_private & OPpCONST_BARE) &&
14136 o->op_flags |= OPf_SPECIAL;
14137 kid->op_private &= ~OPpCONST_STRICT;
14144 Perl_ck_substr(pTHX_ OP *o)
14146 PERL_ARGS_ASSERT_CK_SUBSTR;
14149 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
14150 OP *kid = cLISTOPo->op_first;
14152 if (kid->op_type == OP_NULL)
14153 kid = OpSIBLING(kid);
14155 /* Historically, substr(delete $foo{bar},...) has been allowed
14156 with 4-arg substr. Keep it working by applying entersub
14158 op_lvalue(kid, OP_ENTERSUB);
14165 Perl_ck_tell(pTHX_ OP *o)
14167 PERL_ARGS_ASSERT_CK_TELL;
14169 if (o->op_flags & OPf_KIDS) {
14170 OP *kid = cLISTOPo->op_first;
14171 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
14172 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
14178 Perl_ck_each(pTHX_ OP *o)
14181 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
14182 const unsigned orig_type = o->op_type;
14184 PERL_ARGS_ASSERT_CK_EACH;
14187 switch (kid->op_type) {
14193 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
14194 : orig_type == OP_KEYS ? OP_AKEYS
14198 if (kid->op_private == OPpCONST_BARE
14199 || !SvROK(cSVOPx_sv(kid))
14200 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
14201 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
14206 qerror(Perl_mess(aTHX_
14207 "Experimental %s on scalar is now forbidden",
14208 PL_op_desc[orig_type]));
14210 bad_type_pv(1, "hash or array", o, kid);
14218 Perl_ck_length(pTHX_ OP *o)
14220 PERL_ARGS_ASSERT_CK_LENGTH;
14224 if (ckWARN(WARN_SYNTAX)) {
14225 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
14229 const bool hash = kid->op_type == OP_PADHV
14230 || kid->op_type == OP_RV2HV;
14231 switch (kid->op_type) {
14236 name = S_op_varname(aTHX_ kid);
14242 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14243 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
14245 SVfARG(name), hash ? "keys " : "", SVfARG(name)
14248 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14249 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14250 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
14252 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14253 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14254 "length() used on @array (did you mean \"scalar(@array)\"?)");
14264 ---------------------------------------------------------
14266 Common vars in list assignment
14268 There now follows some enums and static functions for detecting
14269 common variables in list assignments. Here is a little essay I wrote
14270 for myself when trying to get my head around this. DAPM.
14274 First some random observations:
14276 * If a lexical var is an alias of something else, e.g.
14277 for my $x ($lex, $pkg, $a[0]) {...}
14278 then the act of aliasing will increase the reference count of the SV
14280 * If a package var is an alias of something else, it may still have a
14281 reference count of 1, depending on how the alias was created, e.g.
14282 in *a = *b, $a may have a refcount of 1 since the GP is shared
14283 with a single GvSV pointer to the SV. So If it's an alias of another
14284 package var, then RC may be 1; if it's an alias of another scalar, e.g.
14285 a lexical var or an array element, then it will have RC > 1.
14287 * There are many ways to create a package alias; ultimately, XS code
14288 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
14289 run-time tracing mechanisms are unlikely to be able to catch all cases.
14291 * When the LHS is all my declarations, the same vars can't appear directly
14292 on the RHS, but they can indirectly via closures, aliasing and lvalue
14293 subs. But those techniques all involve an increase in the lexical
14294 scalar's ref count.
14296 * When the LHS is all lexical vars (but not necessarily my declarations),
14297 it is possible for the same lexicals to appear directly on the RHS, and
14298 without an increased ref count, since the stack isn't refcounted.
14299 This case can be detected at compile time by scanning for common lex
14300 vars with PL_generation.
14302 * lvalue subs defeat common var detection, but they do at least
14303 return vars with a temporary ref count increment. Also, you can't
14304 tell at compile time whether a sub call is lvalue.
14309 A: There are a few circumstances where there definitely can't be any
14312 LHS empty: () = (...);
14313 RHS empty: (....) = ();
14314 RHS contains only constants or other 'can't possibly be shared'
14315 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
14316 i.e. they only contain ops not marked as dangerous, whose children
14317 are also not dangerous;
14319 LHS contains a single scalar element: e.g. ($x) = (....); because
14320 after $x has been modified, it won't be used again on the RHS;
14321 RHS contains a single element with no aggregate on LHS: e.g.
14322 ($a,$b,$c) = ($x); again, once $a has been modified, its value
14323 won't be used again.
14325 B: If LHS are all 'my' lexical var declarations (or safe ops, which
14328 my ($a, $b, @c) = ...;
14330 Due to closure and goto tricks, these vars may already have content.
14331 For the same reason, an element on the RHS may be a lexical or package
14332 alias of one of the vars on the left, or share common elements, for
14335 my ($x,$y) = f(); # $x and $y on both sides
14336 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14341 my @a = @$ra; # elements of @a on both sides
14342 sub f { @a = 1..4; \@a }
14345 First, just consider scalar vars on LHS:
14347 RHS is safe only if (A), or in addition,
14348 * contains only lexical *scalar* vars, where neither side's
14349 lexicals have been flagged as aliases
14351 If RHS is not safe, then it's always legal to check LHS vars for
14352 RC==1, since the only RHS aliases will always be associated
14355 Note that in particular, RHS is not safe if:
14357 * it contains package scalar vars; e.g.:
14360 my ($x, $y) = (2, $x_alias);
14361 sub f { $x = 1; *x_alias = \$x; }
14363 * It contains other general elements, such as flattened or
14364 * spliced or single array or hash elements, e.g.
14367 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14371 use feature 'refaliasing';
14372 \($a[0], $a[1]) = \($y,$x);
14375 It doesn't matter if the array/hash is lexical or package.
14377 * it contains a function call that happens to be an lvalue
14378 sub which returns one or more of the above, e.g.
14389 (so a sub call on the RHS should be treated the same
14390 as having a package var on the RHS).
14392 * any other "dangerous" thing, such an op or built-in that
14393 returns one of the above, e.g. pp_preinc
14396 If RHS is not safe, what we can do however is at compile time flag
14397 that the LHS are all my declarations, and at run time check whether
14398 all the LHS have RC == 1, and if so skip the full scan.
14400 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14402 Here the issue is whether there can be elements of @a on the RHS
14403 which will get prematurely freed when @a is cleared prior to
14404 assignment. This is only a problem if the aliasing mechanism
14405 is one which doesn't increase the refcount - only if RC == 1
14406 will the RHS element be prematurely freed.
14408 Because the array/hash is being INTROed, it or its elements
14409 can't directly appear on the RHS:
14411 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14413 but can indirectly, e.g.:
14417 sub f { @a = 1..3; \@a }
14419 So if the RHS isn't safe as defined by (A), we must always
14420 mortalise and bump the ref count of any remaining RHS elements
14421 when assigning to a non-empty LHS aggregate.
14423 Lexical scalars on the RHS aren't safe if they've been involved in
14426 use feature 'refaliasing';
14429 \(my $lex) = \$pkg;
14430 my @a = ($lex,3); # equivalent to ($a[0],3)
14437 Similarly with lexical arrays and hashes on the RHS:
14451 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14452 my $a; ($a, my $b) = (....);
14454 The difference between (B) and (C) is that it is now physically
14455 possible for the LHS vars to appear on the RHS too, where they
14456 are not reference counted; but in this case, the compile-time
14457 PL_generation sweep will detect such common vars.
14459 So the rules for (C) differ from (B) in that if common vars are
14460 detected, the runtime "test RC==1" optimisation can no longer be used,
14461 and a full mark and sweep is required
14463 D: As (C), but in addition the LHS may contain package vars.
14465 Since package vars can be aliased without a corresponding refcount
14466 increase, all bets are off. It's only safe if (A). E.g.
14468 my ($x, $y) = (1,2);
14470 for $x_alias ($x) {
14471 ($x_alias, $y) = (3, $x); # whoops
14474 Ditto for LHS aggregate package vars.
14476 E: Any other dangerous ops on LHS, e.g.
14477 (f(), $a[0], @$r) = (...);
14479 this is similar to (E) in that all bets are off. In addition, it's
14480 impossible to determine at compile time whether the LHS
14481 contains a scalar or an aggregate, e.g.
14483 sub f : lvalue { @a }
14486 * ---------------------------------------------------------
14490 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14491 * that at least one of the things flagged was seen.
14495 AAS_MY_SCALAR = 0x001, /* my $scalar */
14496 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
14497 AAS_LEX_SCALAR = 0x004, /* $lexical */
14498 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
14499 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14500 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
14501 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
14502 AAS_DANGEROUS = 0x080, /* an op (other than the above)
14503 that's flagged OA_DANGEROUS */
14504 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
14505 not in any of the categories above */
14506 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
14511 /* helper function for S_aassign_scan().
14512 * check a PAD-related op for commonality and/or set its generation number.
14513 * Returns a boolean indicating whether its shared */
14516 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14518 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14519 /* lexical used in aliasing */
14523 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14525 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14532 Helper function for OPpASSIGN_COMMON* detection in rpeep().
14533 It scans the left or right hand subtree of the aassign op, and returns a
14534 set of flags indicating what sorts of things it found there.
14535 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14536 set PL_generation on lexical vars; if the latter, we see if
14537 PL_generation matches.
14538 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14539 This fn will increment it by the number seen. It's not intended to
14540 be an accurate count (especially as many ops can push a variable
14541 number of SVs onto the stack); rather it's used as to test whether there
14542 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14546 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
14549 OP *effective_top_op = o;
14553 bool top = o == effective_top_op;
14555 OP* next_kid = NULL;
14557 /* first, look for a solitary @_ on the RHS */
14560 && (o->op_flags & OPf_KIDS)
14561 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14563 OP *kid = cUNOPo->op_first;
14564 if ( ( kid->op_type == OP_PUSHMARK
14565 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14566 && ((kid = OpSIBLING(kid)))
14567 && !OpHAS_SIBLING(kid)
14568 && kid->op_type == OP_RV2AV
14569 && !(kid->op_flags & OPf_REF)
14570 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14571 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14572 && ((kid = cUNOPx(kid)->op_first))
14573 && kid->op_type == OP_GV
14574 && cGVOPx_gv(kid) == PL_defgv
14579 switch (o->op_type) {
14582 all_flags |= AAS_PKG_SCALAR;
14588 /* if !top, could be e.g. @a[0,1] */
14589 all_flags |= (top && (o->op_flags & OPf_REF))
14590 ? ((o->op_private & OPpLVAL_INTRO)
14591 ? AAS_MY_AGG : AAS_LEX_AGG)
14597 int comm = S_aassign_padcheck(aTHX_ o, rhs)
14598 ? AAS_LEX_SCALAR_COMM : 0;
14600 all_flags |= (o->op_private & OPpLVAL_INTRO)
14601 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14609 if (cUNOPx(o)->op_first->op_type != OP_GV)
14610 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
14612 /* if !top, could be e.g. @a[0,1] */
14613 else if (top && (o->op_flags & OPf_REF))
14614 all_flags |= AAS_PKG_AGG;
14616 all_flags |= AAS_DANGEROUS;
14621 if (cUNOPx(o)->op_first->op_type != OP_GV) {
14623 all_flags |= AAS_DANGEROUS; /* ${expr} */
14626 all_flags |= AAS_PKG_SCALAR; /* $pkg */
14630 if (o->op_private & OPpSPLIT_ASSIGN) {
14631 /* the assign in @a = split() has been optimised away
14632 * and the @a attached directly to the split op
14633 * Treat the array as appearing on the RHS, i.e.
14634 * ... = (@a = split)
14639 if (o->op_flags & OPf_STACKED) {
14640 /* @{expr} = split() - the array expression is tacked
14641 * on as an extra child to split - process kid */
14642 next_kid = cLISTOPo->op_last;
14646 /* ... else array is directly attached to split op */
14648 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
14649 ? ((o->op_private & OPpLVAL_INTRO)
14650 ? AAS_MY_AGG : AAS_LEX_AGG)
14655 /* other args of split can't be returned */
14656 all_flags |= AAS_SAFE_SCALAR;
14660 /* undef counts as a scalar on the RHS:
14661 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
14662 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
14666 flags = AAS_SAFE_SCALAR;
14671 /* these are all no-ops; they don't push a potentially common SV
14672 * onto the stack, so they are neither AAS_DANGEROUS nor
14673 * AAS_SAFE_SCALAR */
14676 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14681 /* these do nothing, but may have children */
14685 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14687 flags = AAS_DANGEROUS;
14691 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
14692 && (o->op_private & OPpTARGET_MY))
14695 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
14696 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14700 /* if its an unrecognised, non-dangerous op, assume that it
14701 * it the cause of at least one safe scalar */
14703 flags = AAS_SAFE_SCALAR;
14707 all_flags |= flags;
14709 /* by default, process all kids next
14710 * XXX this assumes that all other ops are "transparent" - i.e. that
14711 * they can return some of their children. While this true for e.g.
14712 * sort and grep, it's not true for e.g. map. We really need a
14713 * 'transparent' flag added to regen/opcodes
14715 if (o->op_flags & OPf_KIDS) {
14716 next_kid = cUNOPo->op_first;
14717 /* these ops do nothing but may have children; but their
14718 * children should also be treated as top-level */
14719 if ( o == effective_top_op
14720 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
14722 effective_top_op = next_kid;
14726 /* If next_kid is set, someone in the code above wanted us to process
14727 * that kid and all its remaining siblings. Otherwise, work our way
14728 * back up the tree */
14730 while (!next_kid) {
14732 return all_flags; /* at top; no parents/siblings to try */
14733 if (OpHAS_SIBLING(o)) {
14734 next_kid = o->op_sibparent;
14735 if (o == effective_top_op)
14736 effective_top_op = next_kid;
14739 if (o == effective_top_op)
14740 effective_top_op = o->op_sibparent;
14741 o = o->op_sibparent; /* try parent's next sibling */
14750 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14751 and modify the optree to make them work inplace */
14754 S_inplace_aassign(pTHX_ OP *o) {
14756 OP *modop, *modop_pushmark;
14758 OP *oleft, *oleft_pushmark;
14760 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14762 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14764 assert(cUNOPo->op_first->op_type == OP_NULL);
14765 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14766 assert(modop_pushmark->op_type == OP_PUSHMARK);
14767 modop = OpSIBLING(modop_pushmark);
14769 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14772 /* no other operation except sort/reverse */
14773 if (OpHAS_SIBLING(modop))
14776 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14777 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14779 if (modop->op_flags & OPf_STACKED) {
14780 /* skip sort subroutine/block */
14781 assert(oright->op_type == OP_NULL);
14782 oright = OpSIBLING(oright);
14785 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14786 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14787 assert(oleft_pushmark->op_type == OP_PUSHMARK);
14788 oleft = OpSIBLING(oleft_pushmark);
14790 /* Check the lhs is an array */
14792 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14793 || OpHAS_SIBLING(oleft)
14794 || (oleft->op_private & OPpLVAL_INTRO)
14798 /* Only one thing on the rhs */
14799 if (OpHAS_SIBLING(oright))
14802 /* check the array is the same on both sides */
14803 if (oleft->op_type == OP_RV2AV) {
14804 if (oright->op_type != OP_RV2AV
14805 || !cUNOPx(oright)->op_first
14806 || cUNOPx(oright)->op_first->op_type != OP_GV
14807 || cUNOPx(oleft )->op_first->op_type != OP_GV
14808 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14809 cGVOPx_gv(cUNOPx(oright)->op_first)
14813 else if (oright->op_type != OP_PADAV
14814 || oright->op_targ != oleft->op_targ
14818 /* This actually is an inplace assignment */
14820 modop->op_private |= OPpSORT_INPLACE;
14822 /* transfer MODishness etc from LHS arg to RHS arg */
14823 oright->op_flags = oleft->op_flags;
14825 /* remove the aassign op and the lhs */
14827 op_null(oleft_pushmark);
14828 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14829 op_null(cUNOPx(oleft)->op_first);
14835 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14836 * that potentially represent a series of one or more aggregate derefs
14837 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14838 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14839 * additional ops left in too).
14841 * The caller will have already verified that the first few ops in the
14842 * chain following 'start' indicate a multideref candidate, and will have
14843 * set 'orig_o' to the point further on in the chain where the first index
14844 * expression (if any) begins. 'orig_action' specifies what type of
14845 * beginning has already been determined by the ops between start..orig_o
14846 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
14848 * 'hints' contains any hints flags that need adding (currently just
14849 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14853 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14857 UNOP_AUX_item *arg_buf = NULL;
14858 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
14859 int index_skip = -1; /* don't output index arg on this action */
14861 /* similar to regex compiling, do two passes; the first pass
14862 * determines whether the op chain is convertible and calculates the
14863 * buffer size; the second pass populates the buffer and makes any
14864 * changes necessary to ops (such as moving consts to the pad on
14865 * threaded builds).
14867 * NB: for things like Coverity, note that both passes take the same
14868 * path through the logic tree (except for 'if (pass)' bits), since
14869 * both passes are following the same op_next chain; and in
14870 * particular, if it would return early on the second pass, it would
14871 * already have returned early on the first pass.
14873 for (pass = 0; pass < 2; pass++) {
14875 UV action = orig_action;
14876 OP *first_elem_op = NULL; /* first seen aelem/helem */
14877 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
14878 int action_count = 0; /* number of actions seen so far */
14879 int action_ix = 0; /* action_count % (actions per IV) */
14880 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
14881 bool is_last = FALSE; /* no more derefs to follow */
14882 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14883 UNOP_AUX_item *arg = arg_buf;
14884 UNOP_AUX_item *action_ptr = arg_buf;
14887 action_ptr->uv = 0;
14891 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14892 case MDEREF_HV_gvhv_helem:
14893 next_is_hash = TRUE;
14895 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14896 case MDEREF_AV_gvav_aelem:
14898 #ifdef USE_ITHREADS
14899 arg->pad_offset = cPADOPx(start)->op_padix;
14900 /* stop it being swiped when nulled */
14901 cPADOPx(start)->op_padix = 0;
14903 arg->sv = cSVOPx(start)->op_sv;
14904 cSVOPx(start)->op_sv = NULL;
14910 case MDEREF_HV_padhv_helem:
14911 case MDEREF_HV_padsv_vivify_rv2hv_helem:
14912 next_is_hash = TRUE;
14914 case MDEREF_AV_padav_aelem:
14915 case MDEREF_AV_padsv_vivify_rv2av_aelem:
14917 arg->pad_offset = start->op_targ;
14918 /* we skip setting op_targ = 0 for now, since the intact
14919 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14920 reset_start_targ = TRUE;
14925 case MDEREF_HV_pop_rv2hv_helem:
14926 next_is_hash = TRUE;
14928 case MDEREF_AV_pop_rv2av_aelem:
14932 NOT_REACHED; /* NOTREACHED */
14937 /* look for another (rv2av/hv; get index;
14938 * aelem/helem/exists/delele) sequence */
14943 UV index_type = MDEREF_INDEX_none;
14945 if (action_count) {
14946 /* if this is not the first lookup, consume the rv2av/hv */
14948 /* for N levels of aggregate lookup, we normally expect
14949 * that the first N-1 [ah]elem ops will be flagged as
14950 * /DEREF (so they autovivifiy if necessary), and the last
14951 * lookup op not to be.
14952 * For other things (like @{$h{k1}{k2}}) extra scope or
14953 * leave ops can appear, so abandon the effort in that
14955 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14958 /* rv2av or rv2hv sKR/1 */
14960 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14961 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14962 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14965 /* at this point, we wouldn't expect any of these
14966 * possible private flags:
14967 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14968 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14970 ASSUME(!(o->op_private &
14971 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14973 hints = (o->op_private & OPpHINT_STRICT_REFS);
14975 /* make sure the type of the previous /DEREF matches the
14976 * type of the next lookup */
14977 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14980 action = next_is_hash
14981 ? MDEREF_HV_vivify_rv2hv_helem
14982 : MDEREF_AV_vivify_rv2av_aelem;
14986 /* if this is the second pass, and we're at the depth where
14987 * previously we encountered a non-simple index expression,
14988 * stop processing the index at this point */
14989 if (action_count != index_skip) {
14991 /* look for one or more simple ops that return an array
14992 * index or hash key */
14994 switch (o->op_type) {
14996 /* it may be a lexical var index */
14997 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14998 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14999 ASSUME(!(o->op_private &
15000 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15002 if ( OP_GIMME(o,0) == G_SCALAR
15003 && !(o->op_flags & (OPf_REF|OPf_MOD))
15004 && o->op_private == 0)
15007 arg->pad_offset = o->op_targ;
15009 index_type = MDEREF_INDEX_padsv;
15015 if (next_is_hash) {
15016 /* it's a constant hash index */
15017 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
15018 /* "use constant foo => FOO; $h{+foo}" for
15019 * some weird FOO, can leave you with constants
15020 * that aren't simple strings. It's not worth
15021 * the extra hassle for those edge cases */
15026 OP * helem_op = o->op_next;
15028 ASSUME( helem_op->op_type == OP_HELEM
15029 || helem_op->op_type == OP_NULL
15031 if (helem_op->op_type == OP_HELEM) {
15032 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
15033 if ( helem_op->op_private & OPpLVAL_INTRO
15034 || rop->op_type != OP_RV2HV
15038 /* on first pass just check; on second pass
15040 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
15045 #ifdef USE_ITHREADS
15046 /* Relocate sv to the pad for thread safety */
15047 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
15048 arg->pad_offset = o->op_targ;
15051 arg->sv = cSVOPx_sv(o);
15056 /* it's a constant array index */
15058 SV *ix_sv = cSVOPo->op_sv;
15063 if ( action_count == 0
15066 && ( action == MDEREF_AV_padav_aelem
15067 || action == MDEREF_AV_gvav_aelem)
15069 maybe_aelemfast = TRUE;
15073 SvREFCNT_dec_NN(cSVOPo->op_sv);
15077 /* we've taken ownership of the SV */
15078 cSVOPo->op_sv = NULL;
15080 index_type = MDEREF_INDEX_const;
15085 /* it may be a package var index */
15087 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
15088 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
15089 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
15090 || o->op_private != 0
15095 if (kid->op_type != OP_RV2SV)
15098 ASSUME(!(kid->op_flags &
15099 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
15100 |OPf_SPECIAL|OPf_PARENS)));
15101 ASSUME(!(kid->op_private &
15103 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
15104 |OPpDEREF|OPpLVAL_INTRO)));
15105 if( (kid->op_flags &~ OPf_PARENS)
15106 != (OPf_WANT_SCALAR|OPf_KIDS)
15107 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
15112 #ifdef USE_ITHREADS
15113 arg->pad_offset = cPADOPx(o)->op_padix;
15114 /* stop it being swiped when nulled */
15115 cPADOPx(o)->op_padix = 0;
15117 arg->sv = cSVOPx(o)->op_sv;
15118 cSVOPo->op_sv = NULL;
15122 index_type = MDEREF_INDEX_gvsv;
15127 } /* action_count != index_skip */
15129 action |= index_type;
15132 /* at this point we have either:
15133 * * detected what looks like a simple index expression,
15134 * and expect the next op to be an [ah]elem, or
15135 * an nulled [ah]elem followed by a delete or exists;
15136 * * found a more complex expression, so something other
15137 * than the above follows.
15140 /* possibly an optimised away [ah]elem (where op_next is
15141 * exists or delete) */
15142 if (o->op_type == OP_NULL)
15145 /* at this point we're looking for an OP_AELEM, OP_HELEM,
15146 * OP_EXISTS or OP_DELETE */
15148 /* if a custom array/hash access checker is in scope,
15149 * abandon optimisation attempt */
15150 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
15151 && PL_check[o->op_type] != Perl_ck_null)
15153 /* similarly for customised exists and delete */
15154 if ( (o->op_type == OP_EXISTS)
15155 && PL_check[o->op_type] != Perl_ck_exists)
15157 if ( (o->op_type == OP_DELETE)
15158 && PL_check[o->op_type] != Perl_ck_delete)
15161 if ( o->op_type != OP_AELEM
15162 || (o->op_private &
15163 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
15165 maybe_aelemfast = FALSE;
15167 /* look for aelem/helem/exists/delete. If it's not the last elem
15168 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
15169 * flags; if it's the last, then it mustn't have
15170 * OPpDEREF_AV/HV, but may have lots of other flags, like
15171 * OPpLVAL_INTRO etc
15174 if ( index_type == MDEREF_INDEX_none
15175 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
15176 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
15180 /* we have aelem/helem/exists/delete with valid simple index */
15182 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
15183 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
15184 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
15186 /* This doesn't make much sense but is legal:
15187 * @{ local $x[0][0] } = 1
15188 * Since scope exit will undo the autovivification,
15189 * don't bother in the first place. The OP_LEAVE
15190 * assertion is in case there are other cases of both
15191 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
15192 * exit that would undo the local - in which case this
15193 * block of code would need rethinking.
15195 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
15197 OP *n = o->op_next;
15198 while (n && ( n->op_type == OP_NULL
15199 || n->op_type == OP_LIST
15200 || n->op_type == OP_SCALAR))
15202 assert(n && n->op_type == OP_LEAVE);
15204 o->op_private &= ~OPpDEREF;
15209 ASSUME(!(o->op_flags &
15210 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
15211 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
15213 ok = (o->op_flags &~ OPf_PARENS)
15214 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
15215 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
15217 else if (o->op_type == OP_EXISTS) {
15218 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15219 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15220 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
15221 ok = !(o->op_private & ~OPpARG1_MASK);
15223 else if (o->op_type == OP_DELETE) {
15224 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15225 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15226 ASSUME(!(o->op_private &
15227 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
15228 /* don't handle slices or 'local delete'; the latter
15229 * is fairly rare, and has a complex runtime */
15230 ok = !(o->op_private & ~OPpARG1_MASK);
15231 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
15232 /* skip handling run-tome error */
15233 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
15236 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
15237 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
15238 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
15239 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
15240 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
15241 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
15246 if (!first_elem_op)
15250 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
15255 action |= MDEREF_FLAG_last;
15259 /* at this point we have something that started
15260 * promisingly enough (with rv2av or whatever), but failed
15261 * to find a simple index followed by an
15262 * aelem/helem/exists/delete. If this is the first action,
15263 * give up; but if we've already seen at least one
15264 * aelem/helem, then keep them and add a new action with
15265 * MDEREF_INDEX_none, which causes it to do the vivify
15266 * from the end of the previous lookup, and do the deref,
15267 * but stop at that point. So $a[0][expr] will do one
15268 * av_fetch, vivify and deref, then continue executing at
15273 index_skip = action_count;
15274 action |= MDEREF_FLAG_last;
15275 if (index_type != MDEREF_INDEX_none)
15280 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
15283 /* if there's no space for the next action, create a new slot
15284 * for it *before* we start adding args for that action */
15285 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
15292 } /* while !is_last */
15300 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
15301 if (index_skip == -1) {
15302 mderef->op_flags = o->op_flags
15303 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
15304 if (o->op_type == OP_EXISTS)
15305 mderef->op_private = OPpMULTIDEREF_EXISTS;
15306 else if (o->op_type == OP_DELETE)
15307 mderef->op_private = OPpMULTIDEREF_DELETE;
15309 mderef->op_private = o->op_private
15310 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
15312 /* accumulate strictness from every level (although I don't think
15313 * they can actually vary) */
15314 mderef->op_private |= hints;
15316 /* integrate the new multideref op into the optree and the
15319 * In general an op like aelem or helem has two child
15320 * sub-trees: the aggregate expression (a_expr) and the
15321 * index expression (i_expr):
15327 * The a_expr returns an AV or HV, while the i-expr returns an
15328 * index. In general a multideref replaces most or all of a
15329 * multi-level tree, e.g.
15345 * With multideref, all the i_exprs will be simple vars or
15346 * constants, except that i_expr1 may be arbitrary in the case
15347 * of MDEREF_INDEX_none.
15349 * The bottom-most a_expr will be either:
15350 * 1) a simple var (so padXv or gv+rv2Xv);
15351 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
15352 * so a simple var with an extra rv2Xv;
15353 * 3) or an arbitrary expression.
15355 * 'start', the first op in the execution chain, will point to
15356 * 1),2): the padXv or gv op;
15357 * 3): the rv2Xv which forms the last op in the a_expr
15358 * execution chain, and the top-most op in the a_expr
15361 * For all cases, the 'start' node is no longer required,
15362 * but we can't free it since one or more external nodes
15363 * may point to it. E.g. consider
15364 * $h{foo} = $a ? $b : $c
15365 * Here, both the op_next and op_other branches of the
15366 * cond_expr point to the gv[*h] of the hash expression, so
15367 * we can't free the 'start' op.
15369 * For expr->[...], we need to save the subtree containing the
15370 * expression; for the other cases, we just need to save the
15372 * So in all cases, we null the start op and keep it around by
15373 * making it the child of the multideref op; for the expr->
15374 * case, the expr will be a subtree of the start node.
15376 * So in the simple 1,2 case the optree above changes to
15382 * ex-gv (or ex-padxv)
15384 * with the op_next chain being
15386 * -> ex-gv -> multideref -> op-following-ex-exists ->
15388 * In the 3 case, we have
15401 * -> rest-of-a_expr subtree ->
15402 * ex-rv2xv -> multideref -> op-following-ex-exists ->
15405 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15406 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15407 * multideref attached as the child, e.g.
15413 * ex-rv2av - i_expr1
15421 /* if we free this op, don't free the pad entry */
15422 if (reset_start_targ)
15423 start->op_targ = 0;
15426 /* Cut the bit we need to save out of the tree and attach to
15427 * the multideref op, then free the rest of the tree */
15429 /* find parent of node to be detached (for use by splice) */
15431 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
15432 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15434 /* there is an arbitrary expression preceding us, e.g.
15435 * expr->[..]? so we need to save the 'expr' subtree */
15436 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15437 p = cUNOPx(p)->op_first;
15438 ASSUME( start->op_type == OP_RV2AV
15439 || start->op_type == OP_RV2HV);
15442 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15443 * above for exists/delete. */
15444 while ( (p->op_flags & OPf_KIDS)
15445 && cUNOPx(p)->op_first != start
15447 p = cUNOPx(p)->op_first;
15449 ASSUME(cUNOPx(p)->op_first == start);
15451 /* detach from main tree, and re-attach under the multideref */
15452 op_sibling_splice(mderef, NULL, 0,
15453 op_sibling_splice(p, NULL, 1, NULL));
15456 start->op_next = mderef;
15458 mderef->op_next = index_skip == -1 ? o->op_next : o;
15460 /* excise and free the original tree, and replace with
15461 * the multideref op */
15462 p = op_sibling_splice(top_op, NULL, -1, mderef);
15471 Size_t size = arg - arg_buf;
15473 if (maybe_aelemfast && action_count == 1)
15476 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15477 sizeof(UNOP_AUX_item) * (size + 1));
15478 /* for dumping etc: store the length in a hidden first slot;
15479 * we set the op_aux pointer to the second slot */
15480 arg_buf->uv = size;
15483 } /* for (pass = ...) */
15486 /* See if the ops following o are such that o will always be executed in
15487 * boolean context: that is, the SV which o pushes onto the stack will
15488 * only ever be consumed by later ops via SvTRUE(sv) or similar.
15489 * If so, set a suitable private flag on o. Normally this will be
15490 * bool_flag; but see below why maybe_flag is needed too.
15492 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15493 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15494 * already be taken, so you'll have to give that op two different flags.
15496 * More explanation of 'maybe_flag' and 'safe_and' parameters.
15497 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15498 * those underlying ops) short-circuit, which means that rather than
15499 * necessarily returning a truth value, they may return the LH argument,
15500 * which may not be boolean. For example in $x = (keys %h || -1), keys
15501 * should return a key count rather than a boolean, even though its
15502 * sort-of being used in boolean context.
15504 * So we only consider such logical ops to provide boolean context to
15505 * their LH argument if they themselves are in void or boolean context.
15506 * However, sometimes the context isn't known until run-time. In this
15507 * case the op is marked with the maybe_flag flag it.
15509 * Consider the following.
15511 * sub f { ....; if (%h) { .... } }
15513 * This is actually compiled as
15515 * sub f { ....; %h && do { .... } }
15517 * Here we won't know until runtime whether the final statement (and hence
15518 * the &&) is in void context and so is safe to return a boolean value.
15519 * So mark o with maybe_flag rather than the bool_flag.
15520 * Note that there is cost associated with determining context at runtime
15521 * (e.g. a call to block_gimme()), so it may not be worth setting (at
15522 * compile time) and testing (at runtime) maybe_flag if the scalar verses
15523 * boolean costs savings are marginal.
15525 * However, we can do slightly better with && (compared to || and //):
15526 * this op only returns its LH argument when that argument is false. In
15527 * this case, as long as the op promises to return a false value which is
15528 * valid in both boolean and scalar contexts, we can mark an op consumed
15529 * by && with bool_flag rather than maybe_flag.
15530 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15531 * than &PL_sv_no for a false result in boolean context, then it's safe. An
15532 * op which promises to handle this case is indicated by setting safe_and
15537 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15542 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15544 /* OPpTARGET_MY and boolean context probably don't mix well.
15545 * If someone finds a valid use case, maybe add an extra flag to this
15546 * function which indicates its safe to do so for this op? */
15547 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
15548 && (o->op_private & OPpTARGET_MY)));
15553 switch (lop->op_type) {
15558 /* these two consume the stack argument in the scalar case,
15559 * and treat it as a boolean in the non linenumber case */
15562 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15563 || (lop->op_private & OPpFLIP_LINENUM))
15569 /* these never leave the original value on the stack */
15578 /* OR DOR and AND evaluate their arg as a boolean, but then may
15579 * leave the original scalar value on the stack when following the
15580 * op_next route. If not in void context, we need to ensure
15581 * that whatever follows consumes the arg only in boolean context
15593 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15597 else if (!(lop->op_flags & OPf_WANT)) {
15598 /* unknown context - decide at runtime */
15610 lop = lop->op_next;
15613 o->op_private |= flag;
15618 /* mechanism for deferring recursion in rpeep() */
15620 #define MAX_DEFERRED 4
15624 if (defer_ix == (MAX_DEFERRED-1)) { \
15625 OP **defer = defer_queue[defer_base]; \
15626 CALL_RPEEP(*defer); \
15627 S_prune_chain_head(defer); \
15628 defer_base = (defer_base + 1) % MAX_DEFERRED; \
15631 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15634 #define IS_AND_OP(o) (o->op_type == OP_AND)
15635 #define IS_OR_OP(o) (o->op_type == OP_OR)
15638 /* A peephole optimizer. We visit the ops in the order they're to execute.
15639 * See the comments at the top of this file for more details about when
15640 * peep() is called */
15643 Perl_rpeep(pTHX_ OP *o)
15647 OP* oldoldop = NULL;
15648 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15649 int defer_base = 0;
15652 if (!o || o->op_opt)
15655 assert(o->op_type != OP_FREED);
15659 SAVEVPTR(PL_curcop);
15660 for (;; o = o->op_next) {
15661 if (o && o->op_opt)
15664 while (defer_ix >= 0) {
15666 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15667 CALL_RPEEP(*defer);
15668 S_prune_chain_head(defer);
15675 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15676 assert(!oldoldop || oldoldop->op_next == oldop);
15677 assert(!oldop || oldop->op_next == o);
15679 /* By default, this op has now been optimised. A couple of cases below
15680 clear this again. */
15684 /* look for a series of 1 or more aggregate derefs, e.g.
15685 * $a[1]{foo}[$i]{$k}
15686 * and replace with a single OP_MULTIDEREF op.
15687 * Each index must be either a const, or a simple variable,
15689 * First, look for likely combinations of starting ops,
15690 * corresponding to (global and lexical variants of)
15692 * $r->[...] $r->{...}
15693 * (preceding expression)->[...]
15694 * (preceding expression)->{...}
15695 * and if so, call maybe_multideref() to do a full inspection
15696 * of the op chain and if appropriate, replace with an
15704 switch (o2->op_type) {
15706 /* $pkg[..] : gv[*pkg]
15707 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
15709 /* Fail if there are new op flag combinations that we're
15710 * not aware of, rather than:
15711 * * silently failing to optimise, or
15712 * * silently optimising the flag away.
15713 * If this ASSUME starts failing, examine what new flag
15714 * has been added to the op, and decide whether the
15715 * optimisation should still occur with that flag, then
15716 * update the code accordingly. This applies to all the
15717 * other ASSUMEs in the block of code too.
15719 ASSUME(!(o2->op_flags &
15720 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15721 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15725 if (o2->op_type == OP_RV2AV) {
15726 action = MDEREF_AV_gvav_aelem;
15730 if (o2->op_type == OP_RV2HV) {
15731 action = MDEREF_HV_gvhv_helem;
15735 if (o2->op_type != OP_RV2SV)
15738 /* at this point we've seen gv,rv2sv, so the only valid
15739 * construct left is $pkg->[] or $pkg->{} */
15741 ASSUME(!(o2->op_flags & OPf_STACKED));
15742 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15743 != (OPf_WANT_SCALAR|OPf_MOD))
15746 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15747 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15748 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15750 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
15751 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15755 if (o2->op_type == OP_RV2AV) {
15756 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15759 if (o2->op_type == OP_RV2HV) {
15760 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15766 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15768 ASSUME(!(o2->op_flags &
15769 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15770 if ((o2->op_flags &
15771 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15772 != (OPf_WANT_SCALAR|OPf_MOD))
15775 ASSUME(!(o2->op_private &
15776 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15777 /* skip if state or intro, or not a deref */
15778 if ( o2->op_private != OPpDEREF_AV
15779 && o2->op_private != OPpDEREF_HV)
15783 if (o2->op_type == OP_RV2AV) {
15784 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15787 if (o2->op_type == OP_RV2HV) {
15788 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15795 /* $lex[..]: padav[@lex:1,2] sR *
15796 * or $lex{..}: padhv[%lex:1,2] sR */
15797 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15798 OPf_REF|OPf_SPECIAL)));
15799 if ((o2->op_flags &
15800 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15801 != (OPf_WANT_SCALAR|OPf_REF))
15803 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15805 /* OPf_PARENS isn't currently used in this case;
15806 * if that changes, let us know! */
15807 ASSUME(!(o2->op_flags & OPf_PARENS));
15809 /* at this point, we wouldn't expect any of the remaining
15810 * possible private flags:
15811 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15812 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15814 * OPpSLICEWARNING shouldn't affect runtime
15816 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15818 action = o2->op_type == OP_PADAV
15819 ? MDEREF_AV_padav_aelem
15820 : MDEREF_HV_padhv_helem;
15822 S_maybe_multideref(aTHX_ o, o2, action, 0);
15828 action = o2->op_type == OP_RV2AV
15829 ? MDEREF_AV_pop_rv2av_aelem
15830 : MDEREF_HV_pop_rv2hv_helem;
15833 /* (expr)->[...]: rv2av sKR/1;
15834 * (expr)->{...}: rv2hv sKR/1; */
15836 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15838 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15839 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15840 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15843 /* at this point, we wouldn't expect any of these
15844 * possible private flags:
15845 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15846 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15848 ASSUME(!(o2->op_private &
15849 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15851 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15855 S_maybe_multideref(aTHX_ o, o2, action, hints);
15864 switch (o->op_type) {
15866 PL_curcop = ((COP*)o); /* for warnings */
15869 PL_curcop = ((COP*)o); /* for warnings */
15871 /* Optimise a "return ..." at the end of a sub to just be "...".
15872 * This saves 2 ops. Before:
15873 * 1 <;> nextstate(main 1 -e:1) v ->2
15874 * 4 <@> return K ->5
15875 * 2 <0> pushmark s ->3
15876 * - <1> ex-rv2sv sK/1 ->4
15877 * 3 <#> gvsv[*cat] s ->4
15880 * - <@> return K ->-
15881 * - <0> pushmark s ->2
15882 * - <1> ex-rv2sv sK/1 ->-
15883 * 2 <$> gvsv(*cat) s ->3
15886 OP *next = o->op_next;
15887 OP *sibling = OpSIBLING(o);
15888 if ( OP_TYPE_IS(next, OP_PUSHMARK)
15889 && OP_TYPE_IS(sibling, OP_RETURN)
15890 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15891 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15892 ||OP_TYPE_IS(sibling->op_next->op_next,
15894 && cUNOPx(sibling)->op_first == next
15895 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15898 /* Look through the PUSHMARK's siblings for one that
15899 * points to the RETURN */
15900 OP *top = OpSIBLING(next);
15901 while (top && top->op_next) {
15902 if (top->op_next == sibling) {
15903 top->op_next = sibling->op_next;
15904 o->op_next = next->op_next;
15907 top = OpSIBLING(top);
15912 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15914 * This latter form is then suitable for conversion into padrange
15915 * later on. Convert:
15917 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15921 * nextstate1 -> listop -> nextstate3
15923 * pushmark -> padop1 -> padop2
15925 if (o->op_next && (
15926 o->op_next->op_type == OP_PADSV
15927 || o->op_next->op_type == OP_PADAV
15928 || o->op_next->op_type == OP_PADHV
15930 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15931 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15932 && o->op_next->op_next->op_next && (
15933 o->op_next->op_next->op_next->op_type == OP_PADSV
15934 || o->op_next->op_next->op_next->op_type == OP_PADAV
15935 || o->op_next->op_next->op_next->op_type == OP_PADHV
15937 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15938 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15939 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15940 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15942 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15945 ns2 = pad1->op_next;
15946 pad2 = ns2->op_next;
15947 ns3 = pad2->op_next;
15949 /* we assume here that the op_next chain is the same as
15950 * the op_sibling chain */
15951 assert(OpSIBLING(o) == pad1);
15952 assert(OpSIBLING(pad1) == ns2);
15953 assert(OpSIBLING(ns2) == pad2);
15954 assert(OpSIBLING(pad2) == ns3);
15956 /* excise and delete ns2 */
15957 op_sibling_splice(NULL, pad1, 1, NULL);
15960 /* excise pad1 and pad2 */
15961 op_sibling_splice(NULL, o, 2, NULL);
15963 /* create new listop, with children consisting of:
15964 * a new pushmark, pad1, pad2. */
15965 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15966 newop->op_flags |= OPf_PARENS;
15967 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15969 /* insert newop between o and ns3 */
15970 op_sibling_splice(NULL, o, 0, newop);
15972 /*fixup op_next chain */
15973 newpm = cUNOPx(newop)->op_first; /* pushmark */
15974 o ->op_next = newpm;
15975 newpm->op_next = pad1;
15976 pad1 ->op_next = pad2;
15977 pad2 ->op_next = newop; /* listop */
15978 newop->op_next = ns3;
15980 /* Ensure pushmark has this flag if padops do */
15981 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15982 newpm->op_flags |= OPf_MOD;
15988 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15989 to carry two labels. For now, take the easier option, and skip
15990 this optimisation if the first NEXTSTATE has a label. */
15991 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15992 OP *nextop = o->op_next;
15993 while (nextop && nextop->op_type == OP_NULL)
15994 nextop = nextop->op_next;
15996 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15999 oldop->op_next = nextop;
16001 /* Skip (old)oldop assignment since the current oldop's
16002 op_next already points to the next op. */
16009 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
16010 if (o->op_next->op_private & OPpTARGET_MY) {
16011 if (o->op_flags & OPf_STACKED) /* chained concats */
16012 break; /* ignore_optimization */
16014 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
16015 o->op_targ = o->op_next->op_targ;
16016 o->op_next->op_targ = 0;
16017 o->op_private |= OPpTARGET_MY;
16020 op_null(o->op_next);
16024 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
16025 break; /* Scalar stub must produce undef. List stub is noop */
16029 if (o->op_targ == OP_NEXTSTATE
16030 || o->op_targ == OP_DBSTATE)
16032 PL_curcop = ((COP*)o);
16034 /* XXX: We avoid setting op_seq here to prevent later calls
16035 to rpeep() from mistakenly concluding that optimisation
16036 has already occurred. This doesn't fix the real problem,
16037 though (See 20010220.007 (#5874)). AMS 20010719 */
16038 /* op_seq functionality is now replaced by op_opt */
16046 oldop->op_next = o->op_next;
16060 convert repeat into a stub with no kids.
16062 if (o->op_next->op_type == OP_CONST
16063 || ( o->op_next->op_type == OP_PADSV
16064 && !(o->op_next->op_private & OPpLVAL_INTRO))
16065 || ( o->op_next->op_type == OP_GV
16066 && o->op_next->op_next->op_type == OP_RV2SV
16067 && !(o->op_next->op_next->op_private
16068 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
16070 const OP *kid = o->op_next->op_next;
16071 if (o->op_next->op_type == OP_GV)
16072 kid = kid->op_next;
16073 /* kid is now the ex-list. */
16074 if (kid->op_type == OP_NULL
16075 && (kid = kid->op_next)->op_type == OP_CONST
16076 /* kid is now the repeat count. */
16077 && kid->op_next->op_type == OP_REPEAT
16078 && kid->op_next->op_private & OPpREPEAT_DOLIST
16079 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
16080 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
16083 o = kid->op_next; /* repeat */
16084 oldop->op_next = o;
16085 op_free(cBINOPo->op_first);
16086 op_free(cBINOPo->op_last );
16087 o->op_flags &=~ OPf_KIDS;
16088 /* stub is a baseop; repeat is a binop */
16089 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
16090 OpTYPE_set(o, OP_STUB);
16096 /* Convert a series of PAD ops for my vars plus support into a
16097 * single padrange op. Basically
16099 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
16101 * becomes, depending on circumstances, one of
16103 * padrange ----------------------------------> (list) -> rest
16104 * padrange --------------------------------------------> rest
16106 * where all the pad indexes are sequential and of the same type
16108 * We convert the pushmark into a padrange op, then skip
16109 * any other pad ops, and possibly some trailing ops.
16110 * Note that we don't null() the skipped ops, to make it
16111 * easier for Deparse to undo this optimisation (and none of
16112 * the skipped ops are holding any resourses). It also makes
16113 * it easier for find_uninit_var(), as it can just ignore
16114 * padrange, and examine the original pad ops.
16118 OP *followop = NULL; /* the op that will follow the padrange op */
16121 PADOFFSET base = 0; /* init only to stop compiler whining */
16122 bool gvoid = 0; /* init only to stop compiler whining */
16123 bool defav = 0; /* seen (...) = @_ */
16124 bool reuse = 0; /* reuse an existing padrange op */
16126 /* look for a pushmark -> gv[_] -> rv2av */
16131 if ( p->op_type == OP_GV
16132 && cGVOPx_gv(p) == PL_defgv
16133 && (rv2av = p->op_next)
16134 && rv2av->op_type == OP_RV2AV
16135 && !(rv2av->op_flags & OPf_REF)
16136 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
16137 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
16139 q = rv2av->op_next;
16140 if (q->op_type == OP_NULL)
16142 if (q->op_type == OP_PUSHMARK) {
16152 /* scan for PAD ops */
16154 for (p = p->op_next; p; p = p->op_next) {
16155 if (p->op_type == OP_NULL)
16158 if (( p->op_type != OP_PADSV
16159 && p->op_type != OP_PADAV
16160 && p->op_type != OP_PADHV
16162 /* any private flag other than INTRO? e.g. STATE */
16163 || (p->op_private & ~OPpLVAL_INTRO)
16167 /* let $a[N] potentially be optimised into AELEMFAST_LEX
16169 if ( p->op_type == OP_PADAV
16171 && p->op_next->op_type == OP_CONST
16172 && p->op_next->op_next
16173 && p->op_next->op_next->op_type == OP_AELEM
16177 /* for 1st padop, note what type it is and the range
16178 * start; for the others, check that it's the same type
16179 * and that the targs are contiguous */
16181 intro = (p->op_private & OPpLVAL_INTRO);
16183 gvoid = OP_GIMME(p,0) == G_VOID;
16186 if ((p->op_private & OPpLVAL_INTRO) != intro)
16188 /* Note that you'd normally expect targs to be
16189 * contiguous in my($a,$b,$c), but that's not the case
16190 * when external modules start doing things, e.g.
16191 * Function::Parameters */
16192 if (p->op_targ != base + count)
16194 assert(p->op_targ == base + count);
16195 /* Either all the padops or none of the padops should
16196 be in void context. Since we only do the optimisa-
16197 tion for av/hv when the aggregate itself is pushed
16198 on to the stack (one item), there is no need to dis-
16199 tinguish list from scalar context. */
16200 if (gvoid != (OP_GIMME(p,0) == G_VOID))
16204 /* for AV, HV, only when we're not flattening */
16205 if ( p->op_type != OP_PADSV
16207 && !(p->op_flags & OPf_REF)
16211 if (count >= OPpPADRANGE_COUNTMASK)
16214 /* there's a biggest base we can fit into a
16215 * SAVEt_CLEARPADRANGE in pp_padrange.
16216 * (The sizeof() stuff will be constant-folded, and is
16217 * intended to avoid getting "comparison is always false"
16218 * compiler warnings. See the comments above
16219 * MEM_WRAP_CHECK for more explanation on why we do this
16220 * in a weird way to avoid compiler warnings.)
16223 && (8*sizeof(base) >
16224 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
16226 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
16228 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
16232 /* Success! We've got another valid pad op to optimise away */
16234 followop = p->op_next;
16237 if (count < 1 || (count == 1 && !defav))
16240 /* pp_padrange in specifically compile-time void context
16241 * skips pushing a mark and lexicals; in all other contexts
16242 * (including unknown till runtime) it pushes a mark and the
16243 * lexicals. We must be very careful then, that the ops we
16244 * optimise away would have exactly the same effect as the
16246 * In particular in void context, we can only optimise to
16247 * a padrange if we see the complete sequence
16248 * pushmark, pad*v, ...., list
16249 * which has the net effect of leaving the markstack as it
16250 * was. Not pushing onto the stack (whereas padsv does touch
16251 * the stack) makes no difference in void context.
16255 if (followop->op_type == OP_LIST
16256 && OP_GIMME(followop,0) == G_VOID
16259 followop = followop->op_next; /* skip OP_LIST */
16261 /* consolidate two successive my(...);'s */
16264 && oldoldop->op_type == OP_PADRANGE
16265 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
16266 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
16267 && !(oldoldop->op_flags & OPf_SPECIAL)
16270 assert(oldoldop->op_next == oldop);
16271 assert( oldop->op_type == OP_NEXTSTATE
16272 || oldop->op_type == OP_DBSTATE);
16273 assert(oldop->op_next == o);
16276 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
16278 /* Do not assume pad offsets for $c and $d are con-
16283 if ( oldoldop->op_targ + old_count == base
16284 && old_count < OPpPADRANGE_COUNTMASK - count) {
16285 base = oldoldop->op_targ;
16286 count += old_count;
16291 /* if there's any immediately following singleton
16292 * my var's; then swallow them and the associated
16294 * my ($a,$b); my $c; my $d;
16296 * my ($a,$b,$c,$d);
16299 while ( ((p = followop->op_next))
16300 && ( p->op_type == OP_PADSV
16301 || p->op_type == OP_PADAV
16302 || p->op_type == OP_PADHV)
16303 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
16304 && (p->op_private & OPpLVAL_INTRO) == intro
16305 && !(p->op_private & ~OPpLVAL_INTRO)
16307 && ( p->op_next->op_type == OP_NEXTSTATE
16308 || p->op_next->op_type == OP_DBSTATE)
16309 && count < OPpPADRANGE_COUNTMASK
16310 && base + count == p->op_targ
16313 followop = p->op_next;
16321 assert(oldoldop->op_type == OP_PADRANGE);
16322 oldoldop->op_next = followop;
16323 oldoldop->op_private = (intro | count);
16329 /* Convert the pushmark into a padrange.
16330 * To make Deparse easier, we guarantee that a padrange was
16331 * *always* formerly a pushmark */
16332 assert(o->op_type == OP_PUSHMARK);
16333 o->op_next = followop;
16334 OpTYPE_set(o, OP_PADRANGE);
16336 /* bit 7: INTRO; bit 6..0: count */
16337 o->op_private = (intro | count);
16338 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
16339 | gvoid * OPf_WANT_VOID
16340 | (defav ? OPf_SPECIAL : 0));
16346 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16347 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16352 /*'keys %h' in void or scalar context: skip the OP_KEYS
16353 * and perform the functionality directly in the RV2HV/PADHV
16356 if (o->op_flags & OPf_REF) {
16357 OP *k = o->op_next;
16358 U8 want = (k->op_flags & OPf_WANT);
16360 && k->op_type == OP_KEYS
16361 && ( want == OPf_WANT_VOID
16362 || want == OPf_WANT_SCALAR)
16363 && !(k->op_private & OPpMAYBE_LVSUB)
16364 && !(k->op_flags & OPf_MOD)
16366 o->op_next = k->op_next;
16367 o->op_flags &= ~(OPf_REF|OPf_WANT);
16368 o->op_flags |= want;
16369 o->op_private |= (o->op_type == OP_PADHV ?
16370 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
16371 /* for keys(%lex), hold onto the OP_KEYS's targ
16372 * since padhv doesn't have its own targ to return
16374 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16379 /* see if %h is used in boolean context */
16380 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16381 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16384 if (o->op_type != OP_PADHV)
16388 if ( o->op_type == OP_PADAV
16389 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16391 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16394 /* Skip over state($x) in void context. */
16395 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16396 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16398 oldop->op_next = o->op_next;
16399 goto redo_nextstate;
16401 if (o->op_type != OP_PADAV)
16405 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16406 OP* const pop = (o->op_type == OP_PADAV) ?
16407 o->op_next : o->op_next->op_next;
16409 if (pop && pop->op_type == OP_CONST &&
16410 ((PL_op = pop->op_next)) &&
16411 pop->op_next->op_type == OP_AELEM &&
16412 !(pop->op_next->op_private &
16413 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16414 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16417 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16418 no_bareword_allowed(pop);
16419 if (o->op_type == OP_GV)
16420 op_null(o->op_next);
16421 op_null(pop->op_next);
16423 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16424 o->op_next = pop->op_next->op_next;
16425 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16426 o->op_private = (U8)i;
16427 if (o->op_type == OP_GV) {
16430 o->op_type = OP_AELEMFAST;
16433 o->op_type = OP_AELEMFAST_LEX;
16435 if (o->op_type != OP_GV)
16439 /* Remove $foo from the op_next chain in void context. */
16441 && ( o->op_next->op_type == OP_RV2SV
16442 || o->op_next->op_type == OP_RV2AV
16443 || o->op_next->op_type == OP_RV2HV )
16444 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16445 && !(o->op_next->op_private & OPpLVAL_INTRO))
16447 oldop->op_next = o->op_next->op_next;
16448 /* Reprocess the previous op if it is a nextstate, to
16449 allow double-nextstate optimisation. */
16451 if (oldop->op_type == OP_NEXTSTATE) {
16458 o = oldop->op_next;
16461 else if (o->op_next->op_type == OP_RV2SV) {
16462 if (!(o->op_next->op_private & OPpDEREF)) {
16463 op_null(o->op_next);
16464 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16466 o->op_next = o->op_next->op_next;
16467 OpTYPE_set(o, OP_GVSV);
16470 else if (o->op_next->op_type == OP_READLINE
16471 && o->op_next->op_next->op_type == OP_CONCAT
16472 && (o->op_next->op_next->op_flags & OPf_STACKED))
16474 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16475 OpTYPE_set(o, OP_RCATLINE);
16476 o->op_flags |= OPf_STACKED;
16477 op_null(o->op_next->op_next);
16478 op_null(o->op_next);
16489 while (cLOGOP->op_other->op_type == OP_NULL)
16490 cLOGOP->op_other = cLOGOP->op_other->op_next;
16491 while (o->op_next && ( o->op_type == o->op_next->op_type
16492 || o->op_next->op_type == OP_NULL))
16493 o->op_next = o->op_next->op_next;
16495 /* If we're an OR and our next is an AND in void context, we'll
16496 follow its op_other on short circuit, same for reverse.
16497 We can't do this with OP_DOR since if it's true, its return
16498 value is the underlying value which must be evaluated
16502 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16503 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16505 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16507 o->op_next = ((LOGOP*)o->op_next)->op_other;
16509 DEFER(cLOGOP->op_other);
16514 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16515 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16524 case OP_ARGDEFELEM:
16525 while (cLOGOP->op_other->op_type == OP_NULL)
16526 cLOGOP->op_other = cLOGOP->op_other->op_next;
16527 DEFER(cLOGOP->op_other);
16532 while (cLOOP->op_redoop->op_type == OP_NULL)
16533 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16534 while (cLOOP->op_nextop->op_type == OP_NULL)
16535 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16536 while (cLOOP->op_lastop->op_type == OP_NULL)
16537 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16538 /* a while(1) loop doesn't have an op_next that escapes the
16539 * loop, so we have to explicitly follow the op_lastop to
16540 * process the rest of the code */
16541 DEFER(cLOOP->op_lastop);
16545 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16546 DEFER(cLOGOPo->op_other);
16550 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16551 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16552 assert(!(cPMOP->op_pmflags & PMf_ONCE));
16553 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16554 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16555 cPMOP->op_pmstashstartu.op_pmreplstart
16556 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16557 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16563 if (o->op_flags & OPf_SPECIAL) {
16564 /* first arg is a code block */
16565 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16566 OP * kid = cUNOPx(nullop)->op_first;
16568 assert(nullop->op_type == OP_NULL);
16569 assert(kid->op_type == OP_SCOPE
16570 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16571 /* since OP_SORT doesn't have a handy op_other-style
16572 * field that can point directly to the start of the code
16573 * block, store it in the otherwise-unused op_next field
16574 * of the top-level OP_NULL. This will be quicker at
16575 * run-time, and it will also allow us to remove leading
16576 * OP_NULLs by just messing with op_nexts without
16577 * altering the basic op_first/op_sibling layout. */
16578 kid = kLISTOP->op_first;
16580 (kid->op_type == OP_NULL
16581 && ( kid->op_targ == OP_NEXTSTATE
16582 || kid->op_targ == OP_DBSTATE ))
16583 || kid->op_type == OP_STUB
16584 || kid->op_type == OP_ENTER
16585 || (PL_parser && PL_parser->error_count));
16586 nullop->op_next = kid->op_next;
16587 DEFER(nullop->op_next);
16590 /* check that RHS of sort is a single plain array */
16591 oright = cUNOPo->op_first;
16592 if (!oright || oright->op_type != OP_PUSHMARK)
16595 if (o->op_private & OPpSORT_INPLACE)
16598 /* reverse sort ... can be optimised. */
16599 if (!OpHAS_SIBLING(cUNOPo)) {
16600 /* Nothing follows us on the list. */
16601 OP * const reverse = o->op_next;
16603 if (reverse->op_type == OP_REVERSE &&
16604 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16605 OP * const pushmark = cUNOPx(reverse)->op_first;
16606 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16607 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16608 /* reverse -> pushmark -> sort */
16609 o->op_private |= OPpSORT_REVERSE;
16611 pushmark->op_next = oright->op_next;
16621 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16623 LISTOP *enter, *exlist;
16625 if (o->op_private & OPpSORT_INPLACE)
16628 enter = (LISTOP *) o->op_next;
16631 if (enter->op_type == OP_NULL) {
16632 enter = (LISTOP *) enter->op_next;
16636 /* for $a (...) will have OP_GV then OP_RV2GV here.
16637 for (...) just has an OP_GV. */
16638 if (enter->op_type == OP_GV) {
16639 gvop = (OP *) enter;
16640 enter = (LISTOP *) enter->op_next;
16643 if (enter->op_type == OP_RV2GV) {
16644 enter = (LISTOP *) enter->op_next;
16650 if (enter->op_type != OP_ENTERITER)
16653 iter = enter->op_next;
16654 if (!iter || iter->op_type != OP_ITER)
16657 expushmark = enter->op_first;
16658 if (!expushmark || expushmark->op_type != OP_NULL
16659 || expushmark->op_targ != OP_PUSHMARK)
16662 exlist = (LISTOP *) OpSIBLING(expushmark);
16663 if (!exlist || exlist->op_type != OP_NULL
16664 || exlist->op_targ != OP_LIST)
16667 if (exlist->op_last != o) {
16668 /* Mmm. Was expecting to point back to this op. */
16671 theirmark = exlist->op_first;
16672 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16675 if (OpSIBLING(theirmark) != o) {
16676 /* There's something between the mark and the reverse, eg
16677 for (1, reverse (...))
16682 ourmark = ((LISTOP *)o)->op_first;
16683 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16686 ourlast = ((LISTOP *)o)->op_last;
16687 if (!ourlast || ourlast->op_next != o)
16690 rv2av = OpSIBLING(ourmark);
16691 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16692 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16693 /* We're just reversing a single array. */
16694 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16695 enter->op_flags |= OPf_STACKED;
16698 /* We don't have control over who points to theirmark, so sacrifice
16700 theirmark->op_next = ourmark->op_next;
16701 theirmark->op_flags = ourmark->op_flags;
16702 ourlast->op_next = gvop ? gvop : (OP *) enter;
16705 enter->op_private |= OPpITER_REVERSED;
16706 iter->op_private |= OPpITER_REVERSED;
16710 o = oldop->op_next;
16712 NOT_REACHED; /* NOTREACHED */
16718 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16719 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16724 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16725 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16728 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16730 sv = newRV((SV *)PL_compcv);
16734 OpTYPE_set(o, OP_CONST);
16735 o->op_flags |= OPf_SPECIAL;
16736 cSVOPo->op_sv = sv;
16741 if (OP_GIMME(o,0) == G_VOID
16742 || ( o->op_next->op_type == OP_LINESEQ
16743 && ( o->op_next->op_next->op_type == OP_LEAVESUB
16744 || ( o->op_next->op_next->op_type == OP_RETURN
16745 && !CvLVALUE(PL_compcv)))))
16747 OP *right = cBINOP->op_first;
16766 OP *left = OpSIBLING(right);
16767 if (left->op_type == OP_SUBSTR
16768 && (left->op_private & 7) < 4) {
16770 /* cut out right */
16771 op_sibling_splice(o, NULL, 1, NULL);
16772 /* and insert it as second child of OP_SUBSTR */
16773 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16775 left->op_private |= OPpSUBSTR_REPL_FIRST;
16777 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16784 int l, r, lr, lscalars, rscalars;
16786 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16787 Note that we do this now rather than in newASSIGNOP(),
16788 since only by now are aliased lexicals flagged as such
16790 See the essay "Common vars in list assignment" above for
16791 the full details of the rationale behind all the conditions
16794 PL_generation sorcery:
16795 To detect whether there are common vars, the global var
16796 PL_generation is incremented for each assign op we scan.
16797 Then we run through all the lexical variables on the LHS,
16798 of the assignment, setting a spare slot in each of them to
16799 PL_generation. Then we scan the RHS, and if any lexicals
16800 already have that value, we know we've got commonality.
16801 Also, if the generation number is already set to
16802 PERL_INT_MAX, then the variable is involved in aliasing, so
16803 we also have potential commonality in that case.
16809 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
16812 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
16816 /* After looking for things which are *always* safe, this main
16817 * if/else chain selects primarily based on the type of the
16818 * LHS, gradually working its way down from the more dangerous
16819 * to the more restrictive and thus safer cases */
16821 if ( !l /* () = ....; */
16822 || !r /* .... = (); */
16823 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16824 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16825 || (lscalars < 2) /* ($x, undef) = ... */
16827 NOOP; /* always safe */
16829 else if (l & AAS_DANGEROUS) {
16830 /* always dangerous */
16831 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16832 o->op_private |= OPpASSIGN_COMMON_AGG;
16834 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16835 /* package vars are always dangerous - too many
16836 * aliasing possibilities */
16837 if (l & AAS_PKG_SCALAR)
16838 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16839 if (l & AAS_PKG_AGG)
16840 o->op_private |= OPpASSIGN_COMMON_AGG;
16842 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16843 |AAS_LEX_SCALAR|AAS_LEX_AGG))
16845 /* LHS contains only lexicals and safe ops */
16847 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16848 o->op_private |= OPpASSIGN_COMMON_AGG;
16850 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16851 if (lr & AAS_LEX_SCALAR_COMM)
16852 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16853 else if ( !(l & AAS_LEX_SCALAR)
16854 && (r & AAS_DEFAV))
16858 * as scalar-safe for performance reasons.
16859 * (it will still have been marked _AGG if necessary */
16862 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16863 /* if there are only lexicals on the LHS and no
16864 * common ones on the RHS, then we assume that the
16865 * only way those lexicals could also get
16866 * on the RHS is via some sort of dereffing or
16869 * ($lex, $x) = (1, $$r)
16870 * and in this case we assume the var must have
16871 * a bumped ref count. So if its ref count is 1,
16872 * it must only be on the LHS.
16874 o->op_private |= OPpASSIGN_COMMON_RC1;
16879 * may have to handle aggregate on LHS, but we can't
16880 * have common scalars. */
16883 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16885 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16886 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16891 /* see if ref() is used in boolean context */
16892 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16893 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16897 /* see if the op is used in known boolean context,
16898 * but not if OA_TARGLEX optimisation is enabled */
16899 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16900 && !(o->op_private & OPpTARGET_MY)
16902 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16906 /* see if the op is used in known boolean context */
16907 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16908 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16912 Perl_cpeep_t cpeep =
16913 XopENTRYCUSTOM(o, xop_peep);
16915 cpeep(aTHX_ o, oldop);
16920 /* did we just null the current op? If so, re-process it to handle
16921 * eliding "empty" ops from the chain */
16922 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16935 Perl_peep(pTHX_ OP *o)
16941 =head1 Custom Operators
16943 =for apidoc custom_op_xop
16944 Return the XOP structure for a given custom op. This macro should be
16945 considered internal to C<OP_NAME> and the other access macros: use them instead.
16946 This macro does call a function. Prior
16947 to 5.19.6, this was implemented as a
16954 /* use PERL_MAGIC_ext to call a function to free the xop structure when
16955 * freeing PL_custom_ops */
16958 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
16962 PERL_UNUSED_ARG(mg);
16963 xop = INT2PTR(XOP *, SvIV(sv));
16964 Safefree(xop->xop_name);
16965 Safefree(xop->xop_desc);
16971 static const MGVTBL custom_op_register_vtbl = {
16976 custom_op_register_free, /* free */
16986 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16992 static const XOP xop_null = { 0, 0, 0, 0, 0 };
16994 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16995 assert(o->op_type == OP_CUSTOM);
16997 /* This is wrong. It assumes a function pointer can be cast to IV,
16998 * which isn't guaranteed, but this is what the old custom OP code
16999 * did. In principle it should be safer to Copy the bytes of the
17000 * pointer into a PV: since the new interface is hidden behind
17001 * functions, this can be changed later if necessary. */
17002 /* Change custom_op_xop if this ever happens */
17003 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
17006 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
17008 /* See if the op isn't registered, but its name *is* registered.
17009 * That implies someone is using the pre-5.14 API,where only name and
17010 * description could be registered. If so, fake up a real
17012 * We only check for an existing name, and assume no one will have
17013 * just registered a desc */
17014 if (!he && PL_custom_op_names &&
17015 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
17020 /* XXX does all this need to be shared mem? */
17021 Newxz(xop, 1, XOP);
17022 pv = SvPV(HeVAL(he), l);
17023 XopENTRY_set(xop, xop_name, savepvn(pv, l));
17024 if (PL_custom_op_descs &&
17025 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
17027 pv = SvPV(HeVAL(he), l);
17028 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
17030 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
17031 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
17032 /* add magic to the SV so that the xop struct (pointed to by
17033 * SvIV(sv)) is freed. Normally a static xop is registered, but
17034 * for this backcompat hack, we've alloced one */
17035 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
17036 &custom_op_register_vtbl, NULL, 0);
17041 xop = (XOP *)&xop_null;
17043 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
17047 if(field == XOPe_xop_ptr) {
17050 const U32 flags = XopFLAGS(xop);
17051 if(flags & field) {
17053 case XOPe_xop_name:
17054 any.xop_name = xop->xop_name;
17056 case XOPe_xop_desc:
17057 any.xop_desc = xop->xop_desc;
17059 case XOPe_xop_class:
17060 any.xop_class = xop->xop_class;
17062 case XOPe_xop_peep:
17063 any.xop_peep = xop->xop_peep;
17066 NOT_REACHED; /* NOTREACHED */
17071 case XOPe_xop_name:
17072 any.xop_name = XOPd_xop_name;
17074 case XOPe_xop_desc:
17075 any.xop_desc = XOPd_xop_desc;
17077 case XOPe_xop_class:
17078 any.xop_class = XOPd_xop_class;
17080 case XOPe_xop_peep:
17081 any.xop_peep = XOPd_xop_peep;
17084 NOT_REACHED; /* NOTREACHED */
17089 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
17090 * op.c: In function 'Perl_custom_op_get_field':
17091 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
17092 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
17093 * expands to assert(0), which expands to ((0) ? (void)0 :
17094 * __assert(...)), and gcc doesn't know that __assert can never return. */
17100 =for apidoc custom_op_register
17101 Register a custom op. See L<perlguts/"Custom Operators">.
17107 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
17111 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
17113 /* see the comment in custom_op_xop */
17114 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
17116 if (!PL_custom_ops)
17117 PL_custom_ops = newHV();
17119 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
17120 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
17125 =for apidoc core_prototype
17127 This function assigns the prototype of the named core function to C<sv>, or
17128 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
17129 C<NULL> if the core function has no prototype. C<code> is a code as returned
17130 by C<keyword()>. It must not be equal to 0.
17136 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
17139 int i = 0, n = 0, seen_question = 0, defgv = 0;
17141 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
17142 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
17143 bool nullret = FALSE;
17145 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
17149 if (!sv) sv = sv_newmortal();
17151 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
17153 switch (code < 0 ? -code : code) {
17154 case KEY_and : case KEY_chop: case KEY_chomp:
17155 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
17156 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
17157 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
17158 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
17159 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
17160 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
17161 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
17162 case KEY_x : case KEY_xor :
17163 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
17164 case KEY_glob: retsetpvs("_;", OP_GLOB);
17165 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
17166 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
17167 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
17168 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
17169 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
17171 case KEY_evalbytes:
17172 name = "entereval"; break;
17180 while (i < MAXO) { /* The slow way. */
17181 if (strEQ(name, PL_op_name[i])
17182 || strEQ(name, PL_op_desc[i]))
17184 if (nullret) { assert(opnum); *opnum = i; return NULL; }
17191 defgv = PL_opargs[i] & OA_DEFGV;
17192 oa = PL_opargs[i] >> OASHIFT;
17194 if (oa & OA_OPTIONAL && !seen_question && (
17195 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
17200 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
17201 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
17202 /* But globs are already references (kinda) */
17203 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
17207 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
17208 && !scalar_mod_type(NULL, i)) {
17213 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
17217 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
17218 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
17219 str[n-1] = '_'; defgv = 0;
17223 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
17225 sv_setpvn(sv, str, n - 1);
17226 if (opnum) *opnum = i;
17231 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
17234 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
17235 newSVOP(OP_COREARGS,0,coreargssv);
17238 PERL_ARGS_ASSERT_CORESUB_OP;
17242 return op_append_elem(OP_LINESEQ,
17245 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
17252 o = newUNOP(OP_AVHVSWITCH,0,argop);
17253 o->op_private = opnum-OP_EACH;
17255 case OP_SELECT: /* which represents OP_SSELECT as well */
17260 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
17261 newSVOP(OP_CONST, 0, newSVuv(1))
17263 coresub_op(newSVuv((UV)OP_SSELECT), 0,
17265 coresub_op(coreargssv, 0, OP_SELECT)
17269 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
17271 return op_append_elem(
17274 opnum == OP_WANTARRAY || opnum == OP_RUNCV
17275 ? OPpOFFBYONE << 8 : 0)
17277 case OA_BASEOP_OR_UNOP:
17278 if (opnum == OP_ENTEREVAL) {
17279 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
17280 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
17282 else o = newUNOP(opnum,0,argop);
17283 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
17286 if (is_handle_constructor(o, 1))
17287 argop->op_private |= OPpCOREARGS_DEREF1;
17288 if (scalar_mod_type(NULL, opnum))
17289 argop->op_private |= OPpCOREARGS_SCALARMOD;
17293 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
17294 if (is_handle_constructor(o, 2))
17295 argop->op_private |= OPpCOREARGS_DEREF2;
17296 if (opnum == OP_SUBSTR) {
17297 o->op_private |= OPpMAYBE_LVSUB;
17306 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
17307 SV * const *new_const_svp)
17309 const char *hvname;
17310 bool is_const = !!CvCONST(old_cv);
17311 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
17313 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
17315 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
17317 /* They are 2 constant subroutines generated from
17318 the same constant. This probably means that
17319 they are really the "same" proxy subroutine
17320 instantiated in 2 places. Most likely this is
17321 when a constant is exported twice. Don't warn.
17324 (ckWARN(WARN_REDEFINE)
17326 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
17327 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
17328 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
17329 strEQ(hvname, "autouse"))
17333 && ckWARN_d(WARN_REDEFINE)
17334 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
17337 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
17339 ? "Constant subroutine %" SVf " redefined"
17340 : "Subroutine %" SVf " redefined",
17345 =head1 Hook manipulation
17347 These functions provide convenient and thread-safe means of manipulating
17354 =for apidoc wrap_op_checker
17356 Puts a C function into the chain of check functions for a specified op
17357 type. This is the preferred way to manipulate the L</PL_check> array.
17358 C<opcode> specifies which type of op is to be affected. C<new_checker>
17359 is a pointer to the C function that is to be added to that opcode's
17360 check chain, and C<old_checker_p> points to the storage location where a
17361 pointer to the next function in the chain will be stored. The value of
17362 C<new_checker> is written into the L</PL_check> array, while the value
17363 previously stored there is written to C<*old_checker_p>.
17365 L</PL_check> is global to an entire process, and a module wishing to
17366 hook op checking may find itself invoked more than once per process,
17367 typically in different threads. To handle that situation, this function
17368 is idempotent. The location C<*old_checker_p> must initially (once
17369 per process) contain a null pointer. A C variable of static duration
17370 (declared at file scope, typically also marked C<static> to give
17371 it internal linkage) will be implicitly initialised appropriately,
17372 if it does not have an explicit initialiser. This function will only
17373 actually modify the check chain if it finds C<*old_checker_p> to be null.
17374 This function is also thread safe on the small scale. It uses appropriate
17375 locking to avoid race conditions in accessing L</PL_check>.
17377 When this function is called, the function referenced by C<new_checker>
17378 must be ready to be called, except for C<*old_checker_p> being unfilled.
17379 In a threading situation, C<new_checker> may be called immediately,
17380 even before this function has returned. C<*old_checker_p> will always
17381 be appropriately set before C<new_checker> is called. If C<new_checker>
17382 decides not to do anything special with an op that it is given (which
17383 is the usual case for most uses of op check hooking), it must chain the
17384 check function referenced by C<*old_checker_p>.
17386 Taken all together, XS code to hook an op checker should typically look
17387 something like this:
17389 static Perl_check_t nxck_frob;
17390 static OP *myck_frob(pTHX_ OP *op) {
17392 op = nxck_frob(aTHX_ op);
17397 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
17399 If you want to influence compilation of calls to a specific subroutine,
17400 then use L</cv_set_call_checker_flags> rather than hooking checking of
17401 all C<entersub> ops.
17407 Perl_wrap_op_checker(pTHX_ Optype opcode,
17408 Perl_check_t new_checker, Perl_check_t *old_checker_p)
17412 PERL_UNUSED_CONTEXT;
17413 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
17414 if (*old_checker_p) return;
17415 OP_CHECK_MUTEX_LOCK;
17416 if (!*old_checker_p) {
17417 *old_checker_p = PL_check[opcode];
17418 PL_check[opcode] = new_checker;
17420 OP_CHECK_MUTEX_UNLOCK;
17425 /* Efficient sub that returns a constant scalar value. */
17427 const_sv_xsub(pTHX_ CV* cv)
17430 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17431 PERL_UNUSED_ARG(items);
17441 const_av_xsub(pTHX_ CV* cv)
17444 AV * const av = MUTABLE_AV(XSANY.any_ptr);
17452 if (SvRMAGICAL(av))
17453 Perl_croak(aTHX_ "Magical list constants are not supported");
17454 if (GIMME_V != G_ARRAY) {
17456 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17459 EXTEND(SP, AvFILLp(av)+1);
17460 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17461 XSRETURN(AvFILLp(av)+1);
17464 /* Copy an existing cop->cop_warnings field.
17465 * If it's one of the standard addresses, just re-use the address.
17466 * This is the e implementation for the DUP_WARNINGS() macro
17470 Perl_dup_warnings(pTHX_ STRLEN* warnings)
17473 STRLEN *new_warnings;
17475 if (warnings == NULL || specialWARN(warnings))
17478 size = sizeof(*warnings) + *warnings;
17480 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
17481 Copy(warnings, new_warnings, size, char);
17482 return new_warnings;
17486 * ex: set ts=8 sts=4 sw=4 et: