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 /* Used to avoid recursion through the op tree in scalarvoid() and
179 SSize_t defer_stack_alloc = 0; \
180 SSize_t defer_ix = -1; \
181 OP **defer_stack = NULL;
182 #define DEFER_OP_CLEANUP Safefree(defer_stack)
183 #define DEFERRED_OP_STEP 100
184 #define DEFER_OP(o) \
186 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
187 defer_stack_alloc += DEFERRED_OP_STEP; \
188 assert(defer_stack_alloc > 0); \
189 Renew(defer_stack, defer_stack_alloc, OP *); \
191 defer_stack[++defer_ix] = o; \
193 #define DEFER_REVERSE(count) \
197 OP **top = defer_stack + defer_ix; \
198 /* top - (cnt) + 1 isn't safe here */ \
199 OP **bottom = top - (cnt - 1); \
201 assert(bottom >= defer_stack); \
202 while (top > bottom) { \
210 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
212 /* remove any leading "empty" ops from the op_next chain whose first
213 * node's address is stored in op_p. Store the updated address of the
214 * first node in op_p.
218 S_prune_chain_head(OP** op_p)
221 && ( (*op_p)->op_type == OP_NULL
222 || (*op_p)->op_type == OP_SCOPE
223 || (*op_p)->op_type == OP_SCALAR
224 || (*op_p)->op_type == OP_LINESEQ)
226 *op_p = (*op_p)->op_next;
230 /* See the explanatory comments above struct opslab in op.h. */
232 #ifdef PERL_DEBUG_READONLY_OPS
233 # define PERL_SLAB_SIZE 128
234 # define PERL_MAX_SLAB_SIZE 4096
235 # include <sys/mman.h>
238 #ifndef PERL_SLAB_SIZE
239 # define PERL_SLAB_SIZE 64
241 #ifndef PERL_MAX_SLAB_SIZE
242 # define PERL_MAX_SLAB_SIZE 2048
245 /* rounds up to nearest pointer */
246 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
247 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
249 /* malloc a new op slab (suitable for attaching to PL_compcv) */
252 S_new_slab(pTHX_ size_t sz)
254 #ifdef PERL_DEBUG_READONLY_OPS
255 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
256 PROT_READ|PROT_WRITE,
257 MAP_ANON|MAP_PRIVATE, -1, 0);
258 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
259 (unsigned long) sz, slab));
260 if (slab == MAP_FAILED) {
261 perror("mmap failed");
264 slab->opslab_size = (U16)sz;
266 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
269 /* The context is unused in non-Windows */
272 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
276 /* requires double parens and aTHX_ */
277 #define DEBUG_S_warn(args) \
279 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
282 /* Returns a sz-sized block of memory (suitable for holding an op) from
283 * a free slot in the chain of op slabs attached to PL_compcv.
284 * Allocates a new slab if necessary.
285 * if PL_compcv isn't compiling, malloc() instead.
289 Perl_Slab_Alloc(pTHX_ size_t sz)
297 /* We only allocate ops from the slab during subroutine compilation.
298 We find the slab via PL_compcv, hence that must be non-NULL. It could
299 also be pointing to a subroutine which is now fully set up (CvROOT()
300 pointing to the top of the optree for that sub), or a subroutine
301 which isn't using the slab allocator. If our sanity checks aren't met,
302 don't use a slab, but allocate the OP directly from the heap. */
303 if (!PL_compcv || CvROOT(PL_compcv)
304 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
306 o = (OP*)PerlMemShared_calloc(1, sz);
310 /* While the subroutine is under construction, the slabs are accessed via
311 CvSTART(), to avoid needing to expand PVCV by one pointer for something
312 unneeded at runtime. Once a subroutine is constructed, the slabs are
313 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
314 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
316 if (!CvSTART(PL_compcv)) {
318 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
319 CvSLABBED_on(PL_compcv);
320 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
322 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
324 opsz = SIZE_TO_PSIZE(sz);
325 sz = opsz + OPSLOT_HEADER_P;
327 /* The slabs maintain a free list of OPs. In particular, constant folding
328 will free up OPs, so it makes sense to re-use them where possible. A
329 freed up slot is used in preference to a new allocation. */
330 if (slab->opslab_freed) {
331 OP **too = &slab->opslab_freed;
333 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
334 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
335 DEBUG_S_warn((aTHX_ "Alas! too small"));
336 o = *(too = &o->op_next);
337 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
341 Zero(o, opsz, I32 *);
347 #define INIT_OPSLOT \
348 slot->opslot_slab = slab; \
349 slot->opslot_next = slab2->opslab_first; \
350 slab2->opslab_first = slot; \
351 o = &slot->opslot_op; \
354 /* The partially-filled slab is next in the chain. */
355 slab2 = slab->opslab_next ? slab->opslab_next : slab;
356 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
357 /* Remaining space is too small. */
359 /* If we can fit a BASEOP, add it to the free chain, so as not
361 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
362 slot = &slab2->opslab_slots;
364 o->op_type = OP_FREED;
365 o->op_next = slab->opslab_freed;
366 slab->opslab_freed = o;
369 /* Create a new slab. Make this one twice as big. */
370 slot = slab2->opslab_first;
371 while (slot->opslot_next) slot = slot->opslot_next;
372 slab2 = S_new_slab(aTHX_
373 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
375 : (DIFF(slab2, slot)+1)*2);
376 slab2->opslab_next = slab->opslab_next;
377 slab->opslab_next = slab2;
379 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
381 /* Create a new op slot */
382 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
383 assert(slot >= &slab2->opslab_slots);
384 if (DIFF(&slab2->opslab_slots, slot)
385 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
386 slot = &slab2->opslab_slots;
388 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
391 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
392 assert(!o->op_moresib);
393 assert(!o->op_sibparent);
400 #ifdef PERL_DEBUG_READONLY_OPS
402 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
404 PERL_ARGS_ASSERT_SLAB_TO_RO;
406 if (slab->opslab_readonly) return;
407 slab->opslab_readonly = 1;
408 for (; slab; slab = slab->opslab_next) {
409 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
410 (unsigned long) slab->opslab_size, slab));*/
411 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
412 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
413 (unsigned long)slab->opslab_size, errno);
418 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
422 PERL_ARGS_ASSERT_SLAB_TO_RW;
424 if (!slab->opslab_readonly) return;
426 for (; slab2; slab2 = slab2->opslab_next) {
427 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
428 (unsigned long) size, slab2));*/
429 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
430 PROT_READ|PROT_WRITE)) {
431 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
432 (unsigned long)slab2->opslab_size, errno);
435 slab->opslab_readonly = 0;
439 # define Slab_to_rw(op) NOOP
442 /* This cannot possibly be right, but it was copied from the old slab
443 allocator, to which it was originally added, without explanation, in
446 # define PerlMemShared PerlMem
449 /* make freed ops die if they're inadvertently executed */
454 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
459 /* Return the block of memory used by an op to the free list of
460 * the OP slab associated with that op.
464 Perl_Slab_Free(pTHX_ void *op)
466 OP * const o = (OP *)op;
469 PERL_ARGS_ASSERT_SLAB_FREE;
472 o->op_ppaddr = S_pp_freed;
475 if (!o->op_slabbed) {
477 PerlMemShared_free(op);
482 /* If this op is already freed, our refcount will get screwy. */
483 assert(o->op_type != OP_FREED);
484 o->op_type = OP_FREED;
485 o->op_next = slab->opslab_freed;
486 slab->opslab_freed = o;
487 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
488 OpslabREFCNT_dec_padok(slab);
492 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
494 const bool havepad = !!PL_comppad;
495 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
498 PAD_SAVE_SETNULLPAD();
504 /* Free a chain of OP slabs. Should only be called after all ops contained
505 * in it have been freed. At this point, its reference count should be 1,
506 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
507 * and just directly calls opslab_free().
508 * (Note that the reference count which PL_compcv held on the slab should
509 * have been removed once compilation of the sub was complete).
515 Perl_opslab_free(pTHX_ OPSLAB *slab)
518 PERL_ARGS_ASSERT_OPSLAB_FREE;
520 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
521 assert(slab->opslab_refcnt == 1);
523 slab2 = slab->opslab_next;
525 slab->opslab_refcnt = ~(size_t)0;
527 #ifdef PERL_DEBUG_READONLY_OPS
528 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
530 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
531 perror("munmap failed");
535 PerlMemShared_free(slab);
541 /* like opslab_free(), but first calls op_free() on any ops in the slab
542 * not marked as OP_FREED
546 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
550 size_t savestack_count = 0;
552 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
556 for (slot = slab2->opslab_first;
558 slot = slot->opslot_next) {
559 if (slot->opslot_op.op_type != OP_FREED
560 && !(slot->opslot_op.op_savefree
566 assert(slot->opslot_op.op_slabbed);
567 op_free(&slot->opslot_op);
568 if (slab->opslab_refcnt == 1) goto free;
571 } while ((slab2 = slab2->opslab_next));
572 /* > 1 because the CV still holds a reference count. */
573 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
575 assert(savestack_count == slab->opslab_refcnt-1);
577 /* Remove the CV’s reference count. */
578 slab->opslab_refcnt--;
585 #ifdef PERL_DEBUG_READONLY_OPS
587 Perl_op_refcnt_inc(pTHX_ OP *o)
590 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
591 if (slab && slab->opslab_readonly) {
604 Perl_op_refcnt_dec(pTHX_ OP *o)
607 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
609 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
611 if (slab && slab->opslab_readonly) {
613 result = --o->op_targ;
616 result = --o->op_targ;
622 * In the following definition, the ", (OP*)0" is just to make the compiler
623 * think the expression is of the right type: croak actually does a Siglongjmp.
625 #define CHECKOP(type,o) \
626 ((PL_op_mask && PL_op_mask[type]) \
627 ? ( op_free((OP*)o), \
628 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
630 : PL_check[type](aTHX_ (OP*)o))
632 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
634 #define OpTYPE_set(o,type) \
636 o->op_type = (OPCODE)type; \
637 o->op_ppaddr = PL_ppaddr[type]; \
641 S_no_fh_allowed(pTHX_ OP *o)
643 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
645 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
651 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
653 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
654 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
659 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
661 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
663 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
668 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
670 PERL_ARGS_ASSERT_BAD_TYPE_PV;
672 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
673 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
676 /* remove flags var, its unused in all callers, move to to right end since gv
677 and kid are always the same */
679 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
681 SV * const namesv = cv_name((CV *)gv, NULL, 0);
682 PERL_ARGS_ASSERT_BAD_TYPE_GV;
684 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
685 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
689 S_no_bareword_allowed(pTHX_ OP *o)
691 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
693 qerror(Perl_mess(aTHX_
694 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
696 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
699 /* "register" allocation */
702 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
705 const bool is_our = (PL_parser->in_my == KEY_our);
707 PERL_ARGS_ASSERT_ALLOCMY;
709 if (flags & ~SVf_UTF8)
710 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
713 /* complain about "my $<special_var>" etc etc */
717 || ( (flags & SVf_UTF8)
718 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
719 || (name[1] == '_' && len > 2)))
721 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
723 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
724 /* diag_listed_as: Can't use global %s in "%s" */
725 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
726 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
727 PL_parser->in_my == KEY_state ? "state" : "my"));
729 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
730 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
734 /* allocate a spare slot and store the name in that slot */
736 off = pad_add_name_pvn(name, len,
737 (is_our ? padadd_OUR :
738 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
739 PL_parser->in_my_stash,
741 /* $_ is always in main::, even with our */
742 ? (PL_curstash && !memEQs(name,len,"$_")
748 /* anon sub prototypes contains state vars should always be cloned,
749 * otherwise the state var would be shared between anon subs */
751 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
752 CvCLONE_on(PL_compcv);
758 =head1 Optree Manipulation Functions
760 =for apidoc alloccopstash
762 Available only under threaded builds, this function allocates an entry in
763 C<PL_stashpad> for the stash passed to it.
770 Perl_alloccopstash(pTHX_ HV *hv)
772 PADOFFSET off = 0, o = 1;
773 bool found_slot = FALSE;
775 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
777 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
779 for (; o < PL_stashpadmax; ++o) {
780 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
781 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
782 found_slot = TRUE, off = o;
785 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
786 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
787 off = PL_stashpadmax;
788 PL_stashpadmax += 10;
791 PL_stashpad[PL_stashpadix = off] = hv;
796 /* free the body of an op without examining its contents.
797 * Always use this rather than FreeOp directly */
800 S_op_destroy(pTHX_ OP *o)
808 =for apidoc Am|void|op_free|OP *o
810 Free an op. Only use this when an op is no longer linked to from any
817 Perl_op_free(pTHX_ OP *o)
825 /* Though ops may be freed twice, freeing the op after its slab is a
827 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
828 /* During the forced freeing of ops after compilation failure, kidops
829 may be freed before their parents. */
830 if (!o || o->op_type == OP_FREED)
835 /* an op should only ever acquire op_private flags that we know about.
836 * If this fails, you may need to fix something in regen/op_private.
837 * Don't bother testing if:
838 * * the op_ppaddr doesn't match the op; someone may have
839 * overridden the op and be doing strange things with it;
840 * * we've errored, as op flags are often left in an
841 * inconsistent state then. Note that an error when
842 * compiling the main program leaves PL_parser NULL, so
843 * we can't spot faults in the main code, only
844 * evaled/required code */
846 if ( o->op_ppaddr == PL_ppaddr[o->op_type]
848 && !PL_parser->error_count)
850 assert(!(o->op_private & ~PL_op_private_valid[type]));
854 if (o->op_private & OPpREFCOUNTED) {
865 refcnt = OpREFCNT_dec(o);
868 /* Need to find and remove any pattern match ops from the list
869 we maintain for reset(). */
870 find_and_forget_pmops(o);
880 /* Call the op_free hook if it has been set. Do it now so that it's called
881 * at the right time for refcounted ops, but still before all of the kids
885 if (o->op_flags & OPf_KIDS) {
887 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
888 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
889 if (!kid || kid->op_type == OP_FREED)
890 /* During the forced freeing of ops after
891 compilation failure, kidops may be freed before
894 if (!(kid->op_flags & OPf_KIDS))
895 /* If it has no kids, just free it now */
902 type = (OPCODE)o->op_targ;
905 Slab_to_rw(OpSLAB(o));
907 /* COP* is not cleared by op_clear() so that we may track line
908 * numbers etc even after null() */
909 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
917 } while ( (o = POP_DEFERRED_OP()) );
922 /* S_op_clear_gv(): free a GV attached to an OP */
926 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
928 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
932 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
933 || o->op_type == OP_MULTIDEREF)
936 ? ((GV*)PAD_SVl(*ixp)) : NULL;
938 ? (GV*)(*svp) : NULL;
940 /* It's possible during global destruction that the GV is freed
941 before the optree. Whilst the SvREFCNT_inc is happy to bump from
942 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
943 will trigger an assertion failure, because the entry to sv_clear
944 checks that the scalar is not already freed. A check of for
945 !SvIS_FREED(gv) turns out to be invalid, because during global
946 destruction the reference count can be forced down to zero
947 (with SVf_BREAK set). In which case raising to 1 and then
948 dropping to 0 triggers cleanup before it should happen. I
949 *think* that this might actually be a general, systematic,
950 weakness of the whole idea of SVf_BREAK, in that code *is*
951 allowed to raise and lower references during global destruction,
952 so any *valid* code that happens to do this during global
953 destruction might well trigger premature cleanup. */
954 bool still_valid = gv && SvREFCNT(gv);
957 SvREFCNT_inc_simple_void(gv);
960 pad_swipe(*ixp, TRUE);
968 int try_downgrade = SvREFCNT(gv) == 2;
971 gv_try_downgrade(gv);
977 Perl_op_clear(pTHX_ OP *o)
982 PERL_ARGS_ASSERT_OP_CLEAR;
984 switch (o->op_type) {
985 case OP_NULL: /* Was holding old type, if any. */
988 case OP_ENTEREVAL: /* Was holding hints. */
989 case OP_ARGDEFELEM: /* Was holding signature index. */
993 if (!(o->op_flags & OPf_REF)
994 || (PL_check[o->op_type] != Perl_ck_ftst))
1001 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1003 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1006 case OP_METHOD_REDIR:
1007 case OP_METHOD_REDIR_SUPER:
1009 if (cMETHOPx(o)->op_rclass_targ) {
1010 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1011 cMETHOPx(o)->op_rclass_targ = 0;
1014 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1015 cMETHOPx(o)->op_rclass_sv = NULL;
1018 case OP_METHOD_NAMED:
1019 case OP_METHOD_SUPER:
1020 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1021 cMETHOPx(o)->op_u.op_meth_sv = NULL;
1024 pad_swipe(o->op_targ, 1);
1031 SvREFCNT_dec(cSVOPo->op_sv);
1032 cSVOPo->op_sv = NULL;
1035 Even if op_clear does a pad_free for the target of the op,
1036 pad_free doesn't actually remove the sv that exists in the pad;
1037 instead it lives on. This results in that it could be reused as
1038 a target later on when the pad was reallocated.
1041 pad_swipe(o->op_targ,1);
1051 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1056 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1057 && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1060 if (cPADOPo->op_padix > 0) {
1061 pad_swipe(cPADOPo->op_padix, TRUE);
1062 cPADOPo->op_padix = 0;
1065 SvREFCNT_dec(cSVOPo->op_sv);
1066 cSVOPo->op_sv = NULL;
1070 PerlMemShared_free(cPVOPo->op_pv);
1071 cPVOPo->op_pv = NULL;
1075 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1079 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1080 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1082 if (o->op_private & OPpSPLIT_LEX)
1083 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1086 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1088 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1095 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1096 op_free(cPMOPo->op_code_list);
1097 cPMOPo->op_code_list = NULL;
1098 forget_pmop(cPMOPo);
1099 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1100 /* we use the same protection as the "SAFE" version of the PM_ macros
1101 * here since sv_clean_all might release some PMOPs
1102 * after PL_regex_padav has been cleared
1103 * and the clearing of PL_regex_padav needs to
1104 * happen before sv_clean_all
1107 if(PL_regex_pad) { /* We could be in destruction */
1108 const IV offset = (cPMOPo)->op_pmoffset;
1109 ReREFCNT_dec(PM_GETRE(cPMOPo));
1110 PL_regex_pad[offset] = &PL_sv_undef;
1111 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1115 ReREFCNT_dec(PM_GETRE(cPMOPo));
1116 PM_SETRE(cPMOPo, NULL);
1122 PerlMemShared_free(cUNOP_AUXo->op_aux);
1125 case OP_MULTICONCAT:
1127 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1128 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1129 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1130 * utf8 shared strings */
1131 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1132 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1134 PerlMemShared_free(p1);
1136 PerlMemShared_free(p2);
1137 PerlMemShared_free(aux);
1143 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1144 UV actions = items->uv;
1146 bool is_hash = FALSE;
1149 switch (actions & MDEREF_ACTION_MASK) {
1152 actions = (++items)->uv;
1155 case MDEREF_HV_padhv_helem:
1158 case MDEREF_AV_padav_aelem:
1159 pad_free((++items)->pad_offset);
1162 case MDEREF_HV_gvhv_helem:
1165 case MDEREF_AV_gvav_aelem:
1167 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1169 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1173 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1176 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1178 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1180 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1182 goto do_vivify_rv2xv_elem;
1184 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1187 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1188 pad_free((++items)->pad_offset);
1189 goto do_vivify_rv2xv_elem;
1191 case MDEREF_HV_pop_rv2hv_helem:
1192 case MDEREF_HV_vivify_rv2hv_helem:
1195 do_vivify_rv2xv_elem:
1196 case MDEREF_AV_pop_rv2av_aelem:
1197 case MDEREF_AV_vivify_rv2av_aelem:
1199 switch (actions & MDEREF_INDEX_MASK) {
1200 case MDEREF_INDEX_none:
1203 case MDEREF_INDEX_const:
1207 pad_swipe((++items)->pad_offset, 1);
1209 SvREFCNT_dec((++items)->sv);
1215 case MDEREF_INDEX_padsv:
1216 pad_free((++items)->pad_offset);
1218 case MDEREF_INDEX_gvsv:
1220 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1222 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1227 if (actions & MDEREF_FLAG_last)
1240 actions >>= MDEREF_SHIFT;
1243 /* start of malloc is at op_aux[-1], where the length is
1245 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1250 if (o->op_targ > 0) {
1251 pad_free(o->op_targ);
1257 S_cop_free(pTHX_ COP* cop)
1259 PERL_ARGS_ASSERT_COP_FREE;
1262 if (! specialWARN(cop->cop_warnings))
1263 PerlMemShared_free(cop->cop_warnings);
1264 cophh_free(CopHINTHASH_get(cop));
1265 if (PL_curcop == cop)
1270 S_forget_pmop(pTHX_ PMOP *const o)
1272 HV * const pmstash = PmopSTASH(o);
1274 PERL_ARGS_ASSERT_FORGET_PMOP;
1276 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1277 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1279 PMOP **const array = (PMOP**) mg->mg_ptr;
1280 U32 count = mg->mg_len / sizeof(PMOP**);
1284 if (array[i] == o) {
1285 /* Found it. Move the entry at the end to overwrite it. */
1286 array[i] = array[--count];
1287 mg->mg_len = count * sizeof(PMOP**);
1288 /* Could realloc smaller at this point always, but probably
1289 not worth it. Probably worth free()ing if we're the
1292 Safefree(mg->mg_ptr);
1305 S_find_and_forget_pmops(pTHX_ OP *o)
1307 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1309 if (o->op_flags & OPf_KIDS) {
1310 OP *kid = cUNOPo->op_first;
1312 switch (kid->op_type) {
1317 forget_pmop((PMOP*)kid);
1319 find_and_forget_pmops(kid);
1320 kid = OpSIBLING(kid);
1326 =for apidoc Am|void|op_null|OP *o
1328 Neutralizes an op when it is no longer needed, but is still linked to from
1335 Perl_op_null(pTHX_ OP *o)
1339 PERL_ARGS_ASSERT_OP_NULL;
1341 if (o->op_type == OP_NULL)
1344 o->op_targ = o->op_type;
1345 OpTYPE_set(o, OP_NULL);
1349 Perl_op_refcnt_lock(pTHX)
1350 PERL_TSA_ACQUIRE(PL_op_mutex)
1355 PERL_UNUSED_CONTEXT;
1360 Perl_op_refcnt_unlock(pTHX)
1361 PERL_TSA_RELEASE(PL_op_mutex)
1366 PERL_UNUSED_CONTEXT;
1372 =for apidoc op_sibling_splice
1374 A general function for editing the structure of an existing chain of
1375 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1376 you to delete zero or more sequential nodes, replacing them with zero or
1377 more different nodes. Performs the necessary op_first/op_last
1378 housekeeping on the parent node and op_sibling manipulation on the
1379 children. The last deleted node will be marked as as the last node by
1380 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1382 Note that op_next is not manipulated, and nodes are not freed; that is the
1383 responsibility of the caller. It also won't create a new list op for an
1384 empty list etc; use higher-level functions like op_append_elem() for that.
1386 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1387 the splicing doesn't affect the first or last op in the chain.
1389 C<start> is the node preceding the first node to be spliced. Node(s)
1390 following it will be deleted, and ops will be inserted after it. If it is
1391 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1394 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1395 If -1 or greater than or equal to the number of remaining kids, all
1396 remaining kids are deleted.
1398 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1399 If C<NULL>, no nodes are inserted.
1401 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1406 action before after returns
1407 ------ ----- ----- -------
1410 splice(P, A, 2, X-Y-Z) | | B-C
1414 splice(P, NULL, 1, X-Y) | | A
1418 splice(P, NULL, 3, NULL) | | A-B-C
1422 splice(P, B, 0, X-Y) | | NULL
1426 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1427 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1433 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1437 OP *last_del = NULL;
1438 OP *last_ins = NULL;
1441 first = OpSIBLING(start);
1445 first = cLISTOPx(parent)->op_first;
1447 assert(del_count >= -1);
1449 if (del_count && first) {
1451 while (--del_count && OpHAS_SIBLING(last_del))
1452 last_del = OpSIBLING(last_del);
1453 rest = OpSIBLING(last_del);
1454 OpLASTSIB_set(last_del, NULL);
1461 while (OpHAS_SIBLING(last_ins))
1462 last_ins = OpSIBLING(last_ins);
1463 OpMAYBESIB_set(last_ins, rest, NULL);
1469 OpMAYBESIB_set(start, insert, NULL);
1473 cLISTOPx(parent)->op_first = insert;
1475 parent->op_flags |= OPf_KIDS;
1477 parent->op_flags &= ~OPf_KIDS;
1481 /* update op_last etc */
1488 /* ought to use OP_CLASS(parent) here, but that can't handle
1489 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1491 type = parent->op_type;
1492 if (type == OP_CUSTOM) {
1494 type = XopENTRYCUSTOM(parent, xop_class);
1497 if (type == OP_NULL)
1498 type = parent->op_targ;
1499 type = PL_opargs[type] & OA_CLASS_MASK;
1502 lastop = last_ins ? last_ins : start ? start : NULL;
1503 if ( type == OA_BINOP
1504 || type == OA_LISTOP
1508 cLISTOPx(parent)->op_last = lastop;
1511 OpLASTSIB_set(lastop, parent);
1513 return last_del ? first : NULL;
1516 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1520 =for apidoc op_parent
1522 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1528 Perl_op_parent(OP *o)
1530 PERL_ARGS_ASSERT_OP_PARENT;
1531 while (OpHAS_SIBLING(o))
1533 return o->op_sibparent;
1536 /* replace the sibling following start with a new UNOP, which becomes
1537 * the parent of the original sibling; e.g.
1539 * op_sibling_newUNOP(P, A, unop-args...)
1547 * where U is the new UNOP.
1549 * parent and start args are the same as for op_sibling_splice();
1550 * type and flags args are as newUNOP().
1552 * Returns the new UNOP.
1556 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1560 kid = op_sibling_splice(parent, start, 1, NULL);
1561 newop = newUNOP(type, flags, kid);
1562 op_sibling_splice(parent, start, 0, newop);
1567 /* lowest-level newLOGOP-style function - just allocates and populates
1568 * the struct. Higher-level stuff should be done by S_new_logop() /
1569 * newLOGOP(). This function exists mainly to avoid op_first assignment
1570 * being spread throughout this file.
1574 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1579 NewOp(1101, logop, 1, LOGOP);
1580 OpTYPE_set(logop, type);
1581 logop->op_first = first;
1582 logop->op_other = other;
1584 logop->op_flags = OPf_KIDS;
1585 while (kid && OpHAS_SIBLING(kid))
1586 kid = OpSIBLING(kid);
1588 OpLASTSIB_set(kid, (OP*)logop);
1593 /* Contextualizers */
1596 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1598 Applies a syntactic context to an op tree representing an expression.
1599 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1600 or C<G_VOID> to specify the context to apply. The modified op tree
1607 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1609 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1611 case G_SCALAR: return scalar(o);
1612 case G_ARRAY: return list(o);
1613 case G_VOID: return scalarvoid(o);
1615 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1622 =for apidoc Am|OP*|op_linklist|OP *o
1623 This function is the implementation of the L</LINKLIST> macro. It should
1624 not be called directly.
1630 Perl_op_linklist(pTHX_ OP *o)
1634 PERL_ARGS_ASSERT_OP_LINKLIST;
1639 /* establish postfix order */
1640 first = cUNOPo->op_first;
1643 o->op_next = LINKLIST(first);
1646 OP *sibl = OpSIBLING(kid);
1648 kid->op_next = LINKLIST(sibl);
1663 S_scalarkids(pTHX_ OP *o)
1665 if (o && o->op_flags & OPf_KIDS) {
1667 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1674 S_scalarboolean(pTHX_ OP *o)
1676 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1678 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1679 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1680 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1681 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1682 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1683 if (ckWARN(WARN_SYNTAX)) {
1684 const line_t oldline = CopLINE(PL_curcop);
1686 if (PL_parser && PL_parser->copline != NOLINE) {
1687 /* This ensures that warnings are reported at the first line
1688 of the conditional, not the last. */
1689 CopLINE_set(PL_curcop, PL_parser->copline);
1691 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1692 CopLINE_set(PL_curcop, oldline);
1699 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1702 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1703 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1705 const char funny = o->op_type == OP_PADAV
1706 || o->op_type == OP_RV2AV ? '@' : '%';
1707 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1709 if (cUNOPo->op_first->op_type != OP_GV
1710 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1712 return varname(gv, funny, 0, NULL, 0, subscript_type);
1715 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1720 S_op_varname(pTHX_ const OP *o)
1722 return S_op_varname_subscript(aTHX_ o, 1);
1726 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1727 { /* or not so pretty :-) */
1728 if (o->op_type == OP_CONST) {
1730 if (SvPOK(*retsv)) {
1732 *retsv = sv_newmortal();
1733 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1734 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1736 else if (!SvOK(*retsv))
1739 else *retpv = "...";
1743 S_scalar_slice_warning(pTHX_ const OP *o)
1746 const bool h = o->op_type == OP_HSLICE
1747 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1753 SV *keysv = NULL; /* just to silence compiler warnings */
1754 const char *key = NULL;
1756 if (!(o->op_private & OPpSLICEWARNING))
1758 if (PL_parser && PL_parser->error_count)
1759 /* This warning can be nonsensical when there is a syntax error. */
1762 kid = cLISTOPo->op_first;
1763 kid = OpSIBLING(kid); /* get past pushmark */
1764 /* weed out false positives: any ops that can return lists */
1765 switch (kid->op_type) {
1791 /* Don't warn if we have a nulled list either. */
1792 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1795 assert(OpSIBLING(kid));
1796 name = S_op_varname(aTHX_ OpSIBLING(kid));
1797 if (!name) /* XS module fiddling with the op tree */
1799 S_op_pretty(aTHX_ kid, &keysv, &key);
1800 assert(SvPOK(name));
1801 sv_chop(name,SvPVX(name)+1);
1803 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1804 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1805 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1807 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1808 lbrack, key, rbrack);
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%" SVf "%c better written as $%"
1814 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1815 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1819 Perl_scalar(pTHX_ OP *o)
1823 /* assumes no premature commitment */
1824 if (!o || (PL_parser && PL_parser->error_count)
1825 || (o->op_flags & OPf_WANT)
1826 || o->op_type == OP_RETURN)
1831 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1833 switch (o->op_type) {
1835 scalar(cBINOPo->op_first);
1836 if (o->op_private & OPpREPEAT_DOLIST) {
1837 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1838 assert(kid->op_type == OP_PUSHMARK);
1839 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1840 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1841 o->op_private &=~ OPpREPEAT_DOLIST;
1848 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1858 if (o->op_flags & OPf_KIDS) {
1859 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1865 kid = cLISTOPo->op_first;
1867 kid = OpSIBLING(kid);
1870 OP *sib = OpSIBLING(kid);
1871 if (sib && kid->op_type != OP_LEAVEWHEN
1872 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1873 || ( sib->op_targ != OP_NEXTSTATE
1874 && sib->op_targ != OP_DBSTATE )))
1880 PL_curcop = &PL_compiling;
1885 kid = cLISTOPo->op_first;
1888 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1893 /* Warn about scalar context */
1894 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1895 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1898 const char *key = NULL;
1900 /* This warning can be nonsensical when there is a syntax error. */
1901 if (PL_parser && PL_parser->error_count)
1904 if (!ckWARN(WARN_SYNTAX)) break;
1906 kid = cLISTOPo->op_first;
1907 kid = OpSIBLING(kid); /* get past pushmark */
1908 assert(OpSIBLING(kid));
1909 name = S_op_varname(aTHX_ OpSIBLING(kid));
1910 if (!name) /* XS module fiddling with the op tree */
1912 S_op_pretty(aTHX_ kid, &keysv, &key);
1913 assert(SvPOK(name));
1914 sv_chop(name,SvPVX(name)+1);
1916 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1917 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1918 "%%%" SVf "%c%s%c in scalar context better written "
1919 "as $%" SVf "%c%s%c",
1920 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1921 lbrack, key, rbrack);
1923 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1924 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1925 "%%%" SVf "%c%" SVf "%c in scalar context better "
1926 "written as $%" SVf "%c%" SVf "%c",
1927 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1928 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1935 Perl_scalarvoid(pTHX_ OP *arg)
1943 PERL_ARGS_ASSERT_SCALARVOID;
1947 SV *useless_sv = NULL;
1948 const char* useless = NULL;
1950 if (o->op_type == OP_NEXTSTATE
1951 || o->op_type == OP_DBSTATE
1952 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1953 || o->op_targ == OP_DBSTATE)))
1954 PL_curcop = (COP*)o; /* for warning below */
1956 /* assumes no premature commitment */
1957 want = o->op_flags & OPf_WANT;
1958 if ((want && want != OPf_WANT_SCALAR)
1959 || (PL_parser && PL_parser->error_count)
1960 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1965 if ((o->op_private & OPpTARGET_MY)
1966 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1968 /* newASSIGNOP has already applied scalar context, which we
1969 leave, as if this op is inside SASSIGN. */
1973 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1975 switch (o->op_type) {
1977 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1981 if (o->op_flags & OPf_STACKED)
1983 if (o->op_type == OP_REPEAT)
1984 scalar(cBINOPo->op_first);
1987 if ((o->op_flags & OPf_STACKED) &&
1988 !(o->op_private & OPpCONCAT_NESTED))
1992 if (o->op_private == 4)
2027 case OP_GETSOCKNAME:
2028 case OP_GETPEERNAME:
2033 case OP_GETPRIORITY:
2058 useless = OP_DESC(o);
2068 case OP_AELEMFAST_LEX:
2072 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2073 /* Otherwise it's "Useless use of grep iterator" */
2074 useless = OP_DESC(o);
2078 if (!(o->op_private & OPpSPLIT_ASSIGN))
2079 useless = OP_DESC(o);
2083 kid = cUNOPo->op_first;
2084 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2085 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2088 useless = "negative pattern binding (!~)";
2092 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2093 useless = "non-destructive substitution (s///r)";
2097 useless = "non-destructive transliteration (tr///r)";
2104 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2105 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2106 useless = "a variable";
2111 if (cSVOPo->op_private & OPpCONST_STRICT)
2112 no_bareword_allowed(o);
2114 if (ckWARN(WARN_VOID)) {
2116 /* don't warn on optimised away booleans, eg
2117 * use constant Foo, 5; Foo || print; */
2118 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2120 /* the constants 0 and 1 are permitted as they are
2121 conventionally used as dummies in constructs like
2122 1 while some_condition_with_side_effects; */
2123 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2125 else if (SvPOK(sv)) {
2126 SV * const dsv = newSVpvs("");
2128 = Perl_newSVpvf(aTHX_
2130 pv_pretty(dsv, SvPVX_const(sv),
2131 SvCUR(sv), 32, NULL, NULL,
2133 | PERL_PV_ESCAPE_NOCLEAR
2134 | PERL_PV_ESCAPE_UNI_DETECT));
2135 SvREFCNT_dec_NN(dsv);
2137 else if (SvOK(sv)) {
2138 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2141 useless = "a constant (undef)";
2144 op_null(o); /* don't execute or even remember it */
2148 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2152 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2156 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2160 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2165 UNOP *refgen, *rv2cv;
2168 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2171 rv2gv = ((BINOP *)o)->op_last;
2172 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2175 refgen = (UNOP *)((BINOP *)o)->op_first;
2177 if (!refgen || (refgen->op_type != OP_REFGEN
2178 && refgen->op_type != OP_SREFGEN))
2181 exlist = (LISTOP *)refgen->op_first;
2182 if (!exlist || exlist->op_type != OP_NULL
2183 || exlist->op_targ != OP_LIST)
2186 if (exlist->op_first->op_type != OP_PUSHMARK
2187 && exlist->op_first != exlist->op_last)
2190 rv2cv = (UNOP*)exlist->op_last;
2192 if (rv2cv->op_type != OP_RV2CV)
2195 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2196 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2197 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2199 o->op_private |= OPpASSIGN_CV_TO_GV;
2200 rv2gv->op_private |= OPpDONT_INIT_GV;
2201 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2213 kid = cLOGOPo->op_first;
2214 if (kid->op_type == OP_NOT
2215 && (kid->op_flags & OPf_KIDS)) {
2216 if (o->op_type == OP_AND) {
2217 OpTYPE_set(o, OP_OR);
2219 OpTYPE_set(o, OP_AND);
2229 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2230 if (!(kid->op_flags & OPf_KIDS))
2237 if (o->op_flags & OPf_STACKED)
2244 if (!(o->op_flags & OPf_KIDS))
2255 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2256 if (!(kid->op_flags & OPf_KIDS))
2262 /* If the first kid after pushmark is something that the padrange
2263 optimisation would reject, then null the list and the pushmark.
2265 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2266 && ( !(kid = OpSIBLING(kid))
2267 || ( kid->op_type != OP_PADSV
2268 && kid->op_type != OP_PADAV
2269 && kid->op_type != OP_PADHV)
2270 || kid->op_private & ~OPpLVAL_INTRO
2271 || !(kid = OpSIBLING(kid))
2272 || ( kid->op_type != OP_PADSV
2273 && kid->op_type != OP_PADAV
2274 && kid->op_type != OP_PADHV)
2275 || kid->op_private & ~OPpLVAL_INTRO)
2277 op_null(cUNOPo->op_first); /* NULL the pushmark */
2278 op_null(o); /* NULL the list */
2290 /* mortalise it, in case warnings are fatal. */
2291 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2292 "Useless use of %" SVf " in void context",
2293 SVfARG(sv_2mortal(useless_sv)));
2296 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2297 "Useless use of %s in void context",
2300 } while ( (o = POP_DEFERRED_OP()) );
2308 S_listkids(pTHX_ OP *o)
2310 if (o && o->op_flags & OPf_KIDS) {
2312 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2319 Perl_list(pTHX_ OP *o)
2323 /* assumes no premature commitment */
2324 if (!o || (o->op_flags & OPf_WANT)
2325 || (PL_parser && PL_parser->error_count)
2326 || o->op_type == OP_RETURN)
2331 if ((o->op_private & OPpTARGET_MY)
2332 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2334 return o; /* As if inside SASSIGN */
2337 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2339 switch (o->op_type) {
2341 list(cBINOPo->op_first);
2344 if (o->op_private & OPpREPEAT_DOLIST
2345 && !(o->op_flags & OPf_STACKED))
2347 list(cBINOPo->op_first);
2348 kid = cBINOPo->op_last;
2349 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2350 && SvIVX(kSVOP_sv) == 1)
2352 op_null(o); /* repeat */
2353 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2355 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2362 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2370 if (!(o->op_flags & OPf_KIDS))
2372 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2373 list(cBINOPo->op_first);
2374 return gen_constant_list(o);
2380 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2381 op_null(cUNOPo->op_first); /* NULL the pushmark */
2382 op_null(o); /* NULL the list */
2387 kid = cLISTOPo->op_first;
2389 kid = OpSIBLING(kid);
2392 OP *sib = OpSIBLING(kid);
2393 if (sib && kid->op_type != OP_LEAVEWHEN)
2399 PL_curcop = &PL_compiling;
2403 kid = cLISTOPo->op_first;
2410 S_scalarseq(pTHX_ OP *o)
2413 const OPCODE type = o->op_type;
2415 if (type == OP_LINESEQ || type == OP_SCOPE ||
2416 type == OP_LEAVE || type == OP_LEAVETRY)
2419 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2420 if ((sib = OpSIBLING(kid))
2421 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2422 || ( sib->op_targ != OP_NEXTSTATE
2423 && sib->op_targ != OP_DBSTATE )))
2428 PL_curcop = &PL_compiling;
2430 o->op_flags &= ~OPf_PARENS;
2431 if (PL_hints & HINT_BLOCK_SCOPE)
2432 o->op_flags |= OPf_PARENS;
2435 o = newOP(OP_STUB, 0);
2440 S_modkids(pTHX_ OP *o, I32 type)
2442 if (o && o->op_flags & OPf_KIDS) {
2444 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2445 op_lvalue(kid, type);
2451 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2452 * const fields. Also, convert CONST keys to HEK-in-SVs.
2453 * rop is the op that retrieves the hash;
2454 * key_op is the first key
2455 * real if false, only check (and possibly croak); don't update op
2459 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2465 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2467 if (rop->op_first->op_type == OP_PADSV)
2468 /* @$hash{qw(keys here)} */
2469 rop = (UNOP*)rop->op_first;
2471 /* @{$hash}{qw(keys here)} */
2472 if (rop->op_first->op_type == OP_SCOPE
2473 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2475 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2482 lexname = NULL; /* just to silence compiler warnings */
2483 fields = NULL; /* just to silence compiler warnings */
2487 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2488 SvPAD_TYPED(lexname))
2489 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2490 && isGV(*fields) && GvHV(*fields);
2492 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2494 if (key_op->op_type != OP_CONST)
2496 svp = cSVOPx_svp(key_op);
2498 /* make sure it's not a bareword under strict subs */
2499 if (key_op->op_private & OPpCONST_BARE &&
2500 key_op->op_private & OPpCONST_STRICT)
2502 no_bareword_allowed((OP*)key_op);
2505 /* Make the CONST have a shared SV */
2506 if ( !SvIsCOW_shared_hash(sv = *svp)
2507 && SvTYPE(sv) < SVt_PVMG
2513 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2514 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2515 SvREFCNT_dec_NN(sv);
2520 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2522 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2523 "in variable %" PNf " of type %" HEKf,
2524 SVfARG(*svp), PNfARG(lexname),
2525 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2530 /* info returned by S_sprintf_is_multiconcatable() */
2532 struct sprintf_ismc_info {
2533 SSize_t nargs; /* num of args to sprintf (not including the format) */
2534 char *start; /* start of raw format string */
2535 char *end; /* bytes after end of raw format string */
2536 STRLEN total_len; /* total length (in bytes) of format string, not
2537 including '%s' and half of '%%' */
2538 STRLEN variant; /* number of bytes by which total_len_p would grow
2539 if upgraded to utf8 */
2540 bool utf8; /* whether the format is utf8 */
2544 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2545 * i.e. its format argument is a const string with only '%s' and '%%'
2546 * formats, and the number of args is known, e.g.
2547 * sprintf "a=%s f=%s", $a[0], scalar(f());
2549 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2551 * If successful, the sprintf_ismc_info struct pointed to by info will be
2556 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2558 OP *pm, *constop, *kid;
2561 SSize_t nargs, nformats;
2562 STRLEN cur, total_len, variant;
2565 /* if sprintf's behaviour changes, die here so that someone
2566 * can decide whether to enhance this function or skip optimising
2567 * under those new circumstances */
2568 assert(!(o->op_flags & OPf_STACKED));
2569 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2570 assert(!(o->op_private & ~OPpARG4_MASK));
2572 pm = cUNOPo->op_first;
2573 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2575 constop = OpSIBLING(pm);
2576 if (!constop || constop->op_type != OP_CONST)
2578 sv = cSVOPx_sv(constop);
2579 if (SvMAGICAL(sv) || !SvPOK(sv))
2585 /* Scan format for %% and %s and work out how many %s there are.
2586 * Abandon if other format types are found.
2593 for (p = s; p < e; p++) {
2596 if (!UTF8_IS_INVARIANT(*p))
2602 return FALSE; /* lone % at end gives "Invalid conversion" */
2611 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2614 utf8 = cBOOL(SvUTF8(sv));
2618 /* scan args; they must all be in scalar cxt */
2621 kid = OpSIBLING(constop);
2624 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2627 kid = OpSIBLING(kid);
2630 if (nargs != nformats)
2631 return FALSE; /* e.g. sprintf("%s%s", $a); */
2634 info->nargs = nargs;
2637 info->total_len = total_len;
2638 info->variant = variant;
2646 /* S_maybe_multiconcat():
2648 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2649 * convert it (and its children) into an OP_MULTICONCAT. See the code
2650 * comments just before pp_multiconcat() for the full details of what
2651 * OP_MULTICONCAT supports.
2653 * Basically we're looking for an optree with a chain of OP_CONCATS down
2654 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2655 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2663 * STRINGIFY -- PADSV[$x]
2666 * ex-PUSHMARK -- CONCAT/S
2668 * CONCAT/S -- PADSV[$d]
2670 * CONCAT -- CONST["-"]
2672 * PADSV[$a] -- PADSV[$b]
2674 * Note that at this stage the OP_SASSIGN may have already been optimised
2675 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2679 S_maybe_multiconcat(pTHX_ OP *o)
2682 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2683 OP *topop; /* the top-most op in the concat tree (often equals o,
2684 unless there are assign/stringify ops above it */
2685 OP *parentop; /* the parent op of topop (or itself if no parent) */
2686 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2687 OP *targetop; /* the op corresponding to target=... or target.=... */
2688 OP *stringop; /* the OP_STRINGIFY op, if any */
2689 OP *nextop; /* used for recreating the op_next chain without consts */
2690 OP *kid; /* general-purpose op pointer */
2692 UNOP_AUX_item *lenp;
2693 char *const_str, *p;
2694 struct sprintf_ismc_info sprintf_info;
2696 /* store info about each arg in args[];
2697 * toparg is the highest used slot; argp is a general
2698 * pointer to args[] slots */
2700 void *p; /* initially points to const sv (or null for op);
2701 later, set to SvPV(constsv), with ... */
2702 STRLEN len; /* ... len set to SvPV(..., len) */
2703 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2707 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2710 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2711 the last-processed arg will the LHS of one,
2712 as args are processed in reverse order */
2713 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2714 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2715 U8 flags = 0; /* what will become the op_flags and ... */
2716 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2717 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2718 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2719 bool prev_was_const = FALSE; /* previous arg was a const */
2721 /* -----------------------------------------------------------------
2724 * Examine the optree non-destructively to determine whether it's
2725 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2726 * information about the optree in args[].
2736 assert( o->op_type == OP_SASSIGN
2737 || o->op_type == OP_CONCAT
2738 || o->op_type == OP_SPRINTF
2739 || o->op_type == OP_STRINGIFY);
2741 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2743 /* first see if, at the top of the tree, there is an assign,
2744 * append and/or stringify */
2746 if (topop->op_type == OP_SASSIGN) {
2748 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2750 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2752 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2755 topop = cBINOPo->op_first;
2756 targetop = OpSIBLING(topop);
2757 if (!targetop) /* probably some sort of syntax error */
2760 else if ( topop->op_type == OP_CONCAT
2761 && (topop->op_flags & OPf_STACKED)
2762 && (!(topop->op_private & OPpCONCAT_NESTED))
2767 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2768 * decide what to do about it */
2769 assert(!(o->op_private & OPpTARGET_MY));
2771 /* barf on unknown flags */
2772 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2773 private_flags |= OPpMULTICONCAT_APPEND;
2774 targetop = cBINOPo->op_first;
2776 topop = OpSIBLING(targetop);
2778 /* $x .= <FOO> gets optimised to rcatline instead */
2779 if (topop->op_type == OP_READLINE)
2784 /* Can targetop (the LHS) if it's a padsv, be be optimised
2785 * away and use OPpTARGET_MY instead?
2787 if ( (targetop->op_type == OP_PADSV)
2788 && !(targetop->op_private & OPpDEREF)
2789 && !(targetop->op_private & OPpPAD_STATE)
2790 /* we don't support 'my $x .= ...' */
2791 && ( o->op_type == OP_SASSIGN
2792 || !(targetop->op_private & OPpLVAL_INTRO))
2797 if (topop->op_type == OP_STRINGIFY) {
2798 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2802 /* barf on unknown flags */
2803 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2805 if ((topop->op_private & OPpTARGET_MY)) {
2806 if (o->op_type == OP_SASSIGN)
2807 return; /* can't have two assigns */
2811 private_flags |= OPpMULTICONCAT_STRINGIFY;
2813 topop = cBINOPx(topop)->op_first;
2814 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2815 topop = OpSIBLING(topop);
2818 if (topop->op_type == OP_SPRINTF) {
2819 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2821 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2822 nargs = sprintf_info.nargs;
2823 total_len = sprintf_info.total_len;
2824 variant = sprintf_info.variant;
2825 utf8 = sprintf_info.utf8;
2827 private_flags |= OPpMULTICONCAT_FAKE;
2829 /* we have an sprintf op rather than a concat optree.
2830 * Skip most of the code below which is associated with
2831 * processing that optree. We also skip phase 2, determining
2832 * whether its cost effective to optimise, since for sprintf,
2833 * multiconcat is *always* faster */
2836 /* note that even if the sprintf itself isn't multiconcatable,
2837 * the expression as a whole may be, e.g. in
2838 * $x .= sprintf("%d",...)
2839 * the sprintf op will be left as-is, but the concat/S op may
2840 * be upgraded to multiconcat
2843 else if (topop->op_type == OP_CONCAT) {
2844 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2847 if ((topop->op_private & OPpTARGET_MY)) {
2848 if (o->op_type == OP_SASSIGN || targmyop)
2849 return; /* can't have two assigns */
2854 /* Is it safe to convert a sassign/stringify/concat op into
2856 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
2857 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
2858 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2859 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
2860 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
2861 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2862 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
2863 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2865 /* Now scan the down the tree looking for a series of
2866 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2867 * stacked). For example this tree:
2872 * CONCAT/STACKED -- EXPR5
2874 * CONCAT/STACKED -- EXPR4
2880 * corresponds to an expression like
2882 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2884 * Record info about each EXPR in args[]: in particular, whether it is
2885 * a stringifiable OP_CONST and if so what the const sv is.
2887 * The reason why the last concat can't be STACKED is the difference
2890 * ((($a .= $a) .= $a) .= $a) .= $a
2893 * $a . $a . $a . $a . $a
2895 * The main difference between the optrees for those two constructs
2896 * is the presence of the last STACKED. As well as modifying $a,
2897 * the former sees the changed $a between each concat, so if $s is
2898 * initially 'a', the first returns 'a' x 16, while the latter returns
2899 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2909 if ( kid->op_type == OP_CONCAT
2913 k1 = cUNOPx(kid)->op_first;
2915 /* shouldn't happen except maybe after compile err? */
2919 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
2920 if (kid->op_private & OPpTARGET_MY)
2923 stacked_last = (kid->op_flags & OPf_STACKED);
2935 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
2936 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2938 /* At least two spare slots are needed to decompose both
2939 * concat args. If there are no slots left, continue to
2940 * examine the rest of the optree, but don't push new values
2941 * on args[]. If the optree as a whole is legal for conversion
2942 * (in particular that the last concat isn't STACKED), then
2943 * the first PERL_MULTICONCAT_MAXARG elements of the optree
2944 * can be converted into an OP_MULTICONCAT now, with the first
2945 * child of that op being the remainder of the optree -
2946 * which may itself later be converted to a multiconcat op
2950 /* the last arg is the rest of the optree */
2955 else if ( argop->op_type == OP_CONST
2956 && ((sv = cSVOPx_sv(argop)))
2957 /* defer stringification until runtime of 'constant'
2958 * things that might stringify variantly, e.g. the radix
2959 * point of NVs, or overloaded RVs */
2960 && (SvPOK(sv) || SvIOK(sv))
2961 && (!SvGMAGICAL(sv))
2964 utf8 |= cBOOL(SvUTF8(sv));
2967 /* this const may be demoted back to a plain arg later;
2968 * make sure we have enough arg slots left */
2970 prev_was_const = !prev_was_const;
2975 prev_was_const = FALSE;
2985 return; /* we don't support ((A.=B).=C)...) */
2987 /* look for two adjacent consts and don't fold them together:
2990 * $o->concat("a")->concat("b")
2993 * (but $o .= "a" . "b" should still fold)
2996 bool seen_nonconst = FALSE;
2997 for (argp = toparg; argp >= args; argp--) {
2998 if (argp->p == NULL) {
2999 seen_nonconst = TRUE;
3005 /* both previous and current arg were constants;
3006 * leave the current OP_CONST as-is */
3014 /* -----------------------------------------------------------------
3017 * At this point we have determined that the optree *can* be converted
3018 * into a multiconcat. Having gathered all the evidence, we now decide
3019 * whether it *should*.
3023 /* we need at least one concat action, e.g.:
3029 * otherwise we could be doing something like $x = "foo", which
3030 * if treated as as a concat, would fail to COW.
3032 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3035 /* Benchmarking seems to indicate that we gain if:
3036 * * we optimise at least two actions into a single multiconcat
3037 * (e.g concat+concat, sassign+concat);
3038 * * or if we can eliminate at least 1 OP_CONST;
3039 * * or if we can eliminate a padsv via OPpTARGET_MY
3043 /* eliminated at least one OP_CONST */
3045 /* eliminated an OP_SASSIGN */
3046 || o->op_type == OP_SASSIGN
3047 /* eliminated an OP_PADSV */
3048 || (!targmyop && is_targable)
3050 /* definitely a net gain to optimise */
3053 /* ... if not, what else? */
3055 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3056 * multiconcat is faster (due to not creating a temporary copy of
3057 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3063 && topop->op_type == OP_CONCAT
3065 PADOFFSET t = targmyop->op_targ;
3066 OP *k1 = cBINOPx(topop)->op_first;
3067 OP *k2 = cBINOPx(topop)->op_last;
3068 if ( k2->op_type == OP_PADSV
3070 && ( k1->op_type != OP_PADSV
3071 || k1->op_targ != t)
3076 /* need at least two concats */
3077 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3082 /* -----------------------------------------------------------------
3085 * At this point the optree has been verified as ok to be optimised
3086 * into an OP_MULTICONCAT. Now start changing things.
3091 /* stringify all const args and determine utf8ness */
3094 for (argp = args; argp <= toparg; argp++) {
3095 SV *sv = (SV*)argp->p;
3097 continue; /* not a const op */
3098 if (utf8 && !SvUTF8(sv))
3099 sv_utf8_upgrade_nomg(sv);
3100 argp->p = SvPV_nomg(sv, argp->len);
3101 total_len += argp->len;
3103 /* see if any strings would grow if converted to utf8 */
3105 char *p = (char*)argp->p;
3106 STRLEN len = argp->len;
3109 if (!UTF8_IS_INVARIANT(c))
3115 /* create and populate aux struct */
3119 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3120 sizeof(UNOP_AUX_item)
3122 PERL_MULTICONCAT_HEADER_SIZE
3123 + ((nargs + 1) * (variant ? 2 : 1))
3126 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3128 /* Extract all the non-const expressions from the concat tree then
3129 * dispose of the old tree, e.g. convert the tree from this:
3133 * STRINGIFY -- TARGET
3135 * ex-PUSHMARK -- CONCAT
3150 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3152 * except that if EXPRi is an OP_CONST, it's discarded.
3154 * During the conversion process, EXPR ops are stripped from the tree
3155 * and unshifted onto o. Finally, any of o's remaining original
3156 * childen are discarded and o is converted into an OP_MULTICONCAT.
3158 * In this middle of this, o may contain both: unshifted args on the
3159 * left, and some remaining original args on the right. lastkidop
3160 * is set to point to the right-most unshifted arg to delineate
3161 * between the two sets.
3166 /* create a copy of the format with the %'s removed, and record
3167 * the sizes of the const string segments in the aux struct */
3169 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3171 p = sprintf_info.start;
3174 for (; p < sprintf_info.end; p++) {
3178 (lenp++)->ssize = q - oldq;
3185 lenp->ssize = q - oldq;
3186 assert((STRLEN)(q - const_str) == total_len);
3188 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3189 * may or may not be topop) The pushmark and const ops need to be
3190 * kept in case they're an op_next entry point.
3192 lastkidop = cLISTOPx(topop)->op_last;
3193 kid = cUNOPx(topop)->op_first; /* pushmark */
3195 op_null(OpSIBLING(kid)); /* const */
3197 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3198 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3199 lastkidop->op_next = o;
3204 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3208 /* Concatenate all const strings into const_str.
3209 * Note that args[] contains the RHS args in reverse order, so
3210 * we scan args[] from top to bottom to get constant strings
3213 for (argp = toparg; argp >= args; argp--) {
3215 /* not a const op */
3216 (++lenp)->ssize = -1;
3218 STRLEN l = argp->len;
3219 Copy(argp->p, p, l, char);
3221 if (lenp->ssize == -1)
3232 for (argp = args; argp <= toparg; argp++) {
3233 /* only keep non-const args, except keep the first-in-next-chain
3234 * arg no matter what it is (but nulled if OP_CONST), because it
3235 * may be the entry point to this subtree from the previous
3238 bool last = (argp == toparg);
3241 /* set prev to the sibling *before* the arg to be cut out,
3242 * e.g. when cutting EXPR:
3247 * prev= CONCAT -- EXPR
3250 if (argp == args && kid->op_type != OP_CONCAT) {
3251 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3252 * so the expression to be cut isn't kid->op_last but
3255 /* find the op before kid */
3257 o2 = cUNOPx(parentop)->op_first;
3258 while (o2 && o2 != kid) {
3266 else if (kid == o && lastkidop)
3267 prev = last ? lastkidop : OpSIBLING(lastkidop);
3269 prev = last ? NULL : cUNOPx(kid)->op_first;
3271 if (!argp->p || last) {
3273 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3274 /* and unshift to front of o */
3275 op_sibling_splice(o, NULL, 0, aop);
3276 /* record the right-most op added to o: later we will
3277 * free anything to the right of it */
3280 aop->op_next = nextop;
3283 /* null the const at start of op_next chain */
3287 nextop = prev->op_next;
3290 /* the last two arguments are both attached to the same concat op */
3291 if (argp < toparg - 1)
3296 /* Populate the aux struct */
3298 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3299 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3300 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3301 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3302 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3304 /* if variant > 0, calculate a variant const string and lengths where
3305 * the utf8 version of the string will take 'variant' more bytes than
3309 char *p = const_str;
3310 STRLEN ulen = total_len + variant;
3311 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3312 UNOP_AUX_item *ulens = lens + (nargs + 1);
3313 char *up = (char*)PerlMemShared_malloc(ulen);
3316 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3317 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3319 for (n = 0; n < (nargs + 1); n++) {
3321 char * orig_up = up;
3322 for (i = (lens++)->ssize; i > 0; i--) {
3324 append_utf8_from_native_byte(c, (U8**)&up);
3326 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3331 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3332 * that op's first child - an ex-PUSHMARK - because the op_next of
3333 * the previous op may point to it (i.e. it's the entry point for
3338 ? op_sibling_splice(o, lastkidop, 1, NULL)
3339 : op_sibling_splice(stringop, NULL, 1, NULL);
3340 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3341 op_sibling_splice(o, NULL, 0, pmop);
3348 * target .= A.B.C...
3354 if (o->op_type == OP_SASSIGN) {
3355 /* Move the target subtree from being the last of o's children
3356 * to being the last of o's preserved children.
3357 * Note the difference between 'target = ...' and 'target .= ...':
3358 * for the former, target is executed last; for the latter,
3361 kid = OpSIBLING(lastkidop);
3362 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3363 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3364 lastkidop->op_next = kid->op_next;
3365 lastkidop = targetop;
3368 /* Move the target subtree from being the first of o's
3369 * original children to being the first of *all* o's children.
3372 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3373 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3376 /* if the RHS of .= doesn't contain a concat (e.g.
3377 * $x .= "foo"), it gets missed by the "strip ops from the
3378 * tree and add to o" loop earlier */
3379 assert(topop->op_type != OP_CONCAT);
3381 /* in e.g. $x .= "$y", move the $y expression
3382 * from being a child of OP_STRINGIFY to being the
3383 * second child of the OP_CONCAT
3385 assert(cUNOPx(stringop)->op_first == topop);
3386 op_sibling_splice(stringop, NULL, 1, NULL);
3387 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3389 assert(topop == OpSIBLING(cBINOPo->op_first));
3398 * my $lex = A.B.C...
3401 * The original padsv op is kept but nulled in case it's the
3402 * entry point for the optree (which it will be for
3405 private_flags |= OPpTARGET_MY;
3406 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3407 o->op_targ = targetop->op_targ;
3408 targetop->op_targ = 0;
3412 flags |= OPf_STACKED;
3414 else if (targmyop) {
3415 private_flags |= OPpTARGET_MY;
3416 if (o != targmyop) {
3417 o->op_targ = targmyop->op_targ;
3418 targmyop->op_targ = 0;
3422 /* detach the emaciated husk of the sprintf/concat optree and free it */
3424 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3430 /* and convert o into a multiconcat */
3432 o->op_flags = (flags|OPf_KIDS|stacked_last
3433 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3434 o->op_private = private_flags;
3435 o->op_type = OP_MULTICONCAT;
3436 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3437 cUNOP_AUXo->op_aux = aux;
3441 /* do all the final processing on an optree (e.g. running the peephole
3442 * optimiser on it), then attach it to cv (if cv is non-null)
3446 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3450 /* XXX for some reason, evals, require and main optrees are
3451 * never attached to their CV; instead they just hang off
3452 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3453 * and get manually freed when appropriate */
3455 startp = &CvSTART(cv);
3457 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3460 optree->op_private |= OPpREFCOUNTED;
3461 OpREFCNT_set(optree, 1);
3462 optimize_optree(optree);
3464 finalize_optree(optree);
3465 S_prune_chain_head(startp);
3468 /* now that optimizer has done its work, adjust pad values */
3469 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3470 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3476 =for apidoc optimize_optree
3478 This function applies some optimisations to the optree in top-down order.
3479 It is called before the peephole optimizer, which processes ops in
3480 execution order. Note that finalize_optree() also does a top-down scan,
3481 but is called *after* the peephole optimizer.
3487 Perl_optimize_optree(pTHX_ OP* o)
3489 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3492 SAVEVPTR(PL_curcop);
3500 /* helper for optimize_optree() which optimises on op then recurses
3501 * to optimise any children.
3505 S_optimize_op(pTHX_ OP* o)
3509 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3511 assert(o->op_type != OP_FREED);
3513 switch (o->op_type) {
3516 PL_curcop = ((COP*)o); /* for warnings */
3524 S_maybe_multiconcat(aTHX_ o);
3528 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3529 DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
3536 if (o->op_flags & OPf_KIDS) {
3539 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3543 DEFER_REVERSE(child_count);
3545 } while ( ( o = POP_DEFERRED_OP() ) );
3552 =for apidoc finalize_optree
3554 This function finalizes the optree. Should be called directly after
3555 the complete optree is built. It does some additional
3556 checking which can't be done in the normal C<ck_>xxx functions and makes
3557 the tree thread-safe.
3562 Perl_finalize_optree(pTHX_ OP* o)
3564 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3567 SAVEVPTR(PL_curcop);
3575 /* Relocate sv to the pad for thread safety.
3576 * Despite being a "constant", the SV is written to,
3577 * for reference counts, sv_upgrade() etc. */
3578 PERL_STATIC_INLINE void
3579 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3582 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3584 ix = pad_alloc(OP_CONST, SVf_READONLY);
3585 SvREFCNT_dec(PAD_SVl(ix));
3586 PAD_SETSV(ix, *svp);
3587 /* XXX I don't know how this isn't readonly already. */
3588 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3595 =for apidoc s|OP*|traverse_op_tree|OP* top|OP* o
3597 Return the next op in a depth-first traversal of the op tree,
3598 returning NULL when the traversal is complete.
3600 The initial call must supply the root of the tree as both top and o.
3602 For now it's static, but it may be exposed to the API in the future.
3608 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3611 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3613 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3614 return cUNOPo->op_first;
3616 else if ((sib = OpSIBLING(o))) {
3620 OP *parent = o->op_sibparent;
3621 assert(!(o->op_moresib));
3622 while (parent && parent != top) {
3623 OP *sib = OpSIBLING(parent);
3626 parent = parent->op_sibparent;
3634 S_finalize_op(pTHX_ OP* o)
3637 PERL_ARGS_ASSERT_FINALIZE_OP;
3640 assert(o->op_type != OP_FREED);
3642 switch (o->op_type) {
3645 PL_curcop = ((COP*)o); /* for warnings */
3648 if (OpHAS_SIBLING(o)) {
3649 OP *sib = OpSIBLING(o);
3650 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3651 && ckWARN(WARN_EXEC)
3652 && OpHAS_SIBLING(sib))
3654 const OPCODE type = OpSIBLING(sib)->op_type;
3655 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3656 const line_t oldline = CopLINE(PL_curcop);
3657 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3658 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3659 "Statement unlikely to be reached");
3660 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3661 "\t(Maybe you meant system() when you said exec()?)\n");
3662 CopLINE_set(PL_curcop, oldline);
3669 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3670 GV * const gv = cGVOPo_gv;
3671 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3672 /* XXX could check prototype here instead of just carping */
3673 SV * const sv = sv_newmortal();
3674 gv_efullname3(sv, gv, NULL);
3675 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3676 "%" SVf "() called too early to check prototype",
3683 if (cSVOPo->op_private & OPpCONST_STRICT)
3684 no_bareword_allowed(o);
3688 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3693 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3694 case OP_METHOD_NAMED:
3695 case OP_METHOD_SUPER:
3696 case OP_METHOD_REDIR:
3697 case OP_METHOD_REDIR_SUPER:
3698 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3707 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3710 rop = (UNOP*)((BINOP*)o)->op_first;
3715 S_scalar_slice_warning(aTHX_ o);
3719 kid = OpSIBLING(cLISTOPo->op_first);
3720 if (/* I bet there's always a pushmark... */
3721 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3722 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3727 key_op = (SVOP*)(kid->op_type == OP_CONST
3729 : OpSIBLING(kLISTOP->op_first));
3731 rop = (UNOP*)((LISTOP*)o)->op_last;
3734 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3736 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3740 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3744 S_scalar_slice_warning(aTHX_ o);
3748 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3749 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3757 if (o->op_flags & OPf_KIDS) {
3760 /* check that op_last points to the last sibling, and that
3761 * the last op_sibling/op_sibparent field points back to the
3762 * parent, and that the only ops with KIDS are those which are
3763 * entitled to them */
3764 U32 type = o->op_type;
3768 if (type == OP_NULL) {
3770 /* ck_glob creates a null UNOP with ex-type GLOB
3771 * (which is a list op. So pretend it wasn't a listop */
3772 if (type == OP_GLOB)
3775 family = PL_opargs[type] & OA_CLASS_MASK;
3777 has_last = ( family == OA_BINOP
3778 || family == OA_LISTOP
3779 || family == OA_PMOP
3780 || family == OA_LOOP
3782 assert( has_last /* has op_first and op_last, or ...
3783 ... has (or may have) op_first: */
3784 || family == OA_UNOP
3785 || family == OA_UNOP_AUX
3786 || family == OA_LOGOP
3787 || family == OA_BASEOP_OR_UNOP
3788 || family == OA_FILESTATOP
3789 || family == OA_LOOPEXOP
3790 || family == OA_METHOP
3791 || type == OP_CUSTOM
3792 || type == OP_NULL /* new_logop does this */
3795 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3796 if (!OpHAS_SIBLING(kid)) {
3798 assert(kid == cLISTOPo->op_last);
3799 assert(kid->op_sibparent == o);
3804 } while (( o = traverse_op_tree(top, o)) != NULL);
3808 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3810 Propagate lvalue ("modifiable") context to an op and its children.
3811 C<type> represents the context type, roughly based on the type of op that
3812 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3813 because it has no op type of its own (it is signalled by a flag on
3816 This function detects things that can't be modified, such as C<$x+1>, and
3817 generates errors for them. For example, C<$x+1 = 2> would cause it to be
3818 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3820 It also flags things that need to behave specially in an lvalue context,
3821 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3827 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3830 PadnameLVALUE_on(pn);
3831 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3833 /* RT #127786: cv can be NULL due to an eval within the DB package
3834 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3835 * unless they contain an eval, but calling eval within DB
3836 * pretends the eval was done in the caller's scope.
3840 assert(CvPADLIST(cv));
3842 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3843 assert(PadnameLEN(pn));
3844 PadnameLVALUE_on(pn);
3849 S_vivifies(const OPCODE type)
3852 case OP_RV2AV: case OP_ASLICE:
3853 case OP_RV2HV: case OP_KVASLICE:
3854 case OP_RV2SV: case OP_HSLICE:
3855 case OP_AELEMFAST: case OP_KVHSLICE:
3864 S_lvref(pTHX_ OP *o, I32 type)
3868 switch (o->op_type) {
3870 for (kid = OpSIBLING(cUNOPo->op_first); kid;
3871 kid = OpSIBLING(kid))
3872 S_lvref(aTHX_ kid, type);
3877 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3878 o->op_flags |= OPf_STACKED;
3879 if (o->op_flags & OPf_PARENS) {
3880 if (o->op_private & OPpLVAL_INTRO) {
3881 yyerror(Perl_form(aTHX_ "Can't modify reference to "
3882 "localized parenthesized array in list assignment"));
3886 OpTYPE_set(o, OP_LVAVREF);
3887 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3888 o->op_flags |= OPf_MOD|OPf_REF;
3891 o->op_private |= OPpLVREF_AV;
3894 kid = cUNOPo->op_first;
3895 if (kid->op_type == OP_NULL)
3896 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3898 o->op_private = OPpLVREF_CV;
3899 if (kid->op_type == OP_GV)
3900 o->op_flags |= OPf_STACKED;
3901 else if (kid->op_type == OP_PADCV) {
3902 o->op_targ = kid->op_targ;
3904 op_free(cUNOPo->op_first);
3905 cUNOPo->op_first = NULL;
3906 o->op_flags &=~ OPf_KIDS;
3911 if (o->op_flags & OPf_PARENS) {
3913 yyerror(Perl_form(aTHX_ "Can't modify reference to "
3914 "parenthesized hash in list assignment"));
3917 o->op_private |= OPpLVREF_HV;
3921 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3922 o->op_flags |= OPf_STACKED;
3925 if (o->op_flags & OPf_PARENS) goto parenhash;
3926 o->op_private |= OPpLVREF_HV;
3929 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3932 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3933 if (o->op_flags & OPf_PARENS) goto slurpy;
3934 o->op_private |= OPpLVREF_AV;
3938 o->op_private |= OPpLVREF_ELEM;
3939 o->op_flags |= OPf_STACKED;
3943 OpTYPE_set(o, OP_LVREFSLICE);
3944 o->op_private &= OPpLVAL_INTRO;
3947 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3949 else if (!(o->op_flags & OPf_KIDS))
3951 if (o->op_targ != OP_LIST) {
3952 S_lvref(aTHX_ cBINOPo->op_first, type);
3957 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3958 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3959 S_lvref(aTHX_ kid, type);
3963 if (o->op_flags & OPf_PARENS)
3968 /* diag_listed_as: Can't modify reference to %s in %s assignment */
3969 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3970 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3976 OpTYPE_set(o, OP_LVREF);
3978 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3979 if (type == OP_ENTERLOOP)
3980 o->op_private |= OPpLVREF_ITER;
3983 PERL_STATIC_INLINE bool
3984 S_potential_mod_type(I32 type)
3986 /* Types that only potentially result in modification. */
3987 return type == OP_GREPSTART || type == OP_ENTERSUB
3988 || type == OP_REFGEN || type == OP_LEAVESUBLV;
3992 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3996 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3999 if (!o || (PL_parser && PL_parser->error_count))
4002 if ((o->op_private & OPpTARGET_MY)
4003 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4008 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
4010 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4012 switch (o->op_type) {
4017 if ((o->op_flags & OPf_PARENS))
4021 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4022 !(o->op_flags & OPf_STACKED)) {
4023 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4024 assert(cUNOPo->op_first->op_type == OP_NULL);
4025 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4028 else { /* lvalue subroutine call */
4029 o->op_private |= OPpLVAL_INTRO;
4030 PL_modcount = RETURN_UNLIMITED_NUMBER;
4031 if (S_potential_mod_type(type)) {
4032 o->op_private |= OPpENTERSUB_INARGS;
4035 else { /* Compile-time error message: */
4036 OP *kid = cUNOPo->op_first;
4041 if (kid->op_type != OP_PUSHMARK) {
4042 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4044 "panic: unexpected lvalue entersub "
4045 "args: type/targ %ld:%" UVuf,
4046 (long)kid->op_type, (UV)kid->op_targ);
4047 kid = kLISTOP->op_first;
4049 while (OpHAS_SIBLING(kid))
4050 kid = OpSIBLING(kid);
4051 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4052 break; /* Postpone until runtime */
4055 kid = kUNOP->op_first;
4056 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4057 kid = kUNOP->op_first;
4058 if (kid->op_type == OP_NULL)
4060 "Unexpected constant lvalue entersub "
4061 "entry via type/targ %ld:%" UVuf,
4062 (long)kid->op_type, (UV)kid->op_targ);
4063 if (kid->op_type != OP_GV) {
4070 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4071 ? MUTABLE_CV(SvRV(gv))
4077 if (flags & OP_LVALUE_NO_CROAK)
4080 namesv = cv_name(cv, NULL, 0);
4081 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4082 "subroutine call of &%" SVf " in %s",
4083 SVfARG(namesv), PL_op_desc[type]),
4091 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4092 /* grep, foreach, subcalls, refgen */
4093 if (S_potential_mod_type(type))
4095 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4096 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4099 type ? PL_op_desc[type] : "local"));
4112 case OP_RIGHT_SHIFT:
4121 if (!(o->op_flags & OPf_STACKED))
4127 if (o->op_flags & OPf_STACKED) {
4131 if (!(o->op_private & OPpREPEAT_DOLIST))
4134 const I32 mods = PL_modcount;
4135 modkids(cBINOPo->op_first, type);
4136 if (type != OP_AASSIGN)
4138 kid = cBINOPo->op_last;
4139 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4140 const IV iv = SvIV(kSVOP_sv);
4141 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4143 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4146 PL_modcount = RETURN_UNLIMITED_NUMBER;
4152 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4153 op_lvalue(kid, type);
4158 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4159 PL_modcount = RETURN_UNLIMITED_NUMBER;
4160 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4161 fiable since some contexts need to know. */
4162 o->op_flags |= OPf_MOD;
4167 if (scalar_mod_type(o, type))
4169 ref(cUNOPo->op_first, o->op_type);
4176 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4177 if (type == OP_LEAVESUBLV && (
4178 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4179 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4181 o->op_private |= OPpMAYBE_LVSUB;
4185 PL_modcount = RETURN_UNLIMITED_NUMBER;
4190 if (type == OP_LEAVESUBLV)
4191 o->op_private |= OPpMAYBE_LVSUB;
4194 if (type == OP_LEAVESUBLV
4195 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4196 o->op_private |= OPpMAYBE_LVSUB;
4199 PL_hints |= HINT_BLOCK_SCOPE;
4200 if (type == OP_LEAVESUBLV)
4201 o->op_private |= OPpMAYBE_LVSUB;
4205 ref(cUNOPo->op_first, o->op_type);
4209 PL_hints |= HINT_BLOCK_SCOPE;
4219 case OP_AELEMFAST_LEX:
4226 PL_modcount = RETURN_UNLIMITED_NUMBER;
4227 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4229 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4230 fiable since some contexts need to know. */
4231 o->op_flags |= OPf_MOD;
4234 if (scalar_mod_type(o, type))
4236 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4237 && type == OP_LEAVESUBLV)
4238 o->op_private |= OPpMAYBE_LVSUB;
4242 if (!type) /* local() */
4243 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4244 PNfARG(PAD_COMPNAME(o->op_targ)));
4245 if (!(o->op_private & OPpLVAL_INTRO)
4246 || ( type != OP_SASSIGN && type != OP_AASSIGN
4247 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4248 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4256 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4260 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4266 if (type == OP_LEAVESUBLV)
4267 o->op_private |= OPpMAYBE_LVSUB;
4268 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4269 /* substr and vec */
4270 /* If this op is in merely potential (non-fatal) modifiable
4271 context, then apply OP_ENTERSUB context to
4272 the kid op (to avoid croaking). Other-
4273 wise pass this op’s own type so the correct op is mentioned
4274 in error messages. */
4275 op_lvalue(OpSIBLING(cBINOPo->op_first),
4276 S_potential_mod_type(type)
4284 ref(cBINOPo->op_first, o->op_type);
4285 if (type == OP_ENTERSUB &&
4286 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4287 o->op_private |= OPpLVAL_DEFER;
4288 if (type == OP_LEAVESUBLV)
4289 o->op_private |= OPpMAYBE_LVSUB;
4296 o->op_private |= OPpLVALUE;
4302 if (o->op_flags & OPf_KIDS)
4303 op_lvalue(cLISTOPo->op_last, type);
4308 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4310 else if (!(o->op_flags & OPf_KIDS))
4313 if (o->op_targ != OP_LIST) {
4314 OP *sib = OpSIBLING(cLISTOPo->op_first);
4315 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4322 * compared with things like OP_MATCH which have the argument
4328 * so handle specially to correctly get "Can't modify" croaks etc
4331 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4333 /* this should trigger a "Can't modify transliteration" err */
4334 op_lvalue(sib, type);
4336 op_lvalue(cBINOPo->op_first, type);
4342 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4343 /* elements might be in void context because the list is
4344 in scalar context or because they are attribute sub calls */
4345 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4346 op_lvalue(kid, type);
4354 if (type == OP_LEAVESUBLV
4355 || !S_vivifies(cLOGOPo->op_first->op_type))
4356 op_lvalue(cLOGOPo->op_first, type);
4357 if (type == OP_LEAVESUBLV
4358 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4359 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4363 if (type == OP_NULL) { /* local */
4365 if (!FEATURE_MYREF_IS_ENABLED)
4366 Perl_croak(aTHX_ "The experimental declared_refs "
4367 "feature is not enabled");
4368 Perl_ck_warner_d(aTHX_
4369 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4370 "Declaring references is experimental");
4371 op_lvalue(cUNOPo->op_first, OP_NULL);
4374 if (type != OP_AASSIGN && type != OP_SASSIGN
4375 && type != OP_ENTERLOOP)
4377 /* Don’t bother applying lvalue context to the ex-list. */
4378 kid = cUNOPx(cUNOPo->op_first)->op_first;
4379 assert (!OpHAS_SIBLING(kid));
4382 if (type == OP_NULL) /* local */
4384 if (type != OP_AASSIGN) goto nomod;
4385 kid = cUNOPo->op_first;
4388 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4389 S_lvref(aTHX_ kid, type);
4390 if (!PL_parser || PL_parser->error_count == ec) {
4391 if (!FEATURE_REFALIASING_IS_ENABLED)
4393 "Experimental aliasing via reference not enabled");
4394 Perl_ck_warner_d(aTHX_
4395 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4396 "Aliasing via reference is experimental");
4399 if (o->op_type == OP_REFGEN)
4400 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4405 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4406 /* This is actually @array = split. */
4407 PL_modcount = RETURN_UNLIMITED_NUMBER;
4413 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4417 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4418 their argument is a filehandle; thus \stat(".") should not set
4420 if (type == OP_REFGEN &&
4421 PL_check[o->op_type] == Perl_ck_ftst)
4424 if (type != OP_LEAVESUBLV)
4425 o->op_flags |= OPf_MOD;
4427 if (type == OP_AASSIGN || type == OP_SASSIGN)
4428 o->op_flags |= OPf_SPECIAL
4429 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4430 else if (!type) { /* local() */
4433 o->op_private |= OPpLVAL_INTRO;
4434 o->op_flags &= ~OPf_SPECIAL;
4435 PL_hints |= HINT_BLOCK_SCOPE;
4440 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4441 "Useless localization of %s", OP_DESC(o));
4444 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4445 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4446 o->op_flags |= OPf_REF;
4451 S_scalar_mod_type(const OP *o, I32 type)
4456 if (o && o->op_type == OP_RV2GV)
4480 case OP_RIGHT_SHIFT:
4509 S_is_handle_constructor(const OP *o, I32 numargs)
4511 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4513 switch (o->op_type) {
4521 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4534 S_refkids(pTHX_ OP *o, I32 type)
4536 if (o && o->op_flags & OPf_KIDS) {
4538 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4545 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4550 PERL_ARGS_ASSERT_DOREF;
4552 if (PL_parser && PL_parser->error_count)
4555 switch (o->op_type) {
4557 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4558 !(o->op_flags & OPf_STACKED)) {
4559 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4560 assert(cUNOPo->op_first->op_type == OP_NULL);
4561 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
4562 o->op_flags |= OPf_SPECIAL;
4564 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4565 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4566 : type == OP_RV2HV ? OPpDEREF_HV
4568 o->op_flags |= OPf_MOD;
4574 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4575 doref(kid, type, set_op_ref);
4578 if (type == OP_DEFINED)
4579 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4580 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4583 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4584 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4585 : type == OP_RV2HV ? OPpDEREF_HV
4587 o->op_flags |= OPf_MOD;
4594 o->op_flags |= OPf_REF;
4597 if (type == OP_DEFINED)
4598 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4599 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4605 o->op_flags |= OPf_REF;
4610 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4612 doref(cBINOPo->op_first, type, set_op_ref);
4616 doref(cBINOPo->op_first, o->op_type, set_op_ref);
4617 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4618 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4619 : type == OP_RV2HV ? OPpDEREF_HV
4621 o->op_flags |= OPf_MOD;
4631 if (!(o->op_flags & OPf_KIDS))
4633 doref(cLISTOPo->op_last, type, set_op_ref);
4643 S_dup_attrlist(pTHX_ OP *o)
4647 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4649 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4650 * where the first kid is OP_PUSHMARK and the remaining ones
4651 * are OP_CONST. We need to push the OP_CONST values.
4653 if (o->op_type == OP_CONST)
4654 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4656 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4658 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4659 if (o->op_type == OP_CONST)
4660 rop = op_append_elem(OP_LIST, rop,
4661 newSVOP(OP_CONST, o->op_flags,
4662 SvREFCNT_inc_NN(cSVOPo->op_sv)));
4669 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4671 PERL_ARGS_ASSERT_APPLY_ATTRS;
4673 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4675 /* fake up C<use attributes $pkg,$rv,@attrs> */
4677 #define ATTRSMODULE "attributes"
4678 #define ATTRSMODULE_PM "attributes.pm"
4681 aTHX_ PERL_LOADMOD_IMPORT_OPS,
4682 newSVpvs(ATTRSMODULE),
4684 op_prepend_elem(OP_LIST,
4685 newSVOP(OP_CONST, 0, stashsv),
4686 op_prepend_elem(OP_LIST,
4687 newSVOP(OP_CONST, 0,
4689 dup_attrlist(attrs))));
4694 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4696 OP *pack, *imop, *arg;
4697 SV *meth, *stashsv, **svp;
4699 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4704 assert(target->op_type == OP_PADSV ||
4705 target->op_type == OP_PADHV ||
4706 target->op_type == OP_PADAV);
4708 /* Ensure that attributes.pm is loaded. */
4709 /* Don't force the C<use> if we don't need it. */
4710 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4711 if (svp && *svp != &PL_sv_undef)
4712 NOOP; /* already in %INC */
4714 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4715 newSVpvs(ATTRSMODULE), NULL);
4717 /* Need package name for method call. */
4718 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4720 /* Build up the real arg-list. */
4721 stashsv = newSVhek(HvNAME_HEK(stash));
4723 arg = newOP(OP_PADSV, 0);
4724 arg->op_targ = target->op_targ;
4725 arg = op_prepend_elem(OP_LIST,
4726 newSVOP(OP_CONST, 0, stashsv),
4727 op_prepend_elem(OP_LIST,
4728 newUNOP(OP_REFGEN, 0,
4730 dup_attrlist(attrs)));
4732 /* Fake up a method call to import */
4733 meth = newSVpvs_share("import");
4734 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4735 op_append_elem(OP_LIST,
4736 op_prepend_elem(OP_LIST, pack, arg),
4737 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4739 /* Combine the ops. */
4740 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4744 =notfor apidoc apply_attrs_string
4746 Attempts to apply a list of attributes specified by the C<attrstr> and
4747 C<len> arguments to the subroutine identified by the C<cv> argument which
4748 is expected to be associated with the package identified by the C<stashpv>
4749 argument (see L<attributes>). It gets this wrong, though, in that it
4750 does not correctly identify the boundaries of the individual attribute
4751 specifications within C<attrstr>. This is not really intended for the
4752 public API, but has to be listed here for systems such as AIX which
4753 need an explicit export list for symbols. (It's called from XS code
4754 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
4755 to respect attribute syntax properly would be welcome.
4761 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4762 const char *attrstr, STRLEN len)
4766 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4769 len = strlen(attrstr);
4773 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4775 const char * const sstr = attrstr;
4776 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4777 attrs = op_append_elem(OP_LIST, attrs,
4778 newSVOP(OP_CONST, 0,
4779 newSVpvn(sstr, attrstr-sstr)));
4783 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4784 newSVpvs(ATTRSMODULE),
4785 NULL, op_prepend_elem(OP_LIST,
4786 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4787 op_prepend_elem(OP_LIST,
4788 newSVOP(OP_CONST, 0,
4789 newRV(MUTABLE_SV(cv))),
4794 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4797 OP *new_proto = NULL;
4802 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4808 if (o->op_type == OP_CONST) {
4809 pv = SvPV(cSVOPo_sv, pvlen);
4810 if (memBEGINs(pv, pvlen, "prototype(")) {
4811 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4812 SV ** const tmpo = cSVOPx_svp(o);
4813 SvREFCNT_dec(cSVOPo_sv);
4818 } else if (o->op_type == OP_LIST) {
4820 assert(o->op_flags & OPf_KIDS);
4821 lasto = cLISTOPo->op_first;
4822 assert(lasto->op_type == OP_PUSHMARK);
4823 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4824 if (o->op_type == OP_CONST) {
4825 pv = SvPV(cSVOPo_sv, pvlen);
4826 if (memBEGINs(pv, pvlen, "prototype(")) {
4827 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4828 SV ** const tmpo = cSVOPx_svp(o);
4829 SvREFCNT_dec(cSVOPo_sv);
4831 if (new_proto && ckWARN(WARN_MISC)) {
4833 const char * newp = SvPV(cSVOPo_sv, new_len);
4834 Perl_warner(aTHX_ packWARN(WARN_MISC),
4835 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4836 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4842 /* excise new_proto from the list */
4843 op_sibling_splice(*attrs, lasto, 1, NULL);
4850 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4851 would get pulled in with no real need */
4852 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4861 svname = sv_newmortal();
4862 gv_efullname3(svname, name, NULL);
4864 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4865 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4867 svname = (SV *)name;
4868 if (ckWARN(WARN_ILLEGALPROTO))
4869 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4871 if (*proto && ckWARN(WARN_PROTOTYPE)) {
4872 STRLEN old_len, new_len;
4873 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4874 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4876 if (curstash && svname == (SV *)name
4877 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4878 svname = sv_2mortal(newSVsv(PL_curstname));
4879 sv_catpvs(svname, "::");
4880 sv_catsv(svname, (SV *)name);
4883 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4884 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4886 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4887 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4897 S_cant_declare(pTHX_ OP *o)
4899 if (o->op_type == OP_NULL
4900 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4901 o = cUNOPo->op_first;
4902 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4903 o->op_type == OP_NULL
4904 && o->op_flags & OPf_SPECIAL
4907 PL_parser->in_my == KEY_our ? "our" :
4908 PL_parser->in_my == KEY_state ? "state" :
4913 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4916 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4918 PERL_ARGS_ASSERT_MY_KID;
4920 if (!o || (PL_parser && PL_parser->error_count))
4925 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4927 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4928 my_kid(kid, attrs, imopsp);
4930 } else if (type == OP_UNDEF || type == OP_STUB) {
4932 } else if (type == OP_RV2SV || /* "our" declaration */
4935 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4936 S_cant_declare(aTHX_ o);
4938 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4940 PL_parser->in_my = FALSE;
4941 PL_parser->in_my_stash = NULL;
4942 apply_attrs(GvSTASH(gv),
4943 (type == OP_RV2SV ? GvSVn(gv) :
4944 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4945 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4948 o->op_private |= OPpOUR_INTRO;
4951 else if (type == OP_REFGEN || type == OP_SREFGEN) {
4952 if (!FEATURE_MYREF_IS_ENABLED)
4953 Perl_croak(aTHX_ "The experimental declared_refs "
4954 "feature is not enabled");
4955 Perl_ck_warner_d(aTHX_
4956 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4957 "Declaring references is experimental");
4958 /* Kid is a nulled OP_LIST, handled above. */
4959 my_kid(cUNOPo->op_first, attrs, imopsp);
4962 else if (type != OP_PADSV &&
4965 type != OP_PUSHMARK)
4967 S_cant_declare(aTHX_ o);
4970 else if (attrs && type != OP_PUSHMARK) {
4974 PL_parser->in_my = FALSE;
4975 PL_parser->in_my_stash = NULL;
4977 /* check for C<my Dog $spot> when deciding package */
4978 stash = PAD_COMPNAME_TYPE(o->op_targ);
4980 stash = PL_curstash;
4981 apply_attrs_my(stash, o, attrs, imopsp);
4983 o->op_flags |= OPf_MOD;
4984 o->op_private |= OPpLVAL_INTRO;
4986 o->op_private |= OPpPAD_STATE;
4991 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4994 int maybe_scalar = 0;
4996 PERL_ARGS_ASSERT_MY_ATTRS;
4998 /* [perl #17376]: this appears to be premature, and results in code such as
4999 C< our(%x); > executing in list mode rather than void mode */
5001 if (o->op_flags & OPf_PARENS)
5011 o = my_kid(o, attrs, &rops);
5013 if (maybe_scalar && o->op_type == OP_PADSV) {
5014 o = scalar(op_append_list(OP_LIST, rops, o));
5015 o->op_private |= OPpLVAL_INTRO;
5018 /* The listop in rops might have a pushmark at the beginning,
5019 which will mess up list assignment. */
5020 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5021 if (rops->op_type == OP_LIST &&
5022 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5024 OP * const pushmark = lrops->op_first;
5025 /* excise pushmark */
5026 op_sibling_splice(rops, NULL, 1, NULL);
5029 o = op_append_list(OP_LIST, o, rops);
5032 PL_parser->in_my = FALSE;
5033 PL_parser->in_my_stash = NULL;
5038 Perl_sawparens(pTHX_ OP *o)
5040 PERL_UNUSED_CONTEXT;
5042 o->op_flags |= OPf_PARENS;
5047 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5051 const OPCODE ltype = left->op_type;
5052 const OPCODE rtype = right->op_type;
5054 PERL_ARGS_ASSERT_BIND_MATCH;
5056 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5057 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5059 const char * const desc
5061 rtype == OP_SUBST || rtype == OP_TRANS
5062 || rtype == OP_TRANSR
5064 ? (int)rtype : OP_MATCH];
5065 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5067 S_op_varname(aTHX_ left);
5069 Perl_warner(aTHX_ packWARN(WARN_MISC),
5070 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5071 desc, SVfARG(name), SVfARG(name));
5073 const char * const sample = (isary
5074 ? "@array" : "%hash");
5075 Perl_warner(aTHX_ packWARN(WARN_MISC),
5076 "Applying %s to %s will act on scalar(%s)",
5077 desc, sample, sample);
5081 if (rtype == OP_CONST &&
5082 cSVOPx(right)->op_private & OPpCONST_BARE &&
5083 cSVOPx(right)->op_private & OPpCONST_STRICT)
5085 no_bareword_allowed(right);
5088 /* !~ doesn't make sense with /r, so error on it for now */
5089 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5091 /* diag_listed_as: Using !~ with %s doesn't make sense */
5092 yyerror("Using !~ with s///r doesn't make sense");
5093 if (rtype == OP_TRANSR && type == OP_NOT)
5094 /* diag_listed_as: Using !~ with %s doesn't make sense */
5095 yyerror("Using !~ with tr///r doesn't make sense");
5097 ismatchop = (rtype == OP_MATCH ||
5098 rtype == OP_SUBST ||
5099 rtype == OP_TRANS || rtype == OP_TRANSR)
5100 && !(right->op_flags & OPf_SPECIAL);
5101 if (ismatchop && right->op_private & OPpTARGET_MY) {
5103 right->op_private &= ~OPpTARGET_MY;
5105 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5106 if (left->op_type == OP_PADSV
5107 && !(left->op_private & OPpLVAL_INTRO))
5109 right->op_targ = left->op_targ;
5114 right->op_flags |= OPf_STACKED;
5115 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5116 ! (rtype == OP_TRANS &&
5117 right->op_private & OPpTRANS_IDENTICAL) &&
5118 ! (rtype == OP_SUBST &&
5119 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5120 left = op_lvalue(left, rtype);
5121 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5122 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5124 o = op_prepend_elem(rtype, scalar(left), right);
5127 return newUNOP(OP_NOT, 0, scalar(o));
5131 return bind_match(type, left,
5132 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5136 Perl_invert(pTHX_ OP *o)
5140 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5144 =for apidoc Amx|OP *|op_scope|OP *o
5146 Wraps up an op tree with some additional ops so that at runtime a dynamic
5147 scope will be created. The original ops run in the new dynamic scope,
5148 and then, provided that they exit normally, the scope will be unwound.
5149 The additional ops used to create and unwind the dynamic scope will
5150 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5151 instead if the ops are simple enough to not need the full dynamic scope
5158 Perl_op_scope(pTHX_ OP *o)
5162 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5163 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5164 OpTYPE_set(o, OP_LEAVE);
5166 else if (o->op_type == OP_LINESEQ) {
5168 OpTYPE_set(o, OP_SCOPE);
5169 kid = ((LISTOP*)o)->op_first;
5170 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5173 /* The following deals with things like 'do {1 for 1}' */
5174 kid = OpSIBLING(kid);
5176 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5181 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5187 Perl_op_unscope(pTHX_ OP *o)
5189 if (o && o->op_type == OP_LINESEQ) {
5190 OP *kid = cLISTOPo->op_first;
5191 for(; kid; kid = OpSIBLING(kid))
5192 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5199 =for apidoc Am|int|block_start|int full
5201 Handles compile-time scope entry.
5202 Arranges for hints to be restored on block
5203 exit and also handles pad sequence numbers to make lexical variables scope
5204 right. Returns a savestack index for use with C<block_end>.
5210 Perl_block_start(pTHX_ int full)
5212 const int retval = PL_savestack_ix;
5214 PL_compiling.cop_seq = PL_cop_seqmax;
5216 pad_block_start(full);
5218 PL_hints &= ~HINT_BLOCK_SCOPE;
5219 SAVECOMPILEWARNINGS();
5220 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5221 SAVEI32(PL_compiling.cop_seq);
5222 PL_compiling.cop_seq = 0;
5224 CALL_BLOCK_HOOKS(bhk_start, full);
5230 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5232 Handles compile-time scope exit. C<floor>
5233 is the savestack index returned by
5234 C<block_start>, and C<seq> is the body of the block. Returns the block,
5241 Perl_block_end(pTHX_ I32 floor, OP *seq)
5243 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5244 OP* retval = scalarseq(seq);
5247 /* XXX Is the null PL_parser check necessary here? */
5248 assert(PL_parser); /* Let’s find out under debugging builds. */
5249 if (PL_parser && PL_parser->parsed_sub) {
5250 o = newSTATEOP(0, NULL, NULL);
5252 retval = op_append_elem(OP_LINESEQ, retval, o);
5255 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5259 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5263 /* pad_leavemy has created a sequence of introcv ops for all my
5264 subs declared in the block. We have to replicate that list with
5265 clonecv ops, to deal with this situation:
5270 sub s1 { state sub foo { \&s2 } }
5273 Originally, I was going to have introcv clone the CV and turn
5274 off the stale flag. Since &s1 is declared before &s2, the
5275 introcv op for &s1 is executed (on sub entry) before the one for
5276 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5277 cloned, since it is a state sub) closes over &s2 and expects
5278 to see it in its outer CV’s pad. If the introcv op clones &s1,
5279 then &s2 is still marked stale. Since &s1 is not active, and
5280 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5281 ble will not stay shared’ warning. Because it is the same stub
5282 that will be used when the introcv op for &s2 is executed, clos-
5283 ing over it is safe. Hence, we have to turn off the stale flag
5284 on all lexical subs in the block before we clone any of them.
5285 Hence, having introcv clone the sub cannot work. So we create a
5286 list of ops like this:
5310 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5311 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5312 for (;; kid = OpSIBLING(kid)) {
5313 OP *newkid = newOP(OP_CLONECV, 0);
5314 newkid->op_targ = kid->op_targ;
5315 o = op_append_elem(OP_LINESEQ, o, newkid);
5316 if (kid == last) break;
5318 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5321 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5327 =head1 Compile-time scope hooks
5329 =for apidoc Aox||blockhook_register
5331 Register a set of hooks to be called when the Perl lexical scope changes
5332 at compile time. See L<perlguts/"Compile-time scope hooks">.
5338 Perl_blockhook_register(pTHX_ BHK *hk)
5340 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5342 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5346 Perl_newPROG(pTHX_ OP *o)
5350 PERL_ARGS_ASSERT_NEWPROG;
5357 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5358 ((PL_in_eval & EVAL_KEEPERR)
5359 ? OPf_SPECIAL : 0), o);
5362 assert(CxTYPE(cx) == CXt_EVAL);
5364 if ((cx->blk_gimme & G_WANT) == G_VOID)
5365 scalarvoid(PL_eval_root);
5366 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5369 scalar(PL_eval_root);
5371 start = op_linklist(PL_eval_root);
5372 PL_eval_root->op_next = 0;
5373 i = PL_savestack_ix;
5376 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5378 PL_savestack_ix = i;
5381 if (o->op_type == OP_STUB) {
5382 /* This block is entered if nothing is compiled for the main
5383 program. This will be the case for an genuinely empty main
5384 program, or one which only has BEGIN blocks etc, so already
5387 Historically (5.000) the guard above was !o. However, commit
5388 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5389 c71fccf11fde0068, changed perly.y so that newPROG() is now
5390 called with the output of block_end(), which returns a new
5391 OP_STUB for the case of an empty optree. ByteLoader (and
5392 maybe other things) also take this path, because they set up
5393 PL_main_start and PL_main_root directly, without generating an
5396 If the parsing the main program aborts (due to parse errors,
5397 or due to BEGIN or similar calling exit), then newPROG()
5398 isn't even called, and hence this code path and its cleanups
5399 are skipped. This shouldn't make a make a difference:
5400 * a non-zero return from perl_parse is a failure, and
5401 perl_destruct() should be called immediately.
5402 * however, if exit(0) is called during the parse, then
5403 perl_parse() returns 0, and perl_run() is called. As
5404 PL_main_start will be NULL, perl_run() will return
5405 promptly, and the exit code will remain 0.
5408 PL_comppad_name = 0;
5410 S_op_destroy(aTHX_ o);
5413 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5414 PL_curcop = &PL_compiling;
5415 start = LINKLIST(PL_main_root);
5416 PL_main_root->op_next = 0;
5417 S_process_optree(aTHX_ NULL, PL_main_root, start);
5418 if (!PL_parser->error_count)
5419 /* on error, leave CV slabbed so that ops left lying around
5420 * will eb cleaned up. Else unslab */
5421 cv_forget_slab(PL_compcv);
5424 /* Register with debugger */
5426 CV * const cv = get_cvs("DB::postponed", 0);
5430 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5432 call_sv(MUTABLE_SV(cv), G_DISCARD);
5439 Perl_localize(pTHX_ OP *o, I32 lex)
5441 PERL_ARGS_ASSERT_LOCALIZE;
5443 if (o->op_flags & OPf_PARENS)
5444 /* [perl #17376]: this appears to be premature, and results in code such as
5445 C< our(%x); > executing in list mode rather than void mode */
5452 if ( PL_parser->bufptr > PL_parser->oldbufptr
5453 && PL_parser->bufptr[-1] == ','
5454 && ckWARN(WARN_PARENTHESIS))
5456 char *s = PL_parser->bufptr;
5459 /* some heuristics to detect a potential error */
5460 while (*s && (strchr(", \t\n", *s)))
5464 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5466 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5469 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5471 while (*s && (strchr(", \t\n", *s)))
5477 if (sigil && (*s == ';' || *s == '=')) {
5478 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5479 "Parentheses missing around \"%s\" list",
5481 ? (PL_parser->in_my == KEY_our
5483 : PL_parser->in_my == KEY_state
5493 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5494 PL_parser->in_my = FALSE;
5495 PL_parser->in_my_stash = NULL;
5500 Perl_jmaybe(pTHX_ OP *o)
5502 PERL_ARGS_ASSERT_JMAYBE;
5504 if (o->op_type == OP_LIST) {
5506 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5507 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5512 PERL_STATIC_INLINE OP *
5513 S_op_std_init(pTHX_ OP *o)
5515 I32 type = o->op_type;
5517 PERL_ARGS_ASSERT_OP_STD_INIT;
5519 if (PL_opargs[type] & OA_RETSCALAR)
5521 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5522 o->op_targ = pad_alloc(type, SVs_PADTMP);
5527 PERL_STATIC_INLINE OP *
5528 S_op_integerize(pTHX_ OP *o)
5530 I32 type = o->op_type;
5532 PERL_ARGS_ASSERT_OP_INTEGERIZE;
5534 /* integerize op. */
5535 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5538 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5541 if (type == OP_NEGATE)
5542 /* XXX might want a ck_negate() for this */
5543 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5548 /* This function exists solely to provide a scope to limit
5549 setjmp/longjmp() messing with auto variables.
5551 PERL_STATIC_INLINE int
5552 S_fold_constants_eval(pTHX) {
5568 S_fold_constants(pTHX_ OP *const o)
5573 I32 type = o->op_type;
5578 SV * const oldwarnhook = PL_warnhook;
5579 SV * const olddiehook = PL_diehook;
5581 U8 oldwarn = PL_dowarn;
5584 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5586 if (!(PL_opargs[type] & OA_FOLDCONST))
5595 #ifdef USE_LOCALE_CTYPE
5596 if (IN_LC_COMPILETIME(LC_CTYPE))
5605 #ifdef USE_LOCALE_COLLATE
5606 if (IN_LC_COMPILETIME(LC_COLLATE))
5611 /* XXX what about the numeric ops? */
5612 #ifdef USE_LOCALE_NUMERIC
5613 if (IN_LC_COMPILETIME(LC_NUMERIC))
5618 if (!OpHAS_SIBLING(cLISTOPo->op_first)
5619 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5622 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5623 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5625 const char *s = SvPVX_const(sv);
5626 while (s < SvEND(sv)) {
5627 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5634 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5637 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5638 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5642 if (PL_parser && PL_parser->error_count)
5643 goto nope; /* Don't try to run w/ errors */
5645 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5646 switch (curop->op_type) {
5648 if ( (curop->op_private & OPpCONST_BARE)
5649 && (curop->op_private & OPpCONST_STRICT)) {
5650 no_bareword_allowed(curop);
5658 /* Foldable; move to next op in list */
5662 /* No other op types are considered foldable */
5667 curop = LINKLIST(o);
5668 old_next = o->op_next;
5672 old_cxix = cxstack_ix;
5673 create_eval_scope(NULL, G_FAKINGEVAL);
5675 /* Verify that we don't need to save it: */
5676 assert(PL_curcop == &PL_compiling);
5677 StructCopy(&PL_compiling, ¬_compiling, COP);
5678 PL_curcop = ¬_compiling;
5679 /* The above ensures that we run with all the correct hints of the
5680 currently compiling COP, but that IN_PERL_RUNTIME is true. */
5681 assert(IN_PERL_RUNTIME);
5682 PL_warnhook = PERL_WARNHOOK_FATAL;
5685 /* Effective $^W=1. */
5686 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5687 PL_dowarn |= G_WARN_ON;
5689 ret = S_fold_constants_eval(aTHX);
5693 sv = *(PL_stack_sp--);
5694 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
5695 pad_swipe(o->op_targ, FALSE);
5697 else if (SvTEMP(sv)) { /* grab mortal temp? */
5698 SvREFCNT_inc_simple_void(sv);
5701 else { assert(SvIMMORTAL(sv)); }
5704 /* Something tried to die. Abandon constant folding. */
5705 /* Pretend the error never happened. */
5707 o->op_next = old_next;
5710 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
5711 PL_warnhook = oldwarnhook;
5712 PL_diehook = olddiehook;
5713 /* XXX note that this croak may fail as we've already blown away
5714 * the stack - eg any nested evals */
5715 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5717 PL_dowarn = oldwarn;
5718 PL_warnhook = oldwarnhook;
5719 PL_diehook = olddiehook;
5720 PL_curcop = &PL_compiling;
5722 /* if we croaked, depending on how we croaked the eval scope
5723 * may or may not have already been popped */
5724 if (cxstack_ix > old_cxix) {
5725 assert(cxstack_ix == old_cxix + 1);
5726 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5727 delete_eval_scope();
5732 /* OP_STRINGIFY and constant folding are used to implement qq.
5733 Here the constant folding is an implementation detail that we
5734 want to hide. If the stringify op is itself already marked
5735 folded, however, then it is actually a folded join. */
5736 is_stringify = type == OP_STRINGIFY && !o->op_folded;
5741 else if (!SvIMMORTAL(sv)) {
5745 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5746 if (!is_stringify) newop->op_folded = 1;
5754 S_gen_constant_list(pTHX_ OP *o)
5757 OP *curop, *old_next;
5758 SV * const oldwarnhook = PL_warnhook;
5759 SV * const olddiehook = PL_diehook;
5761 U8 oldwarn = PL_dowarn;
5771 if (PL_parser && PL_parser->error_count)
5772 return o; /* Don't attempt to run with errors */
5774 curop = LINKLIST(o);
5775 old_next = o->op_next;
5777 op_was_null = o->op_type == OP_NULL;
5778 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5779 o->op_type = OP_CUSTOM;
5782 o->op_type = OP_NULL;
5783 S_prune_chain_head(&curop);
5786 old_cxix = cxstack_ix;
5787 create_eval_scope(NULL, G_FAKINGEVAL);
5789 old_curcop = PL_curcop;
5790 StructCopy(old_curcop, ¬_compiling, COP);
5791 PL_curcop = ¬_compiling;
5792 /* The above ensures that we run with all the correct hints of the
5793 current COP, but that IN_PERL_RUNTIME is true. */
5794 assert(IN_PERL_RUNTIME);
5795 PL_warnhook = PERL_WARNHOOK_FATAL;
5799 /* Effective $^W=1. */
5800 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5801 PL_dowarn |= G_WARN_ON;
5805 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5806 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5808 Perl_pp_pushmark(aTHX);
5811 assert (!(curop->op_flags & OPf_SPECIAL));
5812 assert(curop->op_type == OP_RANGE);
5813 Perl_pp_anonlist(aTHX);
5817 o->op_next = old_next;
5821 PL_warnhook = oldwarnhook;
5822 PL_diehook = olddiehook;
5823 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5828 PL_dowarn = oldwarn;
5829 PL_warnhook = oldwarnhook;
5830 PL_diehook = olddiehook;
5831 PL_curcop = old_curcop;
5833 if (cxstack_ix > old_cxix) {
5834 assert(cxstack_ix == old_cxix + 1);
5835 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5836 delete_eval_scope();
5841 OpTYPE_set(o, OP_RV2AV);
5842 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
5843 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
5844 o->op_opt = 0; /* needs to be revisited in rpeep() */
5845 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5847 /* replace subtree with an OP_CONST */
5848 curop = ((UNOP*)o)->op_first;
5849 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5852 if (AvFILLp(av) != -1)
5853 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5856 SvREADONLY_on(*svp);
5863 =head1 Optree Manipulation Functions
5866 /* List constructors */
5869 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5871 Append an item to the list of ops contained directly within a list-type
5872 op, returning the lengthened list. C<first> is the list-type op,
5873 and C<last> is the op to append to the list. C<optype> specifies the
5874 intended opcode for the list. If C<first> is not already a list of the
5875 right type, it will be upgraded into one. If either C<first> or C<last>
5876 is null, the other is returned unchanged.
5882 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5890 if (first->op_type != (unsigned)type
5891 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5893 return newLISTOP(type, 0, first, last);
5896 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5897 first->op_flags |= OPf_KIDS;
5902 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5904 Concatenate the lists of ops contained directly within two list-type ops,
5905 returning the combined list. C<first> and C<last> are the list-type ops
5906 to concatenate. C<optype> specifies the intended opcode for the list.
5907 If either C<first> or C<last> is not already a list of the right type,
5908 it will be upgraded into one. If either C<first> or C<last> is null,
5909 the other is returned unchanged.
5915 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5923 if (first->op_type != (unsigned)type)
5924 return op_prepend_elem(type, first, last);
5926 if (last->op_type != (unsigned)type)
5927 return op_append_elem(type, first, last);
5929 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5930 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5931 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5932 first->op_flags |= (last->op_flags & OPf_KIDS);
5934 S_op_destroy(aTHX_ last);
5940 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5942 Prepend an item to the list of ops contained directly within a list-type
5943 op, returning the lengthened list. C<first> is the op to prepend to the
5944 list, and C<last> is the list-type op. C<optype> specifies the intended
5945 opcode for the list. If C<last> is not already a list of the right type,
5946 it will be upgraded into one. If either C<first> or C<last> is null,
5947 the other is returned unchanged.
5953 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5961 if (last->op_type == (unsigned)type) {
5962 if (type == OP_LIST) { /* already a PUSHMARK there */
5963 /* insert 'first' after pushmark */
5964 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5965 if (!(first->op_flags & OPf_PARENS))
5966 last->op_flags &= ~OPf_PARENS;
5969 op_sibling_splice(last, NULL, 0, first);
5970 last->op_flags |= OPf_KIDS;
5974 return newLISTOP(type, 0, first, last);
5978 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5980 Converts C<o> into a list op if it is not one already, and then converts it
5981 into the specified C<type>, calling its check function, allocating a target if
5982 it needs one, and folding constants.
5984 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5985 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
5986 C<op_convert_list> to make it the right type.
5992 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5995 if (type < 0) type = -type, flags |= OPf_SPECIAL;
5996 if (!o || o->op_type != OP_LIST)
5997 o = force_list(o, 0);
6000 o->op_flags &= ~OPf_WANT;
6001 o->op_private &= ~OPpLVAL_INTRO;
6004 if (!(PL_opargs[type] & OA_MARK))
6005 op_null(cLISTOPo->op_first);
6007 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6008 if (kid2 && kid2->op_type == OP_COREARGS) {
6009 op_null(cLISTOPo->op_first);
6010 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6014 if (type != OP_SPLIT)
6015 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6016 * ck_split() create a real PMOP and leave the op's type as listop
6017 * for now. Otherwise op_free() etc will crash.
6019 OpTYPE_set(o, type);
6021 o->op_flags |= flags;
6022 if (flags & OPf_FOLDED)
6025 o = CHECKOP(type, o);
6026 if (o->op_type != (unsigned)type)
6029 return fold_constants(op_integerize(op_std_init(o)));
6036 =head1 Optree construction
6038 =for apidoc Am|OP *|newNULLLIST
6040 Constructs, checks, and returns a new C<stub> op, which represents an
6041 empty list expression.
6047 Perl_newNULLLIST(pTHX)
6049 return newOP(OP_STUB, 0);
6052 /* promote o and any siblings to be a list if its not already; i.e.
6060 * pushmark - o - A - B
6062 * If nullit it true, the list op is nulled.
6066 S_force_list(pTHX_ OP *o, bool nullit)
6068 if (!o || o->op_type != OP_LIST) {
6071 /* manually detach any siblings then add them back later */
6072 rest = OpSIBLING(o);
6073 OpLASTSIB_set(o, NULL);
6075 o = newLISTOP(OP_LIST, 0, o, NULL);
6077 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6085 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
6087 Constructs, checks, and returns an op of any list type. C<type> is
6088 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6089 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6090 supply up to two ops to be direct children of the list op; they are
6091 consumed by this function and become part of the constructed op tree.
6093 For most list operators, the check function expects all the kid ops to be
6094 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6095 appropriate. What you want to do in that case is create an op of type
6096 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6097 See L</op_convert_list> for more information.
6104 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6109 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6110 || type == OP_CUSTOM);
6112 NewOp(1101, listop, 1, LISTOP);
6114 OpTYPE_set(listop, type);
6117 listop->op_flags = (U8)flags;
6121 else if (!first && last)
6124 OpMORESIB_set(first, last);
6125 listop->op_first = first;
6126 listop->op_last = last;
6127 if (type == OP_LIST) {
6128 OP* const pushop = newOP(OP_PUSHMARK, 0);
6129 OpMORESIB_set(pushop, first);
6130 listop->op_first = pushop;
6131 listop->op_flags |= OPf_KIDS;
6133 listop->op_last = pushop;
6135 if (listop->op_last)
6136 OpLASTSIB_set(listop->op_last, (OP*)listop);
6138 return CHECKOP(type, listop);
6142 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6144 Constructs, checks, and returns an op of any base type (any type that
6145 has no extra fields). C<type> is the opcode. C<flags> gives the
6146 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6153 Perl_newOP(pTHX_ I32 type, I32 flags)
6158 if (type == -OP_ENTEREVAL) {
6159 type = OP_ENTEREVAL;
6160 flags |= OPpEVAL_BYTES<<8;
6163 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6164 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6165 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6166 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6168 NewOp(1101, o, 1, OP);
6169 OpTYPE_set(o, type);
6170 o->op_flags = (U8)flags;
6173 o->op_private = (U8)(0 | (flags >> 8));
6174 if (PL_opargs[type] & OA_RETSCALAR)
6176 if (PL_opargs[type] & OA_TARGET)
6177 o->op_targ = pad_alloc(type, SVs_PADTMP);
6178 return CHECKOP(type, o);
6182 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6184 Constructs, checks, and returns an op of any unary type. C<type> is
6185 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6186 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6187 bits, the eight bits of C<op_private>, except that the bit with value 1
6188 is automatically set. C<first> supplies an optional op to be the direct
6189 child of the unary op; it is consumed by this function and become part
6190 of the constructed op tree.
6196 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6201 if (type == -OP_ENTEREVAL) {
6202 type = OP_ENTEREVAL;
6203 flags |= OPpEVAL_BYTES<<8;
6206 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6207 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6208 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6209 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6210 || type == OP_SASSIGN
6211 || type == OP_ENTERTRY
6212 || type == OP_CUSTOM
6213 || type == OP_NULL );
6216 first = newOP(OP_STUB, 0);
6217 if (PL_opargs[type] & OA_MARK)
6218 first = force_list(first, 1);
6220 NewOp(1101, unop, 1, UNOP);
6221 OpTYPE_set(unop, type);
6222 unop->op_first = first;
6223 unop->op_flags = (U8)(flags | OPf_KIDS);
6224 unop->op_private = (U8)(1 | (flags >> 8));
6226 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6227 OpLASTSIB_set(first, (OP*)unop);
6229 unop = (UNOP*) CHECKOP(type, unop);
6233 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6237 =for apidoc newUNOP_AUX
6239 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6240 initialised to C<aux>
6246 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6251 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6252 || type == OP_CUSTOM);
6254 NewOp(1101, unop, 1, UNOP_AUX);
6255 unop->op_type = (OPCODE)type;
6256 unop->op_ppaddr = PL_ppaddr[type];
6257 unop->op_first = first;
6258 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6259 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6262 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6263 OpLASTSIB_set(first, (OP*)unop);
6265 unop = (UNOP_AUX*) CHECKOP(type, unop);
6267 return op_std_init((OP *) unop);
6271 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6273 Constructs, checks, and returns an op of method type with a method name
6274 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6275 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6276 and, shifted up eight bits, the eight bits of C<op_private>, except that
6277 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6278 op which evaluates method name; it is consumed by this function and
6279 become part of the constructed op tree.
6280 Supported optypes: C<OP_METHOD>.
6286 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6290 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6291 || type == OP_CUSTOM);
6293 NewOp(1101, methop, 1, METHOP);
6295 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6296 methop->op_flags = (U8)(flags | OPf_KIDS);
6297 methop->op_u.op_first = dynamic_meth;
6298 methop->op_private = (U8)(1 | (flags >> 8));
6300 if (!OpHAS_SIBLING(dynamic_meth))
6301 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6305 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6306 methop->op_u.op_meth_sv = const_meth;
6307 methop->op_private = (U8)(0 | (flags >> 8));
6308 methop->op_next = (OP*)methop;
6312 methop->op_rclass_targ = 0;
6314 methop->op_rclass_sv = NULL;
6317 OpTYPE_set(methop, type);
6318 return CHECKOP(type, methop);
6322 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6323 PERL_ARGS_ASSERT_NEWMETHOP;
6324 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6328 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6330 Constructs, checks, and returns an op of method type with a constant
6331 method name. C<type> is the opcode. C<flags> gives the eight bits of
6332 C<op_flags>, and, shifted up eight bits, the eight bits of
6333 C<op_private>. C<const_meth> supplies a constant method name;
6334 it must be a shared COW string.
6335 Supported optypes: C<OP_METHOD_NAMED>.
6341 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6342 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6343 return newMETHOP_internal(type, flags, NULL, const_meth);
6347 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6349 Constructs, checks, and returns an op of any binary type. C<type>
6350 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6351 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6352 the eight bits of C<op_private>, except that the bit with value 1 or
6353 2 is automatically set as required. C<first> and C<last> supply up to
6354 two ops to be the direct children of the binary op; they are consumed
6355 by this function and become part of the constructed op tree.
6361 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6366 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6367 || type == OP_NULL || type == OP_CUSTOM);
6369 NewOp(1101, binop, 1, BINOP);
6372 first = newOP(OP_NULL, 0);
6374 OpTYPE_set(binop, type);
6375 binop->op_first = first;
6376 binop->op_flags = (U8)(flags | OPf_KIDS);
6379 binop->op_private = (U8)(1 | (flags >> 8));
6382 binop->op_private = (U8)(2 | (flags >> 8));
6383 OpMORESIB_set(first, last);
6386 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6387 OpLASTSIB_set(last, (OP*)binop);
6389 binop->op_last = OpSIBLING(binop->op_first);
6391 OpLASTSIB_set(binop->op_last, (OP*)binop);
6393 binop = (BINOP*)CHECKOP(type, binop);
6394 if (binop->op_next || binop->op_type != (OPCODE)type)
6397 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6400 /* Helper function for S_pmtrans(): comparison function to sort an array
6401 * of codepoint range pairs. Sorts by start point, or if equal, by end
6404 static int uvcompare(const void *a, const void *b)
6405 __attribute__nonnull__(1)
6406 __attribute__nonnull__(2)
6407 __attribute__pure__;
6408 static int uvcompare(const void *a, const void *b)
6410 if (*((const UV *)a) < (*(const UV *)b))
6412 if (*((const UV *)a) > (*(const UV *)b))
6414 if (*((const UV *)a+1) < (*(const UV *)b+1))
6416 if (*((const UV *)a+1) > (*(const UV *)b+1))
6421 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6422 * containing the search and replacement strings, assemble into
6423 * a translation table attached as o->op_pv.
6424 * Free expr and repl.
6425 * It expects the toker to have already set the
6426 * OPpTRANS_COMPLEMENT
6429 * flags as appropriate; this function may add
6432 * OPpTRANS_IDENTICAL
6438 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6440 SV * const tstr = ((SVOP*)expr)->op_sv;
6441 SV * const rstr = ((SVOP*)repl)->op_sv;
6444 const U8 *t = (U8*)SvPV_const(tstr, tlen);
6445 const U8 *r = (U8*)SvPV_const(rstr, rlen);
6449 SSize_t struct_size; /* malloced size of table struct */
6451 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6452 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6453 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6456 PERL_ARGS_ASSERT_PMTRANS;
6458 PL_hints |= HINT_BLOCK_SCOPE;
6461 o->op_private |= OPpTRANS_FROM_UTF;
6464 o->op_private |= OPpTRANS_TO_UTF;
6466 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6468 /* for utf8 translations, op_sv will be set to point to a swash
6469 * containing codepoint ranges. This is done by first assembling
6470 * a textual representation of the ranges in listsv then compiling
6471 * it using swash_init(). For more details of the textual format,
6472 * see L<perlunicode.pod/"User-Defined Character Properties"> .
6475 SV* const listsv = newSVpvs("# comment\n");
6477 const U8* tend = t + tlen;
6478 const U8* rend = r + rlen;
6494 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
6495 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
6498 const U32 flags = UTF8_ALLOW_DEFAULT;
6502 t = tsave = bytes_to_utf8(t, &len);
6505 if (!to_utf && rlen) {
6507 r = rsave = bytes_to_utf8(r, &len);
6511 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6512 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6517 * replace t/tlen/tend with a version that has the ranges
6520 U8 tmpbuf[UTF8_MAXBYTES+1];
6523 Newx(cp, 2*tlen, UV);
6525 transv = newSVpvs("");
6527 /* convert search string into array of (start,end) range
6528 * codepoint pairs stored in cp[]. Most "ranges" will start
6529 * and end at the same char */
6531 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6533 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6534 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6536 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6540 cp[2*i+1] = cp[2*i];
6545 /* sort the ranges */
6546 qsort(cp, i, 2*sizeof(UV), uvcompare);
6548 /* Create a utf8 string containing the complement of the
6549 * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6550 * then transv will contain the equivalent of:
6551 * join '', map chr, 0, ILLEGAL_UTF8_BYTE, A - 1,
6552 * B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6553 * D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6554 * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6557 for (j = 0; j < i; j++) {
6559 diff = val - nextmin;
6561 t = uvchr_to_utf8(tmpbuf,nextmin);
6562 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6564 U8 range_mark = ILLEGAL_UTF8_BYTE;
6565 t = uvchr_to_utf8(tmpbuf, val - 1);
6566 sv_catpvn(transv, (char *)&range_mark, 1);
6567 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6575 t = uvchr_to_utf8(tmpbuf,nextmin);
6576 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6578 U8 range_mark = ILLEGAL_UTF8_BYTE;
6579 sv_catpvn(transv, (char *)&range_mark, 1);
6581 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6582 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6583 t = (const U8*)SvPVX_const(transv);
6584 tlen = SvCUR(transv);
6588 else if (!rlen && !del) {
6589 r = t; rlen = tlen; rend = tend;
6593 if ((!rlen && !del) || t == r ||
6594 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6596 o->op_private |= OPpTRANS_IDENTICAL;
6600 /* extract char ranges from t and r and append them to listsv */
6602 while (t < tend || tfirst <= tlast) {
6603 /* see if we need more "t" chars */
6604 if (tfirst > tlast) {
6605 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6607 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6609 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6616 /* now see if we need more "r" chars */
6617 if (rfirst > rlast) {
6619 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6621 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6623 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6632 rfirst = rlast = 0xffffffff;
6636 /* now see which range will peter out first, if either. */
6637 tdiff = tlast - tfirst;
6638 rdiff = rlast - rfirst;
6639 tcount += tdiff + 1;
6640 rcount += rdiff + 1;
6647 if (rfirst == 0xffffffff) {
6648 diff = tdiff; /* oops, pretend rdiff is infinite */
6650 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6651 (long)tfirst, (long)tlast);
6653 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6657 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6658 (long)tfirst, (long)(tfirst + diff),
6661 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6662 (long)tfirst, (long)rfirst);
6664 if (rfirst + diff > max)
6665 max = rfirst + diff;
6667 grows = (tfirst < rfirst &&
6668 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6674 /* compile listsv into a swash and attach to o */
6682 else if (max > 0xff)
6687 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6689 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6690 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6691 PAD_SETSV(cPADOPo->op_padix, swash);
6693 SvREADONLY_on(swash);
6695 cSVOPo->op_sv = swash;
6697 SvREFCNT_dec(listsv);
6698 SvREFCNT_dec(transv);
6700 if (!del && havefinal && rlen)
6701 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6702 newSVuv((UV)final), 0);
6711 else if (rlast == 0xffffffff)
6717 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6718 * table. Entries with the value -1 indicate chars not to be
6719 * translated, while -2 indicates a search char without a
6720 * corresponding replacement char under /d.
6722 * Normally, the table has 256 slots. However, in the presence of
6723 * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6724 * added, and if there are enough replacement chars to start pairing
6725 * with the \x{100},... search chars, then a larger (> 256) table
6728 * In addition, regardless of whether under /c, an extra slot at the
6729 * end is used to store the final repeating char, or -3 under an empty
6730 * replacement list, or -2 under /d; which makes the runtime code
6733 * The toker will have already expanded char ranges in t and r.
6736 /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6737 * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6738 * The OPtrans_map struct already contains one slot; hence the -1.
6740 struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6741 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6743 cPVOPo->op_pv = (char*)tbl;
6748 /* in this branch, j is a count of 'consumed' (i.e. paired off
6749 * with a search char) replacement chars (so j <= rlen always)
6751 for (i = 0; i < tlen; i++)
6752 tbl->map[t[i]] = -1;
6754 for (i = 0, j = 0; i < 256; i++) {
6760 tbl->map[i] = r[j-1];
6762 tbl->map[i] = (short)i;
6765 tbl->map[i] = r[j++];
6767 if ( tbl->map[i] >= 0
6768 && UVCHR_IS_INVARIANT((UV)i)
6769 && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6779 /* More replacement chars than search chars:
6780 * store excess replacement chars at end of main table.
6783 struct_size += excess;
6784 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6785 struct_size + excess * sizeof(short));
6786 tbl->size += excess;
6787 cPVOPo->op_pv = (char*)tbl;
6789 for (i = 0; i < excess; i++)
6790 tbl->map[i + 256] = r[j+i];
6793 /* no more replacement chars than search chars */
6794 if (!rlen && !del && !squash)
6795 o->op_private |= OPpTRANS_IDENTICAL;
6798 tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
6801 if (!rlen && !del) {
6804 o->op_private |= OPpTRANS_IDENTICAL;
6806 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6807 o->op_private |= OPpTRANS_IDENTICAL;
6810 for (i = 0; i < 256; i++)
6812 for (i = 0, j = 0; i < tlen; i++,j++) {
6815 if (tbl->map[t[i]] == -1)
6816 tbl->map[t[i]] = -2;
6821 if (tbl->map[t[i]] == -1) {
6822 if ( UVCHR_IS_INVARIANT(t[i])
6823 && ! UVCHR_IS_INVARIANT(r[j]))
6825 tbl->map[t[i]] = r[j];
6828 tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
6831 /* both non-utf8 and utf8 code paths end up here */
6834 if(del && rlen == tlen) {
6835 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6836 } else if(rlen > tlen && !complement) {
6837 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6841 o->op_private |= OPpTRANS_GROWS;
6850 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6852 Constructs, checks, and returns an op of any pattern matching type.
6853 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
6854 and, shifted up eight bits, the eight bits of C<op_private>.
6860 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6865 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6866 || type == OP_CUSTOM);
6868 NewOp(1101, pmop, 1, PMOP);
6869 OpTYPE_set(pmop, type);
6870 pmop->op_flags = (U8)flags;
6871 pmop->op_private = (U8)(0 | (flags >> 8));
6872 if (PL_opargs[type] & OA_RETSCALAR)
6875 if (PL_hints & HINT_RE_TAINT)
6876 pmop->op_pmflags |= PMf_RETAINT;
6877 #ifdef USE_LOCALE_CTYPE
6878 if (IN_LC_COMPILETIME(LC_CTYPE)) {
6879 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6884 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6886 if (PL_hints & HINT_RE_FLAGS) {
6887 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6888 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6890 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6891 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6892 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6894 if (reflags && SvOK(reflags)) {
6895 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6901 assert(SvPOK(PL_regex_pad[0]));
6902 if (SvCUR(PL_regex_pad[0])) {
6903 /* Pop off the "packed" IV from the end. */
6904 SV *const repointer_list = PL_regex_pad[0];
6905 const char *p = SvEND(repointer_list) - sizeof(IV);
6906 const IV offset = *((IV*)p);
6908 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6910 SvEND_set(repointer_list, p);
6912 pmop->op_pmoffset = offset;
6913 /* This slot should be free, so assert this: */
6914 assert(PL_regex_pad[offset] == &PL_sv_undef);
6916 SV * const repointer = &PL_sv_undef;
6917 av_push(PL_regex_padav, repointer);
6918 pmop->op_pmoffset = av_tindex(PL_regex_padav);
6919 PL_regex_pad = AvARRAY(PL_regex_padav);
6923 return CHECKOP(type, pmop);
6931 /* Any pad names in scope are potentially lvalues. */
6932 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6933 PADNAME *pn = PAD_COMPNAME_SV(i);
6934 if (!pn || !PadnameLEN(pn))
6936 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6937 S_mark_padname_lvalue(aTHX_ pn);
6941 /* Given some sort of match op o, and an expression expr containing a
6942 * pattern, either compile expr into a regex and attach it to o (if it's
6943 * constant), or convert expr into a runtime regcomp op sequence (if it's
6946 * Flags currently has 2 bits of meaning:
6947 * 1: isreg indicates that the pattern is part of a regex construct, eg
6948 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6949 * split "pattern", which aren't. In the former case, expr will be a list
6950 * if the pattern contains more than one term (eg /a$b/).
6951 * 2: The pattern is for a split.
6953 * When the pattern has been compiled within a new anon CV (for
6954 * qr/(?{...})/ ), then floor indicates the savestack level just before
6955 * the new sub was created
6959 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6963 I32 repl_has_vars = 0;
6964 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6965 bool is_compiletime;
6967 bool isreg = cBOOL(flags & 1);
6968 bool is_split = cBOOL(flags & 2);
6970 PERL_ARGS_ASSERT_PMRUNTIME;
6973 return pmtrans(o, expr, repl);
6976 /* find whether we have any runtime or code elements;
6977 * at the same time, temporarily set the op_next of each DO block;
6978 * then when we LINKLIST, this will cause the DO blocks to be excluded
6979 * from the op_next chain (and from having LINKLIST recursively
6980 * applied to them). We fix up the DOs specially later */
6984 if (expr->op_type == OP_LIST) {
6986 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6987 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6989 assert(!o->op_next);
6990 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6991 assert(PL_parser && PL_parser->error_count);
6992 /* This can happen with qr/ (?{(^{})/. Just fake up
6993 the op we were expecting to see, to avoid crashing
6995 op_sibling_splice(expr, o, 0,
6996 newSVOP(OP_CONST, 0, &PL_sv_no));
6998 o->op_next = OpSIBLING(o);
7000 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
7004 else if (expr->op_type != OP_CONST)
7009 /* fix up DO blocks; treat each one as a separate little sub;
7010 * also, mark any arrays as LIST/REF */
7012 if (expr->op_type == OP_LIST) {
7014 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7016 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
7017 assert( !(o->op_flags & OPf_WANT));
7018 /* push the array rather than its contents. The regex
7019 * engine will retrieve and join the elements later */
7020 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
7024 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
7026 o->op_next = NULL; /* undo temporary hack from above */
7029 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
7030 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
7032 assert(leaveop->op_first->op_type == OP_ENTER);
7033 assert(OpHAS_SIBLING(leaveop->op_first));
7034 o->op_next = OpSIBLING(leaveop->op_first);
7036 assert(leaveop->op_flags & OPf_KIDS);
7037 assert(leaveop->op_last->op_next == (OP*)leaveop);
7038 leaveop->op_next = NULL; /* stop on last op */
7039 op_null((OP*)leaveop);
7043 OP *scope = cLISTOPo->op_first;
7044 assert(scope->op_type == OP_SCOPE);
7045 assert(scope->op_flags & OPf_KIDS);
7046 scope->op_next = NULL; /* stop on last op */
7050 /* XXX optimize_optree() must be called on o before
7051 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7052 * currently cope with a peephole-optimised optree.
7053 * Calling optimize_optree() here ensures that condition
7054 * is met, but may mean optimize_optree() is applied
7055 * to the same optree later (where hopefully it won't do any
7056 * harm as it can't convert an op to multiconcat if it's
7057 * already been converted */
7060 /* have to peep the DOs individually as we've removed it from
7061 * the op_next chain */
7063 S_prune_chain_head(&(o->op_next));
7065 /* runtime finalizes as part of finalizing whole tree */
7069 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7070 assert( !(expr->op_flags & OPf_WANT));
7071 /* push the array rather than its contents. The regex
7072 * engine will retrieve and join the elements later */
7073 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7076 PL_hints |= HINT_BLOCK_SCOPE;
7078 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7080 if (is_compiletime) {
7081 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7082 regexp_engine const *eng = current_re_engine();
7085 /* make engine handle split ' ' specially */
7086 pm->op_pmflags |= PMf_SPLIT;
7087 rx_flags |= RXf_SPLIT;
7090 /* Skip compiling if parser found an error for this pattern */
7091 if (pm->op_pmflags & PMf_HAS_ERROR) {
7095 if (!has_code || !eng->op_comp) {
7096 /* compile-time simple constant pattern */
7098 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7099 /* whoops! we guessed that a qr// had a code block, but we
7100 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7101 * that isn't required now. Note that we have to be pretty
7102 * confident that nothing used that CV's pad while the
7103 * regex was parsed, except maybe op targets for \Q etc.
7104 * If there were any op targets, though, they should have
7105 * been stolen by constant folding.
7109 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7110 while (++i <= AvFILLp(PL_comppad)) {
7111 # ifdef USE_PAD_RESET
7112 /* under USE_PAD_RESET, pad swipe replaces a swiped
7113 * folded constant with a fresh padtmp */
7114 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7116 assert(!PL_curpad[i]);
7120 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7121 * outer CV (the one whose slab holds the pm op). The
7122 * inner CV (which holds expr) will be freed later, once
7123 * all the entries on the parse stack have been popped on
7124 * return from this function. Which is why its safe to
7125 * call op_free(expr) below.
7128 pm->op_pmflags &= ~PMf_HAS_CV;
7133 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7134 rx_flags, pm->op_pmflags)
7135 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7136 rx_flags, pm->op_pmflags)
7141 /* compile-time pattern that includes literal code blocks */
7142 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7145 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7148 if (pm->op_pmflags & PMf_HAS_CV) {
7150 /* this QR op (and the anon sub we embed it in) is never
7151 * actually executed. It's just a placeholder where we can
7152 * squirrel away expr in op_code_list without the peephole
7153 * optimiser etc processing it for a second time */
7154 OP *qr = newPMOP(OP_QR, 0);
7155 ((PMOP*)qr)->op_code_list = expr;
7157 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7158 SvREFCNT_inc_simple_void(PL_compcv);
7159 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7160 ReANY(re)->qr_anoncv = cv;
7162 /* attach the anon CV to the pad so that
7163 * pad_fixup_inner_anons() can find it */
7164 (void)pad_add_anon(cv, o->op_type);
7165 SvREFCNT_inc_simple_void(cv);
7168 pm->op_code_list = expr;
7173 /* runtime pattern: build chain of regcomp etc ops */
7175 PADOFFSET cv_targ = 0;
7177 reglist = isreg && expr->op_type == OP_LIST;
7182 pm->op_code_list = expr;
7183 /* don't free op_code_list; its ops are embedded elsewhere too */
7184 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7188 /* make engine handle split ' ' specially */
7189 pm->op_pmflags |= PMf_SPLIT;
7191 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7192 * to allow its op_next to be pointed past the regcomp and
7193 * preceding stacking ops;
7194 * OP_REGCRESET is there to reset taint before executing the
7196 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7197 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7199 if (pm->op_pmflags & PMf_HAS_CV) {
7200 /* we have a runtime qr with literal code. This means
7201 * that the qr// has been wrapped in a new CV, which
7202 * means that runtime consts, vars etc will have been compiled
7203 * against a new pad. So... we need to execute those ops
7204 * within the environment of the new CV. So wrap them in a call
7205 * to a new anon sub. i.e. for
7209 * we build an anon sub that looks like
7211 * sub { "a", $b, '(?{...})' }
7213 * and call it, passing the returned list to regcomp.
7214 * Or to put it another way, the list of ops that get executed
7218 * ------ -------------------
7219 * pushmark (for regcomp)
7220 * pushmark (for entersub)
7224 * regcreset regcreset
7226 * const("a") const("a")
7228 * const("(?{...})") const("(?{...})")
7233 SvREFCNT_inc_simple_void(PL_compcv);
7234 CvLVALUE_on(PL_compcv);
7235 /* these lines are just an unrolled newANONATTRSUB */
7236 expr = newSVOP(OP_ANONCODE, 0,
7237 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7238 cv_targ = expr->op_targ;
7239 expr = newUNOP(OP_REFGEN, 0, expr);
7241 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7244 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7245 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7246 | (reglist ? OPf_STACKED : 0);
7247 rcop->op_targ = cv_targ;
7249 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
7250 if (PL_hints & HINT_RE_EVAL)
7251 S_set_haseval(aTHX);
7253 /* establish postfix order */
7254 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7256 rcop->op_next = expr;
7257 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7260 rcop->op_next = LINKLIST(expr);
7261 expr->op_next = (OP*)rcop;
7264 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7270 /* If we are looking at s//.../e with a single statement, get past
7271 the implicit do{}. */
7272 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7273 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7274 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7277 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7278 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7279 && !OpHAS_SIBLING(sib))
7282 if (curop->op_type == OP_CONST)
7284 else if (( (curop->op_type == OP_RV2SV ||
7285 curop->op_type == OP_RV2AV ||
7286 curop->op_type == OP_RV2HV ||
7287 curop->op_type == OP_RV2GV)
7288 && cUNOPx(curop)->op_first
7289 && cUNOPx(curop)->op_first->op_type == OP_GV )
7290 || curop->op_type == OP_PADSV
7291 || curop->op_type == OP_PADAV
7292 || curop->op_type == OP_PADHV
7293 || curop->op_type == OP_PADANY) {
7301 || !RX_PRELEN(PM_GETRE(pm))
7302 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7304 pm->op_pmflags |= PMf_CONST; /* const for long enough */
7305 op_prepend_elem(o->op_type, scalar(repl), o);
7308 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7309 rcop->op_private = 1;
7311 /* establish postfix order */
7312 rcop->op_next = LINKLIST(repl);
7313 repl->op_next = (OP*)rcop;
7315 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7316 assert(!(pm->op_pmflags & PMf_ONCE));
7317 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7326 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7328 Constructs, checks, and returns an op of any type that involves an
7329 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
7330 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
7331 takes ownership of one reference to it.
7337 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7342 PERL_ARGS_ASSERT_NEWSVOP;
7344 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7345 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7346 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7347 || type == OP_CUSTOM);
7349 NewOp(1101, svop, 1, SVOP);
7350 OpTYPE_set(svop, type);
7352 svop->op_next = (OP*)svop;
7353 svop->op_flags = (U8)flags;
7354 svop->op_private = (U8)(0 | (flags >> 8));
7355 if (PL_opargs[type] & OA_RETSCALAR)
7357 if (PL_opargs[type] & OA_TARGET)
7358 svop->op_targ = pad_alloc(type, SVs_PADTMP);
7359 return CHECKOP(type, svop);
7363 =for apidoc Am|OP *|newDEFSVOP|
7365 Constructs and returns an op to access C<$_>.
7371 Perl_newDEFSVOP(pTHX)
7373 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7379 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7381 Constructs, checks, and returns an op of any type that involves a
7382 reference to a pad element. C<type> is the opcode. C<flags> gives the
7383 eight bits of C<op_flags>. A pad slot is automatically allocated, and
7384 is populated with C<sv>; this function takes ownership of one reference
7387 This function only exists if Perl has been compiled to use ithreads.
7393 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7398 PERL_ARGS_ASSERT_NEWPADOP;
7400 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7401 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7402 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7403 || type == OP_CUSTOM);
7405 NewOp(1101, padop, 1, PADOP);
7406 OpTYPE_set(padop, type);
7408 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7409 SvREFCNT_dec(PAD_SVl(padop->op_padix));
7410 PAD_SETSV(padop->op_padix, sv);
7412 padop->op_next = (OP*)padop;
7413 padop->op_flags = (U8)flags;
7414 if (PL_opargs[type] & OA_RETSCALAR)
7416 if (PL_opargs[type] & OA_TARGET)
7417 padop->op_targ = pad_alloc(type, SVs_PADTMP);
7418 return CHECKOP(type, padop);
7421 #endif /* USE_ITHREADS */
7424 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7426 Constructs, checks, and returns an op of any type that involves an
7427 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
7428 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
7429 reference; calling this function does not transfer ownership of any
7436 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7438 PERL_ARGS_ASSERT_NEWGVOP;
7441 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7443 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7448 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7450 Constructs, checks, and returns an op of any type that involves an
7451 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
7452 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
7453 Depending on the op type, the memory referenced by C<pv> may be freed
7454 when the op is destroyed. If the op is of a freeing type, C<pv> must
7455 have been allocated using C<PerlMemShared_malloc>.
7461 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7464 const bool utf8 = cBOOL(flags & SVf_UTF8);
7469 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7470 || type == OP_RUNCV || type == OP_CUSTOM
7471 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7473 NewOp(1101, pvop, 1, PVOP);
7474 OpTYPE_set(pvop, type);
7476 pvop->op_next = (OP*)pvop;
7477 pvop->op_flags = (U8)flags;
7478 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7479 if (PL_opargs[type] & OA_RETSCALAR)
7481 if (PL_opargs[type] & OA_TARGET)
7482 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7483 return CHECKOP(type, pvop);
7487 Perl_package(pTHX_ OP *o)
7489 SV *const sv = cSVOPo->op_sv;
7491 PERL_ARGS_ASSERT_PACKAGE;
7493 SAVEGENERICSV(PL_curstash);
7494 save_item(PL_curstname);
7496 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7498 sv_setsv(PL_curstname, sv);
7500 PL_hints |= HINT_BLOCK_SCOPE;
7501 PL_parser->copline = NOLINE;
7507 Perl_package_version( pTHX_ OP *v )
7509 U32 savehints = PL_hints;
7510 PERL_ARGS_ASSERT_PACKAGE_VERSION;
7511 PL_hints &= ~HINT_STRICT_VARS;
7512 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7513 PL_hints = savehints;
7518 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7523 SV *use_version = NULL;
7525 PERL_ARGS_ASSERT_UTILIZE;
7527 if (idop->op_type != OP_CONST)
7528 Perl_croak(aTHX_ "Module name must be constant");
7533 SV * const vesv = ((SVOP*)version)->op_sv;
7535 if (!arg && !SvNIOKp(vesv)) {
7542 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7543 Perl_croak(aTHX_ "Version number must be a constant number");
7545 /* Make copy of idop so we don't free it twice */
7546 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7548 /* Fake up a method call to VERSION */
7549 meth = newSVpvs_share("VERSION");
7550 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7551 op_append_elem(OP_LIST,
7552 op_prepend_elem(OP_LIST, pack, version),
7553 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7557 /* Fake up an import/unimport */
7558 if (arg && arg->op_type == OP_STUB) {
7559 imop = arg; /* no import on explicit () */
7561 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7562 imop = NULL; /* use 5.0; */
7564 use_version = ((SVOP*)idop)->op_sv;
7566 idop->op_private |= OPpCONST_NOVER;
7571 /* Make copy of idop so we don't free it twice */
7572 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7574 /* Fake up a method call to import/unimport */
7576 ? newSVpvs_share("import") : newSVpvs_share("unimport");
7577 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7578 op_append_elem(OP_LIST,
7579 op_prepend_elem(OP_LIST, pack, arg),
7580 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7584 /* Fake up the BEGIN {}, which does its thing immediately. */
7586 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7589 op_append_elem(OP_LINESEQ,
7590 op_append_elem(OP_LINESEQ,
7591 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7592 newSTATEOP(0, NULL, veop)),
7593 newSTATEOP(0, NULL, imop) ));
7597 * feature bundle that corresponds to the required version. */
7598 use_version = sv_2mortal(new_version(use_version));
7599 S_enable_feature_bundle(aTHX_ use_version);
7601 /* If a version >= 5.11.0 is requested, strictures are on by default! */
7602 if (vcmp(use_version,
7603 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7604 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7605 PL_hints |= HINT_STRICT_REFS;
7606 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7607 PL_hints |= HINT_STRICT_SUBS;
7608 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7609 PL_hints |= HINT_STRICT_VARS;
7611 /* otherwise they are off */
7613 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7614 PL_hints &= ~HINT_STRICT_REFS;
7615 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7616 PL_hints &= ~HINT_STRICT_SUBS;
7617 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7618 PL_hints &= ~HINT_STRICT_VARS;
7622 /* The "did you use incorrect case?" warning used to be here.
7623 * The problem is that on case-insensitive filesystems one
7624 * might get false positives for "use" (and "require"):
7625 * "use Strict" or "require CARP" will work. This causes
7626 * portability problems for the script: in case-strict
7627 * filesystems the script will stop working.
7629 * The "incorrect case" warning checked whether "use Foo"
7630 * imported "Foo" to your namespace, but that is wrong, too:
7631 * there is no requirement nor promise in the language that
7632 * a Foo.pm should or would contain anything in package "Foo".
7634 * There is very little Configure-wise that can be done, either:
7635 * the case-sensitivity of the build filesystem of Perl does not
7636 * help in guessing the case-sensitivity of the runtime environment.
7639 PL_hints |= HINT_BLOCK_SCOPE;
7640 PL_parser->copline = NOLINE;
7641 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7645 =head1 Embedding Functions
7647 =for apidoc load_module
7649 Loads the module whose name is pointed to by the string part of C<name>.
7650 Note that the actual module name, not its filename, should be given.
7651 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7652 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7653 trailing arguments can be used to specify arguments to the module's C<import()>
7654 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7655 on the flags. The flags argument is a bitwise-ORed collection of any of
7656 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7657 (or 0 for no flags).
7659 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7660 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7661 the trailing optional arguments may be omitted entirely. Otherwise, if
7662 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7663 exactly one C<OP*>, containing the op tree that produces the relevant import
7664 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7665 will be used as import arguments; and the list must be terminated with C<(SV*)
7666 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7667 set, the trailing C<NULL> pointer is needed even if no import arguments are
7668 desired. The reference count for each specified C<SV*> argument is
7669 decremented. In addition, the C<name> argument is modified.
7671 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7677 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7681 PERL_ARGS_ASSERT_LOAD_MODULE;
7683 va_start(args, ver);
7684 vload_module(flags, name, ver, &args);
7688 #ifdef PERL_IMPLICIT_CONTEXT
7690 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7694 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7695 va_start(args, ver);
7696 vload_module(flags, name, ver, &args);
7702 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7705 OP * const modname = newSVOP(OP_CONST, 0, name);
7707 PERL_ARGS_ASSERT_VLOAD_MODULE;
7709 modname->op_private |= OPpCONST_BARE;
7711 veop = newSVOP(OP_CONST, 0, ver);
7715 if (flags & PERL_LOADMOD_NOIMPORT) {
7716 imop = sawparens(newNULLLIST());
7718 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7719 imop = va_arg(*args, OP*);
7724 sv = va_arg(*args, SV*);
7726 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7727 sv = va_arg(*args, SV*);
7731 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7732 * that it has a PL_parser to play with while doing that, and also
7733 * that it doesn't mess with any existing parser, by creating a tmp
7734 * new parser with lex_start(). This won't actually be used for much,
7735 * since pp_require() will create another parser for the real work.
7736 * The ENTER/LEAVE pair protect callers from any side effects of use. */
7739 SAVEVPTR(PL_curcop);
7740 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7741 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
7742 veop, modname, imop);
7746 PERL_STATIC_INLINE OP *
7747 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7749 return newUNOP(OP_ENTERSUB, OPf_STACKED,
7750 newLISTOP(OP_LIST, 0, arg,
7751 newUNOP(OP_RV2CV, 0,
7752 newGVOP(OP_GV, 0, gv))));
7756 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7761 PERL_ARGS_ASSERT_DOFILE;
7763 if (!force_builtin && (gv = gv_override("do", 2))) {
7764 doop = S_new_entersubop(aTHX_ gv, term);
7767 doop = newUNOP(OP_DOFILE, 0, scalar(term));
7773 =head1 Optree construction
7775 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7777 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
7778 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7779 be set automatically, and, shifted up eight bits, the eight bits of
7780 C<op_private>, except that the bit with value 1 or 2 is automatically
7781 set as required. C<listval> and C<subscript> supply the parameters of
7782 the slice; they are consumed by this function and become part of the
7783 constructed op tree.
7789 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7791 return newBINOP(OP_LSLICE, flags,
7792 list(force_list(subscript, 1)),
7793 list(force_list(listval, 1)) );
7796 #define ASSIGN_LIST 1
7797 #define ASSIGN_REF 2
7800 S_assignment_type(pTHX_ const OP *o)
7809 if (o->op_type == OP_SREFGEN)
7811 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7812 type = kid->op_type;
7813 flags = o->op_flags | kid->op_flags;
7814 if (!(flags & OPf_PARENS)
7815 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7816 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7820 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7821 o = cUNOPo->op_first;
7822 flags = o->op_flags;
7827 if (type == OP_COND_EXPR) {
7828 OP * const sib = OpSIBLING(cLOGOPo->op_first);
7829 const I32 t = assignment_type(sib);
7830 const I32 f = assignment_type(OpSIBLING(sib));
7832 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7834 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7835 yyerror("Assignment to both a list and a scalar");
7839 if (type == OP_LIST &&
7840 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7841 o->op_private & OPpLVAL_INTRO)
7844 if (type == OP_LIST || flags & OPf_PARENS ||
7845 type == OP_RV2AV || type == OP_RV2HV ||
7846 type == OP_ASLICE || type == OP_HSLICE ||
7847 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7850 if (type == OP_PADAV || type == OP_PADHV)
7853 if (type == OP_RV2SV)
7860 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7863 const PADOFFSET target = padop->op_targ;
7864 OP *const other = newOP(OP_PADSV,
7866 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7867 OP *const first = newOP(OP_NULL, 0);
7868 OP *const nullop = newCONDOP(0, first, initop, other);
7869 /* XXX targlex disabled for now; see ticket #124160
7870 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7872 OP *const condop = first->op_next;
7874 OpTYPE_set(condop, OP_ONCE);
7875 other->op_targ = target;
7876 nullop->op_flags |= OPf_WANT_SCALAR;
7878 /* Store the initializedness of state vars in a separate
7881 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7882 /* hijacking PADSTALE for uninitialized state variables */
7883 SvPADSTALE_on(PAD_SVl(condop->op_targ));
7889 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7891 Constructs, checks, and returns an assignment op. C<left> and C<right>
7892 supply the parameters of the assignment; they are consumed by this
7893 function and become part of the constructed op tree.
7895 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7896 a suitable conditional optree is constructed. If C<optype> is the opcode
7897 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7898 performs the binary operation and assigns the result to the left argument.
7899 Either way, if C<optype> is non-zero then C<flags> has no effect.
7901 If C<optype> is zero, then a plain scalar or list assignment is
7902 constructed. Which type of assignment it is is automatically determined.
7903 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7904 will be set automatically, and, shifted up eight bits, the eight bits
7905 of C<op_private>, except that the bit with value 1 or 2 is automatically
7912 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7918 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7919 right = scalar(right);
7920 return newLOGOP(optype, 0,
7921 op_lvalue(scalar(left), optype),
7922 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7925 return newBINOP(optype, OPf_STACKED,
7926 op_lvalue(scalar(left), optype), scalar(right));
7930 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7931 OP *state_var_op = NULL;
7932 static const char no_list_state[] = "Initialization of state variables"
7933 " in list currently forbidden";
7936 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7937 left->op_private &= ~ OPpSLICEWARNING;
7940 left = op_lvalue(left, OP_AASSIGN);
7941 curop = list(force_list(left, 1));
7942 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7943 o->op_private = (U8)(0 | (flags >> 8));
7945 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7947 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7948 if (!(left->op_flags & OPf_PARENS) &&
7949 lop->op_type == OP_PUSHMARK &&
7950 (vop = OpSIBLING(lop)) &&
7951 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7952 !(vop->op_flags & OPf_PARENS) &&
7953 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7954 (OPpLVAL_INTRO|OPpPAD_STATE) &&
7955 (eop = OpSIBLING(vop)) &&
7956 eop->op_type == OP_ENTERSUB &&
7957 !OpHAS_SIBLING(eop)) {
7961 if ((lop->op_type == OP_PADSV ||
7962 lop->op_type == OP_PADAV ||
7963 lop->op_type == OP_PADHV ||
7964 lop->op_type == OP_PADANY)
7965 && (lop->op_private & OPpPAD_STATE)
7967 yyerror(no_list_state);
7968 lop = OpSIBLING(lop);
7972 else if ( (left->op_private & OPpLVAL_INTRO)
7973 && (left->op_private & OPpPAD_STATE)
7974 && ( left->op_type == OP_PADSV
7975 || left->op_type == OP_PADAV
7976 || left->op_type == OP_PADHV
7977 || left->op_type == OP_PADANY)
7979 /* All single variable list context state assignments, hence
7989 if (left->op_flags & OPf_PARENS)
7990 yyerror(no_list_state);
7992 state_var_op = left;
7995 /* optimise @a = split(...) into:
7996 * @{expr}: split(..., @{expr}) (where @a is not flattened)
7997 * @a, my @a, local @a: split(...) (where @a is attached to
7998 * the split op itself)
8002 && right->op_type == OP_SPLIT
8003 /* don't do twice, e.g. @b = (@a = split) */
8004 && !(right->op_private & OPpSPLIT_ASSIGN))
8008 if ( ( left->op_type == OP_RV2AV
8009 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
8010 || left->op_type == OP_PADAV)
8012 /* @pkg or @lex or local @pkg' or 'my @lex' */
8016 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
8017 = cPADOPx(gvop)->op_padix;
8018 cPADOPx(gvop)->op_padix = 0; /* steal it */
8020 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
8021 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8022 cSVOPx(gvop)->op_sv = NULL; /* steal it */
8024 right->op_private |=
8025 left->op_private & OPpOUR_INTRO;
8028 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8029 left->op_targ = 0; /* steal it */
8030 right->op_private |= OPpSPLIT_LEX;
8032 right->op_private |= left->op_private & OPpLVAL_INTRO;
8035 tmpop = cUNOPo->op_first; /* to list (nulled) */
8036 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
8037 assert(OpSIBLING(tmpop) == right);
8038 assert(!OpHAS_SIBLING(right));
8039 /* detach the split subtreee from the o tree,
8040 * then free the residual o tree */
8041 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8042 op_free(o); /* blow off assign */
8043 right->op_private |= OPpSPLIT_ASSIGN;
8044 right->op_flags &= ~OPf_WANT;
8045 /* "I don't know and I don't care." */
8048 else if (left->op_type == OP_RV2AV) {
8051 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8052 assert(OpSIBLING(pushop) == left);
8053 /* Detach the array ... */
8054 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8055 /* ... and attach it to the split. */
8056 op_sibling_splice(right, cLISTOPx(right)->op_last,
8058 right->op_flags |= OPf_STACKED;
8059 /* Detach split and expunge aassign as above. */
8062 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8063 ((LISTOP*)right)->op_last->op_type == OP_CONST)
8065 /* convert split(...,0) to split(..., PL_modcount+1) */
8067 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8068 SV * const sv = *svp;
8069 if (SvIOK(sv) && SvIVX(sv) == 0)
8071 if (right->op_private & OPpSPLIT_IMPLIM) {
8072 /* our own SV, created in ck_split */
8074 sv_setiv(sv, PL_modcount+1);
8077 /* SV may belong to someone else */
8079 *svp = newSViv(PL_modcount+1);
8086 o = S_newONCEOP(aTHX_ o, state_var_op);
8089 if (assign_type == ASSIGN_REF)
8090 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8092 right = newOP(OP_UNDEF, 0);
8093 if (right->op_type == OP_READLINE) {
8094 right->op_flags |= OPf_STACKED;
8095 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8099 o = newBINOP(OP_SASSIGN, flags,
8100 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8106 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
8108 Constructs a state op (COP). The state op is normally a C<nextstate> op,
8109 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8110 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8111 If C<label> is non-null, it supplies the name of a label to attach to
8112 the state op; this function takes ownership of the memory pointed at by
8113 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
8116 If C<o> is null, the state op is returned. Otherwise the state op is
8117 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
8118 is consumed by this function and becomes part of the returned op tree.
8124 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8127 const U32 seq = intro_my();
8128 const U32 utf8 = flags & SVf_UTF8;
8131 PL_parser->parsed_sub = 0;
8135 NewOp(1101, cop, 1, COP);
8136 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8137 OpTYPE_set(cop, OP_DBSTATE);
8140 OpTYPE_set(cop, OP_NEXTSTATE);
8142 cop->op_flags = (U8)flags;
8143 CopHINTS_set(cop, PL_hints);
8145 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8147 cop->op_next = (OP*)cop;
8150 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8151 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8153 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8155 PL_hints |= HINT_BLOCK_SCOPE;
8156 /* It seems that we need to defer freeing this pointer, as other parts
8157 of the grammar end up wanting to copy it after this op has been
8162 if (PL_parser->preambling != NOLINE) {
8163 CopLINE_set(cop, PL_parser->preambling);
8164 PL_parser->copline = NOLINE;
8166 else if (PL_parser->copline == NOLINE)
8167 CopLINE_set(cop, CopLINE(PL_curcop));
8169 CopLINE_set(cop, PL_parser->copline);
8170 PL_parser->copline = NOLINE;
8173 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
8175 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8177 CopSTASH_set(cop, PL_curstash);
8179 if (cop->op_type == OP_DBSTATE) {
8180 /* this line can have a breakpoint - store the cop in IV */
8181 AV *av = CopFILEAVx(PL_curcop);
8183 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8184 if (svp && *svp != &PL_sv_undef ) {
8185 (void)SvIOK_on(*svp);
8186 SvIV_set(*svp, PTR2IV(cop));
8191 if (flags & OPf_SPECIAL)
8193 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8197 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
8199 Constructs, checks, and returns a logical (flow control) op. C<type>
8200 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
8201 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8202 the eight bits of C<op_private>, except that the bit with value 1 is
8203 automatically set. C<first> supplies the expression controlling the
8204 flow, and C<other> supplies the side (alternate) chain of ops; they are
8205 consumed by this function and become part of the constructed op tree.
8211 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8213 PERL_ARGS_ASSERT_NEWLOGOP;
8215 return new_logop(type, flags, &first, &other);
8219 S_search_const(pTHX_ OP *o)
8221 PERL_ARGS_ASSERT_SEARCH_CONST;
8223 switch (o->op_type) {
8227 if (o->op_flags & OPf_KIDS)
8228 return search_const(cUNOPo->op_first);
8235 if (!(o->op_flags & OPf_KIDS))
8237 kid = cLISTOPo->op_first;
8239 switch (kid->op_type) {
8243 kid = OpSIBLING(kid);
8246 if (kid != cLISTOPo->op_last)
8252 kid = cLISTOPo->op_last;
8254 return search_const(kid);
8262 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8270 int prepend_not = 0;
8272 PERL_ARGS_ASSERT_NEW_LOGOP;
8277 /* [perl #59802]: Warn about things like "return $a or $b", which
8278 is parsed as "(return $a) or $b" rather than "return ($a or
8279 $b)". NB: This also applies to xor, which is why we do it
8282 switch (first->op_type) {
8286 /* XXX: Perhaps we should emit a stronger warning for these.
8287 Even with the high-precedence operator they don't seem to do
8290 But until we do, fall through here.
8296 /* XXX: Currently we allow people to "shoot themselves in the
8297 foot" by explicitly writing "(return $a) or $b".
8299 Warn unless we are looking at the result from folding or if
8300 the programmer explicitly grouped the operators like this.
8301 The former can occur with e.g.
8303 use constant FEATURE => ( $] >= ... );
8304 sub { not FEATURE and return or do_stuff(); }
8306 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8307 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8308 "Possible precedence issue with control flow operator");
8309 /* XXX: Should we optimze this to "return $a;" (i.e. remove
8315 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8316 return newBINOP(type, flags, scalar(first), scalar(other));
8318 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8319 || type == OP_CUSTOM);
8321 scalarboolean(first);
8323 /* search for a constant op that could let us fold the test */
8324 if ((cstop = search_const(first))) {
8325 if (cstop->op_private & OPpCONST_STRICT)
8326 no_bareword_allowed(cstop);
8327 else if ((cstop->op_private & OPpCONST_BARE))
8328 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8329 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
8330 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8331 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8332 /* Elide the (constant) lhs, since it can't affect the outcome */
8334 if (other->op_type == OP_CONST)
8335 other->op_private |= OPpCONST_SHORTCIRCUIT;
8337 if (other->op_type == OP_LEAVE)
8338 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8339 else if (other->op_type == OP_MATCH
8340 || other->op_type == OP_SUBST
8341 || other->op_type == OP_TRANSR
8342 || other->op_type == OP_TRANS)
8343 /* Mark the op as being unbindable with =~ */
8344 other->op_flags |= OPf_SPECIAL;
8346 other->op_folded = 1;
8350 /* Elide the rhs, since the outcome is entirely determined by
8351 * the (constant) lhs */
8353 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8354 const OP *o2 = other;
8355 if ( ! (o2->op_type == OP_LIST
8356 && (( o2 = cUNOPx(o2)->op_first))
8357 && o2->op_type == OP_PUSHMARK
8358 && (( o2 = OpSIBLING(o2))) )
8361 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8362 || o2->op_type == OP_PADHV)
8363 && o2->op_private & OPpLVAL_INTRO
8364 && !(o2->op_private & OPpPAD_STATE))
8366 Perl_croak(aTHX_ "This use of my() in false conditional is "
8367 "no longer allowed");
8371 if (cstop->op_type == OP_CONST)
8372 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8377 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8378 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8380 const OP * const k1 = ((UNOP*)first)->op_first;
8381 const OP * const k2 = OpSIBLING(k1);
8383 switch (first->op_type)
8386 if (k2 && k2->op_type == OP_READLINE
8387 && (k2->op_flags & OPf_STACKED)
8388 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8390 warnop = k2->op_type;
8395 if (k1->op_type == OP_READDIR
8396 || k1->op_type == OP_GLOB
8397 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8398 || k1->op_type == OP_EACH
8399 || k1->op_type == OP_AEACH)
8401 warnop = ((k1->op_type == OP_NULL)
8402 ? (OPCODE)k1->op_targ : k1->op_type);
8407 const line_t oldline = CopLINE(PL_curcop);
8408 /* This ensures that warnings are reported at the first line
8409 of the construction, not the last. */
8410 CopLINE_set(PL_curcop, PL_parser->copline);
8411 Perl_warner(aTHX_ packWARN(WARN_MISC),
8412 "Value of %s%s can be \"0\"; test with defined()",
8414 ((warnop == OP_READLINE || warnop == OP_GLOB)
8415 ? " construct" : "() operator"));
8416 CopLINE_set(PL_curcop, oldline);
8420 /* optimize AND and OR ops that have NOTs as children */
8421 if (first->op_type == OP_NOT
8422 && (first->op_flags & OPf_KIDS)
8423 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8424 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8426 if (type == OP_AND || type == OP_OR) {
8432 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8434 prepend_not = 1; /* prepend a NOT op later */
8439 logop = alloc_LOGOP(type, first, LINKLIST(other));
8440 logop->op_flags |= (U8)flags;
8441 logop->op_private = (U8)(1 | (flags >> 8));
8443 /* establish postfix order */
8444 logop->op_next = LINKLIST(first);
8445 first->op_next = (OP*)logop;
8446 assert(!OpHAS_SIBLING(first));
8447 op_sibling_splice((OP*)logop, first, 0, other);
8449 CHECKOP(type,logop);
8451 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8452 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8460 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8462 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8463 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8464 will be set automatically, and, shifted up eight bits, the eight bits of
8465 C<op_private>, except that the bit with value 1 is automatically set.
8466 C<first> supplies the expression selecting between the two branches,
8467 and C<trueop> and C<falseop> supply the branches; they are consumed by
8468 this function and become part of the constructed op tree.
8474 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8482 PERL_ARGS_ASSERT_NEWCONDOP;
8485 return newLOGOP(OP_AND, 0, first, trueop);
8487 return newLOGOP(OP_OR, 0, first, falseop);
8489 scalarboolean(first);
8490 if ((cstop = search_const(first))) {
8491 /* Left or right arm of the conditional? */
8492 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8493 OP *live = left ? trueop : falseop;
8494 OP *const dead = left ? falseop : trueop;
8495 if (cstop->op_private & OPpCONST_BARE &&
8496 cstop->op_private & OPpCONST_STRICT) {
8497 no_bareword_allowed(cstop);
8501 if (live->op_type == OP_LEAVE)
8502 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8503 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8504 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8505 /* Mark the op as being unbindable with =~ */
8506 live->op_flags |= OPf_SPECIAL;
8507 live->op_folded = 1;
8510 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8511 logop->op_flags |= (U8)flags;
8512 logop->op_private = (U8)(1 | (flags >> 8));
8513 logop->op_next = LINKLIST(falseop);
8515 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8518 /* establish postfix order */
8519 start = LINKLIST(first);
8520 first->op_next = (OP*)logop;
8522 /* make first, trueop, falseop siblings */
8523 op_sibling_splice((OP*)logop, first, 0, trueop);
8524 op_sibling_splice((OP*)logop, trueop, 0, falseop);
8526 o = newUNOP(OP_NULL, 0, (OP*)logop);
8528 trueop->op_next = falseop->op_next = o;
8535 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8537 Constructs and returns a C<range> op, with subordinate C<flip> and
8538 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
8539 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8540 for both the C<flip> and C<range> ops, except that the bit with value
8541 1 is automatically set. C<left> and C<right> supply the expressions
8542 controlling the endpoints of the range; they are consumed by this function
8543 and become part of the constructed op tree.
8549 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8557 PERL_ARGS_ASSERT_NEWRANGE;
8559 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8560 range->op_flags = OPf_KIDS;
8561 leftstart = LINKLIST(left);
8562 range->op_private = (U8)(1 | (flags >> 8));
8564 /* make left and right siblings */
8565 op_sibling_splice((OP*)range, left, 0, right);
8567 range->op_next = (OP*)range;
8568 flip = newUNOP(OP_FLIP, flags, (OP*)range);
8569 flop = newUNOP(OP_FLOP, 0, flip);
8570 o = newUNOP(OP_NULL, 0, flop);
8572 range->op_next = leftstart;
8574 left->op_next = flip;
8575 right->op_next = flop;
8578 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8579 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8581 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8582 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8583 SvPADTMP_on(PAD_SV(flip->op_targ));
8585 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8586 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8588 /* check barewords before they might be optimized aways */
8589 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8590 no_bareword_allowed(left);
8591 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8592 no_bareword_allowed(right);
8595 if (!flip->op_private || !flop->op_private)
8596 LINKLIST(o); /* blow off optimizer unless constant */
8602 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8604 Constructs, checks, and returns an op tree expressing a loop. This is
8605 only a loop in the control flow through the op tree; it does not have
8606 the heavyweight loop structure that allows exiting the loop by C<last>
8607 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
8608 top-level op, except that some bits will be set automatically as required.
8609 C<expr> supplies the expression controlling loop iteration, and C<block>
8610 supplies the body of the loop; they are consumed by this function and
8611 become part of the constructed op tree. C<debuggable> is currently
8612 unused and should always be 1.
8618 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8622 const bool once = block && block->op_flags & OPf_SPECIAL &&
8623 block->op_type == OP_NULL;
8625 PERL_UNUSED_ARG(debuggable);
8629 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8630 || ( expr->op_type == OP_NOT
8631 && cUNOPx(expr)->op_first->op_type == OP_CONST
8632 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8635 /* Return the block now, so that S_new_logop does not try to
8637 return block; /* do {} while 0 does once */
8638 if (expr->op_type == OP_READLINE
8639 || expr->op_type == OP_READDIR
8640 || expr->op_type == OP_GLOB
8641 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8642 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8643 expr = newUNOP(OP_DEFINED, 0,
8644 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8645 } else if (expr->op_flags & OPf_KIDS) {
8646 const OP * const k1 = ((UNOP*)expr)->op_first;
8647 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8648 switch (expr->op_type) {
8650 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8651 && (k2->op_flags & OPf_STACKED)
8652 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8653 expr = newUNOP(OP_DEFINED, 0, expr);
8657 if (k1 && (k1->op_type == OP_READDIR
8658 || k1->op_type == OP_GLOB
8659 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8660 || k1->op_type == OP_EACH
8661 || k1->op_type == OP_AEACH))
8662 expr = newUNOP(OP_DEFINED, 0, expr);
8668 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8669 * op, in listop. This is wrong. [perl #27024] */
8671 block = newOP(OP_NULL, 0);
8672 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8673 o = new_logop(OP_AND, 0, &expr, &listop);
8680 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8682 if (once && o != listop)
8684 assert(cUNOPo->op_first->op_type == OP_AND
8685 || cUNOPo->op_first->op_type == OP_OR);
8686 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8690 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
8692 o->op_flags |= flags;
8694 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8699 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8701 Constructs, checks, and returns an op tree expressing a C<while> loop.
8702 This is a heavyweight loop, with structure that allows exiting the loop
8703 by C<last> and suchlike.
8705 C<loop> is an optional preconstructed C<enterloop> op to use in the
8706 loop; if it is null then a suitable op will be constructed automatically.
8707 C<expr> supplies the loop's controlling expression. C<block> supplies the
8708 main body of the loop, and C<cont> optionally supplies a C<continue> block
8709 that operates as a second half of the body. All of these optree inputs
8710 are consumed by this function and become part of the constructed op tree.
8712 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8713 op and, shifted up eight bits, the eight bits of C<op_private> for
8714 the C<leaveloop> op, except that (in both cases) some bits will be set
8715 automatically. C<debuggable> is currently unused and should always be 1.
8716 C<has_my> can be supplied as true to force the
8717 loop body to be enclosed in its own scope.
8723 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8724 OP *expr, OP *block, OP *cont, I32 has_my)
8733 PERL_UNUSED_ARG(debuggable);
8736 if (expr->op_type == OP_READLINE
8737 || expr->op_type == OP_READDIR
8738 || expr->op_type == OP_GLOB
8739 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8740 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8741 expr = newUNOP(OP_DEFINED, 0,
8742 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8743 } else if (expr->op_flags & OPf_KIDS) {
8744 const OP * const k1 = ((UNOP*)expr)->op_first;
8745 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8746 switch (expr->op_type) {
8748 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8749 && (k2->op_flags & OPf_STACKED)
8750 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8751 expr = newUNOP(OP_DEFINED, 0, expr);
8755 if (k1 && (k1->op_type == OP_READDIR
8756 || k1->op_type == OP_GLOB
8757 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8758 || k1->op_type == OP_EACH
8759 || k1->op_type == OP_AEACH))
8760 expr = newUNOP(OP_DEFINED, 0, expr);
8767 block = newOP(OP_NULL, 0);
8768 else if (cont || has_my) {
8769 block = op_scope(block);
8773 next = LINKLIST(cont);
8776 OP * const unstack = newOP(OP_UNSTACK, 0);
8779 cont = op_append_elem(OP_LINESEQ, cont, unstack);
8783 listop = op_append_list(OP_LINESEQ, block, cont);
8785 redo = LINKLIST(listop);
8789 o = new_logop(OP_AND, 0, &expr, &listop);
8790 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8792 return expr; /* listop already freed by new_logop */
8795 ((LISTOP*)listop)->op_last->op_next =
8796 (o == listop ? redo : LINKLIST(o));
8802 NewOp(1101,loop,1,LOOP);
8803 OpTYPE_set(loop, OP_ENTERLOOP);
8804 loop->op_private = 0;
8805 loop->op_next = (OP*)loop;
8808 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8810 loop->op_redoop = redo;
8811 loop->op_lastop = o;
8812 o->op_private |= loopflags;
8815 loop->op_nextop = next;
8817 loop->op_nextop = o;
8819 o->op_flags |= flags;
8820 o->op_private |= (flags >> 8);
8825 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8827 Constructs, checks, and returns an op tree expressing a C<foreach>
8828 loop (iteration through a list of values). This is a heavyweight loop,
8829 with structure that allows exiting the loop by C<last> and suchlike.
8831 C<sv> optionally supplies the variable that will be aliased to each
8832 item in turn; if null, it defaults to C<$_>.
8833 C<expr> supplies the list of values to iterate over. C<block> supplies
8834 the main body of the loop, and C<cont> optionally supplies a C<continue>
8835 block that operates as a second half of the body. All of these optree
8836 inputs are consumed by this function and become part of the constructed
8839 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8840 op and, shifted up eight bits, the eight bits of C<op_private> for
8841 the C<leaveloop> op, except that (in both cases) some bits will be set
8848 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8853 PADOFFSET padoff = 0;
8857 PERL_ARGS_ASSERT_NEWFOROP;
8860 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
8861 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8862 OpTYPE_set(sv, OP_RV2GV);
8864 /* The op_type check is needed to prevent a possible segfault
8865 * if the loop variable is undeclared and 'strict vars' is in
8866 * effect. This is illegal but is nonetheless parsed, so we
8867 * may reach this point with an OP_CONST where we're expecting
8870 if (cUNOPx(sv)->op_first->op_type == OP_GV
8871 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8872 iterpflags |= OPpITER_DEF;
8874 else if (sv->op_type == OP_PADSV) { /* private variable */
8875 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8876 padoff = sv->op_targ;
8880 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8882 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8885 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8887 PADNAME * const pn = PAD_COMPNAME(padoff);
8888 const char * const name = PadnamePV(pn);
8890 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8891 iterpflags |= OPpITER_DEF;
8895 sv = newGVOP(OP_GV, 0, PL_defgv);
8896 iterpflags |= OPpITER_DEF;
8899 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8900 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8901 iterflags |= OPf_STACKED;
8903 else if (expr->op_type == OP_NULL &&
8904 (expr->op_flags & OPf_KIDS) &&
8905 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8907 /* Basically turn for($x..$y) into the same as for($x,$y), but we
8908 * set the STACKED flag to indicate that these values are to be
8909 * treated as min/max values by 'pp_enteriter'.
8911 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8912 LOGOP* const range = (LOGOP*) flip->op_first;
8913 OP* const left = range->op_first;
8914 OP* const right = OpSIBLING(left);
8917 range->op_flags &= ~OPf_KIDS;
8918 /* detach range's children */
8919 op_sibling_splice((OP*)range, NULL, -1, NULL);
8921 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8922 listop->op_first->op_next = range->op_next;
8923 left->op_next = range->op_other;
8924 right->op_next = (OP*)listop;
8925 listop->op_next = listop->op_first;
8928 expr = (OP*)(listop);
8930 iterflags |= OPf_STACKED;
8933 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8936 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8937 op_append_elem(OP_LIST, list(expr),
8939 assert(!loop->op_next);
8940 /* for my $x () sets OPpLVAL_INTRO;
8941 * for our $x () sets OPpOUR_INTRO */
8942 loop->op_private = (U8)iterpflags;
8943 if (loop->op_slabbed
8944 && DIFF(loop, OpSLOT(loop)->opslot_next)
8945 < SIZE_TO_PSIZE(sizeof(LOOP)))
8948 NewOp(1234,tmp,1,LOOP);
8949 Copy(loop,tmp,1,LISTOP);
8950 assert(loop->op_last->op_sibparent == (OP*)loop);
8951 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8952 S_op_destroy(aTHX_ (OP*)loop);
8955 else if (!loop->op_slabbed)
8957 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8958 OpLASTSIB_set(loop->op_last, (OP*)loop);
8960 loop->op_targ = padoff;
8961 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8966 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8968 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8969 or C<last>). C<type> is the opcode. C<label> supplies the parameter
8970 determining the target of the op; it is consumed by this function and
8971 becomes part of the constructed op tree.
8977 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8981 PERL_ARGS_ASSERT_NEWLOOPEX;
8983 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8984 || type == OP_CUSTOM);
8986 if (type != OP_GOTO) {
8987 /* "last()" means "last" */
8988 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8989 o = newOP(type, OPf_SPECIAL);
8993 /* Check whether it's going to be a goto &function */
8994 if (label->op_type == OP_ENTERSUB
8995 && !(label->op_flags & OPf_STACKED))
8996 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8999 /* Check for a constant argument */
9000 if (label->op_type == OP_CONST) {
9001 SV * const sv = ((SVOP *)label)->op_sv;
9003 const char *s = SvPV_const(sv,l);
9004 if (l == strlen(s)) {
9006 SvUTF8(((SVOP*)label)->op_sv),
9008 SvPV_nolen_const(((SVOP*)label)->op_sv)));
9012 /* If we have already created an op, we do not need the label. */
9015 else o = newUNOP(type, OPf_STACKED, label);
9017 PL_hints |= HINT_BLOCK_SCOPE;
9021 /* if the condition is a literal array or hash
9022 (or @{ ... } etc), make a reference to it.
9025 S_ref_array_or_hash(pTHX_ OP *cond)
9028 && (cond->op_type == OP_RV2AV
9029 || cond->op_type == OP_PADAV
9030 || cond->op_type == OP_RV2HV
9031 || cond->op_type == OP_PADHV))
9033 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9036 && (cond->op_type == OP_ASLICE
9037 || cond->op_type == OP_KVASLICE
9038 || cond->op_type == OP_HSLICE
9039 || cond->op_type == OP_KVHSLICE)) {
9041 /* anonlist now needs a list from this op, was previously used in
9043 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9044 cond->op_flags |= OPf_WANT_LIST;
9046 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9053 /* These construct the optree fragments representing given()
9056 entergiven and enterwhen are LOGOPs; the op_other pointer
9057 points up to the associated leave op. We need this so we
9058 can put it in the context and make break/continue work.
9059 (Also, of course, pp_enterwhen will jump straight to
9060 op_other if the match fails.)
9064 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9065 I32 enter_opcode, I32 leave_opcode,
9066 PADOFFSET entertarg)
9072 PERL_ARGS_ASSERT_NEWGIVWHENOP;
9073 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9075 enterop = alloc_LOGOP(enter_opcode, block, NULL);
9076 enterop->op_targ = 0;
9077 enterop->op_private = 0;
9079 o = newUNOP(leave_opcode, 0, (OP *) enterop);
9082 /* prepend cond if we have one */
9083 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9085 o->op_next = LINKLIST(cond);
9086 cond->op_next = (OP *) enterop;
9089 /* This is a default {} block */
9090 enterop->op_flags |= OPf_SPECIAL;
9091 o ->op_flags |= OPf_SPECIAL;
9093 o->op_next = (OP *) enterop;
9096 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9097 entergiven and enterwhen both
9100 enterop->op_next = LINKLIST(block);
9101 block->op_next = enterop->op_other = o;
9106 /* Does this look like a boolean operation? For these purposes
9107 a boolean operation is:
9108 - a subroutine call [*]
9109 - a logical connective
9110 - a comparison operator
9111 - a filetest operator, with the exception of -s -M -A -C
9112 - defined(), exists() or eof()
9113 - /$re/ or $foo =~ /$re/
9115 [*] possibly surprising
9118 S_looks_like_bool(pTHX_ const OP *o)
9120 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9122 switch(o->op_type) {
9125 return looks_like_bool(cLOGOPo->op_first);
9129 OP* sibl = OpSIBLING(cLOGOPo->op_first);
9132 looks_like_bool(cLOGOPo->op_first)
9133 && looks_like_bool(sibl));
9139 o->op_flags & OPf_KIDS
9140 && looks_like_bool(cUNOPo->op_first));
9144 case OP_NOT: case OP_XOR:
9146 case OP_EQ: case OP_NE: case OP_LT:
9147 case OP_GT: case OP_LE: case OP_GE:
9149 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
9150 case OP_I_GT: case OP_I_LE: case OP_I_GE:
9152 case OP_SEQ: case OP_SNE: case OP_SLT:
9153 case OP_SGT: case OP_SLE: case OP_SGE:
9157 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
9158 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
9159 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
9160 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
9161 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
9162 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
9163 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
9164 case OP_FTTEXT: case OP_FTBINARY:
9166 case OP_DEFINED: case OP_EXISTS:
9167 case OP_MATCH: case OP_EOF:
9175 /* optimised-away (index() != -1) or similar comparison */
9176 if (o->op_private & OPpTRUEBOOL)
9181 /* Detect comparisons that have been optimized away */
9182 if (cSVOPo->op_sv == &PL_sv_yes
9183 || cSVOPo->op_sv == &PL_sv_no)
9195 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
9197 Constructs, checks, and returns an op tree expressing a C<given> block.
9198 C<cond> supplies the expression to whose value C<$_> will be locally
9199 aliased, and C<block> supplies the body of the C<given> construct; they
9200 are consumed by this function and become part of the constructed op tree.
9201 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9207 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9209 PERL_ARGS_ASSERT_NEWGIVENOP;
9210 PERL_UNUSED_ARG(defsv_off);
9213 return newGIVWHENOP(
9214 ref_array_or_hash(cond),
9216 OP_ENTERGIVEN, OP_LEAVEGIVEN,
9221 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9223 Constructs, checks, and returns an op tree expressing a C<when> block.
9224 C<cond> supplies the test expression, and C<block> supplies the block
9225 that will be executed if the test evaluates to true; they are consumed
9226 by this function and become part of the constructed op tree. C<cond>
9227 will be interpreted DWIMically, often as a comparison against C<$_>,
9228 and may be null to generate a C<default> block.
9234 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9236 const bool cond_llb = (!cond || looks_like_bool(cond));
9239 PERL_ARGS_ASSERT_NEWWHENOP;
9244 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9246 scalar(ref_array_or_hash(cond)));
9249 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9252 /* must not conflict with SVf_UTF8 */
9253 #define CV_CKPROTO_CURSTASH 0x1
9256 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9257 const STRLEN len, const U32 flags)
9259 SV *name = NULL, *msg;
9260 const char * cvp = SvROK(cv)
9261 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9262 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9265 STRLEN clen = CvPROTOLEN(cv), plen = len;
9267 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9269 if (p == NULL && cvp == NULL)
9272 if (!ckWARN_d(WARN_PROTOTYPE))
9276 p = S_strip_spaces(aTHX_ p, &plen);
9277 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9278 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9279 if (plen == clen && memEQ(cvp, p, plen))
9282 if (flags & SVf_UTF8) {
9283 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9287 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9293 msg = sv_newmortal();
9298 gv_efullname3(name = sv_newmortal(), gv, NULL);
9299 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9300 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9301 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9302 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9303 sv_catpvs(name, "::");
9305 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9306 assert (CvNAMED(SvRV_const(gv)));
9307 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9309 else sv_catsv(name, (SV *)gv);
9311 else name = (SV *)gv;
9313 sv_setpvs(msg, "Prototype mismatch:");
9315 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9317 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9318 UTF8fARG(SvUTF8(cv),clen,cvp)
9321 sv_catpvs(msg, ": none");
9322 sv_catpvs(msg, " vs ");
9324 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9326 sv_catpvs(msg, "none");
9327 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9330 static void const_sv_xsub(pTHX_ CV* cv);
9331 static void const_av_xsub(pTHX_ CV* cv);
9335 =head1 Optree Manipulation Functions
9337 =for apidoc cv_const_sv
9339 If C<cv> is a constant sub eligible for inlining, returns the constant
9340 value returned by the sub. Otherwise, returns C<NULL>.
9342 Constant subs can be created with C<newCONSTSUB> or as described in
9343 L<perlsub/"Constant Functions">.
9348 Perl_cv_const_sv(const CV *const cv)
9353 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9355 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9356 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9361 Perl_cv_const_sv_or_av(const CV * const cv)
9365 if (SvROK(cv)) return SvRV((SV *)cv);
9366 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9367 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9370 /* op_const_sv: examine an optree to determine whether it's in-lineable.
9371 * Can be called in 2 ways:
9374 * look for a single OP_CONST with attached value: return the value
9376 * allow_lex && !CvCONST(cv);
9378 * examine the clone prototype, and if contains only a single
9379 * OP_CONST, return the value; or if it contains a single PADSV ref-
9380 * erencing an outer lexical, turn on CvCONST to indicate the CV is
9381 * a candidate for "constizing" at clone time, and return NULL.
9385 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9393 for (; o; o = o->op_next) {
9394 const OPCODE type = o->op_type;
9396 if (type == OP_NEXTSTATE || type == OP_LINESEQ
9398 || type == OP_PUSHMARK)
9400 if (type == OP_DBSTATE)
9402 if (type == OP_LEAVESUB)
9406 if (type == OP_CONST && cSVOPo->op_sv)
9408 else if (type == OP_UNDEF && !o->op_private) {
9412 else if (allow_lex && type == OP_PADSV) {
9413 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9415 sv = &PL_sv_undef; /* an arbitrary non-null value */
9433 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9434 PADNAME * const name, SV ** const const_svp)
9440 if (CvFLAGS(PL_compcv)) {
9441 /* might have had built-in attrs applied */
9442 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9443 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9444 && ckWARN(WARN_MISC))
9446 /* protect against fatal warnings leaking compcv */
9447 SAVEFREESV(PL_compcv);
9448 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9449 SvREFCNT_inc_simple_void_NN(PL_compcv);
9452 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9453 & ~(CVf_LVALUE * pureperl));
9458 /* redundant check for speed: */
9459 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9460 const line_t oldline = CopLINE(PL_curcop);
9463 : sv_2mortal(newSVpvn_utf8(
9464 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9466 if (PL_parser && PL_parser->copline != NOLINE)
9467 /* This ensures that warnings are reported at the first
9468 line of a redefinition, not the last. */
9469 CopLINE_set(PL_curcop, PL_parser->copline);
9470 /* protect against fatal warnings leaking compcv */
9471 SAVEFREESV(PL_compcv);
9472 report_redefined_cv(namesv, cv, const_svp);
9473 SvREFCNT_inc_simple_void_NN(PL_compcv);
9474 CopLINE_set(PL_curcop, oldline);
9481 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9486 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9489 CV *compcv = PL_compcv;
9492 PADOFFSET pax = o->op_targ;
9493 CV *outcv = CvOUTSIDE(PL_compcv);
9496 bool reusable = FALSE;
9498 #ifdef PERL_DEBUG_READONLY_OPS
9499 OPSLAB *slab = NULL;
9502 PERL_ARGS_ASSERT_NEWMYSUB;
9504 PL_hints |= HINT_BLOCK_SCOPE;
9506 /* Find the pad slot for storing the new sub.
9507 We cannot use PL_comppad, as it is the pad owned by the new sub. We
9508 need to look in CvOUTSIDE and find the pad belonging to the enclos-
9509 ing sub. And then we need to dig deeper if this is a lexical from
9511 my sub foo; sub { sub foo { } }
9514 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9515 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9516 pax = PARENT_PAD_INDEX(name);
9517 outcv = CvOUTSIDE(outcv);
9522 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9523 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9524 spot = (CV **)svspot;
9526 if (!(PL_parser && PL_parser->error_count))
9527 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9530 assert(proto->op_type == OP_CONST);
9531 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9532 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9542 if (PL_parser && PL_parser->error_count) {
9544 SvREFCNT_dec(PL_compcv);
9549 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9551 svspot = (SV **)(spot = &clonee);
9553 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9556 assert (SvTYPE(*spot) == SVt_PVCV);
9558 hek = CvNAME_HEK(*spot);
9562 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9563 CvNAME_HEK_set(*spot, hek =
9566 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9570 CvLEXICAL_on(*spot);
9572 cv = PadnamePROTOCV(name);
9573 svspot = (SV **)(spot = &PadnamePROTOCV(name));
9577 /* This makes sub {}; work as expected. */
9578 if (block->op_type == OP_STUB) {
9579 const line_t l = PL_parser->copline;
9581 block = newSTATEOP(0, NULL, 0);
9582 PL_parser->copline = l;
9584 block = CvLVALUE(compcv)
9585 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9586 ? newUNOP(OP_LEAVESUBLV, 0,
9587 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9588 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9589 start = LINKLIST(block);
9591 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9592 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9600 const bool exists = CvROOT(cv) || CvXSUB(cv);
9602 /* if the subroutine doesn't exist and wasn't pre-declared
9603 * with a prototype, assume it will be AUTOLOADed,
9604 * skipping the prototype check
9606 if (exists || SvPOK(cv))
9607 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9609 /* already defined? */
9611 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9617 /* just a "sub foo;" when &foo is already defined */
9622 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9629 SvREFCNT_inc_simple_void_NN(const_sv);
9630 SvFLAGS(const_sv) |= SVs_PADTMP;
9632 assert(!CvROOT(cv) && !CvCONST(cv));
9636 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9637 CvFILE_set_from_cop(cv, PL_curcop);
9638 CvSTASH_set(cv, PL_curstash);
9641 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
9642 CvXSUBANY(cv).any_ptr = const_sv;
9643 CvXSUB(cv) = const_sv_xsub;
9647 CvFLAGS(cv) |= CvMETHOD(compcv);
9649 SvREFCNT_dec(compcv);
9654 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9655 determine whether this sub definition is in the same scope as its
9656 declaration. If this sub definition is inside an inner named pack-
9657 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9658 the package sub. So check PadnameOUTER(name) too.
9660 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9661 assert(!CvWEAKOUTSIDE(compcv));
9662 SvREFCNT_dec(CvOUTSIDE(compcv));
9663 CvWEAKOUTSIDE_on(compcv);
9665 /* XXX else do we have a circular reference? */
9667 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
9668 /* transfer PL_compcv to cv */
9670 cv_flags_t preserved_flags =
9671 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9672 PADLIST *const temp_padl = CvPADLIST(cv);
9673 CV *const temp_cv = CvOUTSIDE(cv);
9674 const cv_flags_t other_flags =
9675 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9676 OP * const cvstart = CvSTART(cv);
9680 CvFLAGS(compcv) | preserved_flags;
9681 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9682 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9683 CvPADLIST_set(cv, CvPADLIST(compcv));
9684 CvOUTSIDE(compcv) = temp_cv;
9685 CvPADLIST_set(compcv, temp_padl);
9686 CvSTART(cv) = CvSTART(compcv);
9687 CvSTART(compcv) = cvstart;
9688 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9689 CvFLAGS(compcv) |= other_flags;
9691 if (CvFILE(cv) && CvDYNFILE(cv)) {
9692 Safefree(CvFILE(cv));
9695 /* inner references to compcv must be fixed up ... */
9696 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9697 if (PERLDB_INTER)/* Advice debugger on the new sub. */
9698 ++PL_sub_generation;
9701 /* Might have had built-in attributes applied -- propagate them. */
9702 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9704 /* ... before we throw it away */
9705 SvREFCNT_dec(compcv);
9706 PL_compcv = compcv = cv;
9715 if (!CvNAME_HEK(cv)) {
9716 if (hek) (void)share_hek_hek(hek);
9720 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9721 hek = share_hek(PadnamePV(name)+1,
9722 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9725 CvNAME_HEK_set(cv, hek);
9731 CvFILE_set_from_cop(cv, PL_curcop);
9732 CvSTASH_set(cv, PL_curstash);
9735 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9737 SvUTF8_on(MUTABLE_SV(cv));
9741 /* If we assign an optree to a PVCV, then we've defined a
9742 * subroutine that the debugger could be able to set a breakpoint
9743 * in, so signal to pp_entereval that it should not throw away any
9744 * saved lines at scope exit. */
9746 PL_breakable_sub_gen++;
9748 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9749 itself has a refcount. */
9751 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9752 #ifdef PERL_DEBUG_READONLY_OPS
9753 slab = (OPSLAB *)CvSTART(cv);
9755 S_process_optree(aTHX_ cv, block, start);
9760 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9761 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9765 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9766 SV * const tmpstr = sv_newmortal();
9767 GV * const db_postponed = gv_fetchpvs("DB::postponed",
9768 GV_ADDMULTI, SVt_PVHV);
9770 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9773 (long)CopLINE(PL_curcop));
9774 if (HvNAME_HEK(PL_curstash)) {
9775 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9776 sv_catpvs(tmpstr, "::");
9779 sv_setpvs(tmpstr, "__ANON__::");
9781 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9782 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9783 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9784 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9785 hv = GvHVn(db_postponed);
9786 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9787 CV * const pcv = GvCV(db_postponed);
9793 call_sv(MUTABLE_SV(pcv), G_DISCARD);
9801 assert(CvDEPTH(outcv));
9803 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9805 cv_clone_into(clonee, *spot);
9806 else *spot = cv_clone(clonee);
9807 SvREFCNT_dec_NN(clonee);
9811 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9812 PADOFFSET depth = CvDEPTH(outcv);
9815 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9817 *svspot = SvREFCNT_inc_simple_NN(cv);
9818 SvREFCNT_dec(oldcv);
9824 PL_parser->copline = NOLINE;
9826 #ifdef PERL_DEBUG_READONLY_OPS
9835 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9837 Construct a Perl subroutine, also performing some surrounding jobs.
9839 This function is expected to be called in a Perl compilation context,
9840 and some aspects of the subroutine are taken from global variables
9841 associated with compilation. In particular, C<PL_compcv> represents
9842 the subroutine that is currently being compiled. It must be non-null
9843 when this function is called, and some aspects of the subroutine being
9844 constructed are taken from it. The constructed subroutine may actually
9845 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9847 If C<block> is null then the subroutine will have no body, and for the
9848 time being it will be an error to call it. This represents a forward
9849 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
9850 non-null then it provides the Perl code of the subroutine body, which
9851 will be executed when the subroutine is called. This body includes
9852 any argument unwrapping code resulting from a subroutine signature or
9853 similar. The pad use of the code must correspond to the pad attached
9854 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
9855 C<leavesublv> op; this function will add such an op. C<block> is consumed
9856 by this function and will become part of the constructed subroutine.
9858 C<proto> specifies the subroutine's prototype, unless one is supplied
9859 as an attribute (see below). If C<proto> is null, then the subroutine
9860 will not have a prototype. If C<proto> is non-null, it must point to a
9861 C<const> op whose value is a string, and the subroutine will have that
9862 string as its prototype. If a prototype is supplied as an attribute, the
9863 attribute takes precedence over C<proto>, but in that case C<proto> should
9864 preferably be null. In any case, C<proto> is consumed by this function.
9866 C<attrs> supplies attributes to be applied the subroutine. A handful of
9867 attributes take effect by built-in means, being applied to C<PL_compcv>
9868 immediately when seen. Other attributes are collected up and attached
9869 to the subroutine by this route. C<attrs> may be null to supply no
9870 attributes, or point to a C<const> op for a single attribute, or point
9871 to a C<list> op whose children apart from the C<pushmark> are C<const>
9872 ops for one or more attributes. Each C<const> op must be a string,
9873 giving the attribute name optionally followed by parenthesised arguments,
9874 in the manner in which attributes appear in Perl source. The attributes
9875 will be applied to the sub by this function. C<attrs> is consumed by
9878 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9879 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
9880 must point to a C<const> op, which will be consumed by this function,
9881 and its string value supplies a name for the subroutine. The name may
9882 be qualified or unqualified, and if it is unqualified then a default
9883 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
9884 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9885 by which the subroutine will be named.
9887 If there is already a subroutine of the specified name, then the new
9888 sub will either replace the existing one in the glob or be merged with
9889 the existing one. A warning may be generated about redefinition.
9891 If the subroutine has one of a few special names, such as C<BEGIN> or
9892 C<END>, then it will be claimed by the appropriate queue for automatic
9893 running of phase-related subroutines. In this case the relevant glob will
9894 be left not containing any subroutine, even if it did contain one before.
9895 In the case of C<BEGIN>, the subroutine will be executed and the reference
9896 to it disposed of before this function returns.
9898 The function returns a pointer to the constructed subroutine. If the sub
9899 is anonymous then ownership of one counted reference to the subroutine
9900 is transferred to the caller. If the sub is named then the caller does
9901 not get ownership of a reference. In most such cases, where the sub
9902 has a non-phase name, the sub will be alive at the point it is returned
9903 by virtue of being contained in the glob that names it. A phase-named
9904 subroutine will usually be alive by virtue of the reference owned by the
9905 phase's automatic run queue. But a C<BEGIN> subroutine, having already
9906 been executed, will quite likely have been destroyed already by the
9907 time this function returns, making it erroneous for the caller to make
9908 any use of the returned pointer. It is the caller's responsibility to
9909 ensure that it knows which of these situations applies.
9916 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9917 OP *block, bool o_is_gv)
9921 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9923 CV *cv = NULL; /* the previous CV with this name, if any */
9925 const bool ec = PL_parser && PL_parser->error_count;
9926 /* If the subroutine has no body, no attributes, and no builtin attributes
9927 then it's just a sub declaration, and we may be able to get away with
9928 storing with a placeholder scalar in the symbol table, rather than a
9929 full CV. If anything is present then it will take a full CV to
9931 const I32 gv_fetch_flags
9932 = ec ? GV_NOADD_NOINIT :
9933 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9934 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9936 const char * const name =
9937 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9939 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9940 bool evanescent = FALSE;
9942 #ifdef PERL_DEBUG_READONLY_OPS
9943 OPSLAB *slab = NULL;
9951 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
9952 hek and CvSTASH pointer together can imply the GV. If the name
9953 contains a package name, then GvSTASH(CvGV(cv)) may differ from
9954 CvSTASH, so forego the optimisation if we find any.
9955 Also, we may be called from load_module at run time, so
9956 PL_curstash (which sets CvSTASH) may not point to the stash the
9957 sub is stored in. */
9958 /* XXX This optimization is currently disabled for packages other
9959 than main, since there was too much CPAN breakage. */
9961 ec ? GV_NOADD_NOINIT
9962 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9963 || PL_curstash != PL_defstash
9964 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9966 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9967 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9969 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9970 SV * const sv = sv_newmortal();
9971 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9972 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9973 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9974 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9976 } else if (PL_curstash) {
9977 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9980 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9986 move_proto_attr(&proto, &attrs, gv, 0);
9989 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9994 assert(proto->op_type == OP_CONST);
9995 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9996 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10012 SvREFCNT_dec(PL_compcv);
10017 if (name && block) {
10018 const char *s = (char *) my_memrchr(name, ':', namlen);
10019 s = s ? s+1 : name;
10020 if (strEQ(s, "BEGIN")) {
10021 if (PL_in_eval & EVAL_KEEPERR)
10022 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10024 SV * const errsv = ERRSV;
10025 /* force display of errors found but not reported */
10026 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10027 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10034 if (!block && SvTYPE(gv) != SVt_PVGV) {
10035 /* If we are not defining a new sub and the existing one is not a
10037 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10038 /* We are applying attributes to an existing sub, so we need it
10039 upgraded if it is a constant. */
10040 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10041 gv_init_pvn(gv, PL_curstash, name, namlen,
10042 SVf_UTF8 * name_is_utf8);
10044 else { /* Maybe prototype now, and had at maximum
10045 a prototype or const/sub ref before. */
10046 if (SvTYPE(gv) > SVt_NULL) {
10047 cv_ckproto_len_flags((const CV *)gv,
10048 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10054 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10056 SvUTF8_on(MUTABLE_SV(gv));
10059 sv_setiv(MUTABLE_SV(gv), -1);
10062 SvREFCNT_dec(PL_compcv);
10063 cv = PL_compcv = NULL;
10068 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10072 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10078 /* This makes sub {}; work as expected. */
10079 if (block->op_type == OP_STUB) {
10080 const line_t l = PL_parser->copline;
10082 block = newSTATEOP(0, NULL, 0);
10083 PL_parser->copline = l;
10085 block = CvLVALUE(PL_compcv)
10086 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10087 && (!isGV(gv) || !GvASSUMECV(gv)))
10088 ? newUNOP(OP_LEAVESUBLV, 0,
10089 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10090 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10091 start = LINKLIST(block);
10092 block->op_next = 0;
10093 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10095 S_op_const_sv(aTHX_ start, PL_compcv,
10096 cBOOL(CvCLONE(PL_compcv)));
10103 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10104 cv_ckproto_len_flags((const CV *)gv,
10105 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10106 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10108 /* All the other code for sub redefinition warnings expects the
10109 clobbered sub to be a CV. Instead of making all those code
10110 paths more complex, just inline the RV version here. */
10111 const line_t oldline = CopLINE(PL_curcop);
10112 assert(IN_PERL_COMPILETIME);
10113 if (PL_parser && PL_parser->copline != NOLINE)
10114 /* This ensures that warnings are reported at the first
10115 line of a redefinition, not the last. */
10116 CopLINE_set(PL_curcop, PL_parser->copline);
10117 /* protect against fatal warnings leaking compcv */
10118 SAVEFREESV(PL_compcv);
10120 if (ckWARN(WARN_REDEFINE)
10121 || ( ckWARN_d(WARN_REDEFINE)
10122 && ( !const_sv || SvRV(gv) == const_sv
10123 || sv_cmp(SvRV(gv), const_sv) ))) {
10125 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10126 "Constant subroutine %" SVf " redefined",
10127 SVfARG(cSVOPo->op_sv));
10130 SvREFCNT_inc_simple_void_NN(PL_compcv);
10131 CopLINE_set(PL_curcop, oldline);
10132 SvREFCNT_dec(SvRV(gv));
10137 const bool exists = CvROOT(cv) || CvXSUB(cv);
10139 /* if the subroutine doesn't exist and wasn't pre-declared
10140 * with a prototype, assume it will be AUTOLOADed,
10141 * skipping the prototype check
10143 if (exists || SvPOK(cv))
10144 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10145 /* already defined (or promised)? */
10146 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10147 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10153 /* just a "sub foo;" when &foo is already defined */
10154 SAVEFREESV(PL_compcv);
10161 SvREFCNT_inc_simple_void_NN(const_sv);
10162 SvFLAGS(const_sv) |= SVs_PADTMP;
10164 assert(!CvROOT(cv) && !CvCONST(cv));
10165 cv_forget_slab(cv);
10166 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10167 CvXSUBANY(cv).any_ptr = const_sv;
10168 CvXSUB(cv) = const_sv_xsub;
10172 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10175 if (isGV(gv) || CvMETHOD(PL_compcv)) {
10176 if (name && isGV(gv))
10177 GvCV_set(gv, NULL);
10178 cv = newCONSTSUB_flags(
10179 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10183 assert(SvREFCNT((SV*)cv) != 0);
10184 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10188 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10189 prepare_SV_for_RV((SV *)gv);
10190 SvOK_off((SV *)gv);
10193 SvRV_set(gv, const_sv);
10197 SvREFCNT_dec(PL_compcv);
10202 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10203 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10206 if (cv) { /* must reuse cv if autoloaded */
10207 /* transfer PL_compcv to cv */
10209 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10210 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10211 PADLIST *const temp_av = CvPADLIST(cv);
10212 CV *const temp_cv = CvOUTSIDE(cv);
10213 const cv_flags_t other_flags =
10214 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10215 OP * const cvstart = CvSTART(cv);
10219 assert(!CvCVGV_RC(cv));
10220 assert(CvGV(cv) == gv);
10225 PERL_HASH(hash, name, namlen);
10235 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10237 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10238 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10239 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10240 CvOUTSIDE(PL_compcv) = temp_cv;
10241 CvPADLIST_set(PL_compcv, temp_av);
10242 CvSTART(cv) = CvSTART(PL_compcv);
10243 CvSTART(PL_compcv) = cvstart;
10244 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10245 CvFLAGS(PL_compcv) |= other_flags;
10248 Safefree(CvFILE(cv));
10250 CvFILE_set_from_cop(cv, PL_curcop);
10251 CvSTASH_set(cv, PL_curstash);
10253 /* inner references to PL_compcv must be fixed up ... */
10254 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10255 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10256 ++PL_sub_generation;
10259 /* Might have had built-in attributes applied -- propagate them. */
10260 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10262 /* ... before we throw it away */
10263 SvREFCNT_dec(PL_compcv);
10268 if (name && isGV(gv)) {
10271 if (HvENAME_HEK(GvSTASH(gv)))
10272 /* sub Foo::bar { (shift)+1 } */
10273 gv_method_changed(gv);
10277 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10278 prepare_SV_for_RV((SV *)gv);
10279 SvOK_off((SV *)gv);
10282 SvRV_set(gv, (SV *)cv);
10283 if (HvENAME_HEK(PL_curstash))
10284 mro_method_changed_in(PL_curstash);
10288 assert(SvREFCNT((SV*)cv) != 0);
10290 if (!CvHASGV(cv)) {
10296 PERL_HASH(hash, name, namlen);
10297 CvNAME_HEK_set(cv, share_hek(name,
10303 CvFILE_set_from_cop(cv, PL_curcop);
10304 CvSTASH_set(cv, PL_curstash);
10308 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10310 SvUTF8_on(MUTABLE_SV(cv));
10314 /* If we assign an optree to a PVCV, then we've defined a
10315 * subroutine that the debugger could be able to set a breakpoint
10316 * in, so signal to pp_entereval that it should not throw away any
10317 * saved lines at scope exit. */
10319 PL_breakable_sub_gen++;
10320 CvROOT(cv) = block;
10321 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10322 itself has a refcount. */
10324 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10325 #ifdef PERL_DEBUG_READONLY_OPS
10326 slab = (OPSLAB *)CvSTART(cv);
10328 S_process_optree(aTHX_ cv, block, start);
10333 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10334 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10335 ? GvSTASH(CvGV(cv))
10339 apply_attrs(stash, MUTABLE_SV(cv), attrs);
10341 SvREFCNT_inc_simple_void_NN(cv);
10344 if (block && has_name) {
10345 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10346 SV * const tmpstr = cv_name(cv,NULL,0);
10347 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10348 GV_ADDMULTI, SVt_PVHV);
10350 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10351 CopFILE(PL_curcop),
10353 (long)CopLINE(PL_curcop));
10354 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10355 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10356 hv = GvHVn(db_postponed);
10357 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10358 CV * const pcv = GvCV(db_postponed);
10364 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10370 if (PL_parser && PL_parser->error_count)
10371 clear_special_blocks(name, gv, cv);
10374 process_special_blocks(floor, name, gv, cv);
10380 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10382 PL_parser->copline = NOLINE;
10383 LEAVE_SCOPE(floor);
10385 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10387 #ifdef PERL_DEBUG_READONLY_OPS
10391 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10392 pad_add_weakref(cv);
10398 S_clear_special_blocks(pTHX_ const char *const fullname,
10399 GV *const gv, CV *const cv) {
10403 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10405 colon = strrchr(fullname,':');
10406 name = colon ? colon + 1 : fullname;
10408 if ((*name == 'B' && strEQ(name, "BEGIN"))
10409 || (*name == 'E' && strEQ(name, "END"))
10410 || (*name == 'U' && strEQ(name, "UNITCHECK"))
10411 || (*name == 'C' && strEQ(name, "CHECK"))
10412 || (*name == 'I' && strEQ(name, "INIT"))) {
10417 GvCV_set(gv, NULL);
10418 SvREFCNT_dec_NN(MUTABLE_SV(cv));
10422 /* Returns true if the sub has been freed. */
10424 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10428 const char *const colon = strrchr(fullname,':');
10429 const char *const name = colon ? colon + 1 : fullname;
10431 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10433 if (*name == 'B') {
10434 if (strEQ(name, "BEGIN")) {
10435 const I32 oldscope = PL_scopestack_ix;
10438 if (floor) LEAVE_SCOPE(floor);
10440 PUSHSTACKi(PERLSI_REQUIRE);
10441 SAVECOPFILE(&PL_compiling);
10442 SAVECOPLINE(&PL_compiling);
10443 SAVEVPTR(PL_curcop);
10445 DEBUG_x( dump_sub(gv) );
10446 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10447 GvCV_set(gv,0); /* cv has been hijacked */
10448 call_list(oldscope, PL_beginav);
10452 return !PL_savebegin;
10457 if (*name == 'E') {
10458 if strEQ(name, "END") {
10459 DEBUG_x( dump_sub(gv) );
10460 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10463 } else if (*name == 'U') {
10464 if (strEQ(name, "UNITCHECK")) {
10465 /* It's never too late to run a unitcheck block */
10466 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10470 } else if (*name == 'C') {
10471 if (strEQ(name, "CHECK")) {
10473 /* diag_listed_as: Too late to run %s block */
10474 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10475 "Too late to run CHECK block");
10476 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10480 } else if (*name == 'I') {
10481 if (strEQ(name, "INIT")) {
10483 /* diag_listed_as: Too late to run %s block */
10484 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10485 "Too late to run INIT block");
10486 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10492 DEBUG_x( dump_sub(gv) );
10494 GvCV_set(gv,0); /* cv has been hijacked */
10500 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10502 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10503 rather than of counted length, and no flags are set. (This means that
10504 C<name> is always interpreted as Latin-1.)
10510 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10512 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10516 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10518 Construct a constant subroutine, also performing some surrounding
10519 jobs. A scalar constant-valued subroutine is eligible for inlining
10520 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10521 123 }>>. Other kinds of constant subroutine have other treatment.
10523 The subroutine will have an empty prototype and will ignore any arguments
10524 when called. Its constant behaviour is determined by C<sv>. If C<sv>
10525 is null, the subroutine will yield an empty list. If C<sv> points to a
10526 scalar, the subroutine will always yield that scalar. If C<sv> points
10527 to an array, the subroutine will always yield a list of the elements of
10528 that array in list context, or the number of elements in the array in
10529 scalar context. This function takes ownership of one counted reference
10530 to the scalar or array, and will arrange for the object to live as long
10531 as the subroutine does. If C<sv> points to a scalar then the inlining
10532 assumes that the value of the scalar will never change, so the caller
10533 must ensure that the scalar is not subsequently written to. If C<sv>
10534 points to an array then no such assumption is made, so it is ostensibly
10535 safe to mutate the array or its elements, but whether this is really
10536 supported has not been determined.
10538 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10539 Other aspects of the subroutine will be left in their default state.
10540 The caller is free to mutate the subroutine beyond its initial state
10541 after this function has returned.
10543 If C<name> is null then the subroutine will be anonymous, with its
10544 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10545 subroutine will be named accordingly, referenced by the appropriate glob.
10546 C<name> is a string of length C<len> bytes giving a sigilless symbol
10547 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10548 otherwise. The name may be either qualified or unqualified. If the
10549 name is unqualified then it defaults to being in the stash specified by
10550 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10551 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10554 C<flags> should not have bits set other than C<SVf_UTF8>.
10556 If there is already a subroutine of the specified name, then the new sub
10557 will replace the existing one in the glob. A warning may be generated
10558 about the redefinition.
10560 If the subroutine has one of a few special names, such as C<BEGIN> or
10561 C<END>, then it will be claimed by the appropriate queue for automatic
10562 running of phase-related subroutines. In this case the relevant glob will
10563 be left not containing any subroutine, even if it did contain one before.
10564 Execution of the subroutine will likely be a no-op, unless C<sv> was
10565 a tied array or the caller modified the subroutine in some interesting
10566 way before it was executed. In the case of C<BEGIN>, the treatment is
10567 buggy: the sub will be executed when only half built, and may be deleted
10568 prematurely, possibly causing a crash.
10570 The function returns a pointer to the constructed subroutine. If the sub
10571 is anonymous then ownership of one counted reference to the subroutine
10572 is transferred to the caller. If the sub is named then the caller does
10573 not get ownership of a reference. In most such cases, where the sub
10574 has a non-phase name, the sub will be alive at the point it is returned
10575 by virtue of being contained in the glob that names it. A phase-named
10576 subroutine will usually be alive by virtue of the reference owned by
10577 the phase's automatic run queue. A C<BEGIN> subroutine may have been
10578 destroyed already by the time this function returns, but currently bugs
10579 occur in that case before the caller gets control. It is the caller's
10580 responsibility to ensure that it knows which of these situations applies.
10586 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10590 const char *const file = CopFILE(PL_curcop);
10594 if (IN_PERL_RUNTIME) {
10595 /* at runtime, it's not safe to manipulate PL_curcop: it may be
10596 * an op shared between threads. Use a non-shared COP for our
10598 SAVEVPTR(PL_curcop);
10599 SAVECOMPILEWARNINGS();
10600 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10601 PL_curcop = &PL_compiling;
10603 SAVECOPLINE(PL_curcop);
10604 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10607 PL_hints &= ~HINT_BLOCK_SCOPE;
10610 SAVEGENERICSV(PL_curstash);
10611 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10614 /* Protect sv against leakage caused by fatal warnings. */
10615 if (sv) SAVEFREESV(sv);
10617 /* file becomes the CvFILE. For an XS, it's usually static storage,
10618 and so doesn't get free()d. (It's expected to be from the C pre-
10619 processor __FILE__ directive). But we need a dynamically allocated one,
10620 and we need it to get freed. */
10621 cv = newXS_len_flags(name, len,
10622 sv && SvTYPE(sv) == SVt_PVAV
10625 file ? file : "", "",
10626 &sv, XS_DYNAMIC_FILENAME | flags);
10628 assert(SvREFCNT((SV*)cv) != 0);
10629 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10638 =for apidoc U||newXS
10640 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
10641 static storage, as it is used directly as CvFILE(), without a copy being made.
10647 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10649 PERL_ARGS_ASSERT_NEWXS;
10650 return newXS_len_flags(
10651 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10656 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10657 const char *const filename, const char *const proto,
10660 PERL_ARGS_ASSERT_NEWXS_FLAGS;
10661 return newXS_len_flags(
10662 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10667 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10669 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10670 return newXS_len_flags(
10671 name, strlen(name), subaddr, NULL, NULL, NULL, 0
10676 =for apidoc m|CV *|newXS_len_flags|const char *name|STRLEN len|XSUBADDR_t subaddr|const char *const filename|const char *const proto|SV **const_svp|U32 flags
10678 Construct an XS subroutine, also performing some surrounding jobs.
10680 The subroutine will have the entry point C<subaddr>. It will have
10681 the prototype specified by the nul-terminated string C<proto>, or
10682 no prototype if C<proto> is null. The prototype string is copied;
10683 the caller can mutate the supplied string afterwards. If C<filename>
10684 is non-null, it must be a nul-terminated filename, and the subroutine
10685 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
10686 point directly to the supplied string, which must be static. If C<flags>
10687 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10690 Other aspects of the subroutine will be left in their default state.
10691 If anything else needs to be done to the subroutine for it to function
10692 correctly, it is the caller's responsibility to do that after this
10693 function has constructed it. However, beware of the subroutine
10694 potentially being destroyed before this function returns, as described
10697 If C<name> is null then the subroutine will be anonymous, with its
10698 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10699 subroutine will be named accordingly, referenced by the appropriate glob.
10700 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10701 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10702 The name may be either qualified or unqualified, with the stash defaulting
10703 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
10704 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10705 they have there, such as C<GV_ADDWARN>. The symbol is always added to
10706 the stash if necessary, with C<GV_ADDMULTI> semantics.
10708 If there is already a subroutine of the specified name, then the new sub
10709 will replace the existing one in the glob. A warning may be generated
10710 about the redefinition. If the old subroutine was C<CvCONST> then the
10711 decision about whether to warn is influenced by an expectation about
10712 whether the new subroutine will become a constant of similar value.
10713 That expectation is determined by C<const_svp>. (Note that the call to
10714 this function doesn't make the new subroutine C<CvCONST> in any case;
10715 that is left to the caller.) If C<const_svp> is null then it indicates
10716 that the new subroutine will not become a constant. If C<const_svp>
10717 is non-null then it indicates that the new subroutine will become a
10718 constant, and it points to an C<SV*> that provides the constant value
10719 that the subroutine will have.
10721 If the subroutine has one of a few special names, such as C<BEGIN> or
10722 C<END>, then it will be claimed by the appropriate queue for automatic
10723 running of phase-related subroutines. In this case the relevant glob will
10724 be left not containing any subroutine, even if it did contain one before.
10725 In the case of C<BEGIN>, the subroutine will be executed and the reference
10726 to it disposed of before this function returns, and also before its
10727 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
10728 constructed by this function to be ready for execution then the caller
10729 must prevent this happening by giving the subroutine a different name.
10731 The function returns a pointer to the constructed subroutine. If the sub
10732 is anonymous then ownership of one counted reference to the subroutine
10733 is transferred to the caller. If the sub is named then the caller does
10734 not get ownership of a reference. In most such cases, where the sub
10735 has a non-phase name, the sub will be alive at the point it is returned
10736 by virtue of being contained in the glob that names it. A phase-named
10737 subroutine will usually be alive by virtue of the reference owned by the
10738 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10739 been executed, will quite likely have been destroyed already by the
10740 time this function returns, making it erroneous for the caller to make
10741 any use of the returned pointer. It is the caller's responsibility to
10742 ensure that it knows which of these situations applies.
10748 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10749 XSUBADDR_t subaddr, const char *const filename,
10750 const char *const proto, SV **const_svp,
10754 bool interleave = FALSE;
10755 bool evanescent = FALSE;
10757 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10760 GV * const gv = gv_fetchpvn(
10761 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10762 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10763 sizeof("__ANON__::__ANON__") - 1,
10764 GV_ADDMULTI | flags, SVt_PVCV);
10766 if ((cv = (name ? GvCV(gv) : NULL))) {
10768 /* just a cached method */
10772 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10773 /* already defined (or promised) */
10774 /* Redundant check that allows us to avoid creating an SV
10775 most of the time: */
10776 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10777 report_redefined_cv(newSVpvn_flags(
10778 name,len,(flags&SVf_UTF8)|SVs_TEMP
10789 if (cv) /* must reuse cv if autoloaded */
10792 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10796 if (HvENAME_HEK(GvSTASH(gv)))
10797 gv_method_changed(gv); /* newXS */
10801 assert(SvREFCNT((SV*)cv) != 0);
10805 /* XSUBs can't be perl lang/perl5db.pl debugged
10806 if (PERLDB_LINE_OR_SAVESRC)
10807 (void)gv_fetchfile(filename); */
10808 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10809 if (flags & XS_DYNAMIC_FILENAME) {
10811 CvFILE(cv) = savepv(filename);
10813 /* NOTE: not copied, as it is expected to be an external constant string */
10814 CvFILE(cv) = (char *)filename;
10817 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10818 CvFILE(cv) = (char*)PL_xsubfilename;
10821 CvXSUB(cv) = subaddr;
10822 #ifndef PERL_IMPLICIT_CONTEXT
10823 CvHSCXT(cv) = &PL_stack_sp;
10829 evanescent = process_special_blocks(0, name, gv, cv);
10832 } /* <- not a conditional branch */
10835 assert(evanescent || SvREFCNT((SV*)cv) != 0);
10837 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10838 if (interleave) LEAVE;
10839 assert(evanescent || SvREFCNT((SV*)cv) != 0);
10843 /* Add a stub CV to a typeglob.
10844 * This is the implementation of a forward declaration, 'sub foo';'
10848 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10850 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10852 PERL_ARGS_ASSERT_NEWSTUB;
10853 assert(!GvCVu(gv));
10856 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10857 gv_method_changed(gv);
10859 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10863 CvGV_set(cv, cvgv);
10864 CvFILE_set_from_cop(cv, PL_curcop);
10865 CvSTASH_set(cv, PL_curstash);
10871 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10878 if (PL_parser && PL_parser->error_count) {
10884 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10885 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10888 if ((cv = GvFORM(gv))) {
10889 if (ckWARN(WARN_REDEFINE)) {
10890 const line_t oldline = CopLINE(PL_curcop);
10891 if (PL_parser && PL_parser->copline != NOLINE)
10892 CopLINE_set(PL_curcop, PL_parser->copline);
10894 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10895 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10897 /* diag_listed_as: Format %s redefined */
10898 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10899 "Format STDOUT redefined");
10901 CopLINE_set(PL_curcop, oldline);
10906 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10908 CvFILE_set_from_cop(cv, PL_curcop);
10911 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10913 start = LINKLIST(root);
10915 S_process_optree(aTHX_ cv, root, start);
10916 cv_forget_slab(cv);
10921 PL_parser->copline = NOLINE;
10922 LEAVE_SCOPE(floor);
10923 PL_compiling.cop_seq = 0;
10927 Perl_newANONLIST(pTHX_ OP *o)
10929 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10933 Perl_newANONHASH(pTHX_ OP *o)
10935 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10939 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10941 return newANONATTRSUB(floor, proto, NULL, block);
10945 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10947 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10949 newSVOP(OP_ANONCODE, 0,
10951 if (CvANONCONST(cv))
10952 anoncode = newUNOP(OP_ANONCONST, 0,
10953 op_convert_list(OP_ENTERSUB,
10954 OPf_STACKED|OPf_WANT_SCALAR,
10956 return newUNOP(OP_REFGEN, 0, anoncode);
10960 Perl_oopsAV(pTHX_ OP *o)
10964 PERL_ARGS_ASSERT_OOPSAV;
10966 switch (o->op_type) {
10969 OpTYPE_set(o, OP_PADAV);
10970 return ref(o, OP_RV2AV);
10974 OpTYPE_set(o, OP_RV2AV);
10979 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10986 Perl_oopsHV(pTHX_ OP *o)
10990 PERL_ARGS_ASSERT_OOPSHV;
10992 switch (o->op_type) {
10995 OpTYPE_set(o, OP_PADHV);
10996 return ref(o, OP_RV2HV);
11000 OpTYPE_set(o, OP_RV2HV);
11001 /* rv2hv steals the bottom bit for its own uses */
11002 o->op_private &= ~OPpARG1_MASK;
11007 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11014 Perl_newAVREF(pTHX_ OP *o)
11018 PERL_ARGS_ASSERT_NEWAVREF;
11020 if (o->op_type == OP_PADANY) {
11021 OpTYPE_set(o, OP_PADAV);
11024 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11025 Perl_croak(aTHX_ "Can't use an array as a reference");
11027 return newUNOP(OP_RV2AV, 0, scalar(o));
11031 Perl_newGVREF(pTHX_ I32 type, OP *o)
11033 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11034 return newUNOP(OP_NULL, 0, o);
11035 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11039 Perl_newHVREF(pTHX_ OP *o)
11043 PERL_ARGS_ASSERT_NEWHVREF;
11045 if (o->op_type == OP_PADANY) {
11046 OpTYPE_set(o, OP_PADHV);
11049 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11050 Perl_croak(aTHX_ "Can't use a hash as a reference");
11052 return newUNOP(OP_RV2HV, 0, scalar(o));
11056 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11058 if (o->op_type == OP_PADANY) {
11060 OpTYPE_set(o, OP_PADCV);
11062 return newUNOP(OP_RV2CV, flags, scalar(o));
11066 Perl_newSVREF(pTHX_ OP *o)
11070 PERL_ARGS_ASSERT_NEWSVREF;
11072 if (o->op_type == OP_PADANY) {
11073 OpTYPE_set(o, OP_PADSV);
11077 return newUNOP(OP_RV2SV, 0, scalar(o));
11080 /* Check routines. See the comments at the top of this file for details
11081 * on when these are called */
11084 Perl_ck_anoncode(pTHX_ OP *o)
11086 PERL_ARGS_ASSERT_CK_ANONCODE;
11088 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11089 cSVOPo->op_sv = NULL;
11094 S_io_hints(pTHX_ OP *o)
11096 #if O_BINARY != 0 || O_TEXT != 0
11098 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11100 SV **svp = hv_fetchs(table, "open_IN", FALSE);
11103 const char *d = SvPV_const(*svp, len);
11104 const I32 mode = mode_from_discipline(d, len);
11105 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11107 if (mode & O_BINARY)
11108 o->op_private |= OPpOPEN_IN_RAW;
11112 o->op_private |= OPpOPEN_IN_CRLF;
11116 svp = hv_fetchs(table, "open_OUT", FALSE);
11119 const char *d = SvPV_const(*svp, len);
11120 const I32 mode = mode_from_discipline(d, len);
11121 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11123 if (mode & O_BINARY)
11124 o->op_private |= OPpOPEN_OUT_RAW;
11128 o->op_private |= OPpOPEN_OUT_CRLF;
11133 PERL_UNUSED_CONTEXT;
11134 PERL_UNUSED_ARG(o);
11139 Perl_ck_backtick(pTHX_ OP *o)
11144 PERL_ARGS_ASSERT_CK_BACKTICK;
11146 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11147 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11148 && (gv = gv_override("readpipe",8)))
11150 /* detach rest of siblings from o and its first child */
11151 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11152 newop = S_new_entersubop(aTHX_ gv, sibl);
11154 else if (!(o->op_flags & OPf_KIDS))
11155 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11160 S_io_hints(aTHX_ o);
11165 Perl_ck_bitop(pTHX_ OP *o)
11167 PERL_ARGS_ASSERT_CK_BITOP;
11169 o->op_private = (U8)(PL_hints & HINT_INTEGER);
11171 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11172 && OP_IS_INFIX_BIT(o->op_type))
11174 const OP * const left = cBINOPo->op_first;
11175 const OP * const right = OpSIBLING(left);
11176 if ((OP_IS_NUMCOMPARE(left->op_type) &&
11177 (left->op_flags & OPf_PARENS) == 0) ||
11178 (OP_IS_NUMCOMPARE(right->op_type) &&
11179 (right->op_flags & OPf_PARENS) == 0))
11180 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11181 "Possible precedence problem on bitwise %s operator",
11182 o->op_type == OP_BIT_OR
11183 ||o->op_type == OP_NBIT_OR ? "|"
11184 : o->op_type == OP_BIT_AND
11185 ||o->op_type == OP_NBIT_AND ? "&"
11186 : o->op_type == OP_BIT_XOR
11187 ||o->op_type == OP_NBIT_XOR ? "^"
11188 : o->op_type == OP_SBIT_OR ? "|."
11189 : o->op_type == OP_SBIT_AND ? "&." : "^."
11195 PERL_STATIC_INLINE bool
11196 is_dollar_bracket(pTHX_ const OP * const o)
11199 PERL_UNUSED_CONTEXT;
11200 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11201 && (kid = cUNOPx(o)->op_first)
11202 && kid->op_type == OP_GV
11203 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11206 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11209 Perl_ck_cmp(pTHX_ OP *o)
11215 OP *indexop, *constop, *start;
11219 PERL_ARGS_ASSERT_CK_CMP;
11221 is_eq = ( o->op_type == OP_EQ
11222 || o->op_type == OP_NE
11223 || o->op_type == OP_I_EQ
11224 || o->op_type == OP_I_NE);
11226 if (!is_eq && ckWARN(WARN_SYNTAX)) {
11227 const OP *kid = cUNOPo->op_first;
11230 ( is_dollar_bracket(aTHX_ kid)
11231 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11233 || ( kid->op_type == OP_CONST
11234 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11238 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11239 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11242 /* convert (index(...) == -1) and variations into
11243 * (r)index/BOOL(,NEG)
11248 indexop = cUNOPo->op_first;
11249 constop = OpSIBLING(indexop);
11251 if (indexop->op_type == OP_CONST) {
11253 indexop = OpSIBLING(constop);
11258 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11261 /* ($lex = index(....)) == -1 */
11262 if (indexop->op_private & OPpTARGET_MY)
11265 if (constop->op_type != OP_CONST)
11268 sv = cSVOPx_sv(constop);
11269 if (!(sv && SvIOK_notUV(sv)))
11273 if (iv != -1 && iv != 0)
11277 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11278 if (!(iv0 ^ reverse))
11282 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11287 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11288 if (!(iv0 ^ reverse))
11292 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11297 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11303 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11309 indexop->op_flags &= ~OPf_PARENS;
11310 indexop->op_flags |= (o->op_flags & OPf_PARENS);
11311 indexop->op_private |= OPpTRUEBOOL;
11313 indexop->op_private |= OPpINDEX_BOOLNEG;
11314 /* cut out the index op and free the eq,const ops */
11315 (void)op_sibling_splice(o, start, 1, NULL);
11323 Perl_ck_concat(pTHX_ OP *o)
11325 const OP * const kid = cUNOPo->op_first;
11327 PERL_ARGS_ASSERT_CK_CONCAT;
11328 PERL_UNUSED_CONTEXT;
11330 /* reuse the padtmp returned by the concat child */
11331 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11332 !(kUNOP->op_first->op_flags & OPf_MOD))
11334 o->op_flags |= OPf_STACKED;
11335 o->op_private |= OPpCONCAT_NESTED;
11341 Perl_ck_spair(pTHX_ OP *o)
11345 PERL_ARGS_ASSERT_CK_SPAIR;
11347 if (o->op_flags & OPf_KIDS) {
11351 const OPCODE type = o->op_type;
11352 o = modkids(ck_fun(o), type);
11353 kid = cUNOPo->op_first;
11354 kidkid = kUNOP->op_first;
11355 newop = OpSIBLING(kidkid);
11357 const OPCODE type = newop->op_type;
11358 if (OpHAS_SIBLING(newop))
11360 if (o->op_type == OP_REFGEN
11361 && ( type == OP_RV2CV
11362 || ( !(newop->op_flags & OPf_PARENS)
11363 && ( type == OP_RV2AV || type == OP_PADAV
11364 || type == OP_RV2HV || type == OP_PADHV))))
11365 NOOP; /* OK (allow srefgen for \@a and \%h) */
11366 else if (OP_GIMME(newop,0) != G_SCALAR)
11369 /* excise first sibling */
11370 op_sibling_splice(kid, NULL, 1, NULL);
11373 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11374 * and OP_CHOMP into OP_SCHOMP */
11375 o->op_ppaddr = PL_ppaddr[++o->op_type];
11380 Perl_ck_delete(pTHX_ OP *o)
11382 PERL_ARGS_ASSERT_CK_DELETE;
11386 if (o->op_flags & OPf_KIDS) {
11387 OP * const kid = cUNOPo->op_first;
11388 switch (kid->op_type) {
11390 o->op_flags |= OPf_SPECIAL;
11393 o->op_private |= OPpSLICE;
11396 o->op_flags |= OPf_SPECIAL;
11401 o->op_flags |= OPf_SPECIAL;
11404 o->op_private |= OPpKVSLICE;
11407 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11408 "element or slice");
11410 if (kid->op_private & OPpLVAL_INTRO)
11411 o->op_private |= OPpLVAL_INTRO;
11418 Perl_ck_eof(pTHX_ OP *o)
11420 PERL_ARGS_ASSERT_CK_EOF;
11422 if (o->op_flags & OPf_KIDS) {
11424 if (cLISTOPo->op_first->op_type == OP_STUB) {
11426 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11431 kid = cLISTOPo->op_first;
11432 if (kid->op_type == OP_RV2GV)
11433 kid->op_private |= OPpALLOW_FAKE;
11440 Perl_ck_eval(pTHX_ OP *o)
11444 PERL_ARGS_ASSERT_CK_EVAL;
11446 PL_hints |= HINT_BLOCK_SCOPE;
11447 if (o->op_flags & OPf_KIDS) {
11448 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11451 if (o->op_type == OP_ENTERTRY) {
11454 /* cut whole sibling chain free from o */
11455 op_sibling_splice(o, NULL, -1, NULL);
11458 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11460 /* establish postfix order */
11461 enter->op_next = (OP*)enter;
11463 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11464 OpTYPE_set(o, OP_LEAVETRY);
11465 enter->op_other = o;
11470 S_set_haseval(aTHX);
11474 const U8 priv = o->op_private;
11476 /* the newUNOP will recursively call ck_eval(), which will handle
11477 * all the stuff at the end of this function, like adding
11480 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11482 o->op_targ = (PADOFFSET)PL_hints;
11483 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11484 if ((PL_hints & HINT_LOCALIZE_HH) != 0
11485 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11486 /* Store a copy of %^H that pp_entereval can pick up. */
11487 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11488 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11489 /* append hhop to only child */
11490 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11492 o->op_private |= OPpEVAL_HAS_HH;
11494 if (!(o->op_private & OPpEVAL_BYTES)
11495 && FEATURE_UNIEVAL_IS_ENABLED)
11496 o->op_private |= OPpEVAL_UNICODE;
11501 Perl_ck_exec(pTHX_ OP *o)
11503 PERL_ARGS_ASSERT_CK_EXEC;
11505 if (o->op_flags & OPf_STACKED) {
11508 kid = OpSIBLING(cUNOPo->op_first);
11509 if (kid->op_type == OP_RV2GV)
11518 Perl_ck_exists(pTHX_ OP *o)
11520 PERL_ARGS_ASSERT_CK_EXISTS;
11523 if (o->op_flags & OPf_KIDS) {
11524 OP * const kid = cUNOPo->op_first;
11525 if (kid->op_type == OP_ENTERSUB) {
11526 (void) ref(kid, o->op_type);
11527 if (kid->op_type != OP_RV2CV
11528 && !(PL_parser && PL_parser->error_count))
11530 "exists argument is not a subroutine name");
11531 o->op_private |= OPpEXISTS_SUB;
11533 else if (kid->op_type == OP_AELEM)
11534 o->op_flags |= OPf_SPECIAL;
11535 else if (kid->op_type != OP_HELEM)
11536 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11537 "element or a subroutine");
11544 Perl_ck_rvconst(pTHX_ OP *o)
11547 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11549 PERL_ARGS_ASSERT_CK_RVCONST;
11551 if (o->op_type == OP_RV2HV)
11552 /* rv2hv steals the bottom bit for its own uses */
11553 o->op_private &= ~OPpARG1_MASK;
11555 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11557 if (kid->op_type == OP_CONST) {
11560 SV * const kidsv = kid->op_sv;
11562 /* Is it a constant from cv_const_sv()? */
11563 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11566 if (SvTYPE(kidsv) == SVt_PVAV) return o;
11567 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11568 const char *badthing;
11569 switch (o->op_type) {
11571 badthing = "a SCALAR";
11574 badthing = "an ARRAY";
11577 badthing = "a HASH";
11585 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11586 SVfARG(kidsv), badthing);
11589 * This is a little tricky. We only want to add the symbol if we
11590 * didn't add it in the lexer. Otherwise we get duplicate strict
11591 * warnings. But if we didn't add it in the lexer, we must at
11592 * least pretend like we wanted to add it even if it existed before,
11593 * or we get possible typo warnings. OPpCONST_ENTERED says
11594 * whether the lexer already added THIS instance of this symbol.
11596 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11597 gv = gv_fetchsv(kidsv,
11598 o->op_type == OP_RV2CV
11599 && o->op_private & OPpMAY_RETURN_CONSTANT
11601 : iscv | !(kid->op_private & OPpCONST_ENTERED),
11604 : o->op_type == OP_RV2SV
11606 : o->op_type == OP_RV2AV
11608 : o->op_type == OP_RV2HV
11615 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11616 && SvTYPE(SvRV(gv)) != SVt_PVCV)
11617 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11619 OpTYPE_set(kid, OP_GV);
11620 SvREFCNT_dec(kid->op_sv);
11621 #ifdef USE_ITHREADS
11622 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11623 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11624 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11625 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11626 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11628 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11630 kid->op_private = 0;
11631 /* FAKE globs in the symbol table cause weird bugs (#77810) */
11639 Perl_ck_ftst(pTHX_ OP *o)
11642 const I32 type = o->op_type;
11644 PERL_ARGS_ASSERT_CK_FTST;
11646 if (o->op_flags & OPf_REF) {
11649 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11650 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11651 const OPCODE kidtype = kid->op_type;
11653 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11654 && !kid->op_folded) {
11655 OP * const newop = newGVOP(type, OPf_REF,
11656 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11661 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11662 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11664 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11665 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11666 array_passed_to_stat, name);
11669 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11670 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11673 scalar((OP *) kid);
11674 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11675 o->op_private |= OPpFT_ACCESS;
11676 if (type != OP_STAT && type != OP_LSTAT
11677 && PL_check[kidtype] == Perl_ck_ftst
11678 && kidtype != OP_STAT && kidtype != OP_LSTAT
11680 o->op_private |= OPpFT_STACKED;
11681 kid->op_private |= OPpFT_STACKING;
11682 if (kidtype == OP_FTTTY && (
11683 !(kid->op_private & OPpFT_STACKED)
11684 || kid->op_private & OPpFT_AFTER_t
11686 o->op_private |= OPpFT_AFTER_t;
11691 if (type == OP_FTTTY)
11692 o = newGVOP(type, OPf_REF, PL_stdingv);
11694 o = newUNOP(type, 0, newDEFSVOP());
11700 Perl_ck_fun(pTHX_ OP *o)
11702 const int type = o->op_type;
11703 I32 oa = PL_opargs[type] >> OASHIFT;
11705 PERL_ARGS_ASSERT_CK_FUN;
11707 if (o->op_flags & OPf_STACKED) {
11708 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11709 oa &= ~OA_OPTIONAL;
11711 return no_fh_allowed(o);
11714 if (o->op_flags & OPf_KIDS) {
11715 OP *prev_kid = NULL;
11716 OP *kid = cLISTOPo->op_first;
11718 bool seen_optional = FALSE;
11720 if (kid->op_type == OP_PUSHMARK ||
11721 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11724 kid = OpSIBLING(kid);
11726 if (kid && kid->op_type == OP_COREARGS) {
11727 bool optional = FALSE;
11730 if (oa & OA_OPTIONAL) optional = TRUE;
11733 if (optional) o->op_private |= numargs;
11738 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11739 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11740 kid = newDEFSVOP();
11741 /* append kid to chain */
11742 op_sibling_splice(o, prev_kid, 0, kid);
11744 seen_optional = TRUE;
11751 /* list seen where single (scalar) arg expected? */
11752 if (numargs == 1 && !(oa >> 4)
11753 && kid->op_type == OP_LIST && type != OP_SCALAR)
11755 return too_many_arguments_pv(o,PL_op_desc[type], 0);
11757 if (type != OP_DELETE) scalar(kid);
11768 if ((type == OP_PUSH || type == OP_UNSHIFT)
11769 && !OpHAS_SIBLING(kid))
11770 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11771 "Useless use of %s with no values",
11774 if (kid->op_type == OP_CONST
11775 && ( !SvROK(cSVOPx_sv(kid))
11776 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
11778 bad_type_pv(numargs, "array", o, kid);
11779 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
11780 || kid->op_type == OP_RV2GV) {
11781 bad_type_pv(1, "array", o, kid);
11783 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11784 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11785 PL_op_desc[type]), 0);
11788 op_lvalue(kid, type);
11792 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11793 bad_type_pv(numargs, "hash", o, kid);
11794 op_lvalue(kid, type);
11798 /* replace kid with newop in chain */
11800 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11801 newop->op_next = newop;
11806 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11807 if (kid->op_type == OP_CONST &&
11808 (kid->op_private & OPpCONST_BARE))
11810 OP * const newop = newGVOP(OP_GV, 0,
11811 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11812 /* replace kid with newop in chain */
11813 op_sibling_splice(o, prev_kid, 1, newop);
11817 else if (kid->op_type == OP_READLINE) {
11818 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11819 bad_type_pv(numargs, "HANDLE", o, kid);
11822 I32 flags = OPf_SPECIAL;
11824 PADOFFSET targ = 0;
11826 /* is this op a FH constructor? */
11827 if (is_handle_constructor(o,numargs)) {
11828 const char *name = NULL;
11831 bool want_dollar = TRUE;
11834 /* Set a flag to tell rv2gv to vivify
11835 * need to "prove" flag does not mean something
11836 * else already - NI-S 1999/05/07
11839 if (kid->op_type == OP_PADSV) {
11841 = PAD_COMPNAME_SV(kid->op_targ);
11842 name = PadnamePV (pn);
11843 len = PadnameLEN(pn);
11844 name_utf8 = PadnameUTF8(pn);
11846 else if (kid->op_type == OP_RV2SV
11847 && kUNOP->op_first->op_type == OP_GV)
11849 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11851 len = GvNAMELEN(gv);
11852 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11854 else if (kid->op_type == OP_AELEM
11855 || kid->op_type == OP_HELEM)
11858 OP *op = ((BINOP*)kid)->op_first;
11862 const char * const a =
11863 kid->op_type == OP_AELEM ?
11865 if (((op->op_type == OP_RV2AV) ||
11866 (op->op_type == OP_RV2HV)) &&
11867 (firstop = ((UNOP*)op)->op_first) &&
11868 (firstop->op_type == OP_GV)) {
11869 /* packagevar $a[] or $h{} */
11870 GV * const gv = cGVOPx_gv(firstop);
11873 Perl_newSVpvf(aTHX_
11878 else if (op->op_type == OP_PADAV
11879 || op->op_type == OP_PADHV) {
11880 /* lexicalvar $a[] or $h{} */
11881 const char * const padname =
11882 PAD_COMPNAME_PV(op->op_targ);
11885 Perl_newSVpvf(aTHX_
11891 name = SvPV_const(tmpstr, len);
11892 name_utf8 = SvUTF8(tmpstr);
11893 sv_2mortal(tmpstr);
11897 name = "__ANONIO__";
11899 want_dollar = FALSE;
11901 op_lvalue(kid, type);
11905 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11906 namesv = PAD_SVl(targ);
11907 if (want_dollar && *name != '$')
11908 sv_setpvs(namesv, "$");
11911 sv_catpvn(namesv, name, len);
11912 if ( name_utf8 ) SvUTF8_on(namesv);
11916 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11918 kid->op_targ = targ;
11919 kid->op_private |= priv;
11925 if ((type == OP_UNDEF || type == OP_POS)
11926 && numargs == 1 && !(oa >> 4)
11927 && kid->op_type == OP_LIST)
11928 return too_many_arguments_pv(o,PL_op_desc[type], 0);
11929 op_lvalue(scalar(kid), type);
11934 kid = OpSIBLING(kid);
11936 /* FIXME - should the numargs or-ing move after the too many
11937 * arguments check? */
11938 o->op_private |= numargs;
11940 return too_many_arguments_pv(o,OP_DESC(o), 0);
11943 else if (PL_opargs[type] & OA_DEFGV) {
11944 /* Ordering of these two is important to keep f_map.t passing. */
11946 return newUNOP(type, 0, newDEFSVOP());
11950 while (oa & OA_OPTIONAL)
11952 if (oa && oa != OA_LIST)
11953 return too_few_arguments_pv(o,OP_DESC(o), 0);
11959 Perl_ck_glob(pTHX_ OP *o)
11963 PERL_ARGS_ASSERT_CK_GLOB;
11966 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11967 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11969 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11973 * \ null - const(wildcard)
11978 * \ mark - glob - rv2cv
11979 * | \ gv(CORE::GLOBAL::glob)
11981 * \ null - const(wildcard)
11983 o->op_flags |= OPf_SPECIAL;
11984 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11985 o = S_new_entersubop(aTHX_ gv, o);
11986 o = newUNOP(OP_NULL, 0, o);
11987 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11990 else o->op_flags &= ~OPf_SPECIAL;
11991 #if !defined(PERL_EXTERNAL_GLOB)
11992 if (!PL_globhook) {
11994 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11995 newSVpvs("File::Glob"), NULL, NULL, NULL);
11998 #endif /* !PERL_EXTERNAL_GLOB */
11999 gv = (GV *)newSV(0);
12000 gv_init(gv, 0, "", 0, 0);
12002 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12003 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12009 Perl_ck_grep(pTHX_ OP *o)
12013 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12015 PERL_ARGS_ASSERT_CK_GREP;
12017 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12019 if (o->op_flags & OPf_STACKED) {
12020 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12021 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12022 return no_fh_allowed(o);
12023 o->op_flags &= ~OPf_STACKED;
12025 kid = OpSIBLING(cLISTOPo->op_first);
12026 if (type == OP_MAPWHILE)
12031 if (PL_parser && PL_parser->error_count)
12033 kid = OpSIBLING(cLISTOPo->op_first);
12034 if (kid->op_type != OP_NULL)
12035 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12036 kid = kUNOP->op_first;
12038 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12039 kid->op_next = (OP*)gwop;
12040 o->op_private = gwop->op_private = 0;
12041 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12043 kid = OpSIBLING(cLISTOPo->op_first);
12044 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12045 op_lvalue(kid, OP_GREPSTART);
12051 Perl_ck_index(pTHX_ OP *o)
12053 PERL_ARGS_ASSERT_CK_INDEX;
12055 if (o->op_flags & OPf_KIDS) {
12056 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12058 kid = OpSIBLING(kid); /* get past "big" */
12059 if (kid && kid->op_type == OP_CONST) {
12060 const bool save_taint = TAINT_get;
12061 SV *sv = kSVOP->op_sv;
12062 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12063 && SvOK(sv) && !SvROK(sv))
12066 sv_copypv(sv, kSVOP->op_sv);
12067 SvREFCNT_dec_NN(kSVOP->op_sv);
12070 if (SvOK(sv)) fbm_compile(sv, 0);
12071 TAINT_set(save_taint);
12072 #ifdef NO_TAINT_SUPPORT
12073 PERL_UNUSED_VAR(save_taint);
12081 Perl_ck_lfun(pTHX_ OP *o)
12083 const OPCODE type = o->op_type;
12085 PERL_ARGS_ASSERT_CK_LFUN;
12087 return modkids(ck_fun(o), type);
12091 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
12093 PERL_ARGS_ASSERT_CK_DEFINED;
12095 if ((o->op_flags & OPf_KIDS)) {
12096 switch (cUNOPo->op_first->op_type) {
12099 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12100 " (Maybe you should just omit the defined()?)");
12101 NOT_REACHED; /* NOTREACHED */
12105 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12106 " (Maybe you should just omit the defined()?)");
12107 NOT_REACHED; /* NOTREACHED */
12118 Perl_ck_readline(pTHX_ OP *o)
12120 PERL_ARGS_ASSERT_CK_READLINE;
12122 if (o->op_flags & OPf_KIDS) {
12123 OP *kid = cLISTOPo->op_first;
12124 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12128 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12136 Perl_ck_rfun(pTHX_ OP *o)
12138 const OPCODE type = o->op_type;
12140 PERL_ARGS_ASSERT_CK_RFUN;
12142 return refkids(ck_fun(o), type);
12146 Perl_ck_listiob(pTHX_ OP *o)
12150 PERL_ARGS_ASSERT_CK_LISTIOB;
12152 kid = cLISTOPo->op_first;
12154 o = force_list(o, 1);
12155 kid = cLISTOPo->op_first;
12157 if (kid->op_type == OP_PUSHMARK)
12158 kid = OpSIBLING(kid);
12159 if (kid && o->op_flags & OPf_STACKED)
12160 kid = OpSIBLING(kid);
12161 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
12162 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12163 && !kid->op_folded) {
12164 o->op_flags |= OPf_STACKED; /* make it a filehandle */
12166 /* replace old const op with new OP_RV2GV parent */
12167 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12168 OP_RV2GV, OPf_REF);
12169 kid = OpSIBLING(kid);
12174 op_append_elem(o->op_type, o, newDEFSVOP());
12176 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12177 return listkids(o);
12181 Perl_ck_smartmatch(pTHX_ OP *o)
12184 PERL_ARGS_ASSERT_CK_SMARTMATCH;
12185 if (0 == (o->op_flags & OPf_SPECIAL)) {
12186 OP *first = cBINOPo->op_first;
12187 OP *second = OpSIBLING(first);
12189 /* Implicitly take a reference to an array or hash */
12191 /* remove the original two siblings, then add back the
12192 * (possibly different) first and second sibs.
12194 op_sibling_splice(o, NULL, 1, NULL);
12195 op_sibling_splice(o, NULL, 1, NULL);
12196 first = ref_array_or_hash(first);
12197 second = ref_array_or_hash(second);
12198 op_sibling_splice(o, NULL, 0, second);
12199 op_sibling_splice(o, NULL, 0, first);
12201 /* Implicitly take a reference to a regular expression */
12202 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12203 OpTYPE_set(first, OP_QR);
12205 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12206 OpTYPE_set(second, OP_QR);
12215 S_maybe_targlex(pTHX_ OP *o)
12217 OP * const kid = cLISTOPo->op_first;
12218 /* has a disposable target? */
12219 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12220 && !(kid->op_flags & OPf_STACKED)
12221 /* Cannot steal the second time! */
12222 && !(kid->op_private & OPpTARGET_MY)
12225 OP * const kkid = OpSIBLING(kid);
12227 /* Can just relocate the target. */
12228 if (kkid && kkid->op_type == OP_PADSV
12229 && (!(kkid->op_private & OPpLVAL_INTRO)
12230 || kkid->op_private & OPpPAD_STATE))
12232 kid->op_targ = kkid->op_targ;
12234 /* Now we do not need PADSV and SASSIGN.
12235 * Detach kid and free the rest. */
12236 op_sibling_splice(o, NULL, 1, NULL);
12238 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
12246 Perl_ck_sassign(pTHX_ OP *o)
12249 OP * const kid = cBINOPo->op_first;
12251 PERL_ARGS_ASSERT_CK_SASSIGN;
12253 if (OpHAS_SIBLING(kid)) {
12254 OP *kkid = OpSIBLING(kid);
12255 /* For state variable assignment with attributes, kkid is a list op
12256 whose op_last is a padsv. */
12257 if ((kkid->op_type == OP_PADSV ||
12258 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12259 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12262 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12263 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12264 return S_newONCEOP(aTHX_ o, kkid);
12267 return S_maybe_targlex(aTHX_ o);
12272 Perl_ck_match(pTHX_ OP *o)
12274 PERL_UNUSED_CONTEXT;
12275 PERL_ARGS_ASSERT_CK_MATCH;
12281 Perl_ck_method(pTHX_ OP *o)
12283 SV *sv, *methsv, *rclass;
12284 const char* method;
12287 STRLEN len, nsplit = 0, i;
12289 OP * const kid = cUNOPo->op_first;
12291 PERL_ARGS_ASSERT_CK_METHOD;
12292 if (kid->op_type != OP_CONST) return o;
12296 /* replace ' with :: */
12297 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12298 SvEND(sv) - SvPVX(sv) )))
12301 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12304 method = SvPVX_const(sv);
12306 utf8 = SvUTF8(sv) ? -1 : 1;
12308 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12313 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12315 if (!nsplit) { /* $proto->method() */
12317 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12320 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12322 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12325 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12326 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12327 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12328 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12330 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12331 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12333 #ifdef USE_ITHREADS
12334 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12336 cMETHOPx(new_op)->op_rclass_sv = rclass;
12343 Perl_ck_null(pTHX_ OP *o)
12345 PERL_ARGS_ASSERT_CK_NULL;
12346 PERL_UNUSED_CONTEXT;
12351 Perl_ck_open(pTHX_ OP *o)
12353 PERL_ARGS_ASSERT_CK_OPEN;
12355 S_io_hints(aTHX_ o);
12357 /* In case of three-arg dup open remove strictness
12358 * from the last arg if it is a bareword. */
12359 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12360 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
12364 if ((last->op_type == OP_CONST) && /* The bareword. */
12365 (last->op_private & OPpCONST_BARE) &&
12366 (last->op_private & OPpCONST_STRICT) &&
12367 (oa = OpSIBLING(first)) && /* The fh. */
12368 (oa = OpSIBLING(oa)) && /* The mode. */
12369 (oa->op_type == OP_CONST) &&
12370 SvPOK(((SVOP*)oa)->op_sv) &&
12371 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12372 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
12373 (last == OpSIBLING(oa))) /* The bareword. */
12374 last->op_private &= ~OPpCONST_STRICT;
12380 Perl_ck_prototype(pTHX_ OP *o)
12382 PERL_ARGS_ASSERT_CK_PROTOTYPE;
12383 if (!(o->op_flags & OPf_KIDS)) {
12385 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12391 Perl_ck_refassign(pTHX_ OP *o)
12393 OP * const right = cLISTOPo->op_first;
12394 OP * const left = OpSIBLING(right);
12395 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12398 PERL_ARGS_ASSERT_CK_REFASSIGN;
12400 assert (left->op_type == OP_SREFGEN);
12403 /* we use OPpPAD_STATE in refassign to mean either of those things,
12404 * and the code assumes the two flags occupy the same bit position
12405 * in the various ops below */
12406 assert(OPpPAD_STATE == OPpOUR_INTRO);
12408 switch (varop->op_type) {
12410 o->op_private |= OPpLVREF_AV;
12413 o->op_private |= OPpLVREF_HV;
12417 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12418 o->op_targ = varop->op_targ;
12419 varop->op_targ = 0;
12420 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12424 o->op_private |= OPpLVREF_AV;
12426 NOT_REACHED; /* NOTREACHED */
12428 o->op_private |= OPpLVREF_HV;
12432 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12433 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12435 /* Point varop to its GV kid, detached. */
12436 varop = op_sibling_splice(varop, NULL, -1, NULL);
12440 OP * const kidparent =
12441 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12442 OP * const kid = cUNOPx(kidparent)->op_first;
12443 o->op_private |= OPpLVREF_CV;
12444 if (kid->op_type == OP_GV) {
12446 goto detach_and_stack;
12448 if (kid->op_type != OP_PADCV) goto bad;
12449 o->op_targ = kid->op_targ;
12455 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12456 o->op_private |= OPpLVREF_ELEM;
12459 /* Detach varop. */
12460 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12464 /* diag_listed_as: Can't modify reference to %s in %s assignment */
12465 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12470 if (!FEATURE_REFALIASING_IS_ENABLED)
12472 "Experimental aliasing via reference not enabled");
12473 Perl_ck_warner_d(aTHX_
12474 packWARN(WARN_EXPERIMENTAL__REFALIASING),
12475 "Aliasing via reference is experimental");
12477 o->op_flags |= OPf_STACKED;
12478 op_sibling_splice(o, right, 1, varop);
12481 o->op_flags &=~ OPf_STACKED;
12482 op_sibling_splice(o, right, 1, NULL);
12489 Perl_ck_repeat(pTHX_ OP *o)
12491 PERL_ARGS_ASSERT_CK_REPEAT;
12493 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12495 o->op_private |= OPpREPEAT_DOLIST;
12496 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12497 kids = force_list(kids, 1); /* promote it to a list */
12498 op_sibling_splice(o, NULL, 0, kids); /* and add back */
12506 Perl_ck_require(pTHX_ OP *o)
12510 PERL_ARGS_ASSERT_CK_REQUIRE;
12512 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
12513 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12517 if (kid->op_type == OP_CONST) {
12518 SV * const sv = kid->op_sv;
12519 U32 const was_readonly = SvREADONLY(sv);
12520 if (kid->op_private & OPpCONST_BARE) {
12525 if (was_readonly) {
12526 SvREADONLY_off(sv);
12528 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12533 /* treat ::foo::bar as foo::bar */
12534 if (len >= 2 && s[0] == ':' && s[1] == ':')
12535 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12537 DIE(aTHX_ "Bareword in require maps to empty filename");
12539 for (; s < end; s++) {
12540 if (*s == ':' && s[1] == ':') {
12542 Move(s+2, s+1, end - s - 1, char);
12546 SvEND_set(sv, end);
12547 sv_catpvs(sv, ".pm");
12548 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12549 hek = share_hek(SvPVX(sv),
12550 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12552 sv_sethek(sv, hek);
12554 SvFLAGS(sv) |= was_readonly;
12556 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12559 if (SvREFCNT(sv) > 1) {
12560 kid->op_sv = newSVpvn_share(
12561 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12562 SvREFCNT_dec_NN(sv);
12567 if (was_readonly) SvREADONLY_off(sv);
12568 PERL_HASH(hash, s, len);
12570 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12572 sv_sethek(sv, hek);
12574 SvFLAGS(sv) |= was_readonly;
12580 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12581 /* handle override, if any */
12582 && (gv = gv_override("require", 7))) {
12584 if (o->op_flags & OPf_KIDS) {
12585 kid = cUNOPo->op_first;
12586 op_sibling_splice(o, NULL, -1, NULL);
12589 kid = newDEFSVOP();
12592 newop = S_new_entersubop(aTHX_ gv, kid);
12600 Perl_ck_return(pTHX_ OP *o)
12604 PERL_ARGS_ASSERT_CK_RETURN;
12606 kid = OpSIBLING(cLISTOPo->op_first);
12607 if (PL_compcv && CvLVALUE(PL_compcv)) {
12608 for (; kid; kid = OpSIBLING(kid))
12609 op_lvalue(kid, OP_LEAVESUBLV);
12616 Perl_ck_select(pTHX_ OP *o)
12621 PERL_ARGS_ASSERT_CK_SELECT;
12623 if (o->op_flags & OPf_KIDS) {
12624 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12625 if (kid && OpHAS_SIBLING(kid)) {
12626 OpTYPE_set(o, OP_SSELECT);
12628 return fold_constants(op_integerize(op_std_init(o)));
12632 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12633 if (kid && kid->op_type == OP_RV2GV)
12634 kid->op_private &= ~HINT_STRICT_REFS;
12639 Perl_ck_shift(pTHX_ OP *o)
12641 const I32 type = o->op_type;
12643 PERL_ARGS_ASSERT_CK_SHIFT;
12645 if (!(o->op_flags & OPf_KIDS)) {
12648 if (!CvUNIQUE(PL_compcv)) {
12649 o->op_flags |= OPf_SPECIAL;
12653 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12655 return newUNOP(type, 0, scalar(argop));
12657 return scalar(ck_fun(o));
12661 Perl_ck_sort(pTHX_ OP *o)
12665 HV * const hinthv =
12666 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12669 PERL_ARGS_ASSERT_CK_SORT;
12672 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12674 const I32 sorthints = (I32)SvIV(*svp);
12675 if ((sorthints & HINT_SORT_STABLE) != 0)
12676 o->op_private |= OPpSORT_STABLE;
12677 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12678 o->op_private |= OPpSORT_UNSTABLE;
12682 if (o->op_flags & OPf_STACKED)
12684 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12686 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
12687 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
12689 /* if the first arg is a code block, process it and mark sort as
12691 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12693 if (kid->op_type == OP_LEAVE)
12694 op_null(kid); /* wipe out leave */
12695 /* Prevent execution from escaping out of the sort block. */
12698 /* provide scalar context for comparison function/block */
12699 kid = scalar(firstkid);
12700 kid->op_next = kid;
12701 o->op_flags |= OPf_SPECIAL;
12703 else if (kid->op_type == OP_CONST
12704 && kid->op_private & OPpCONST_BARE) {
12708 const char * const name = SvPV(kSVOP_sv, len);
12710 assert (len < 256);
12711 Copy(name, tmpbuf+1, len, char);
12712 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12713 if (off != NOT_IN_PAD) {
12714 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12716 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12717 sv_catpvs(fq, "::");
12718 sv_catsv(fq, kSVOP_sv);
12719 SvREFCNT_dec_NN(kSVOP_sv);
12723 OP * const padop = newOP(OP_PADCV, 0);
12724 padop->op_targ = off;
12725 /* replace the const op with the pad op */
12726 op_sibling_splice(firstkid, NULL, 1, padop);
12732 firstkid = OpSIBLING(firstkid);
12735 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12736 /* provide list context for arguments */
12739 op_lvalue(kid, OP_GREPSTART);
12745 /* for sort { X } ..., where X is one of
12746 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12747 * elide the second child of the sort (the one containing X),
12748 * and set these flags as appropriate
12752 * Also, check and warn on lexical $a, $b.
12756 S_simplify_sort(pTHX_ OP *o)
12758 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12762 const char *gvname;
12765 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12767 kid = kUNOP->op_first; /* get past null */
12768 if (!(have_scopeop = kid->op_type == OP_SCOPE)
12769 && kid->op_type != OP_LEAVE)
12771 kid = kLISTOP->op_last; /* get past scope */
12772 switch(kid->op_type) {
12776 if (!have_scopeop) goto padkids;
12781 k = kid; /* remember this node*/
12782 if (kBINOP->op_first->op_type != OP_RV2SV
12783 || kBINOP->op_last ->op_type != OP_RV2SV)
12786 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12787 then used in a comparison. This catches most, but not
12788 all cases. For instance, it catches
12789 sort { my($a); $a <=> $b }
12791 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12792 (although why you'd do that is anyone's guess).
12796 if (!ckWARN(WARN_SYNTAX)) return;
12797 kid = kBINOP->op_first;
12799 if (kid->op_type == OP_PADSV) {
12800 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12801 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12802 && ( PadnamePV(name)[1] == 'a'
12803 || PadnamePV(name)[1] == 'b' ))
12804 /* diag_listed_as: "my %s" used in sort comparison */
12805 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12806 "\"%s %s\" used in sort comparison",
12807 PadnameIsSTATE(name)
12812 } while ((kid = OpSIBLING(kid)));
12815 kid = kBINOP->op_first; /* get past cmp */
12816 if (kUNOP->op_first->op_type != OP_GV)
12818 kid = kUNOP->op_first; /* get past rv2sv */
12820 if (GvSTASH(gv) != PL_curstash)
12822 gvname = GvNAME(gv);
12823 if (*gvname == 'a' && gvname[1] == '\0')
12825 else if (*gvname == 'b' && gvname[1] == '\0')
12830 kid = k; /* back to cmp */
12831 /* already checked above that it is rv2sv */
12832 kid = kBINOP->op_last; /* down to 2nd arg */
12833 if (kUNOP->op_first->op_type != OP_GV)
12835 kid = kUNOP->op_first; /* get past rv2sv */
12837 if (GvSTASH(gv) != PL_curstash)
12839 gvname = GvNAME(gv);
12841 ? !(*gvname == 'a' && gvname[1] == '\0')
12842 : !(*gvname == 'b' && gvname[1] == '\0'))
12844 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12846 o->op_private |= OPpSORT_DESCEND;
12847 if (k->op_type == OP_NCMP)
12848 o->op_private |= OPpSORT_NUMERIC;
12849 if (k->op_type == OP_I_NCMP)
12850 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12851 kid = OpSIBLING(cLISTOPo->op_first);
12852 /* cut out and delete old block (second sibling) */
12853 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12858 Perl_ck_split(pTHX_ OP *o)
12864 PERL_ARGS_ASSERT_CK_SPLIT;
12866 assert(o->op_type == OP_LIST);
12868 if (o->op_flags & OPf_STACKED)
12869 return no_fh_allowed(o);
12871 kid = cLISTOPo->op_first;
12872 /* delete leading NULL node, then add a CONST if no other nodes */
12873 assert(kid->op_type == OP_NULL);
12874 op_sibling_splice(o, NULL, 1,
12875 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12877 kid = cLISTOPo->op_first;
12879 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12880 /* remove match expression, and replace with new optree with
12881 * a match op at its head */
12882 op_sibling_splice(o, NULL, 1, NULL);
12883 /* pmruntime will handle split " " behavior with flag==2 */
12884 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12885 op_sibling_splice(o, NULL, 0, kid);
12888 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12890 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12891 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12892 "Use of /g modifier is meaningless in split");
12895 /* eliminate the split op, and move the match op (plus any children)
12896 * into its place, then convert the match op into a split op. i.e.
12898 * SPLIT MATCH SPLIT(ex-MATCH)
12900 * MATCH - A - B - C => R - A - B - C => R - A - B - C
12906 * (R, if it exists, will be a regcomp op)
12909 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12910 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12911 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12912 OpTYPE_set(kid, OP_SPLIT);
12913 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
12914 kid->op_private = o->op_private;
12917 kid = sibs; /* kid is now the string arg of the split */
12920 kid = newDEFSVOP();
12921 op_append_elem(OP_SPLIT, o, kid);
12925 kid = OpSIBLING(kid);
12927 kid = newSVOP(OP_CONST, 0, newSViv(0));
12928 op_append_elem(OP_SPLIT, o, kid);
12929 o->op_private |= OPpSPLIT_IMPLIM;
12933 if (OpHAS_SIBLING(kid))
12934 return too_many_arguments_pv(o,OP_DESC(o), 0);
12940 Perl_ck_stringify(pTHX_ OP *o)
12942 OP * const kid = OpSIBLING(cUNOPo->op_first);
12943 PERL_ARGS_ASSERT_CK_STRINGIFY;
12944 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12945 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
12946 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
12947 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12949 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12957 Perl_ck_join(pTHX_ OP *o)
12959 OP * const kid = OpSIBLING(cLISTOPo->op_first);
12961 PERL_ARGS_ASSERT_CK_JOIN;
12963 if (kid && kid->op_type == OP_MATCH) {
12964 if (ckWARN(WARN_SYNTAX)) {
12965 const REGEXP *re = PM_GETRE(kPMOP);
12967 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12968 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12969 : newSVpvs_flags( "STRING", SVs_TEMP );
12970 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12971 "/%" SVf "/ should probably be written as \"%" SVf "\"",
12972 SVfARG(msg), SVfARG(msg));
12976 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12977 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12978 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12979 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12981 const OP * const bairn = OpSIBLING(kid); /* the list */
12982 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12983 && OP_GIMME(bairn,0) == G_SCALAR)
12985 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12986 op_sibling_splice(o, kid, 1, NULL));
12996 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12998 Examines an op, which is expected to identify a subroutine at runtime,
12999 and attempts to determine at compile time which subroutine it identifies.
13000 This is normally used during Perl compilation to determine whether
13001 a prototype can be applied to a function call. C<cvop> is the op
13002 being considered, normally an C<rv2cv> op. A pointer to the identified
13003 subroutine is returned, if it could be determined statically, and a null
13004 pointer is returned if it was not possible to determine statically.
13006 Currently, the subroutine can be identified statically if the RV that the
13007 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13008 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
13009 suitable if the constant value must be an RV pointing to a CV. Details of
13010 this process may change in future versions of Perl. If the C<rv2cv> op
13011 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13012 the subroutine statically: this flag is used to suppress compile-time
13013 magic on a subroutine call, forcing it to use default runtime behaviour.
13015 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13016 of a GV reference is modified. If a GV was examined and its CV slot was
13017 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13018 If the op is not optimised away, and the CV slot is later populated with
13019 a subroutine having a prototype, that flag eventually triggers the warning
13020 "called too early to check prototype".
13022 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13023 of returning a pointer to the subroutine it returns a pointer to the
13024 GV giving the most appropriate name for the subroutine in this context.
13025 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13026 (C<CvANON>) subroutine that is referenced through a GV it will be the
13027 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
13028 A null pointer is returned as usual if there is no statically-determinable
13034 /* shared by toke.c:yylex */
13036 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13038 PADNAME *name = PAD_COMPNAME(off);
13039 CV *compcv = PL_compcv;
13040 while (PadnameOUTER(name)) {
13041 assert(PARENT_PAD_INDEX(name));
13042 compcv = CvOUTSIDE(compcv);
13043 name = PadlistNAMESARRAY(CvPADLIST(compcv))
13044 [off = PARENT_PAD_INDEX(name)];
13046 assert(!PadnameIsOUR(name));
13047 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13048 return PadnamePROTOCV(name);
13050 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13054 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13059 PERL_ARGS_ASSERT_RV2CV_OP_CV;
13060 if (flags & ~RV2CVOPCV_FLAG_MASK)
13061 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13062 if (cvop->op_type != OP_RV2CV)
13064 if (cvop->op_private & OPpENTERSUB_AMPER)
13066 if (!(cvop->op_flags & OPf_KIDS))
13068 rvop = cUNOPx(cvop)->op_first;
13069 switch (rvop->op_type) {
13071 gv = cGVOPx_gv(rvop);
13073 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13074 cv = MUTABLE_CV(SvRV(gv));
13078 if (flags & RV2CVOPCV_RETURN_STUB)
13084 if (flags & RV2CVOPCV_MARK_EARLY)
13085 rvop->op_private |= OPpEARLY_CV;
13090 SV *rv = cSVOPx_sv(rvop);
13093 cv = (CV*)SvRV(rv);
13097 cv = find_lexical_cv(rvop->op_targ);
13102 } NOT_REACHED; /* NOTREACHED */
13104 if (SvTYPE((SV*)cv) != SVt_PVCV)
13106 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13107 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13111 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13112 if (CvLEXICAL(cv) || CvNAMED(cv))
13114 if (!CvANON(cv) || !gv)
13124 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
13126 Performs the default fixup of the arguments part of an C<entersub>
13127 op tree. This consists of applying list context to each of the
13128 argument ops. This is the standard treatment used on a call marked
13129 with C<&>, or a method call, or a call through a subroutine reference,
13130 or any other call where the callee can't be identified at compile time,
13131 or a call where the callee has no prototype.
13137 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13141 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13143 aop = cUNOPx(entersubop)->op_first;
13144 if (!OpHAS_SIBLING(aop))
13145 aop = cUNOPx(aop)->op_first;
13146 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13147 /* skip the extra attributes->import() call implicitly added in
13148 * something like foo(my $x : bar)
13150 if ( aop->op_type == OP_ENTERSUB
13151 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13155 op_lvalue(aop, OP_ENTERSUB);
13161 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
13163 Performs the fixup of the arguments part of an C<entersub> op tree
13164 based on a subroutine prototype. This makes various modifications to
13165 the argument ops, from applying context up to inserting C<refgen> ops,
13166 and checking the number and syntactic types of arguments, as directed by
13167 the prototype. This is the standard treatment used on a subroutine call,
13168 not marked with C<&>, where the callee can be identified at compile time
13169 and has a prototype.
13171 C<protosv> supplies the subroutine prototype to be applied to the call.
13172 It may be a normal defined scalar, of which the string value will be used.
13173 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13174 that has been cast to C<SV*>) which has a prototype. The prototype
13175 supplied, in whichever form, does not need to match the actual callee
13176 referenced by the op tree.
13178 If the argument ops disagree with the prototype, for example by having
13179 an unacceptable number of arguments, a valid op tree is returned anyway.
13180 The error is reflected in the parser state, normally resulting in a single
13181 exception at the top level of parsing which covers all the compilation
13182 errors that occurred. In the error message, the callee is referred to
13183 by the name defined by the C<namegv> parameter.
13189 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13192 const char *proto, *proto_end;
13193 OP *aop, *prev, *cvop, *parent;
13196 I32 contextclass = 0;
13197 const char *e = NULL;
13198 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13199 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13200 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13201 "flags=%lx", (unsigned long) SvFLAGS(protosv));
13202 if (SvTYPE(protosv) == SVt_PVCV)
13203 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13204 else proto = SvPV(protosv, proto_len);
13205 proto = S_strip_spaces(aTHX_ proto, &proto_len);
13206 proto_end = proto + proto_len;
13207 parent = entersubop;
13208 aop = cUNOPx(entersubop)->op_first;
13209 if (!OpHAS_SIBLING(aop)) {
13211 aop = cUNOPx(aop)->op_first;
13214 aop = OpSIBLING(aop);
13215 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13216 while (aop != cvop) {
13219 if (proto >= proto_end)
13221 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13222 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13223 SVfARG(namesv)), SvUTF8(namesv));
13233 /* _ must be at the end */
13234 if (proto[1] && !strchr(";@%", proto[1]))
13250 if ( o3->op_type != OP_UNDEF
13251 && (o3->op_type != OP_SREFGEN
13252 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13254 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13256 bad_type_gv(arg, namegv, o3,
13257 arg == 1 ? "block or sub {}" : "sub {}");
13260 /* '*' allows any scalar type, including bareword */
13263 if (o3->op_type == OP_RV2GV)
13264 goto wrapref; /* autoconvert GLOB -> GLOBref */
13265 else if (o3->op_type == OP_CONST)
13266 o3->op_private &= ~OPpCONST_STRICT;
13272 if (o3->op_type == OP_RV2AV ||
13273 o3->op_type == OP_PADAV ||
13274 o3->op_type == OP_RV2HV ||
13275 o3->op_type == OP_PADHV
13281 case '[': case ']':
13288 switch (*proto++) {
13290 if (contextclass++ == 0) {
13291 e = (char *) memchr(proto, ']', proto_end - proto);
13292 if (!e || e == proto)
13300 if (contextclass) {
13301 const char *p = proto;
13302 const char *const end = proto;
13304 while (*--p != '[')
13305 /* \[$] accepts any scalar lvalue */
13307 && Perl_op_lvalue_flags(aTHX_
13309 OP_READ, /* not entersub */
13312 bad_type_gv(arg, namegv, o3,
13313 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13318 if (o3->op_type == OP_RV2GV)
13321 bad_type_gv(arg, namegv, o3, "symbol");
13324 if (o3->op_type == OP_ENTERSUB
13325 && !(o3->op_flags & OPf_STACKED))
13328 bad_type_gv(arg, namegv, o3, "subroutine");
13331 if (o3->op_type == OP_RV2SV ||
13332 o3->op_type == OP_PADSV ||
13333 o3->op_type == OP_HELEM ||
13334 o3->op_type == OP_AELEM)
13336 if (!contextclass) {
13337 /* \$ accepts any scalar lvalue */
13338 if (Perl_op_lvalue_flags(aTHX_
13340 OP_READ, /* not entersub */
13343 bad_type_gv(arg, namegv, o3, "scalar");
13347 if (o3->op_type == OP_RV2AV ||
13348 o3->op_type == OP_PADAV)
13350 o3->op_flags &=~ OPf_PARENS;
13354 bad_type_gv(arg, namegv, o3, "array");
13357 if (o3->op_type == OP_RV2HV ||
13358 o3->op_type == OP_PADHV)
13360 o3->op_flags &=~ OPf_PARENS;
13364 bad_type_gv(arg, namegv, o3, "hash");
13367 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13369 if (contextclass && e) {
13374 default: goto oops;
13384 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13385 SVfARG(cv_name((CV *)namegv, NULL, 0)),
13390 op_lvalue(aop, OP_ENTERSUB);
13392 aop = OpSIBLING(aop);
13394 if (aop == cvop && *proto == '_') {
13395 /* generate an access to $_ */
13396 op_sibling_splice(parent, prev, 0, newDEFSVOP());
13398 if (!optional && proto_end > proto &&
13399 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13401 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13402 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13403 SVfARG(namesv)), SvUTF8(namesv));
13409 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13411 Performs the fixup of the arguments part of an C<entersub> op tree either
13412 based on a subroutine prototype or using default list-context processing.
13413 This is the standard treatment used on a subroutine call, not marked
13414 with C<&>, where the callee can be identified at compile time.
13416 C<protosv> supplies the subroutine prototype to be applied to the call,
13417 or indicates that there is no prototype. It may be a normal scalar,
13418 in which case if it is defined then the string value will be used
13419 as a prototype, and if it is undefined then there is no prototype.
13420 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13421 that has been cast to C<SV*>), of which the prototype will be used if it
13422 has one. The prototype (or lack thereof) supplied, in whichever form,
13423 does not need to match the actual callee referenced by the op tree.
13425 If the argument ops disagree with the prototype, for example by having
13426 an unacceptable number of arguments, a valid op tree is returned anyway.
13427 The error is reflected in the parser state, normally resulting in a single
13428 exception at the top level of parsing which covers all the compilation
13429 errors that occurred. In the error message, the callee is referred to
13430 by the name defined by the C<namegv> parameter.
13436 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13437 GV *namegv, SV *protosv)
13439 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13440 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13441 return ck_entersub_args_proto(entersubop, namegv, protosv);
13443 return ck_entersub_args_list(entersubop);
13447 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13449 IV cvflags = SvIVX(protosv);
13450 int opnum = cvflags & 0xffff;
13451 OP *aop = cUNOPx(entersubop)->op_first;
13453 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13457 if (!OpHAS_SIBLING(aop))
13458 aop = cUNOPx(aop)->op_first;
13459 aop = OpSIBLING(aop);
13460 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13462 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13463 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13464 SVfARG(namesv)), SvUTF8(namesv));
13467 op_free(entersubop);
13468 switch(cvflags >> 16) {
13469 case 'F': return newSVOP(OP_CONST, 0,
13470 newSVpv(CopFILE(PL_curcop),0));
13471 case 'L': return newSVOP(
13473 Perl_newSVpvf(aTHX_
13474 "%" IVdf, (IV)CopLINE(PL_curcop)
13477 case 'P': return newSVOP(OP_CONST, 0,
13479 ? newSVhek(HvNAME_HEK(PL_curstash))
13484 NOT_REACHED; /* NOTREACHED */
13487 OP *prev, *cvop, *first, *parent;
13490 parent = entersubop;
13491 if (!OpHAS_SIBLING(aop)) {
13493 aop = cUNOPx(aop)->op_first;
13496 first = prev = aop;
13497 aop = OpSIBLING(aop);
13498 /* find last sibling */
13500 OpHAS_SIBLING(cvop);
13501 prev = cvop, cvop = OpSIBLING(cvop))
13503 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13504 /* Usually, OPf_SPECIAL on an op with no args means that it had
13505 * parens, but these have their own meaning for that flag: */
13506 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13507 && opnum != OP_DELETE && opnum != OP_EXISTS)
13508 flags |= OPf_SPECIAL;
13509 /* excise cvop from end of sibling chain */
13510 op_sibling_splice(parent, prev, 1, NULL);
13512 if (aop == cvop) aop = NULL;
13514 /* detach remaining siblings from the first sibling, then
13515 * dispose of original optree */
13518 op_sibling_splice(parent, first, -1, NULL);
13519 op_free(entersubop);
13521 if (cvflags == (OP_ENTEREVAL | (1<<16)))
13522 flags |= OPpEVAL_BYTES <<8;
13524 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13526 case OA_BASEOP_OR_UNOP:
13527 case OA_FILESTATOP:
13528 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13531 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13532 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13533 SVfARG(namesv)), SvUTF8(namesv));
13536 return opnum == OP_RUNCV
13537 ? newPVOP(OP_RUNCV,0,NULL)
13540 return op_convert_list(opnum,0,aop);
13543 NOT_REACHED; /* NOTREACHED */
13548 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13550 Retrieves the function that will be used to fix up a call to C<cv>.
13551 Specifically, the function is applied to an C<entersub> op tree for a
13552 subroutine call, not marked with C<&>, where the callee can be identified
13553 at compile time as C<cv>.
13555 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13556 for it is returned in C<*ckobj_p>, and control flags are returned in
13557 C<*ckflags_p>. The function is intended to be called in this manner:
13559 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13561 In this call, C<entersubop> is a pointer to the C<entersub> op,
13562 which may be replaced by the check function, and C<namegv> supplies
13563 the name that should be used by the check function to refer
13564 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13565 It is permitted to apply the check function in non-standard situations,
13566 such as to a call to a different subroutine or to a method call.
13568 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
13569 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13570 instead, anything that can be used as the first argument to L</cv_name>.
13571 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13572 check function requires C<namegv> to be a genuine GV.
13574 By default, the check function is
13575 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13576 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13577 flag is clear. This implements standard prototype processing. It can
13578 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13580 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13581 indicates that the caller only knows about the genuine GV version of
13582 C<namegv>, and accordingly the corresponding bit will always be set in
13583 C<*ckflags_p>, regardless of the check function's recorded requirements.
13584 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13585 indicates the caller knows about the possibility of passing something
13586 other than a GV as C<namegv>, and accordingly the corresponding bit may
13587 be either set or clear in C<*ckflags_p>, indicating the check function's
13588 recorded requirements.
13590 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13591 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13592 (for which see above). All other bits should be clear.
13594 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13596 The original form of L</cv_get_call_checker_flags>, which does not return
13597 checker flags. When using a checker function returned by this function,
13598 it is only safe to call it with a genuine GV as its C<namegv> argument.
13604 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13605 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13608 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13609 PERL_UNUSED_CONTEXT;
13610 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13612 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13613 *ckobj_p = callmg->mg_obj;
13614 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13616 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13617 *ckobj_p = (SV*)cv;
13618 *ckflags_p = gflags & MGf_REQUIRE_GV;
13623 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13626 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13627 PERL_UNUSED_CONTEXT;
13628 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13633 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13635 Sets the function that will be used to fix up a call to C<cv>.
13636 Specifically, the function is applied to an C<entersub> op tree for a
13637 subroutine call, not marked with C<&>, where the callee can be identified
13638 at compile time as C<cv>.
13640 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13641 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13642 The function should be defined like this:
13644 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13646 It is intended to be called in this manner:
13648 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13650 In this call, C<entersubop> is a pointer to the C<entersub> op,
13651 which may be replaced by the check function, and C<namegv> supplies
13652 the name that should be used by the check function to refer
13653 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13654 It is permitted to apply the check function in non-standard situations,
13655 such as to a call to a different subroutine or to a method call.
13657 C<namegv> may not actually be a GV. For efficiency, perl may pass a
13658 CV or other SV instead. Whatever is passed can be used as the first
13659 argument to L</cv_name>. You can force perl to pass a GV by including
13660 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13662 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13663 bit currently has a defined meaning (for which see above). All other
13664 bits should be clear.
13666 The current setting for a particular CV can be retrieved by
13667 L</cv_get_call_checker_flags>.
13669 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13671 The original form of L</cv_set_call_checker_flags>, which passes it the
13672 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
13673 of that flag setting is that the check function is guaranteed to get a
13674 genuine GV as its C<namegv> argument.
13680 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13682 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13683 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13687 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13688 SV *ckobj, U32 ckflags)
13690 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13691 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13692 if (SvMAGICAL((SV*)cv))
13693 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13696 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13697 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13699 if (callmg->mg_flags & MGf_REFCOUNTED) {
13700 SvREFCNT_dec(callmg->mg_obj);
13701 callmg->mg_flags &= ~MGf_REFCOUNTED;
13703 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13704 callmg->mg_obj = ckobj;
13705 if (ckobj != (SV*)cv) {
13706 SvREFCNT_inc_simple_void_NN(ckobj);
13707 callmg->mg_flags |= MGf_REFCOUNTED;
13709 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13710 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13715 S_entersub_alloc_targ(pTHX_ OP * const o)
13717 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13718 o->op_private |= OPpENTERSUB_HASTARG;
13722 Perl_ck_subr(pTHX_ OP *o)
13727 SV **const_class = NULL;
13729 PERL_ARGS_ASSERT_CK_SUBR;
13731 aop = cUNOPx(o)->op_first;
13732 if (!OpHAS_SIBLING(aop))
13733 aop = cUNOPx(aop)->op_first;
13734 aop = OpSIBLING(aop);
13735 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13736 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13737 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13739 o->op_private &= ~1;
13740 o->op_private |= (PL_hints & HINT_STRICT_REFS);
13741 if (PERLDB_SUB && PL_curstash != PL_debstash)
13742 o->op_private |= OPpENTERSUB_DB;
13743 switch (cvop->op_type) {
13745 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13749 case OP_METHOD_NAMED:
13750 case OP_METHOD_SUPER:
13751 case OP_METHOD_REDIR:
13752 case OP_METHOD_REDIR_SUPER:
13753 o->op_flags |= OPf_REF;
13754 if (aop->op_type == OP_CONST) {
13755 aop->op_private &= ~OPpCONST_STRICT;
13756 const_class = &cSVOPx(aop)->op_sv;
13758 else if (aop->op_type == OP_LIST) {
13759 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13760 if (sib && sib->op_type == OP_CONST) {
13761 sib->op_private &= ~OPpCONST_STRICT;
13762 const_class = &cSVOPx(sib)->op_sv;
13765 /* make class name a shared cow string to speedup method calls */
13766 /* constant string might be replaced with object, f.e. bigint */
13767 if (const_class && SvPOK(*const_class)) {
13769 const char* str = SvPV(*const_class, len);
13771 SV* const shared = newSVpvn_share(
13772 str, SvUTF8(*const_class)
13773 ? -(SSize_t)len : (SSize_t)len,
13776 if (SvREADONLY(*const_class))
13777 SvREADONLY_on(shared);
13778 SvREFCNT_dec(*const_class);
13779 *const_class = shared;
13786 S_entersub_alloc_targ(aTHX_ o);
13787 return ck_entersub_args_list(o);
13789 Perl_call_checker ckfun;
13792 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13793 if (CvISXSUB(cv) || !CvROOT(cv))
13794 S_entersub_alloc_targ(aTHX_ o);
13796 /* The original call checker API guarantees that a GV will be
13797 be provided with the right name. So, if the old API was
13798 used (or the REQUIRE_GV flag was passed), we have to reify
13799 the CV’s GV, unless this is an anonymous sub. This is not
13800 ideal for lexical subs, as its stringification will include
13801 the package. But it is the best we can do. */
13802 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13803 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13806 else namegv = MUTABLE_GV(cv);
13807 /* After a syntax error in a lexical sub, the cv that
13808 rv2cv_op_cv returns may be a nameless stub. */
13809 if (!namegv) return ck_entersub_args_list(o);
13812 return ckfun(aTHX_ o, namegv, ckobj);
13817 Perl_ck_svconst(pTHX_ OP *o)
13819 SV * const sv = cSVOPo->op_sv;
13820 PERL_ARGS_ASSERT_CK_SVCONST;
13821 PERL_UNUSED_CONTEXT;
13822 #ifdef PERL_COPY_ON_WRITE
13823 /* Since the read-only flag may be used to protect a string buffer, we
13824 cannot do copy-on-write with existing read-only scalars that are not
13825 already copy-on-write scalars. To allow $_ = "hello" to do COW with
13826 that constant, mark the constant as COWable here, if it is not
13827 already read-only. */
13828 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13831 # ifdef PERL_DEBUG_READONLY_COW
13841 Perl_ck_trunc(pTHX_ OP *o)
13843 PERL_ARGS_ASSERT_CK_TRUNC;
13845 if (o->op_flags & OPf_KIDS) {
13846 SVOP *kid = (SVOP*)cUNOPo->op_first;
13848 if (kid->op_type == OP_NULL)
13849 kid = (SVOP*)OpSIBLING(kid);
13850 if (kid && kid->op_type == OP_CONST &&
13851 (kid->op_private & OPpCONST_BARE) &&
13854 o->op_flags |= OPf_SPECIAL;
13855 kid->op_private &= ~OPpCONST_STRICT;
13862 Perl_ck_substr(pTHX_ OP *o)
13864 PERL_ARGS_ASSERT_CK_SUBSTR;
13867 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13868 OP *kid = cLISTOPo->op_first;
13870 if (kid->op_type == OP_NULL)
13871 kid = OpSIBLING(kid);
13873 /* Historically, substr(delete $foo{bar},...) has been allowed
13874 with 4-arg substr. Keep it working by applying entersub
13876 op_lvalue(kid, OP_ENTERSUB);
13883 Perl_ck_tell(pTHX_ OP *o)
13885 PERL_ARGS_ASSERT_CK_TELL;
13887 if (o->op_flags & OPf_KIDS) {
13888 OP *kid = cLISTOPo->op_first;
13889 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13890 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13896 Perl_ck_each(pTHX_ OP *o)
13899 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13900 const unsigned orig_type = o->op_type;
13902 PERL_ARGS_ASSERT_CK_EACH;
13905 switch (kid->op_type) {
13911 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13912 : orig_type == OP_KEYS ? OP_AKEYS
13916 if (kid->op_private == OPpCONST_BARE
13917 || !SvROK(cSVOPx_sv(kid))
13918 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13919 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
13924 qerror(Perl_mess(aTHX_
13925 "Experimental %s on scalar is now forbidden",
13926 PL_op_desc[orig_type]));
13928 bad_type_pv(1, "hash or array", o, kid);
13936 Perl_ck_length(pTHX_ OP *o)
13938 PERL_ARGS_ASSERT_CK_LENGTH;
13942 if (ckWARN(WARN_SYNTAX)) {
13943 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13947 const bool hash = kid->op_type == OP_PADHV
13948 || kid->op_type == OP_RV2HV;
13949 switch (kid->op_type) {
13954 name = S_op_varname(aTHX_ kid);
13960 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13961 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13963 SVfARG(name), hash ? "keys " : "", SVfARG(name)
13966 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13967 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13968 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13970 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13971 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13972 "length() used on @array (did you mean \"scalar(@array)\"?)");
13982 ---------------------------------------------------------
13984 Common vars in list assignment
13986 There now follows some enums and static functions for detecting
13987 common variables in list assignments. Here is a little essay I wrote
13988 for myself when trying to get my head around this. DAPM.
13992 First some random observations:
13994 * If a lexical var is an alias of something else, e.g.
13995 for my $x ($lex, $pkg, $a[0]) {...}
13996 then the act of aliasing will increase the reference count of the SV
13998 * If a package var is an alias of something else, it may still have a
13999 reference count of 1, depending on how the alias was created, e.g.
14000 in *a = *b, $a may have a refcount of 1 since the GP is shared
14001 with a single GvSV pointer to the SV. So If it's an alias of another
14002 package var, then RC may be 1; if it's an alias of another scalar, e.g.
14003 a lexical var or an array element, then it will have RC > 1.
14005 * There are many ways to create a package alias; ultimately, XS code
14006 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
14007 run-time tracing mechanisms are unlikely to be able to catch all cases.
14009 * When the LHS is all my declarations, the same vars can't appear directly
14010 on the RHS, but they can indirectly via closures, aliasing and lvalue
14011 subs. But those techniques all involve an increase in the lexical
14012 scalar's ref count.
14014 * When the LHS is all lexical vars (but not necessarily my declarations),
14015 it is possible for the same lexicals to appear directly on the RHS, and
14016 without an increased ref count, since the stack isn't refcounted.
14017 This case can be detected at compile time by scanning for common lex
14018 vars with PL_generation.
14020 * lvalue subs defeat common var detection, but they do at least
14021 return vars with a temporary ref count increment. Also, you can't
14022 tell at compile time whether a sub call is lvalue.
14027 A: There are a few circumstances where there definitely can't be any
14030 LHS empty: () = (...);
14031 RHS empty: (....) = ();
14032 RHS contains only constants or other 'can't possibly be shared'
14033 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
14034 i.e. they only contain ops not marked as dangerous, whose children
14035 are also not dangerous;
14037 LHS contains a single scalar element: e.g. ($x) = (....); because
14038 after $x has been modified, it won't be used again on the RHS;
14039 RHS contains a single element with no aggregate on LHS: e.g.
14040 ($a,$b,$c) = ($x); again, once $a has been modified, its value
14041 won't be used again.
14043 B: If LHS are all 'my' lexical var declarations (or safe ops, which
14046 my ($a, $b, @c) = ...;
14048 Due to closure and goto tricks, these vars may already have content.
14049 For the same reason, an element on the RHS may be a lexical or package
14050 alias of one of the vars on the left, or share common elements, for
14053 my ($x,$y) = f(); # $x and $y on both sides
14054 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14059 my @a = @$ra; # elements of @a on both sides
14060 sub f { @a = 1..4; \@a }
14063 First, just consider scalar vars on LHS:
14065 RHS is safe only if (A), or in addition,
14066 * contains only lexical *scalar* vars, where neither side's
14067 lexicals have been flagged as aliases
14069 If RHS is not safe, then it's always legal to check LHS vars for
14070 RC==1, since the only RHS aliases will always be associated
14073 Note that in particular, RHS is not safe if:
14075 * it contains package scalar vars; e.g.:
14078 my ($x, $y) = (2, $x_alias);
14079 sub f { $x = 1; *x_alias = \$x; }
14081 * It contains other general elements, such as flattened or
14082 * spliced or single array or hash elements, e.g.
14085 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14089 use feature 'refaliasing';
14090 \($a[0], $a[1]) = \($y,$x);
14093 It doesn't matter if the array/hash is lexical or package.
14095 * it contains a function call that happens to be an lvalue
14096 sub which returns one or more of the above, e.g.
14107 (so a sub call on the RHS should be treated the same
14108 as having a package var on the RHS).
14110 * any other "dangerous" thing, such an op or built-in that
14111 returns one of the above, e.g. pp_preinc
14114 If RHS is not safe, what we can do however is at compile time flag
14115 that the LHS are all my declarations, and at run time check whether
14116 all the LHS have RC == 1, and if so skip the full scan.
14118 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14120 Here the issue is whether there can be elements of @a on the RHS
14121 which will get prematurely freed when @a is cleared prior to
14122 assignment. This is only a problem if the aliasing mechanism
14123 is one which doesn't increase the refcount - only if RC == 1
14124 will the RHS element be prematurely freed.
14126 Because the array/hash is being INTROed, it or its elements
14127 can't directly appear on the RHS:
14129 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14131 but can indirectly, e.g.:
14135 sub f { @a = 1..3; \@a }
14137 So if the RHS isn't safe as defined by (A), we must always
14138 mortalise and bump the ref count of any remaining RHS elements
14139 when assigning to a non-empty LHS aggregate.
14141 Lexical scalars on the RHS aren't safe if they've been involved in
14144 use feature 'refaliasing';
14147 \(my $lex) = \$pkg;
14148 my @a = ($lex,3); # equivalent to ($a[0],3)
14155 Similarly with lexical arrays and hashes on the RHS:
14169 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14170 my $a; ($a, my $b) = (....);
14172 The difference between (B) and (C) is that it is now physically
14173 possible for the LHS vars to appear on the RHS too, where they
14174 are not reference counted; but in this case, the compile-time
14175 PL_generation sweep will detect such common vars.
14177 So the rules for (C) differ from (B) in that if common vars are
14178 detected, the runtime "test RC==1" optimisation can no longer be used,
14179 and a full mark and sweep is required
14181 D: As (C), but in addition the LHS may contain package vars.
14183 Since package vars can be aliased without a corresponding refcount
14184 increase, all bets are off. It's only safe if (A). E.g.
14186 my ($x, $y) = (1,2);
14188 for $x_alias ($x) {
14189 ($x_alias, $y) = (3, $x); # whoops
14192 Ditto for LHS aggregate package vars.
14194 E: Any other dangerous ops on LHS, e.g.
14195 (f(), $a[0], @$r) = (...);
14197 this is similar to (E) in that all bets are off. In addition, it's
14198 impossible to determine at compile time whether the LHS
14199 contains a scalar or an aggregate, e.g.
14201 sub f : lvalue { @a }
14204 * ---------------------------------------------------------
14208 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14209 * that at least one of the things flagged was seen.
14213 AAS_MY_SCALAR = 0x001, /* my $scalar */
14214 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
14215 AAS_LEX_SCALAR = 0x004, /* $lexical */
14216 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
14217 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14218 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
14219 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
14220 AAS_DANGEROUS = 0x080, /* an op (other than the above)
14221 that's flagged OA_DANGEROUS */
14222 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
14223 not in any of the categories above */
14224 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
14229 /* helper function for S_aassign_scan().
14230 * check a PAD-related op for commonality and/or set its generation number.
14231 * Returns a boolean indicating whether its shared */
14234 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14236 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14237 /* lexical used in aliasing */
14241 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14243 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14250 Helper function for OPpASSIGN_COMMON* detection in rpeep().
14251 It scans the left or right hand subtree of the aassign op, and returns a
14252 set of flags indicating what sorts of things it found there.
14253 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14254 set PL_generation on lexical vars; if the latter, we see if
14255 PL_generation matches.
14256 'top' indicates whether we're recursing or at the top level.
14257 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14258 This fn will increment it by the number seen. It's not intended to
14259 be an accurate count (especially as many ops can push a variable
14260 number of SVs onto the stack); rather it's used as to test whether there
14261 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14265 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14268 bool kid_top = FALSE;
14270 /* first, look for a solitary @_ on the RHS */
14273 && (o->op_flags & OPf_KIDS)
14274 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14276 OP *kid = cUNOPo->op_first;
14277 if ( ( kid->op_type == OP_PUSHMARK
14278 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14279 && ((kid = OpSIBLING(kid)))
14280 && !OpHAS_SIBLING(kid)
14281 && kid->op_type == OP_RV2AV
14282 && !(kid->op_flags & OPf_REF)
14283 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14284 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14285 && ((kid = cUNOPx(kid)->op_first))
14286 && kid->op_type == OP_GV
14287 && cGVOPx_gv(kid) == PL_defgv
14289 flags |= AAS_DEFAV;
14292 switch (o->op_type) {
14295 return AAS_PKG_SCALAR;
14300 /* if !top, could be e.g. @a[0,1] */
14301 if (top && (o->op_flags & OPf_REF))
14302 return (o->op_private & OPpLVAL_INTRO)
14303 ? AAS_MY_AGG : AAS_LEX_AGG;
14304 return AAS_DANGEROUS;
14308 int comm = S_aassign_padcheck(aTHX_ o, rhs)
14309 ? AAS_LEX_SCALAR_COMM : 0;
14311 return (o->op_private & OPpLVAL_INTRO)
14312 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14318 if (cUNOPx(o)->op_first->op_type != OP_GV)
14319 return AAS_DANGEROUS; /* @{expr}, %{expr} */
14321 /* if !top, could be e.g. @a[0,1] */
14322 if (top && (o->op_flags & OPf_REF))
14323 return AAS_PKG_AGG;
14324 return AAS_DANGEROUS;
14328 if (cUNOPx(o)->op_first->op_type != OP_GV) {
14330 return AAS_DANGEROUS; /* ${expr} */
14332 return AAS_PKG_SCALAR; /* $pkg */
14335 if (o->op_private & OPpSPLIT_ASSIGN) {
14336 /* the assign in @a = split() has been optimised away
14337 * and the @a attached directly to the split op
14338 * Treat the array as appearing on the RHS, i.e.
14339 * ... = (@a = split)
14344 if (o->op_flags & OPf_STACKED)
14345 /* @{expr} = split() - the array expression is tacked
14346 * on as an extra child to split - process kid */
14347 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14350 /* ... else array is directly attached to split op */
14352 if (PL_op->op_private & OPpSPLIT_LEX)
14353 return (o->op_private & OPpLVAL_INTRO)
14354 ? AAS_MY_AGG : AAS_LEX_AGG;
14356 return AAS_PKG_AGG;
14359 /* other args of split can't be returned */
14360 return AAS_SAFE_SCALAR;
14363 /* undef counts as a scalar on the RHS:
14364 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
14365 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
14369 flags = AAS_SAFE_SCALAR;
14374 /* these are all no-ops; they don't push a potentially common SV
14375 * onto the stack, so they are neither AAS_DANGEROUS nor
14376 * AAS_SAFE_SCALAR */
14379 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14384 /* these do nothing but may have children; but their children
14385 * should also be treated as top-level */
14390 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14392 flags = AAS_DANGEROUS;
14396 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
14397 && (o->op_private & OPpTARGET_MY))
14400 return S_aassign_padcheck(aTHX_ o, rhs)
14401 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14404 /* if its an unrecognised, non-dangerous op, assume that it
14405 * it the cause of at least one safe scalar */
14407 flags = AAS_SAFE_SCALAR;
14411 /* XXX this assumes that all other ops are "transparent" - i.e. that
14412 * they can return some of their children. While this true for e.g.
14413 * sort and grep, it's not true for e.g. map. We really need a
14414 * 'transparent' flag added to regen/opcodes
14416 if (o->op_flags & OPf_KIDS) {
14418 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14419 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14425 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14426 and modify the optree to make them work inplace */
14429 S_inplace_aassign(pTHX_ OP *o) {
14431 OP *modop, *modop_pushmark;
14433 OP *oleft, *oleft_pushmark;
14435 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14437 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14439 assert(cUNOPo->op_first->op_type == OP_NULL);
14440 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14441 assert(modop_pushmark->op_type == OP_PUSHMARK);
14442 modop = OpSIBLING(modop_pushmark);
14444 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14447 /* no other operation except sort/reverse */
14448 if (OpHAS_SIBLING(modop))
14451 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14452 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14454 if (modop->op_flags & OPf_STACKED) {
14455 /* skip sort subroutine/block */
14456 assert(oright->op_type == OP_NULL);
14457 oright = OpSIBLING(oright);
14460 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14461 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14462 assert(oleft_pushmark->op_type == OP_PUSHMARK);
14463 oleft = OpSIBLING(oleft_pushmark);
14465 /* Check the lhs is an array */
14467 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14468 || OpHAS_SIBLING(oleft)
14469 || (oleft->op_private & OPpLVAL_INTRO)
14473 /* Only one thing on the rhs */
14474 if (OpHAS_SIBLING(oright))
14477 /* check the array is the same on both sides */
14478 if (oleft->op_type == OP_RV2AV) {
14479 if (oright->op_type != OP_RV2AV
14480 || !cUNOPx(oright)->op_first
14481 || cUNOPx(oright)->op_first->op_type != OP_GV
14482 || cUNOPx(oleft )->op_first->op_type != OP_GV
14483 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14484 cGVOPx_gv(cUNOPx(oright)->op_first)
14488 else if (oright->op_type != OP_PADAV
14489 || oright->op_targ != oleft->op_targ
14493 /* This actually is an inplace assignment */
14495 modop->op_private |= OPpSORT_INPLACE;
14497 /* transfer MODishness etc from LHS arg to RHS arg */
14498 oright->op_flags = oleft->op_flags;
14500 /* remove the aassign op and the lhs */
14502 op_null(oleft_pushmark);
14503 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14504 op_null(cUNOPx(oleft)->op_first);
14510 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14511 * that potentially represent a series of one or more aggregate derefs
14512 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14513 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14514 * additional ops left in too).
14516 * The caller will have already verified that the first few ops in the
14517 * chain following 'start' indicate a multideref candidate, and will have
14518 * set 'orig_o' to the point further on in the chain where the first index
14519 * expression (if any) begins. 'orig_action' specifies what type of
14520 * beginning has already been determined by the ops between start..orig_o
14521 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
14523 * 'hints' contains any hints flags that need adding (currently just
14524 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14528 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14532 UNOP_AUX_item *arg_buf = NULL;
14533 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
14534 int index_skip = -1; /* don't output index arg on this action */
14536 /* similar to regex compiling, do two passes; the first pass
14537 * determines whether the op chain is convertible and calculates the
14538 * buffer size; the second pass populates the buffer and makes any
14539 * changes necessary to ops (such as moving consts to the pad on
14540 * threaded builds).
14542 * NB: for things like Coverity, note that both passes take the same
14543 * path through the logic tree (except for 'if (pass)' bits), since
14544 * both passes are following the same op_next chain; and in
14545 * particular, if it would return early on the second pass, it would
14546 * already have returned early on the first pass.
14548 for (pass = 0; pass < 2; pass++) {
14550 UV action = orig_action;
14551 OP *first_elem_op = NULL; /* first seen aelem/helem */
14552 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
14553 int action_count = 0; /* number of actions seen so far */
14554 int action_ix = 0; /* action_count % (actions per IV) */
14555 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
14556 bool is_last = FALSE; /* no more derefs to follow */
14557 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14558 UNOP_AUX_item *arg = arg_buf;
14559 UNOP_AUX_item *action_ptr = arg_buf;
14562 action_ptr->uv = 0;
14566 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14567 case MDEREF_HV_gvhv_helem:
14568 next_is_hash = TRUE;
14570 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14571 case MDEREF_AV_gvav_aelem:
14573 #ifdef USE_ITHREADS
14574 arg->pad_offset = cPADOPx(start)->op_padix;
14575 /* stop it being swiped when nulled */
14576 cPADOPx(start)->op_padix = 0;
14578 arg->sv = cSVOPx(start)->op_sv;
14579 cSVOPx(start)->op_sv = NULL;
14585 case MDEREF_HV_padhv_helem:
14586 case MDEREF_HV_padsv_vivify_rv2hv_helem:
14587 next_is_hash = TRUE;
14589 case MDEREF_AV_padav_aelem:
14590 case MDEREF_AV_padsv_vivify_rv2av_aelem:
14592 arg->pad_offset = start->op_targ;
14593 /* we skip setting op_targ = 0 for now, since the intact
14594 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14595 reset_start_targ = TRUE;
14600 case MDEREF_HV_pop_rv2hv_helem:
14601 next_is_hash = TRUE;
14603 case MDEREF_AV_pop_rv2av_aelem:
14607 NOT_REACHED; /* NOTREACHED */
14612 /* look for another (rv2av/hv; get index;
14613 * aelem/helem/exists/delele) sequence */
14618 UV index_type = MDEREF_INDEX_none;
14620 if (action_count) {
14621 /* if this is not the first lookup, consume the rv2av/hv */
14623 /* for N levels of aggregate lookup, we normally expect
14624 * that the first N-1 [ah]elem ops will be flagged as
14625 * /DEREF (so they autovivifiy if necessary), and the last
14626 * lookup op not to be.
14627 * For other things (like @{$h{k1}{k2}}) extra scope or
14628 * leave ops can appear, so abandon the effort in that
14630 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14633 /* rv2av or rv2hv sKR/1 */
14635 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14636 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14637 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14640 /* at this point, we wouldn't expect any of these
14641 * possible private flags:
14642 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14643 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14645 ASSUME(!(o->op_private &
14646 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14648 hints = (o->op_private & OPpHINT_STRICT_REFS);
14650 /* make sure the type of the previous /DEREF matches the
14651 * type of the next lookup */
14652 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14655 action = next_is_hash
14656 ? MDEREF_HV_vivify_rv2hv_helem
14657 : MDEREF_AV_vivify_rv2av_aelem;
14661 /* if this is the second pass, and we're at the depth where
14662 * previously we encountered a non-simple index expression,
14663 * stop processing the index at this point */
14664 if (action_count != index_skip) {
14666 /* look for one or more simple ops that return an array
14667 * index or hash key */
14669 switch (o->op_type) {
14671 /* it may be a lexical var index */
14672 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14673 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14674 ASSUME(!(o->op_private &
14675 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14677 if ( OP_GIMME(o,0) == G_SCALAR
14678 && !(o->op_flags & (OPf_REF|OPf_MOD))
14679 && o->op_private == 0)
14682 arg->pad_offset = o->op_targ;
14684 index_type = MDEREF_INDEX_padsv;
14690 if (next_is_hash) {
14691 /* it's a constant hash index */
14692 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14693 /* "use constant foo => FOO; $h{+foo}" for
14694 * some weird FOO, can leave you with constants
14695 * that aren't simple strings. It's not worth
14696 * the extra hassle for those edge cases */
14701 OP * helem_op = o->op_next;
14703 ASSUME( helem_op->op_type == OP_HELEM
14704 || helem_op->op_type == OP_NULL
14706 if (helem_op->op_type == OP_HELEM) {
14707 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14708 if ( helem_op->op_private & OPpLVAL_INTRO
14709 || rop->op_type != OP_RV2HV
14713 /* on first pass just check; on second pass
14715 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
14720 #ifdef USE_ITHREADS
14721 /* Relocate sv to the pad for thread safety */
14722 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14723 arg->pad_offset = o->op_targ;
14726 arg->sv = cSVOPx_sv(o);
14731 /* it's a constant array index */
14733 SV *ix_sv = cSVOPo->op_sv;
14738 if ( action_count == 0
14741 && ( action == MDEREF_AV_padav_aelem
14742 || action == MDEREF_AV_gvav_aelem)
14744 maybe_aelemfast = TRUE;
14748 SvREFCNT_dec_NN(cSVOPo->op_sv);
14752 /* we've taken ownership of the SV */
14753 cSVOPo->op_sv = NULL;
14755 index_type = MDEREF_INDEX_const;
14760 /* it may be a package var index */
14762 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14763 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14764 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14765 || o->op_private != 0
14770 if (kid->op_type != OP_RV2SV)
14773 ASSUME(!(kid->op_flags &
14774 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14775 |OPf_SPECIAL|OPf_PARENS)));
14776 ASSUME(!(kid->op_private &
14778 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14779 |OPpDEREF|OPpLVAL_INTRO)));
14780 if( (kid->op_flags &~ OPf_PARENS)
14781 != (OPf_WANT_SCALAR|OPf_KIDS)
14782 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14787 #ifdef USE_ITHREADS
14788 arg->pad_offset = cPADOPx(o)->op_padix;
14789 /* stop it being swiped when nulled */
14790 cPADOPx(o)->op_padix = 0;
14792 arg->sv = cSVOPx(o)->op_sv;
14793 cSVOPo->op_sv = NULL;
14797 index_type = MDEREF_INDEX_gvsv;
14802 } /* action_count != index_skip */
14804 action |= index_type;
14807 /* at this point we have either:
14808 * * detected what looks like a simple index expression,
14809 * and expect the next op to be an [ah]elem, or
14810 * an nulled [ah]elem followed by a delete or exists;
14811 * * found a more complex expression, so something other
14812 * than the above follows.
14815 /* possibly an optimised away [ah]elem (where op_next is
14816 * exists or delete) */
14817 if (o->op_type == OP_NULL)
14820 /* at this point we're looking for an OP_AELEM, OP_HELEM,
14821 * OP_EXISTS or OP_DELETE */
14823 /* if a custom array/hash access checker is in scope,
14824 * abandon optimisation attempt */
14825 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14826 && PL_check[o->op_type] != Perl_ck_null)
14828 /* similarly for customised exists and delete */
14829 if ( (o->op_type == OP_EXISTS)
14830 && PL_check[o->op_type] != Perl_ck_exists)
14832 if ( (o->op_type == OP_DELETE)
14833 && PL_check[o->op_type] != Perl_ck_delete)
14836 if ( o->op_type != OP_AELEM
14837 || (o->op_private &
14838 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14840 maybe_aelemfast = FALSE;
14842 /* look for aelem/helem/exists/delete. If it's not the last elem
14843 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14844 * flags; if it's the last, then it mustn't have
14845 * OPpDEREF_AV/HV, but may have lots of other flags, like
14846 * OPpLVAL_INTRO etc
14849 if ( index_type == MDEREF_INDEX_none
14850 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
14851 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14855 /* we have aelem/helem/exists/delete with valid simple index */
14857 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14858 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
14859 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14861 /* This doesn't make much sense but is legal:
14862 * @{ local $x[0][0] } = 1
14863 * Since scope exit will undo the autovivification,
14864 * don't bother in the first place. The OP_LEAVE
14865 * assertion is in case there are other cases of both
14866 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14867 * exit that would undo the local - in which case this
14868 * block of code would need rethinking.
14870 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14872 OP *n = o->op_next;
14873 while (n && ( n->op_type == OP_NULL
14874 || n->op_type == OP_LIST))
14876 assert(n && n->op_type == OP_LEAVE);
14878 o->op_private &= ~OPpDEREF;
14883 ASSUME(!(o->op_flags &
14884 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14885 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14887 ok = (o->op_flags &~ OPf_PARENS)
14888 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14889 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14891 else if (o->op_type == OP_EXISTS) {
14892 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14893 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14894 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14895 ok = !(o->op_private & ~OPpARG1_MASK);
14897 else if (o->op_type == OP_DELETE) {
14898 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14899 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14900 ASSUME(!(o->op_private &
14901 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14902 /* don't handle slices or 'local delete'; the latter
14903 * is fairly rare, and has a complex runtime */
14904 ok = !(o->op_private & ~OPpARG1_MASK);
14905 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14906 /* skip handling run-tome error */
14907 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14910 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14911 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14912 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14913 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14914 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14915 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14920 if (!first_elem_op)
14924 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14929 action |= MDEREF_FLAG_last;
14933 /* at this point we have something that started
14934 * promisingly enough (with rv2av or whatever), but failed
14935 * to find a simple index followed by an
14936 * aelem/helem/exists/delete. If this is the first action,
14937 * give up; but if we've already seen at least one
14938 * aelem/helem, then keep them and add a new action with
14939 * MDEREF_INDEX_none, which causes it to do the vivify
14940 * from the end of the previous lookup, and do the deref,
14941 * but stop at that point. So $a[0][expr] will do one
14942 * av_fetch, vivify and deref, then continue executing at
14947 index_skip = action_count;
14948 action |= MDEREF_FLAG_last;
14949 if (index_type != MDEREF_INDEX_none)
14954 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14957 /* if there's no space for the next action, create a new slot
14958 * for it *before* we start adding args for that action */
14959 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14966 } /* while !is_last */
14974 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14975 if (index_skip == -1) {
14976 mderef->op_flags = o->op_flags
14977 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14978 if (o->op_type == OP_EXISTS)
14979 mderef->op_private = OPpMULTIDEREF_EXISTS;
14980 else if (o->op_type == OP_DELETE)
14981 mderef->op_private = OPpMULTIDEREF_DELETE;
14983 mderef->op_private = o->op_private
14984 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14986 /* accumulate strictness from every level (although I don't think
14987 * they can actually vary) */
14988 mderef->op_private |= hints;
14990 /* integrate the new multideref op into the optree and the
14993 * In general an op like aelem or helem has two child
14994 * sub-trees: the aggregate expression (a_expr) and the
14995 * index expression (i_expr):
15001 * The a_expr returns an AV or HV, while the i-expr returns an
15002 * index. In general a multideref replaces most or all of a
15003 * multi-level tree, e.g.
15019 * With multideref, all the i_exprs will be simple vars or
15020 * constants, except that i_expr1 may be arbitrary in the case
15021 * of MDEREF_INDEX_none.
15023 * The bottom-most a_expr will be either:
15024 * 1) a simple var (so padXv or gv+rv2Xv);
15025 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
15026 * so a simple var with an extra rv2Xv;
15027 * 3) or an arbitrary expression.
15029 * 'start', the first op in the execution chain, will point to
15030 * 1),2): the padXv or gv op;
15031 * 3): the rv2Xv which forms the last op in the a_expr
15032 * execution chain, and the top-most op in the a_expr
15035 * For all cases, the 'start' node is no longer required,
15036 * but we can't free it since one or more external nodes
15037 * may point to it. E.g. consider
15038 * $h{foo} = $a ? $b : $c
15039 * Here, both the op_next and op_other branches of the
15040 * cond_expr point to the gv[*h] of the hash expression, so
15041 * we can't free the 'start' op.
15043 * For expr->[...], we need to save the subtree containing the
15044 * expression; for the other cases, we just need to save the
15046 * So in all cases, we null the start op and keep it around by
15047 * making it the child of the multideref op; for the expr->
15048 * case, the expr will be a subtree of the start node.
15050 * So in the simple 1,2 case the optree above changes to
15056 * ex-gv (or ex-padxv)
15058 * with the op_next chain being
15060 * -> ex-gv -> multideref -> op-following-ex-exists ->
15062 * In the 3 case, we have
15075 * -> rest-of-a_expr subtree ->
15076 * ex-rv2xv -> multideref -> op-following-ex-exists ->
15079 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15080 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15081 * multideref attached as the child, e.g.
15087 * ex-rv2av - i_expr1
15095 /* if we free this op, don't free the pad entry */
15096 if (reset_start_targ)
15097 start->op_targ = 0;
15100 /* Cut the bit we need to save out of the tree and attach to
15101 * the multideref op, then free the rest of the tree */
15103 /* find parent of node to be detached (for use by splice) */
15105 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
15106 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15108 /* there is an arbitrary expression preceding us, e.g.
15109 * expr->[..]? so we need to save the 'expr' subtree */
15110 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15111 p = cUNOPx(p)->op_first;
15112 ASSUME( start->op_type == OP_RV2AV
15113 || start->op_type == OP_RV2HV);
15116 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15117 * above for exists/delete. */
15118 while ( (p->op_flags & OPf_KIDS)
15119 && cUNOPx(p)->op_first != start
15121 p = cUNOPx(p)->op_first;
15123 ASSUME(cUNOPx(p)->op_first == start);
15125 /* detach from main tree, and re-attach under the multideref */
15126 op_sibling_splice(mderef, NULL, 0,
15127 op_sibling_splice(p, NULL, 1, NULL));
15130 start->op_next = mderef;
15132 mderef->op_next = index_skip == -1 ? o->op_next : o;
15134 /* excise and free the original tree, and replace with
15135 * the multideref op */
15136 p = op_sibling_splice(top_op, NULL, -1, mderef);
15145 Size_t size = arg - arg_buf;
15147 if (maybe_aelemfast && action_count == 1)
15150 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15151 sizeof(UNOP_AUX_item) * (size + 1));
15152 /* for dumping etc: store the length in a hidden first slot;
15153 * we set the op_aux pointer to the second slot */
15154 arg_buf->uv = size;
15157 } /* for (pass = ...) */
15160 /* See if the ops following o are such that o will always be executed in
15161 * boolean context: that is, the SV which o pushes onto the stack will
15162 * only ever be consumed by later ops via SvTRUE(sv) or similar.
15163 * If so, set a suitable private flag on o. Normally this will be
15164 * bool_flag; but see below why maybe_flag is needed too.
15166 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15167 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15168 * already be taken, so you'll have to give that op two different flags.
15170 * More explanation of 'maybe_flag' and 'safe_and' parameters.
15171 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15172 * those underlying ops) short-circuit, which means that rather than
15173 * necessarily returning a truth value, they may return the LH argument,
15174 * which may not be boolean. For example in $x = (keys %h || -1), keys
15175 * should return a key count rather than a boolean, even though its
15176 * sort-of being used in boolean context.
15178 * So we only consider such logical ops to provide boolean context to
15179 * their LH argument if they themselves are in void or boolean context.
15180 * However, sometimes the context isn't known until run-time. In this
15181 * case the op is marked with the maybe_flag flag it.
15183 * Consider the following.
15185 * sub f { ....; if (%h) { .... } }
15187 * This is actually compiled as
15189 * sub f { ....; %h && do { .... } }
15191 * Here we won't know until runtime whether the final statement (and hence
15192 * the &&) is in void context and so is safe to return a boolean value.
15193 * So mark o with maybe_flag rather than the bool_flag.
15194 * Note that there is cost associated with determining context at runtime
15195 * (e.g. a call to block_gimme()), so it may not be worth setting (at
15196 * compile time) and testing (at runtime) maybe_flag if the scalar verses
15197 * boolean costs savings are marginal.
15199 * However, we can do slightly better with && (compared to || and //):
15200 * this op only returns its LH argument when that argument is false. In
15201 * this case, as long as the op promises to return a false value which is
15202 * valid in both boolean and scalar contexts, we can mark an op consumed
15203 * by && with bool_flag rather than maybe_flag.
15204 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15205 * than &PL_sv_no for a false result in boolean context, then it's safe. An
15206 * op which promises to handle this case is indicated by setting safe_and
15211 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15216 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15218 /* OPpTARGET_MY and boolean context probably don't mix well.
15219 * If someone finds a valid use case, maybe add an extra flag to this
15220 * function which indicates its safe to do so for this op? */
15221 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
15222 && (o->op_private & OPpTARGET_MY)));
15227 switch (lop->op_type) {
15232 /* these two consume the stack argument in the scalar case,
15233 * and treat it as a boolean in the non linenumber case */
15236 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15237 || (lop->op_private & OPpFLIP_LINENUM))
15243 /* these never leave the original value on the stack */
15252 /* OR DOR and AND evaluate their arg as a boolean, but then may
15253 * leave the original scalar value on the stack when following the
15254 * op_next route. If not in void context, we need to ensure
15255 * that whatever follows consumes the arg only in boolean context
15267 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15271 else if (!(lop->op_flags & OPf_WANT)) {
15272 /* unknown context - decide at runtime */
15284 lop = lop->op_next;
15287 o->op_private |= flag;
15292 /* mechanism for deferring recursion in rpeep() */
15294 #define MAX_DEFERRED 4
15298 if (defer_ix == (MAX_DEFERRED-1)) { \
15299 OP **defer = defer_queue[defer_base]; \
15300 CALL_RPEEP(*defer); \
15301 S_prune_chain_head(defer); \
15302 defer_base = (defer_base + 1) % MAX_DEFERRED; \
15305 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15308 #define IS_AND_OP(o) (o->op_type == OP_AND)
15309 #define IS_OR_OP(o) (o->op_type == OP_OR)
15312 /* A peephole optimizer. We visit the ops in the order they're to execute.
15313 * See the comments at the top of this file for more details about when
15314 * peep() is called */
15317 Perl_rpeep(pTHX_ OP *o)
15321 OP* oldoldop = NULL;
15322 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15323 int defer_base = 0;
15326 if (!o || o->op_opt)
15329 assert(o->op_type != OP_FREED);
15333 SAVEVPTR(PL_curcop);
15334 for (;; o = o->op_next) {
15335 if (o && o->op_opt)
15338 while (defer_ix >= 0) {
15340 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15341 CALL_RPEEP(*defer);
15342 S_prune_chain_head(defer);
15349 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15350 assert(!oldoldop || oldoldop->op_next == oldop);
15351 assert(!oldop || oldop->op_next == o);
15353 /* By default, this op has now been optimised. A couple of cases below
15354 clear this again. */
15358 /* look for a series of 1 or more aggregate derefs, e.g.
15359 * $a[1]{foo}[$i]{$k}
15360 * and replace with a single OP_MULTIDEREF op.
15361 * Each index must be either a const, or a simple variable,
15363 * First, look for likely combinations of starting ops,
15364 * corresponding to (global and lexical variants of)
15366 * $r->[...] $r->{...}
15367 * (preceding expression)->[...]
15368 * (preceding expression)->{...}
15369 * and if so, call maybe_multideref() to do a full inspection
15370 * of the op chain and if appropriate, replace with an
15378 switch (o2->op_type) {
15380 /* $pkg[..] : gv[*pkg]
15381 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
15383 /* Fail if there are new op flag combinations that we're
15384 * not aware of, rather than:
15385 * * silently failing to optimise, or
15386 * * silently optimising the flag away.
15387 * If this ASSUME starts failing, examine what new flag
15388 * has been added to the op, and decide whether the
15389 * optimisation should still occur with that flag, then
15390 * update the code accordingly. This applies to all the
15391 * other ASSUMEs in the block of code too.
15393 ASSUME(!(o2->op_flags &
15394 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15395 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15399 if (o2->op_type == OP_RV2AV) {
15400 action = MDEREF_AV_gvav_aelem;
15404 if (o2->op_type == OP_RV2HV) {
15405 action = MDEREF_HV_gvhv_helem;
15409 if (o2->op_type != OP_RV2SV)
15412 /* at this point we've seen gv,rv2sv, so the only valid
15413 * construct left is $pkg->[] or $pkg->{} */
15415 ASSUME(!(o2->op_flags & OPf_STACKED));
15416 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15417 != (OPf_WANT_SCALAR|OPf_MOD))
15420 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15421 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15422 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15424 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
15425 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15429 if (o2->op_type == OP_RV2AV) {
15430 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15433 if (o2->op_type == OP_RV2HV) {
15434 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15440 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15442 ASSUME(!(o2->op_flags &
15443 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15444 if ((o2->op_flags &
15445 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15446 != (OPf_WANT_SCALAR|OPf_MOD))
15449 ASSUME(!(o2->op_private &
15450 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15451 /* skip if state or intro, or not a deref */
15452 if ( o2->op_private != OPpDEREF_AV
15453 && o2->op_private != OPpDEREF_HV)
15457 if (o2->op_type == OP_RV2AV) {
15458 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15461 if (o2->op_type == OP_RV2HV) {
15462 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15469 /* $lex[..]: padav[@lex:1,2] sR *
15470 * or $lex{..}: padhv[%lex:1,2] sR */
15471 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15472 OPf_REF|OPf_SPECIAL)));
15473 if ((o2->op_flags &
15474 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15475 != (OPf_WANT_SCALAR|OPf_REF))
15477 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15479 /* OPf_PARENS isn't currently used in this case;
15480 * if that changes, let us know! */
15481 ASSUME(!(o2->op_flags & OPf_PARENS));
15483 /* at this point, we wouldn't expect any of the remaining
15484 * possible private flags:
15485 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15486 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15488 * OPpSLICEWARNING shouldn't affect runtime
15490 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15492 action = o2->op_type == OP_PADAV
15493 ? MDEREF_AV_padav_aelem
15494 : MDEREF_HV_padhv_helem;
15496 S_maybe_multideref(aTHX_ o, o2, action, 0);
15502 action = o2->op_type == OP_RV2AV
15503 ? MDEREF_AV_pop_rv2av_aelem
15504 : MDEREF_HV_pop_rv2hv_helem;
15507 /* (expr)->[...]: rv2av sKR/1;
15508 * (expr)->{...}: rv2hv sKR/1; */
15510 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15512 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15513 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15514 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15517 /* at this point, we wouldn't expect any of these
15518 * possible private flags:
15519 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15520 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15522 ASSUME(!(o2->op_private &
15523 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15525 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15529 S_maybe_multideref(aTHX_ o, o2, action, hints);
15538 switch (o->op_type) {
15540 PL_curcop = ((COP*)o); /* for warnings */
15543 PL_curcop = ((COP*)o); /* for warnings */
15545 /* Optimise a "return ..." at the end of a sub to just be "...".
15546 * This saves 2 ops. Before:
15547 * 1 <;> nextstate(main 1 -e:1) v ->2
15548 * 4 <@> return K ->5
15549 * 2 <0> pushmark s ->3
15550 * - <1> ex-rv2sv sK/1 ->4
15551 * 3 <#> gvsv[*cat] s ->4
15554 * - <@> return K ->-
15555 * - <0> pushmark s ->2
15556 * - <1> ex-rv2sv sK/1 ->-
15557 * 2 <$> gvsv(*cat) s ->3
15560 OP *next = o->op_next;
15561 OP *sibling = OpSIBLING(o);
15562 if ( OP_TYPE_IS(next, OP_PUSHMARK)
15563 && OP_TYPE_IS(sibling, OP_RETURN)
15564 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15565 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15566 ||OP_TYPE_IS(sibling->op_next->op_next,
15568 && cUNOPx(sibling)->op_first == next
15569 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15572 /* Look through the PUSHMARK's siblings for one that
15573 * points to the RETURN */
15574 OP *top = OpSIBLING(next);
15575 while (top && top->op_next) {
15576 if (top->op_next == sibling) {
15577 top->op_next = sibling->op_next;
15578 o->op_next = next->op_next;
15581 top = OpSIBLING(top);
15586 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15588 * This latter form is then suitable for conversion into padrange
15589 * later on. Convert:
15591 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15595 * nextstate1 -> listop -> nextstate3
15597 * pushmark -> padop1 -> padop2
15599 if (o->op_next && (
15600 o->op_next->op_type == OP_PADSV
15601 || o->op_next->op_type == OP_PADAV
15602 || o->op_next->op_type == OP_PADHV
15604 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15605 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15606 && o->op_next->op_next->op_next && (
15607 o->op_next->op_next->op_next->op_type == OP_PADSV
15608 || o->op_next->op_next->op_next->op_type == OP_PADAV
15609 || o->op_next->op_next->op_next->op_type == OP_PADHV
15611 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15612 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15613 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15614 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15616 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15619 ns2 = pad1->op_next;
15620 pad2 = ns2->op_next;
15621 ns3 = pad2->op_next;
15623 /* we assume here that the op_next chain is the same as
15624 * the op_sibling chain */
15625 assert(OpSIBLING(o) == pad1);
15626 assert(OpSIBLING(pad1) == ns2);
15627 assert(OpSIBLING(ns2) == pad2);
15628 assert(OpSIBLING(pad2) == ns3);
15630 /* excise and delete ns2 */
15631 op_sibling_splice(NULL, pad1, 1, NULL);
15634 /* excise pad1 and pad2 */
15635 op_sibling_splice(NULL, o, 2, NULL);
15637 /* create new listop, with children consisting of:
15638 * a new pushmark, pad1, pad2. */
15639 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15640 newop->op_flags |= OPf_PARENS;
15641 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15643 /* insert newop between o and ns3 */
15644 op_sibling_splice(NULL, o, 0, newop);
15646 /*fixup op_next chain */
15647 newpm = cUNOPx(newop)->op_first; /* pushmark */
15648 o ->op_next = newpm;
15649 newpm->op_next = pad1;
15650 pad1 ->op_next = pad2;
15651 pad2 ->op_next = newop; /* listop */
15652 newop->op_next = ns3;
15654 /* Ensure pushmark has this flag if padops do */
15655 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15656 newpm->op_flags |= OPf_MOD;
15662 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15663 to carry two labels. For now, take the easier option, and skip
15664 this optimisation if the first NEXTSTATE has a label. */
15665 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15666 OP *nextop = o->op_next;
15667 while (nextop && nextop->op_type == OP_NULL)
15668 nextop = nextop->op_next;
15670 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15673 oldop->op_next = nextop;
15675 /* Skip (old)oldop assignment since the current oldop's
15676 op_next already points to the next op. */
15683 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15684 if (o->op_next->op_private & OPpTARGET_MY) {
15685 if (o->op_flags & OPf_STACKED) /* chained concats */
15686 break; /* ignore_optimization */
15688 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15689 o->op_targ = o->op_next->op_targ;
15690 o->op_next->op_targ = 0;
15691 o->op_private |= OPpTARGET_MY;
15694 op_null(o->op_next);
15698 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15699 break; /* Scalar stub must produce undef. List stub is noop */
15703 if (o->op_targ == OP_NEXTSTATE
15704 || o->op_targ == OP_DBSTATE)
15706 PL_curcop = ((COP*)o);
15708 /* XXX: We avoid setting op_seq here to prevent later calls
15709 to rpeep() from mistakenly concluding that optimisation
15710 has already occurred. This doesn't fix the real problem,
15711 though (See 20010220.007 (#5874)). AMS 20010719 */
15712 /* op_seq functionality is now replaced by op_opt */
15720 oldop->op_next = o->op_next;
15734 convert repeat into a stub with no kids.
15736 if (o->op_next->op_type == OP_CONST
15737 || ( o->op_next->op_type == OP_PADSV
15738 && !(o->op_next->op_private & OPpLVAL_INTRO))
15739 || ( o->op_next->op_type == OP_GV
15740 && o->op_next->op_next->op_type == OP_RV2SV
15741 && !(o->op_next->op_next->op_private
15742 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15744 const OP *kid = o->op_next->op_next;
15745 if (o->op_next->op_type == OP_GV)
15746 kid = kid->op_next;
15747 /* kid is now the ex-list. */
15748 if (kid->op_type == OP_NULL
15749 && (kid = kid->op_next)->op_type == OP_CONST
15750 /* kid is now the repeat count. */
15751 && kid->op_next->op_type == OP_REPEAT
15752 && kid->op_next->op_private & OPpREPEAT_DOLIST
15753 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15754 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15757 o = kid->op_next; /* repeat */
15758 oldop->op_next = o;
15759 op_free(cBINOPo->op_first);
15760 op_free(cBINOPo->op_last );
15761 o->op_flags &=~ OPf_KIDS;
15762 /* stub is a baseop; repeat is a binop */
15763 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15764 OpTYPE_set(o, OP_STUB);
15770 /* Convert a series of PAD ops for my vars plus support into a
15771 * single padrange op. Basically
15773 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15775 * becomes, depending on circumstances, one of
15777 * padrange ----------------------------------> (list) -> rest
15778 * padrange --------------------------------------------> rest
15780 * where all the pad indexes are sequential and of the same type
15782 * We convert the pushmark into a padrange op, then skip
15783 * any other pad ops, and possibly some trailing ops.
15784 * Note that we don't null() the skipped ops, to make it
15785 * easier for Deparse to undo this optimisation (and none of
15786 * the skipped ops are holding any resourses). It also makes
15787 * it easier for find_uninit_var(), as it can just ignore
15788 * padrange, and examine the original pad ops.
15792 OP *followop = NULL; /* the op that will follow the padrange op */
15795 PADOFFSET base = 0; /* init only to stop compiler whining */
15796 bool gvoid = 0; /* init only to stop compiler whining */
15797 bool defav = 0; /* seen (...) = @_ */
15798 bool reuse = 0; /* reuse an existing padrange op */
15800 /* look for a pushmark -> gv[_] -> rv2av */
15805 if ( p->op_type == OP_GV
15806 && cGVOPx_gv(p) == PL_defgv
15807 && (rv2av = p->op_next)
15808 && rv2av->op_type == OP_RV2AV
15809 && !(rv2av->op_flags & OPf_REF)
15810 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15811 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15813 q = rv2av->op_next;
15814 if (q->op_type == OP_NULL)
15816 if (q->op_type == OP_PUSHMARK) {
15826 /* scan for PAD ops */
15828 for (p = p->op_next; p; p = p->op_next) {
15829 if (p->op_type == OP_NULL)
15832 if (( p->op_type != OP_PADSV
15833 && p->op_type != OP_PADAV
15834 && p->op_type != OP_PADHV
15836 /* any private flag other than INTRO? e.g. STATE */
15837 || (p->op_private & ~OPpLVAL_INTRO)
15841 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15843 if ( p->op_type == OP_PADAV
15845 && p->op_next->op_type == OP_CONST
15846 && p->op_next->op_next
15847 && p->op_next->op_next->op_type == OP_AELEM
15851 /* for 1st padop, note what type it is and the range
15852 * start; for the others, check that it's the same type
15853 * and that the targs are contiguous */
15855 intro = (p->op_private & OPpLVAL_INTRO);
15857 gvoid = OP_GIMME(p,0) == G_VOID;
15860 if ((p->op_private & OPpLVAL_INTRO) != intro)
15862 /* Note that you'd normally expect targs to be
15863 * contiguous in my($a,$b,$c), but that's not the case
15864 * when external modules start doing things, e.g.
15865 * Function::Parameters */
15866 if (p->op_targ != base + count)
15868 assert(p->op_targ == base + count);
15869 /* Either all the padops or none of the padops should
15870 be in void context. Since we only do the optimisa-
15871 tion for av/hv when the aggregate itself is pushed
15872 on to the stack (one item), there is no need to dis-
15873 tinguish list from scalar context. */
15874 if (gvoid != (OP_GIMME(p,0) == G_VOID))
15878 /* for AV, HV, only when we're not flattening */
15879 if ( p->op_type != OP_PADSV
15881 && !(p->op_flags & OPf_REF)
15885 if (count >= OPpPADRANGE_COUNTMASK)
15888 /* there's a biggest base we can fit into a
15889 * SAVEt_CLEARPADRANGE in pp_padrange.
15890 * (The sizeof() stuff will be constant-folded, and is
15891 * intended to avoid getting "comparison is always false"
15892 * compiler warnings. See the comments above
15893 * MEM_WRAP_CHECK for more explanation on why we do this
15894 * in a weird way to avoid compiler warnings.)
15897 && (8*sizeof(base) >
15898 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15900 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15902 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15906 /* Success! We've got another valid pad op to optimise away */
15908 followop = p->op_next;
15911 if (count < 1 || (count == 1 && !defav))
15914 /* pp_padrange in specifically compile-time void context
15915 * skips pushing a mark and lexicals; in all other contexts
15916 * (including unknown till runtime) it pushes a mark and the
15917 * lexicals. We must be very careful then, that the ops we
15918 * optimise away would have exactly the same effect as the
15920 * In particular in void context, we can only optimise to
15921 * a padrange if we see the complete sequence
15922 * pushmark, pad*v, ...., list
15923 * which has the net effect of leaving the markstack as it
15924 * was. Not pushing onto the stack (whereas padsv does touch
15925 * the stack) makes no difference in void context.
15929 if (followop->op_type == OP_LIST
15930 && OP_GIMME(followop,0) == G_VOID
15933 followop = followop->op_next; /* skip OP_LIST */
15935 /* consolidate two successive my(...);'s */
15938 && oldoldop->op_type == OP_PADRANGE
15939 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15940 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15941 && !(oldoldop->op_flags & OPf_SPECIAL)
15944 assert(oldoldop->op_next == oldop);
15945 assert( oldop->op_type == OP_NEXTSTATE
15946 || oldop->op_type == OP_DBSTATE);
15947 assert(oldop->op_next == o);
15950 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15952 /* Do not assume pad offsets for $c and $d are con-
15957 if ( oldoldop->op_targ + old_count == base
15958 && old_count < OPpPADRANGE_COUNTMASK - count) {
15959 base = oldoldop->op_targ;
15960 count += old_count;
15965 /* if there's any immediately following singleton
15966 * my var's; then swallow them and the associated
15968 * my ($a,$b); my $c; my $d;
15970 * my ($a,$b,$c,$d);
15973 while ( ((p = followop->op_next))
15974 && ( p->op_type == OP_PADSV
15975 || p->op_type == OP_PADAV
15976 || p->op_type == OP_PADHV)
15977 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15978 && (p->op_private & OPpLVAL_INTRO) == intro
15979 && !(p->op_private & ~OPpLVAL_INTRO)
15981 && ( p->op_next->op_type == OP_NEXTSTATE
15982 || p->op_next->op_type == OP_DBSTATE)
15983 && count < OPpPADRANGE_COUNTMASK
15984 && base + count == p->op_targ
15987 followop = p->op_next;
15995 assert(oldoldop->op_type == OP_PADRANGE);
15996 oldoldop->op_next = followop;
15997 oldoldop->op_private = (intro | count);
16003 /* Convert the pushmark into a padrange.
16004 * To make Deparse easier, we guarantee that a padrange was
16005 * *always* formerly a pushmark */
16006 assert(o->op_type == OP_PUSHMARK);
16007 o->op_next = followop;
16008 OpTYPE_set(o, OP_PADRANGE);
16010 /* bit 7: INTRO; bit 6..0: count */
16011 o->op_private = (intro | count);
16012 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
16013 | gvoid * OPf_WANT_VOID
16014 | (defav ? OPf_SPECIAL : 0));
16020 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16021 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16026 /*'keys %h' in void or scalar context: skip the OP_KEYS
16027 * and perform the functionality directly in the RV2HV/PADHV
16030 if (o->op_flags & OPf_REF) {
16031 OP *k = o->op_next;
16032 U8 want = (k->op_flags & OPf_WANT);
16034 && k->op_type == OP_KEYS
16035 && ( want == OPf_WANT_VOID
16036 || want == OPf_WANT_SCALAR)
16037 && !(k->op_private & OPpMAYBE_LVSUB)
16038 && !(k->op_flags & OPf_MOD)
16040 o->op_next = k->op_next;
16041 o->op_flags &= ~(OPf_REF|OPf_WANT);
16042 o->op_flags |= want;
16043 o->op_private |= (o->op_type == OP_PADHV ?
16044 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
16045 /* for keys(%lex), hold onto the OP_KEYS's targ
16046 * since padhv doesn't have its own targ to return
16048 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16053 /* see if %h is used in boolean context */
16054 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16055 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16058 if (o->op_type != OP_PADHV)
16062 if ( o->op_type == OP_PADAV
16063 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16065 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16068 /* Skip over state($x) in void context. */
16069 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16070 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16072 oldop->op_next = o->op_next;
16073 goto redo_nextstate;
16075 if (o->op_type != OP_PADAV)
16079 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16080 OP* const pop = (o->op_type == OP_PADAV) ?
16081 o->op_next : o->op_next->op_next;
16083 if (pop && pop->op_type == OP_CONST &&
16084 ((PL_op = pop->op_next)) &&
16085 pop->op_next->op_type == OP_AELEM &&
16086 !(pop->op_next->op_private &
16087 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16088 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16091 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16092 no_bareword_allowed(pop);
16093 if (o->op_type == OP_GV)
16094 op_null(o->op_next);
16095 op_null(pop->op_next);
16097 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16098 o->op_next = pop->op_next->op_next;
16099 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16100 o->op_private = (U8)i;
16101 if (o->op_type == OP_GV) {
16104 o->op_type = OP_AELEMFAST;
16107 o->op_type = OP_AELEMFAST_LEX;
16109 if (o->op_type != OP_GV)
16113 /* Remove $foo from the op_next chain in void context. */
16115 && ( o->op_next->op_type == OP_RV2SV
16116 || o->op_next->op_type == OP_RV2AV
16117 || o->op_next->op_type == OP_RV2HV )
16118 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16119 && !(o->op_next->op_private & OPpLVAL_INTRO))
16121 oldop->op_next = o->op_next->op_next;
16122 /* Reprocess the previous op if it is a nextstate, to
16123 allow double-nextstate optimisation. */
16125 if (oldop->op_type == OP_NEXTSTATE) {
16132 o = oldop->op_next;
16135 else if (o->op_next->op_type == OP_RV2SV) {
16136 if (!(o->op_next->op_private & OPpDEREF)) {
16137 op_null(o->op_next);
16138 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16140 o->op_next = o->op_next->op_next;
16141 OpTYPE_set(o, OP_GVSV);
16144 else if (o->op_next->op_type == OP_READLINE
16145 && o->op_next->op_next->op_type == OP_CONCAT
16146 && (o->op_next->op_next->op_flags & OPf_STACKED))
16148 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16149 OpTYPE_set(o, OP_RCATLINE);
16150 o->op_flags |= OPf_STACKED;
16151 op_null(o->op_next->op_next);
16152 op_null(o->op_next);
16163 while (cLOGOP->op_other->op_type == OP_NULL)
16164 cLOGOP->op_other = cLOGOP->op_other->op_next;
16165 while (o->op_next && ( o->op_type == o->op_next->op_type
16166 || o->op_next->op_type == OP_NULL))
16167 o->op_next = o->op_next->op_next;
16169 /* If we're an OR and our next is an AND in void context, we'll
16170 follow its op_other on short circuit, same for reverse.
16171 We can't do this with OP_DOR since if it's true, its return
16172 value is the underlying value which must be evaluated
16176 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16177 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16179 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16181 o->op_next = ((LOGOP*)o->op_next)->op_other;
16183 DEFER(cLOGOP->op_other);
16188 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16189 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16198 case OP_ARGDEFELEM:
16199 while (cLOGOP->op_other->op_type == OP_NULL)
16200 cLOGOP->op_other = cLOGOP->op_other->op_next;
16201 DEFER(cLOGOP->op_other);
16206 while (cLOOP->op_redoop->op_type == OP_NULL)
16207 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16208 while (cLOOP->op_nextop->op_type == OP_NULL)
16209 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16210 while (cLOOP->op_lastop->op_type == OP_NULL)
16211 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16212 /* a while(1) loop doesn't have an op_next that escapes the
16213 * loop, so we have to explicitly follow the op_lastop to
16214 * process the rest of the code */
16215 DEFER(cLOOP->op_lastop);
16219 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16220 DEFER(cLOGOPo->op_other);
16224 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16225 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16226 assert(!(cPMOP->op_pmflags & PMf_ONCE));
16227 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16228 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16229 cPMOP->op_pmstashstartu.op_pmreplstart
16230 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16231 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16237 if (o->op_flags & OPf_SPECIAL) {
16238 /* first arg is a code block */
16239 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16240 OP * kid = cUNOPx(nullop)->op_first;
16242 assert(nullop->op_type == OP_NULL);
16243 assert(kid->op_type == OP_SCOPE
16244 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16245 /* since OP_SORT doesn't have a handy op_other-style
16246 * field that can point directly to the start of the code
16247 * block, store it in the otherwise-unused op_next field
16248 * of the top-level OP_NULL. This will be quicker at
16249 * run-time, and it will also allow us to remove leading
16250 * OP_NULLs by just messing with op_nexts without
16251 * altering the basic op_first/op_sibling layout. */
16252 kid = kLISTOP->op_first;
16254 (kid->op_type == OP_NULL
16255 && ( kid->op_targ == OP_NEXTSTATE
16256 || kid->op_targ == OP_DBSTATE ))
16257 || kid->op_type == OP_STUB
16258 || kid->op_type == OP_ENTER
16259 || (PL_parser && PL_parser->error_count));
16260 nullop->op_next = kid->op_next;
16261 DEFER(nullop->op_next);
16264 /* check that RHS of sort is a single plain array */
16265 oright = cUNOPo->op_first;
16266 if (!oright || oright->op_type != OP_PUSHMARK)
16269 if (o->op_private & OPpSORT_INPLACE)
16272 /* reverse sort ... can be optimised. */
16273 if (!OpHAS_SIBLING(cUNOPo)) {
16274 /* Nothing follows us on the list. */
16275 OP * const reverse = o->op_next;
16277 if (reverse->op_type == OP_REVERSE &&
16278 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16279 OP * const pushmark = cUNOPx(reverse)->op_first;
16280 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16281 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16282 /* reverse -> pushmark -> sort */
16283 o->op_private |= OPpSORT_REVERSE;
16285 pushmark->op_next = oright->op_next;
16295 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16297 LISTOP *enter, *exlist;
16299 if (o->op_private & OPpSORT_INPLACE)
16302 enter = (LISTOP *) o->op_next;
16305 if (enter->op_type == OP_NULL) {
16306 enter = (LISTOP *) enter->op_next;
16310 /* for $a (...) will have OP_GV then OP_RV2GV here.
16311 for (...) just has an OP_GV. */
16312 if (enter->op_type == OP_GV) {
16313 gvop = (OP *) enter;
16314 enter = (LISTOP *) enter->op_next;
16317 if (enter->op_type == OP_RV2GV) {
16318 enter = (LISTOP *) enter->op_next;
16324 if (enter->op_type != OP_ENTERITER)
16327 iter = enter->op_next;
16328 if (!iter || iter->op_type != OP_ITER)
16331 expushmark = enter->op_first;
16332 if (!expushmark || expushmark->op_type != OP_NULL
16333 || expushmark->op_targ != OP_PUSHMARK)
16336 exlist = (LISTOP *) OpSIBLING(expushmark);
16337 if (!exlist || exlist->op_type != OP_NULL
16338 || exlist->op_targ != OP_LIST)
16341 if (exlist->op_last != o) {
16342 /* Mmm. Was expecting to point back to this op. */
16345 theirmark = exlist->op_first;
16346 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16349 if (OpSIBLING(theirmark) != o) {
16350 /* There's something between the mark and the reverse, eg
16351 for (1, reverse (...))
16356 ourmark = ((LISTOP *)o)->op_first;
16357 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16360 ourlast = ((LISTOP *)o)->op_last;
16361 if (!ourlast || ourlast->op_next != o)
16364 rv2av = OpSIBLING(ourmark);
16365 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16366 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16367 /* We're just reversing a single array. */
16368 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16369 enter->op_flags |= OPf_STACKED;
16372 /* We don't have control over who points to theirmark, so sacrifice
16374 theirmark->op_next = ourmark->op_next;
16375 theirmark->op_flags = ourmark->op_flags;
16376 ourlast->op_next = gvop ? gvop : (OP *) enter;
16379 enter->op_private |= OPpITER_REVERSED;
16380 iter->op_private |= OPpITER_REVERSED;
16384 o = oldop->op_next;
16386 NOT_REACHED; /* NOTREACHED */
16392 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16393 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16398 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16399 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16402 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16404 sv = newRV((SV *)PL_compcv);
16408 OpTYPE_set(o, OP_CONST);
16409 o->op_flags |= OPf_SPECIAL;
16410 cSVOPo->op_sv = sv;
16415 if (OP_GIMME(o,0) == G_VOID
16416 || ( o->op_next->op_type == OP_LINESEQ
16417 && ( o->op_next->op_next->op_type == OP_LEAVESUB
16418 || ( o->op_next->op_next->op_type == OP_RETURN
16419 && !CvLVALUE(PL_compcv)))))
16421 OP *right = cBINOP->op_first;
16440 OP *left = OpSIBLING(right);
16441 if (left->op_type == OP_SUBSTR
16442 && (left->op_private & 7) < 4) {
16444 /* cut out right */
16445 op_sibling_splice(o, NULL, 1, NULL);
16446 /* and insert it as second child of OP_SUBSTR */
16447 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16449 left->op_private |= OPpSUBSTR_REPL_FIRST;
16451 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16458 int l, r, lr, lscalars, rscalars;
16460 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16461 Note that we do this now rather than in newASSIGNOP(),
16462 since only by now are aliased lexicals flagged as such
16464 See the essay "Common vars in list assignment" above for
16465 the full details of the rationale behind all the conditions
16468 PL_generation sorcery:
16469 To detect whether there are common vars, the global var
16470 PL_generation is incremented for each assign op we scan.
16471 Then we run through all the lexical variables on the LHS,
16472 of the assignment, setting a spare slot in each of them to
16473 PL_generation. Then we scan the RHS, and if any lexicals
16474 already have that value, we know we've got commonality.
16475 Also, if the generation number is already set to
16476 PERL_INT_MAX, then the variable is involved in aliasing, so
16477 we also have potential commonality in that case.
16483 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
16486 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16490 /* After looking for things which are *always* safe, this main
16491 * if/else chain selects primarily based on the type of the
16492 * LHS, gradually working its way down from the more dangerous
16493 * to the more restrictive and thus safer cases */
16495 if ( !l /* () = ....; */
16496 || !r /* .... = (); */
16497 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16498 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16499 || (lscalars < 2) /* ($x, undef) = ... */
16501 NOOP; /* always safe */
16503 else if (l & AAS_DANGEROUS) {
16504 /* always dangerous */
16505 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16506 o->op_private |= OPpASSIGN_COMMON_AGG;
16508 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16509 /* package vars are always dangerous - too many
16510 * aliasing possibilities */
16511 if (l & AAS_PKG_SCALAR)
16512 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16513 if (l & AAS_PKG_AGG)
16514 o->op_private |= OPpASSIGN_COMMON_AGG;
16516 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16517 |AAS_LEX_SCALAR|AAS_LEX_AGG))
16519 /* LHS contains only lexicals and safe ops */
16521 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16522 o->op_private |= OPpASSIGN_COMMON_AGG;
16524 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16525 if (lr & AAS_LEX_SCALAR_COMM)
16526 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16527 else if ( !(l & AAS_LEX_SCALAR)
16528 && (r & AAS_DEFAV))
16532 * as scalar-safe for performance reasons.
16533 * (it will still have been marked _AGG if necessary */
16536 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16537 /* if there are only lexicals on the LHS and no
16538 * common ones on the RHS, then we assume that the
16539 * only way those lexicals could also get
16540 * on the RHS is via some sort of dereffing or
16543 * ($lex, $x) = (1, $$r)
16544 * and in this case we assume the var must have
16545 * a bumped ref count. So if its ref count is 1,
16546 * it must only be on the LHS.
16548 o->op_private |= OPpASSIGN_COMMON_RC1;
16553 * may have to handle aggregate on LHS, but we can't
16554 * have common scalars. */
16557 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16559 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16560 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16565 /* see if ref() is used in boolean context */
16566 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16567 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16571 /* see if the op is used in known boolean context,
16572 * but not if OA_TARGLEX optimisation is enabled */
16573 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16574 && !(o->op_private & OPpTARGET_MY)
16576 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16580 /* see if the op is used in known boolean context */
16581 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16582 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16586 Perl_cpeep_t cpeep =
16587 XopENTRYCUSTOM(o, xop_peep);
16589 cpeep(aTHX_ o, oldop);
16594 /* did we just null the current op? If so, re-process it to handle
16595 * eliding "empty" ops from the chain */
16596 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16609 Perl_peep(pTHX_ OP *o)
16615 =head1 Custom Operators
16617 =for apidoc Ao||custom_op_xop
16618 Return the XOP structure for a given custom op. This macro should be
16619 considered internal to C<OP_NAME> and the other access macros: use them instead.
16620 This macro does call a function. Prior
16621 to 5.19.6, this was implemented as a
16628 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16634 static const XOP xop_null = { 0, 0, 0, 0, 0 };
16636 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16637 assert(o->op_type == OP_CUSTOM);
16639 /* This is wrong. It assumes a function pointer can be cast to IV,
16640 * which isn't guaranteed, but this is what the old custom OP code
16641 * did. In principle it should be safer to Copy the bytes of the
16642 * pointer into a PV: since the new interface is hidden behind
16643 * functions, this can be changed later if necessary. */
16644 /* Change custom_op_xop if this ever happens */
16645 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16648 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16650 /* assume noone will have just registered a desc */
16651 if (!he && PL_custom_op_names &&
16652 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16657 /* XXX does all this need to be shared mem? */
16658 Newxz(xop, 1, XOP);
16659 pv = SvPV(HeVAL(he), l);
16660 XopENTRY_set(xop, xop_name, savepvn(pv, l));
16661 if (PL_custom_op_descs &&
16662 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16664 pv = SvPV(HeVAL(he), l);
16665 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16667 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16671 xop = (XOP *)&xop_null;
16673 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16677 if(field == XOPe_xop_ptr) {
16680 const U32 flags = XopFLAGS(xop);
16681 if(flags & field) {
16683 case XOPe_xop_name:
16684 any.xop_name = xop->xop_name;
16686 case XOPe_xop_desc:
16687 any.xop_desc = xop->xop_desc;
16689 case XOPe_xop_class:
16690 any.xop_class = xop->xop_class;
16692 case XOPe_xop_peep:
16693 any.xop_peep = xop->xop_peep;
16696 NOT_REACHED; /* NOTREACHED */
16701 case XOPe_xop_name:
16702 any.xop_name = XOPd_xop_name;
16704 case XOPe_xop_desc:
16705 any.xop_desc = XOPd_xop_desc;
16707 case XOPe_xop_class:
16708 any.xop_class = XOPd_xop_class;
16710 case XOPe_xop_peep:
16711 any.xop_peep = XOPd_xop_peep;
16714 NOT_REACHED; /* NOTREACHED */
16719 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16720 * op.c: In function 'Perl_custom_op_get_field':
16721 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16722 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16723 * expands to assert(0), which expands to ((0) ? (void)0 :
16724 * __assert(...)), and gcc doesn't know that __assert can never return. */
16730 =for apidoc Ao||custom_op_register
16731 Register a custom op. See L<perlguts/"Custom Operators">.
16737 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16741 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16743 /* see the comment in custom_op_xop */
16744 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16746 if (!PL_custom_ops)
16747 PL_custom_ops = newHV();
16749 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16750 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16755 =for apidoc core_prototype
16757 This function assigns the prototype of the named core function to C<sv>, or
16758 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
16759 C<NULL> if the core function has no prototype. C<code> is a code as returned
16760 by C<keyword()>. It must not be equal to 0.
16766 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16769 int i = 0, n = 0, seen_question = 0, defgv = 0;
16771 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16772 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16773 bool nullret = FALSE;
16775 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16779 if (!sv) sv = sv_newmortal();
16781 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16783 switch (code < 0 ? -code : code) {
16784 case KEY_and : case KEY_chop: case KEY_chomp:
16785 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
16786 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
16787 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
16788 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
16789 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
16790 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
16791 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
16792 case KEY_x : case KEY_xor :
16793 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16794 case KEY_glob: retsetpvs("_;", OP_GLOB);
16795 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
16796 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
16797 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
16798 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
16799 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16801 case KEY_evalbytes:
16802 name = "entereval"; break;
16810 while (i < MAXO) { /* The slow way. */
16811 if (strEQ(name, PL_op_name[i])
16812 || strEQ(name, PL_op_desc[i]))
16814 if (nullret) { assert(opnum); *opnum = i; return NULL; }
16821 defgv = PL_opargs[i] & OA_DEFGV;
16822 oa = PL_opargs[i] >> OASHIFT;
16824 if (oa & OA_OPTIONAL && !seen_question && (
16825 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16830 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16831 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16832 /* But globs are already references (kinda) */
16833 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16837 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16838 && !scalar_mod_type(NULL, i)) {
16843 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16847 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16848 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16849 str[n-1] = '_'; defgv = 0;
16853 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16855 sv_setpvn(sv, str, n - 1);
16856 if (opnum) *opnum = i;
16861 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16864 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16867 PERL_ARGS_ASSERT_CORESUB_OP;
16871 return op_append_elem(OP_LINESEQ,
16874 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16881 o = newUNOP(OP_AVHVSWITCH,0,argop);
16882 o->op_private = opnum-OP_EACH;
16884 case OP_SELECT: /* which represents OP_SSELECT as well */
16889 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16890 newSVOP(OP_CONST, 0, newSVuv(1))
16892 coresub_op(newSVuv((UV)OP_SSELECT), 0,
16894 coresub_op(coreargssv, 0, OP_SELECT)
16898 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16900 return op_append_elem(
16903 opnum == OP_WANTARRAY || opnum == OP_RUNCV
16904 ? OPpOFFBYONE << 8 : 0)
16906 case OA_BASEOP_OR_UNOP:
16907 if (opnum == OP_ENTEREVAL) {
16908 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16909 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16911 else o = newUNOP(opnum,0,argop);
16912 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16915 if (is_handle_constructor(o, 1))
16916 argop->op_private |= OPpCOREARGS_DEREF1;
16917 if (scalar_mod_type(NULL, opnum))
16918 argop->op_private |= OPpCOREARGS_SCALARMOD;
16922 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16923 if (is_handle_constructor(o, 2))
16924 argop->op_private |= OPpCOREARGS_DEREF2;
16925 if (opnum == OP_SUBSTR) {
16926 o->op_private |= OPpMAYBE_LVSUB;
16935 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16936 SV * const *new_const_svp)
16938 const char *hvname;
16939 bool is_const = !!CvCONST(old_cv);
16940 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16942 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16944 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16946 /* They are 2 constant subroutines generated from
16947 the same constant. This probably means that
16948 they are really the "same" proxy subroutine
16949 instantiated in 2 places. Most likely this is
16950 when a constant is exported twice. Don't warn.
16953 (ckWARN(WARN_REDEFINE)
16955 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16956 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16957 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16958 strEQ(hvname, "autouse"))
16962 && ckWARN_d(WARN_REDEFINE)
16963 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16966 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16968 ? "Constant subroutine %" SVf " redefined"
16969 : "Subroutine %" SVf " redefined",
16974 =head1 Hook manipulation
16976 These functions provide convenient and thread-safe means of manipulating
16983 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16985 Puts a C function into the chain of check functions for a specified op
16986 type. This is the preferred way to manipulate the L</PL_check> array.
16987 C<opcode> specifies which type of op is to be affected. C<new_checker>
16988 is a pointer to the C function that is to be added to that opcode's
16989 check chain, and C<old_checker_p> points to the storage location where a
16990 pointer to the next function in the chain will be stored. The value of
16991 C<new_checker> is written into the L</PL_check> array, while the value
16992 previously stored there is written to C<*old_checker_p>.
16994 L</PL_check> is global to an entire process, and a module wishing to
16995 hook op checking may find itself invoked more than once per process,
16996 typically in different threads. To handle that situation, this function
16997 is idempotent. The location C<*old_checker_p> must initially (once
16998 per process) contain a null pointer. A C variable of static duration
16999 (declared at file scope, typically also marked C<static> to give
17000 it internal linkage) will be implicitly initialised appropriately,
17001 if it does not have an explicit initialiser. This function will only
17002 actually modify the check chain if it finds C<*old_checker_p> to be null.
17003 This function is also thread safe on the small scale. It uses appropriate
17004 locking to avoid race conditions in accessing L</PL_check>.
17006 When this function is called, the function referenced by C<new_checker>
17007 must be ready to be called, except for C<*old_checker_p> being unfilled.
17008 In a threading situation, C<new_checker> may be called immediately,
17009 even before this function has returned. C<*old_checker_p> will always
17010 be appropriately set before C<new_checker> is called. If C<new_checker>
17011 decides not to do anything special with an op that it is given (which
17012 is the usual case for most uses of op check hooking), it must chain the
17013 check function referenced by C<*old_checker_p>.
17015 Taken all together, XS code to hook an op checker should typically look
17016 something like this:
17018 static Perl_check_t nxck_frob;
17019 static OP *myck_frob(pTHX_ OP *op) {
17021 op = nxck_frob(aTHX_ op);
17026 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
17028 If you want to influence compilation of calls to a specific subroutine,
17029 then use L</cv_set_call_checker_flags> rather than hooking checking of
17030 all C<entersub> ops.
17036 Perl_wrap_op_checker(pTHX_ Optype opcode,
17037 Perl_check_t new_checker, Perl_check_t *old_checker_p)
17041 PERL_UNUSED_CONTEXT;
17042 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
17043 if (*old_checker_p) return;
17044 OP_CHECK_MUTEX_LOCK;
17045 if (!*old_checker_p) {
17046 *old_checker_p = PL_check[opcode];
17047 PL_check[opcode] = new_checker;
17049 OP_CHECK_MUTEX_UNLOCK;
17054 /* Efficient sub that returns a constant scalar value. */
17056 const_sv_xsub(pTHX_ CV* cv)
17059 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17060 PERL_UNUSED_ARG(items);
17070 const_av_xsub(pTHX_ CV* cv)
17073 AV * const av = MUTABLE_AV(XSANY.any_ptr);
17081 if (SvRMAGICAL(av))
17082 Perl_croak(aTHX_ "Magical list constants are not supported");
17083 if (GIMME_V != G_ARRAY) {
17085 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17088 EXTEND(SP, AvFILLp(av)+1);
17089 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17090 XSRETURN(AvFILLp(av)+1);
17093 /* Copy an existing cop->cop_warnings field.
17094 * If it's one of the standard addresses, just re-use the address.
17095 * This is the e implementation for the DUP_WARNINGS() macro
17099 Perl_dup_warnings(pTHX_ STRLEN* warnings)
17102 STRLEN *new_warnings;
17104 if (warnings == NULL || specialWARN(warnings))
17107 size = sizeof(*warnings) + *warnings;
17109 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
17110 Copy(warnings, new_warnings, size, char);
17111 return new_warnings;
17115 * ex: set ts=8 sts=4 sw=4 et: