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
178 #define DEFERRED_OP_STEP 100
179 #define DEFER_OP(o) \
181 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
182 defer_stack_alloc += DEFERRED_OP_STEP; \
183 assert(defer_stack_alloc > 0); \
184 Renew(defer_stack, defer_stack_alloc, OP *); \
186 defer_stack[++defer_ix] = o; \
189 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
191 /* remove any leading "empty" ops from the op_next chain whose first
192 * node's address is stored in op_p. Store the updated address of the
193 * first node in op_p.
197 S_prune_chain_head(OP** op_p)
200 && ( (*op_p)->op_type == OP_NULL
201 || (*op_p)->op_type == OP_SCOPE
202 || (*op_p)->op_type == OP_SCALAR
203 || (*op_p)->op_type == OP_LINESEQ)
205 *op_p = (*op_p)->op_next;
209 /* See the explanatory comments above struct opslab in op.h. */
211 #ifdef PERL_DEBUG_READONLY_OPS
212 # define PERL_SLAB_SIZE 128
213 # define PERL_MAX_SLAB_SIZE 4096
214 # include <sys/mman.h>
217 #ifndef PERL_SLAB_SIZE
218 # define PERL_SLAB_SIZE 64
220 #ifndef PERL_MAX_SLAB_SIZE
221 # define PERL_MAX_SLAB_SIZE 2048
224 /* rounds up to nearest pointer */
225 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
226 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
229 S_new_slab(pTHX_ size_t sz)
231 #ifdef PERL_DEBUG_READONLY_OPS
232 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
233 PROT_READ|PROT_WRITE,
234 MAP_ANON|MAP_PRIVATE, -1, 0);
235 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
236 (unsigned long) sz, slab));
237 if (slab == MAP_FAILED) {
238 perror("mmap failed");
241 slab->opslab_size = (U16)sz;
243 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
246 /* The context is unused in non-Windows */
249 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
253 /* requires double parens and aTHX_ */
254 #define DEBUG_S_warn(args) \
256 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
260 Perl_Slab_Alloc(pTHX_ size_t sz)
268 /* We only allocate ops from the slab during subroutine compilation.
269 We find the slab via PL_compcv, hence that must be non-NULL. It could
270 also be pointing to a subroutine which is now fully set up (CvROOT()
271 pointing to the top of the optree for that sub), or a subroutine
272 which isn't using the slab allocator. If our sanity checks aren't met,
273 don't use a slab, but allocate the OP directly from the heap. */
274 if (!PL_compcv || CvROOT(PL_compcv)
275 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
277 o = (OP*)PerlMemShared_calloc(1, sz);
281 /* While the subroutine is under construction, the slabs are accessed via
282 CvSTART(), to avoid needing to expand PVCV by one pointer for something
283 unneeded at runtime. Once a subroutine is constructed, the slabs are
284 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
285 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
287 if (!CvSTART(PL_compcv)) {
289 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
290 CvSLABBED_on(PL_compcv);
291 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
293 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
295 opsz = SIZE_TO_PSIZE(sz);
296 sz = opsz + OPSLOT_HEADER_P;
298 /* The slabs maintain a free list of OPs. In particular, constant folding
299 will free up OPs, so it makes sense to re-use them where possible. A
300 freed up slot is used in preference to a new allocation. */
301 if (slab->opslab_freed) {
302 OP **too = &slab->opslab_freed;
304 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
305 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
306 DEBUG_S_warn((aTHX_ "Alas! too small"));
307 o = *(too = &o->op_next);
308 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
312 Zero(o, opsz, I32 *);
318 #define INIT_OPSLOT \
319 slot->opslot_slab = slab; \
320 slot->opslot_next = slab2->opslab_first; \
321 slab2->opslab_first = slot; \
322 o = &slot->opslot_op; \
325 /* The partially-filled slab is next in the chain. */
326 slab2 = slab->opslab_next ? slab->opslab_next : slab;
327 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
328 /* Remaining space is too small. */
330 /* If we can fit a BASEOP, add it to the free chain, so as not
332 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
333 slot = &slab2->opslab_slots;
335 o->op_type = OP_FREED;
336 o->op_next = slab->opslab_freed;
337 slab->opslab_freed = o;
340 /* Create a new slab. Make this one twice as big. */
341 slot = slab2->opslab_first;
342 while (slot->opslot_next) slot = slot->opslot_next;
343 slab2 = S_new_slab(aTHX_
344 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
346 : (DIFF(slab2, slot)+1)*2);
347 slab2->opslab_next = slab->opslab_next;
348 slab->opslab_next = slab2;
350 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
352 /* Create a new op slot */
353 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
354 assert(slot >= &slab2->opslab_slots);
355 if (DIFF(&slab2->opslab_slots, slot)
356 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
357 slot = &slab2->opslab_slots;
359 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
362 #ifdef PERL_OP_PARENT
363 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
364 assert(!o->op_moresib);
365 assert(!o->op_sibparent);
373 #ifdef PERL_DEBUG_READONLY_OPS
375 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
377 PERL_ARGS_ASSERT_SLAB_TO_RO;
379 if (slab->opslab_readonly) return;
380 slab->opslab_readonly = 1;
381 for (; slab; slab = slab->opslab_next) {
382 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
383 (unsigned long) slab->opslab_size, slab));*/
384 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
385 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
386 (unsigned long)slab->opslab_size, errno);
391 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
395 PERL_ARGS_ASSERT_SLAB_TO_RW;
397 if (!slab->opslab_readonly) return;
399 for (; slab2; slab2 = slab2->opslab_next) {
400 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
401 (unsigned long) size, slab2));*/
402 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
403 PROT_READ|PROT_WRITE)) {
404 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
405 (unsigned long)slab2->opslab_size, errno);
408 slab->opslab_readonly = 0;
412 # define Slab_to_rw(op) NOOP
415 /* This cannot possibly be right, but it was copied from the old slab
416 allocator, to which it was originally added, without explanation, in
419 # define PerlMemShared PerlMem
422 /* make freed ops die if they're inadvertently executed */
427 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
432 Perl_Slab_Free(pTHX_ void *op)
434 OP * const o = (OP *)op;
437 PERL_ARGS_ASSERT_SLAB_FREE;
440 o->op_ppaddr = S_pp_freed;
443 if (!o->op_slabbed) {
445 PerlMemShared_free(op);
450 /* If this op is already freed, our refcount will get screwy. */
451 assert(o->op_type != OP_FREED);
452 o->op_type = OP_FREED;
453 o->op_next = slab->opslab_freed;
454 slab->opslab_freed = o;
455 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
456 OpslabREFCNT_dec_padok(slab);
460 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
462 const bool havepad = !!PL_comppad;
463 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
466 PAD_SAVE_SETNULLPAD();
473 Perl_opslab_free(pTHX_ OPSLAB *slab)
476 PERL_ARGS_ASSERT_OPSLAB_FREE;
478 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
479 assert(slab->opslab_refcnt == 1);
481 slab2 = slab->opslab_next;
483 slab->opslab_refcnt = ~(size_t)0;
485 #ifdef PERL_DEBUG_READONLY_OPS
486 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
488 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
489 perror("munmap failed");
493 PerlMemShared_free(slab);
500 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
504 size_t savestack_count = 0;
506 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
510 for (slot = slab2->opslab_first;
512 slot = slot->opslot_next) {
513 if (slot->opslot_op.op_type != OP_FREED
514 && !(slot->opslot_op.op_savefree
520 assert(slot->opslot_op.op_slabbed);
521 op_free(&slot->opslot_op);
522 if (slab->opslab_refcnt == 1) goto free;
525 } while ((slab2 = slab2->opslab_next));
526 /* > 1 because the CV still holds a reference count. */
527 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
529 assert(savestack_count == slab->opslab_refcnt-1);
531 /* Remove the CV’s reference count. */
532 slab->opslab_refcnt--;
539 #ifdef PERL_DEBUG_READONLY_OPS
541 Perl_op_refcnt_inc(pTHX_ OP *o)
544 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
545 if (slab && slab->opslab_readonly) {
558 Perl_op_refcnt_dec(pTHX_ OP *o)
561 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
563 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
565 if (slab && slab->opslab_readonly) {
567 result = --o->op_targ;
570 result = --o->op_targ;
576 * In the following definition, the ", (OP*)0" is just to make the compiler
577 * think the expression is of the right type: croak actually does a Siglongjmp.
579 #define CHECKOP(type,o) \
580 ((PL_op_mask && PL_op_mask[type]) \
581 ? ( op_free((OP*)o), \
582 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
584 : PL_check[type](aTHX_ (OP*)o))
586 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
588 #define OpTYPE_set(o,type) \
590 o->op_type = (OPCODE)type; \
591 o->op_ppaddr = PL_ppaddr[type]; \
595 S_no_fh_allowed(pTHX_ OP *o)
597 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
599 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
605 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
607 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
608 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
613 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
615 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
617 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
622 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
624 PERL_ARGS_ASSERT_BAD_TYPE_PV;
626 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
627 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
630 /* remove flags var, its unused in all callers, move to to right end since gv
631 and kid are always the same */
633 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
635 SV * const namesv = cv_name((CV *)gv, NULL, 0);
636 PERL_ARGS_ASSERT_BAD_TYPE_GV;
638 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
639 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
643 S_no_bareword_allowed(pTHX_ OP *o)
645 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
647 qerror(Perl_mess(aTHX_
648 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
650 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
653 /* "register" allocation */
656 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
659 const bool is_our = (PL_parser->in_my == KEY_our);
661 PERL_ARGS_ASSERT_ALLOCMY;
663 if (flags & ~SVf_UTF8)
664 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
667 /* complain about "my $<special_var>" etc etc */
671 || ( (flags & SVf_UTF8)
672 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
673 || (name[1] == '_' && len > 2)))
675 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
677 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
678 /* diag_listed_as: Can't use global %s in "%s" */
679 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
680 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
681 PL_parser->in_my == KEY_state ? "state" : "my"));
683 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
684 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
688 /* allocate a spare slot and store the name in that slot */
690 off = pad_add_name_pvn(name, len,
691 (is_our ? padadd_OUR :
692 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
693 PL_parser->in_my_stash,
695 /* $_ is always in main::, even with our */
696 ? (PL_curstash && !memEQs(name,len,"$_")
702 /* anon sub prototypes contains state vars should always be cloned,
703 * otherwise the state var would be shared between anon subs */
705 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
706 CvCLONE_on(PL_compcv);
712 =head1 Optree Manipulation Functions
714 =for apidoc alloccopstash
716 Available only under threaded builds, this function allocates an entry in
717 C<PL_stashpad> for the stash passed to it.
724 Perl_alloccopstash(pTHX_ HV *hv)
726 PADOFFSET off = 0, o = 1;
727 bool found_slot = FALSE;
729 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
731 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
733 for (; o < PL_stashpadmax; ++o) {
734 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
735 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
736 found_slot = TRUE, off = o;
739 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
740 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
741 off = PL_stashpadmax;
742 PL_stashpadmax += 10;
745 PL_stashpad[PL_stashpadix = off] = hv;
750 /* free the body of an op without examining its contents.
751 * Always use this rather than FreeOp directly */
754 S_op_destroy(pTHX_ OP *o)
762 =for apidoc Am|void|op_free|OP *o
764 Free an op. Only use this when an op is no longer linked to from any
771 Perl_op_free(pTHX_ OP *o)
775 SSize_t defer_ix = -1;
776 SSize_t defer_stack_alloc = 0;
777 OP **defer_stack = NULL;
781 /* Though ops may be freed twice, freeing the op after its slab is a
783 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
784 /* During the forced freeing of ops after compilation failure, kidops
785 may be freed before their parents. */
786 if (!o || o->op_type == OP_FREED)
791 /* an op should only ever acquire op_private flags that we know about.
792 * If this fails, you may need to fix something in regen/op_private.
793 * Don't bother testing if:
794 * * the op_ppaddr doesn't match the op; someone may have
795 * overridden the op and be doing strange things with it;
796 * * we've errored, as op flags are often left in an
797 * inconsistent state then. Note that an error when
798 * compiling the main program leaves PL_parser NULL, so
799 * we can't spot faults in the main code, only
800 * evaled/required code */
802 if ( o->op_ppaddr == PL_ppaddr[o->op_type]
804 && !PL_parser->error_count)
806 assert(!(o->op_private & ~PL_op_private_valid[type]));
810 if (o->op_private & OPpREFCOUNTED) {
821 refcnt = OpREFCNT_dec(o);
824 /* Need to find and remove any pattern match ops from the list
825 we maintain for reset(). */
826 find_and_forget_pmops(o);
836 /* Call the op_free hook if it has been set. Do it now so that it's called
837 * at the right time for refcounted ops, but still before all of the kids
841 if (o->op_flags & OPf_KIDS) {
843 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
844 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
845 if (!kid || kid->op_type == OP_FREED)
846 /* During the forced freeing of ops after
847 compilation failure, kidops may be freed before
850 if (!(kid->op_flags & OPf_KIDS))
851 /* If it has no kids, just free it now */
858 type = (OPCODE)o->op_targ;
861 Slab_to_rw(OpSLAB(o));
863 /* COP* is not cleared by op_clear() so that we may track line
864 * numbers etc even after null() */
865 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
873 } while ( (o = POP_DEFERRED_OP()) );
875 Safefree(defer_stack);
878 /* S_op_clear_gv(): free a GV attached to an OP */
882 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
884 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
888 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
889 || o->op_type == OP_MULTIDEREF)
892 ? ((GV*)PAD_SVl(*ixp)) : NULL;
894 ? (GV*)(*svp) : NULL;
896 /* It's possible during global destruction that the GV is freed
897 before the optree. Whilst the SvREFCNT_inc is happy to bump from
898 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
899 will trigger an assertion failure, because the entry to sv_clear
900 checks that the scalar is not already freed. A check of for
901 !SvIS_FREED(gv) turns out to be invalid, because during global
902 destruction the reference count can be forced down to zero
903 (with SVf_BREAK set). In which case raising to 1 and then
904 dropping to 0 triggers cleanup before it should happen. I
905 *think* that this might actually be a general, systematic,
906 weakness of the whole idea of SVf_BREAK, in that code *is*
907 allowed to raise and lower references during global destruction,
908 so any *valid* code that happens to do this during global
909 destruction might well trigger premature cleanup. */
910 bool still_valid = gv && SvREFCNT(gv);
913 SvREFCNT_inc_simple_void(gv);
916 pad_swipe(*ixp, TRUE);
924 int try_downgrade = SvREFCNT(gv) == 2;
927 gv_try_downgrade(gv);
933 Perl_op_clear(pTHX_ OP *o)
938 PERL_ARGS_ASSERT_OP_CLEAR;
940 switch (o->op_type) {
941 case OP_NULL: /* Was holding old type, if any. */
944 case OP_ENTEREVAL: /* Was holding hints. */
945 case OP_ARGDEFELEM: /* Was holding signature index. */
949 if (!(o->op_flags & OPf_REF)
950 || (PL_check[o->op_type] != Perl_ck_ftst))
957 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
959 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
962 case OP_METHOD_REDIR:
963 case OP_METHOD_REDIR_SUPER:
965 if (cMETHOPx(o)->op_rclass_targ) {
966 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
967 cMETHOPx(o)->op_rclass_targ = 0;
970 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
971 cMETHOPx(o)->op_rclass_sv = NULL;
974 case OP_METHOD_NAMED:
975 case OP_METHOD_SUPER:
976 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
977 cMETHOPx(o)->op_u.op_meth_sv = NULL;
980 pad_swipe(o->op_targ, 1);
987 SvREFCNT_dec(cSVOPo->op_sv);
988 cSVOPo->op_sv = NULL;
991 Even if op_clear does a pad_free for the target of the op,
992 pad_free doesn't actually remove the sv that exists in the pad;
993 instead it lives on. This results in that it could be reused as
994 a target later on when the pad was reallocated.
997 pad_swipe(o->op_targ,1);
1007 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1012 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1013 && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1016 if (cPADOPo->op_padix > 0) {
1017 pad_swipe(cPADOPo->op_padix, TRUE);
1018 cPADOPo->op_padix = 0;
1021 SvREFCNT_dec(cSVOPo->op_sv);
1022 cSVOPo->op_sv = NULL;
1026 PerlMemShared_free(cPVOPo->op_pv);
1027 cPVOPo->op_pv = NULL;
1031 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1035 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1036 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1038 if (o->op_private & OPpSPLIT_LEX)
1039 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1042 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1044 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1051 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1052 op_free(cPMOPo->op_code_list);
1053 cPMOPo->op_code_list = NULL;
1054 forget_pmop(cPMOPo);
1055 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1056 /* we use the same protection as the "SAFE" version of the PM_ macros
1057 * here since sv_clean_all might release some PMOPs
1058 * after PL_regex_padav has been cleared
1059 * and the clearing of PL_regex_padav needs to
1060 * happen before sv_clean_all
1063 if(PL_regex_pad) { /* We could be in destruction */
1064 const IV offset = (cPMOPo)->op_pmoffset;
1065 ReREFCNT_dec(PM_GETRE(cPMOPo));
1066 PL_regex_pad[offset] = &PL_sv_undef;
1067 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1071 ReREFCNT_dec(PM_GETRE(cPMOPo));
1072 PM_SETRE(cPMOPo, NULL);
1078 PerlMemShared_free(cUNOP_AUXo->op_aux);
1081 case OP_MULTICONCAT:
1083 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1084 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1085 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1086 * utf8 shared strings */
1087 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1088 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1090 PerlMemShared_free(p1);
1092 PerlMemShared_free(p2);
1093 PerlMemShared_free(aux);
1099 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1100 UV actions = items->uv;
1102 bool is_hash = FALSE;
1105 switch (actions & MDEREF_ACTION_MASK) {
1108 actions = (++items)->uv;
1111 case MDEREF_HV_padhv_helem:
1114 case MDEREF_AV_padav_aelem:
1115 pad_free((++items)->pad_offset);
1118 case MDEREF_HV_gvhv_helem:
1121 case MDEREF_AV_gvav_aelem:
1123 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1125 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1129 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1132 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1134 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1136 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1138 goto do_vivify_rv2xv_elem;
1140 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1143 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1144 pad_free((++items)->pad_offset);
1145 goto do_vivify_rv2xv_elem;
1147 case MDEREF_HV_pop_rv2hv_helem:
1148 case MDEREF_HV_vivify_rv2hv_helem:
1151 do_vivify_rv2xv_elem:
1152 case MDEREF_AV_pop_rv2av_aelem:
1153 case MDEREF_AV_vivify_rv2av_aelem:
1155 switch (actions & MDEREF_INDEX_MASK) {
1156 case MDEREF_INDEX_none:
1159 case MDEREF_INDEX_const:
1163 pad_swipe((++items)->pad_offset, 1);
1165 SvREFCNT_dec((++items)->sv);
1171 case MDEREF_INDEX_padsv:
1172 pad_free((++items)->pad_offset);
1174 case MDEREF_INDEX_gvsv:
1176 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1178 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1183 if (actions & MDEREF_FLAG_last)
1196 actions >>= MDEREF_SHIFT;
1199 /* start of malloc is at op_aux[-1], where the length is
1201 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1206 if (o->op_targ > 0) {
1207 pad_free(o->op_targ);
1213 S_cop_free(pTHX_ COP* cop)
1215 PERL_ARGS_ASSERT_COP_FREE;
1218 if (! specialWARN(cop->cop_warnings))
1219 PerlMemShared_free(cop->cop_warnings);
1220 cophh_free(CopHINTHASH_get(cop));
1221 if (PL_curcop == cop)
1226 S_forget_pmop(pTHX_ PMOP *const o
1229 HV * const pmstash = PmopSTASH(o);
1231 PERL_ARGS_ASSERT_FORGET_PMOP;
1233 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1234 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1236 PMOP **const array = (PMOP**) mg->mg_ptr;
1237 U32 count = mg->mg_len / sizeof(PMOP**);
1241 if (array[i] == o) {
1242 /* Found it. Move the entry at the end to overwrite it. */
1243 array[i] = array[--count];
1244 mg->mg_len = count * sizeof(PMOP**);
1245 /* Could realloc smaller at this point always, but probably
1246 not worth it. Probably worth free()ing if we're the
1249 Safefree(mg->mg_ptr);
1262 S_find_and_forget_pmops(pTHX_ OP *o)
1264 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1266 if (o->op_flags & OPf_KIDS) {
1267 OP *kid = cUNOPo->op_first;
1269 switch (kid->op_type) {
1274 forget_pmop((PMOP*)kid);
1276 find_and_forget_pmops(kid);
1277 kid = OpSIBLING(kid);
1283 =for apidoc Am|void|op_null|OP *o
1285 Neutralizes an op when it is no longer needed, but is still linked to from
1292 Perl_op_null(pTHX_ OP *o)
1296 PERL_ARGS_ASSERT_OP_NULL;
1298 if (o->op_type == OP_NULL)
1301 o->op_targ = o->op_type;
1302 OpTYPE_set(o, OP_NULL);
1306 Perl_op_refcnt_lock(pTHX)
1307 PERL_TSA_ACQUIRE(PL_op_mutex)
1312 PERL_UNUSED_CONTEXT;
1317 Perl_op_refcnt_unlock(pTHX)
1318 PERL_TSA_RELEASE(PL_op_mutex)
1323 PERL_UNUSED_CONTEXT;
1329 =for apidoc op_sibling_splice
1331 A general function for editing the structure of an existing chain of
1332 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1333 you to delete zero or more sequential nodes, replacing them with zero or
1334 more different nodes. Performs the necessary op_first/op_last
1335 housekeeping on the parent node and op_sibling manipulation on the
1336 children. The last deleted node will be marked as as the last node by
1337 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1339 Note that op_next is not manipulated, and nodes are not freed; that is the
1340 responsibility of the caller. It also won't create a new list op for an
1341 empty list etc; use higher-level functions like op_append_elem() for that.
1343 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1344 the splicing doesn't affect the first or last op in the chain.
1346 C<start> is the node preceding the first node to be spliced. Node(s)
1347 following it will be deleted, and ops will be inserted after it. If it is
1348 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1351 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1352 If -1 or greater than or equal to the number of remaining kids, all
1353 remaining kids are deleted.
1355 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1356 If C<NULL>, no nodes are inserted.
1358 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1363 action before after returns
1364 ------ ----- ----- -------
1367 splice(P, A, 2, X-Y-Z) | | B-C
1371 splice(P, NULL, 1, X-Y) | | A
1375 splice(P, NULL, 3, NULL) | | A-B-C
1379 splice(P, B, 0, X-Y) | | NULL
1383 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1384 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1390 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1394 OP *last_del = NULL;
1395 OP *last_ins = NULL;
1398 first = OpSIBLING(start);
1402 first = cLISTOPx(parent)->op_first;
1404 assert(del_count >= -1);
1406 if (del_count && first) {
1408 while (--del_count && OpHAS_SIBLING(last_del))
1409 last_del = OpSIBLING(last_del);
1410 rest = OpSIBLING(last_del);
1411 OpLASTSIB_set(last_del, NULL);
1418 while (OpHAS_SIBLING(last_ins))
1419 last_ins = OpSIBLING(last_ins);
1420 OpMAYBESIB_set(last_ins, rest, NULL);
1426 OpMAYBESIB_set(start, insert, NULL);
1431 cLISTOPx(parent)->op_first = insert;
1433 parent->op_flags |= OPf_KIDS;
1435 parent->op_flags &= ~OPf_KIDS;
1439 /* update op_last etc */
1446 /* ought to use OP_CLASS(parent) here, but that can't handle
1447 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1449 type = parent->op_type;
1450 if (type == OP_CUSTOM) {
1452 type = XopENTRYCUSTOM(parent, xop_class);
1455 if (type == OP_NULL)
1456 type = parent->op_targ;
1457 type = PL_opargs[type] & OA_CLASS_MASK;
1460 lastop = last_ins ? last_ins : start ? start : NULL;
1461 if ( type == OA_BINOP
1462 || type == OA_LISTOP
1466 cLISTOPx(parent)->op_last = lastop;
1469 OpLASTSIB_set(lastop, parent);
1471 return last_del ? first : NULL;
1474 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1478 #ifdef PERL_OP_PARENT
1481 =for apidoc op_parent
1483 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1484 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1490 Perl_op_parent(OP *o)
1492 PERL_ARGS_ASSERT_OP_PARENT;
1493 while (OpHAS_SIBLING(o))
1495 return o->op_sibparent;
1501 /* replace the sibling following start with a new UNOP, which becomes
1502 * the parent of the original sibling; e.g.
1504 * op_sibling_newUNOP(P, A, unop-args...)
1512 * where U is the new UNOP.
1514 * parent and start args are the same as for op_sibling_splice();
1515 * type and flags args are as newUNOP().
1517 * Returns the new UNOP.
1521 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1525 kid = op_sibling_splice(parent, start, 1, NULL);
1526 newop = newUNOP(type, flags, kid);
1527 op_sibling_splice(parent, start, 0, newop);
1532 /* lowest-level newLOGOP-style function - just allocates and populates
1533 * the struct. Higher-level stuff should be done by S_new_logop() /
1534 * newLOGOP(). This function exists mainly to avoid op_first assignment
1535 * being spread throughout this file.
1539 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1544 NewOp(1101, logop, 1, LOGOP);
1545 OpTYPE_set(logop, type);
1546 logop->op_first = first;
1547 logop->op_other = other;
1549 logop->op_flags = OPf_KIDS;
1550 while (kid && OpHAS_SIBLING(kid))
1551 kid = OpSIBLING(kid);
1553 OpLASTSIB_set(kid, (OP*)logop);
1558 /* Contextualizers */
1561 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1563 Applies a syntactic context to an op tree representing an expression.
1564 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1565 or C<G_VOID> to specify the context to apply. The modified op tree
1572 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1574 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1576 case G_SCALAR: return scalar(o);
1577 case G_ARRAY: return list(o);
1578 case G_VOID: return scalarvoid(o);
1580 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1587 =for apidoc Am|OP*|op_linklist|OP *o
1588 This function is the implementation of the L</LINKLIST> macro. It should
1589 not be called directly.
1595 Perl_op_linklist(pTHX_ OP *o)
1599 PERL_ARGS_ASSERT_OP_LINKLIST;
1604 /* establish postfix order */
1605 first = cUNOPo->op_first;
1608 o->op_next = LINKLIST(first);
1611 OP *sibl = OpSIBLING(kid);
1613 kid->op_next = LINKLIST(sibl);
1628 S_scalarkids(pTHX_ OP *o)
1630 if (o && o->op_flags & OPf_KIDS) {
1632 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1639 S_scalarboolean(pTHX_ OP *o)
1641 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1643 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1644 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1645 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1646 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1647 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1648 if (ckWARN(WARN_SYNTAX)) {
1649 const line_t oldline = CopLINE(PL_curcop);
1651 if (PL_parser && PL_parser->copline != NOLINE) {
1652 /* This ensures that warnings are reported at the first line
1653 of the conditional, not the last. */
1654 CopLINE_set(PL_curcop, PL_parser->copline);
1656 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1657 CopLINE_set(PL_curcop, oldline);
1664 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1667 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1668 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1670 const char funny = o->op_type == OP_PADAV
1671 || o->op_type == OP_RV2AV ? '@' : '%';
1672 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1674 if (cUNOPo->op_first->op_type != OP_GV
1675 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1677 return varname(gv, funny, 0, NULL, 0, subscript_type);
1680 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1685 S_op_varname(pTHX_ const OP *o)
1687 return S_op_varname_subscript(aTHX_ o, 1);
1691 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1692 { /* or not so pretty :-) */
1693 if (o->op_type == OP_CONST) {
1695 if (SvPOK(*retsv)) {
1697 *retsv = sv_newmortal();
1698 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1699 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1701 else if (!SvOK(*retsv))
1704 else *retpv = "...";
1708 S_scalar_slice_warning(pTHX_ const OP *o)
1711 const bool h = o->op_type == OP_HSLICE
1712 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1718 SV *keysv = NULL; /* just to silence compiler warnings */
1719 const char *key = NULL;
1721 if (!(o->op_private & OPpSLICEWARNING))
1723 if (PL_parser && PL_parser->error_count)
1724 /* This warning can be nonsensical when there is a syntax error. */
1727 kid = cLISTOPo->op_first;
1728 kid = OpSIBLING(kid); /* get past pushmark */
1729 /* weed out false positives: any ops that can return lists */
1730 switch (kid->op_type) {
1756 /* Don't warn if we have a nulled list either. */
1757 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1760 assert(OpSIBLING(kid));
1761 name = S_op_varname(aTHX_ OpSIBLING(kid));
1762 if (!name) /* XS module fiddling with the op tree */
1764 S_op_pretty(aTHX_ kid, &keysv, &key);
1765 assert(SvPOK(name));
1766 sv_chop(name,SvPVX(name)+1);
1768 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1769 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1770 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1772 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1773 lbrack, key, rbrack);
1775 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1776 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1777 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1779 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1780 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1784 Perl_scalar(pTHX_ OP *o)
1788 /* assumes no premature commitment */
1789 if (!o || (PL_parser && PL_parser->error_count)
1790 || (o->op_flags & OPf_WANT)
1791 || o->op_type == OP_RETURN)
1796 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1798 switch (o->op_type) {
1800 scalar(cBINOPo->op_first);
1801 if (o->op_private & OPpREPEAT_DOLIST) {
1802 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1803 assert(kid->op_type == OP_PUSHMARK);
1804 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1805 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1806 o->op_private &=~ OPpREPEAT_DOLIST;
1813 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1823 if (o->op_flags & OPf_KIDS) {
1824 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1830 kid = cLISTOPo->op_first;
1832 kid = OpSIBLING(kid);
1835 OP *sib = OpSIBLING(kid);
1836 if (sib && kid->op_type != OP_LEAVEWHEN
1837 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1838 || ( sib->op_targ != OP_NEXTSTATE
1839 && sib->op_targ != OP_DBSTATE )))
1845 PL_curcop = &PL_compiling;
1850 kid = cLISTOPo->op_first;
1853 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1858 /* Warn about scalar context */
1859 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1860 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1863 const char *key = NULL;
1865 /* This warning can be nonsensical when there is a syntax error. */
1866 if (PL_parser && PL_parser->error_count)
1869 if (!ckWARN(WARN_SYNTAX)) break;
1871 kid = cLISTOPo->op_first;
1872 kid = OpSIBLING(kid); /* get past pushmark */
1873 assert(OpSIBLING(kid));
1874 name = S_op_varname(aTHX_ OpSIBLING(kid));
1875 if (!name) /* XS module fiddling with the op tree */
1877 S_op_pretty(aTHX_ kid, &keysv, &key);
1878 assert(SvPOK(name));
1879 sv_chop(name,SvPVX(name)+1);
1881 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1882 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1883 "%%%" SVf "%c%s%c in scalar context better written "
1884 "as $%" SVf "%c%s%c",
1885 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1886 lbrack, key, rbrack);
1888 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1889 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1890 "%%%" SVf "%c%" SVf "%c in scalar context better "
1891 "written as $%" SVf "%c%" SVf "%c",
1892 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1893 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1900 Perl_scalarvoid(pTHX_ OP *arg)
1905 SSize_t defer_stack_alloc = 0;
1906 SSize_t defer_ix = -1;
1907 OP **defer_stack = NULL;
1910 PERL_ARGS_ASSERT_SCALARVOID;
1914 SV *useless_sv = NULL;
1915 const char* useless = NULL;
1917 if (o->op_type == OP_NEXTSTATE
1918 || o->op_type == OP_DBSTATE
1919 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1920 || o->op_targ == OP_DBSTATE)))
1921 PL_curcop = (COP*)o; /* for warning below */
1923 /* assumes no premature commitment */
1924 want = o->op_flags & OPf_WANT;
1925 if ((want && want != OPf_WANT_SCALAR)
1926 || (PL_parser && PL_parser->error_count)
1927 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1932 if ((o->op_private & OPpTARGET_MY)
1933 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1935 /* newASSIGNOP has already applied scalar context, which we
1936 leave, as if this op is inside SASSIGN. */
1940 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1942 switch (o->op_type) {
1944 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1948 if (o->op_flags & OPf_STACKED)
1950 if (o->op_type == OP_REPEAT)
1951 scalar(cBINOPo->op_first);
1954 if ((o->op_flags & OPf_STACKED) &&
1955 !(o->op_private & OPpCONCAT_NESTED))
1959 if (o->op_private == 4)
1994 case OP_GETSOCKNAME:
1995 case OP_GETPEERNAME:
2000 case OP_GETPRIORITY:
2025 useless = OP_DESC(o);
2035 case OP_AELEMFAST_LEX:
2039 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2040 /* Otherwise it's "Useless use of grep iterator" */
2041 useless = OP_DESC(o);
2045 if (!(o->op_private & OPpSPLIT_ASSIGN))
2046 useless = OP_DESC(o);
2050 kid = cUNOPo->op_first;
2051 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2052 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2055 useless = "negative pattern binding (!~)";
2059 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2060 useless = "non-destructive substitution (s///r)";
2064 useless = "non-destructive transliteration (tr///r)";
2071 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2072 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2073 useless = "a variable";
2078 if (cSVOPo->op_private & OPpCONST_STRICT)
2079 no_bareword_allowed(o);
2081 if (ckWARN(WARN_VOID)) {
2083 /* don't warn on optimised away booleans, eg
2084 * use constant Foo, 5; Foo || print; */
2085 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2087 /* the constants 0 and 1 are permitted as they are
2088 conventionally used as dummies in constructs like
2089 1 while some_condition_with_side_effects; */
2090 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2092 else if (SvPOK(sv)) {
2093 SV * const dsv = newSVpvs("");
2095 = Perl_newSVpvf(aTHX_
2097 pv_pretty(dsv, SvPVX_const(sv),
2098 SvCUR(sv), 32, NULL, NULL,
2100 | PERL_PV_ESCAPE_NOCLEAR
2101 | PERL_PV_ESCAPE_UNI_DETECT));
2102 SvREFCNT_dec_NN(dsv);
2104 else if (SvOK(sv)) {
2105 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2108 useless = "a constant (undef)";
2111 op_null(o); /* don't execute or even remember it */
2115 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2119 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2123 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2127 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2132 UNOP *refgen, *rv2cv;
2135 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2138 rv2gv = ((BINOP *)o)->op_last;
2139 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2142 refgen = (UNOP *)((BINOP *)o)->op_first;
2144 if (!refgen || (refgen->op_type != OP_REFGEN
2145 && refgen->op_type != OP_SREFGEN))
2148 exlist = (LISTOP *)refgen->op_first;
2149 if (!exlist || exlist->op_type != OP_NULL
2150 || exlist->op_targ != OP_LIST)
2153 if (exlist->op_first->op_type != OP_PUSHMARK
2154 && exlist->op_first != exlist->op_last)
2157 rv2cv = (UNOP*)exlist->op_last;
2159 if (rv2cv->op_type != OP_RV2CV)
2162 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2163 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2164 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2166 o->op_private |= OPpASSIGN_CV_TO_GV;
2167 rv2gv->op_private |= OPpDONT_INIT_GV;
2168 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2180 kid = cLOGOPo->op_first;
2181 if (kid->op_type == OP_NOT
2182 && (kid->op_flags & OPf_KIDS)) {
2183 if (o->op_type == OP_AND) {
2184 OpTYPE_set(o, OP_OR);
2186 OpTYPE_set(o, OP_AND);
2196 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2197 if (!(kid->op_flags & OPf_KIDS))
2204 if (o->op_flags & OPf_STACKED)
2211 if (!(o->op_flags & OPf_KIDS))
2222 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2223 if (!(kid->op_flags & OPf_KIDS))
2229 /* If the first kid after pushmark is something that the padrange
2230 optimisation would reject, then null the list and the pushmark.
2232 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2233 && ( !(kid = OpSIBLING(kid))
2234 || ( kid->op_type != OP_PADSV
2235 && kid->op_type != OP_PADAV
2236 && kid->op_type != OP_PADHV)
2237 || kid->op_private & ~OPpLVAL_INTRO
2238 || !(kid = OpSIBLING(kid))
2239 || ( kid->op_type != OP_PADSV
2240 && kid->op_type != OP_PADAV
2241 && kid->op_type != OP_PADHV)
2242 || kid->op_private & ~OPpLVAL_INTRO)
2244 op_null(cUNOPo->op_first); /* NULL the pushmark */
2245 op_null(o); /* NULL the list */
2257 /* mortalise it, in case warnings are fatal. */
2258 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2259 "Useless use of %" SVf " in void context",
2260 SVfARG(sv_2mortal(useless_sv)));
2263 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2264 "Useless use of %s in void context",
2267 } while ( (o = POP_DEFERRED_OP()) );
2269 Safefree(defer_stack);
2275 S_listkids(pTHX_ OP *o)
2277 if (o && o->op_flags & OPf_KIDS) {
2279 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2286 Perl_list(pTHX_ OP *o)
2290 /* assumes no premature commitment */
2291 if (!o || (o->op_flags & OPf_WANT)
2292 || (PL_parser && PL_parser->error_count)
2293 || o->op_type == OP_RETURN)
2298 if ((o->op_private & OPpTARGET_MY)
2299 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2301 return o; /* As if inside SASSIGN */
2304 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2306 switch (o->op_type) {
2308 list(cBINOPo->op_first);
2311 if (o->op_private & OPpREPEAT_DOLIST
2312 && !(o->op_flags & OPf_STACKED))
2314 list(cBINOPo->op_first);
2315 kid = cBINOPo->op_last;
2316 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2317 && SvIVX(kSVOP_sv) == 1)
2319 op_null(o); /* repeat */
2320 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2322 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2329 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2337 if (!(o->op_flags & OPf_KIDS))
2339 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2340 list(cBINOPo->op_first);
2341 return gen_constant_list(o);
2347 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2348 op_null(cUNOPo->op_first); /* NULL the pushmark */
2349 op_null(o); /* NULL the list */
2354 kid = cLISTOPo->op_first;
2356 kid = OpSIBLING(kid);
2359 OP *sib = OpSIBLING(kid);
2360 if (sib && kid->op_type != OP_LEAVEWHEN)
2366 PL_curcop = &PL_compiling;
2370 kid = cLISTOPo->op_first;
2377 S_scalarseq(pTHX_ OP *o)
2380 const OPCODE type = o->op_type;
2382 if (type == OP_LINESEQ || type == OP_SCOPE ||
2383 type == OP_LEAVE || type == OP_LEAVETRY)
2386 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2387 if ((sib = OpSIBLING(kid))
2388 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2389 || ( sib->op_targ != OP_NEXTSTATE
2390 && sib->op_targ != OP_DBSTATE )))
2395 PL_curcop = &PL_compiling;
2397 o->op_flags &= ~OPf_PARENS;
2398 if (PL_hints & HINT_BLOCK_SCOPE)
2399 o->op_flags |= OPf_PARENS;
2402 o = newOP(OP_STUB, 0);
2407 S_modkids(pTHX_ OP *o, I32 type)
2409 if (o && o->op_flags & OPf_KIDS) {
2411 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2412 op_lvalue(kid, type);
2418 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2419 * const fields. Also, convert CONST keys to HEK-in-SVs.
2420 * rop is the op that retrieves the hash;
2421 * key_op is the first key
2425 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2431 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2433 if (rop->op_first->op_type == OP_PADSV)
2434 /* @$hash{qw(keys here)} */
2435 rop = (UNOP*)rop->op_first;
2437 /* @{$hash}{qw(keys here)} */
2438 if (rop->op_first->op_type == OP_SCOPE
2439 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2441 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2448 lexname = NULL; /* just to silence compiler warnings */
2449 fields = NULL; /* just to silence compiler warnings */
2453 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2454 SvPAD_TYPED(lexname))
2455 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2456 && isGV(*fields) && GvHV(*fields);
2458 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2460 if (key_op->op_type != OP_CONST)
2462 svp = cSVOPx_svp(key_op);
2464 /* make sure it's not a bareword under strict subs */
2465 if (key_op->op_private & OPpCONST_BARE &&
2466 key_op->op_private & OPpCONST_STRICT)
2468 no_bareword_allowed((OP*)key_op);
2471 /* Make the CONST have a shared SV */
2472 if ( !SvIsCOW_shared_hash(sv = *svp)
2473 && SvTYPE(sv) < SVt_PVMG
2478 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2479 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2480 SvREFCNT_dec_NN(sv);
2485 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2487 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2488 "in variable %" PNf " of type %" HEKf,
2489 SVfARG(*svp), PNfARG(lexname),
2490 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2495 /* info returned by S_sprintf_is_multiconcatable() */
2497 struct sprintf_ismc_info {
2498 SSize_t nargs; /* num of args to sprintf (not including the format) */
2499 char *start; /* start of raw format string */
2500 char *end; /* bytes after end of raw format string */
2501 STRLEN total_len; /* total length (in bytes) of format string, not
2502 including '%s' and half of '%%' */
2503 STRLEN variant; /* number of bytes by which total_len_p would grow
2504 if upgraded to utf8 */
2505 bool utf8; /* whether the format is utf8 */
2509 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2510 * i.e. its format argument is a const string with only '%s' and '%%'
2511 * formats, and the number of args is known, e.g.
2512 * sprintf "a=%s f=%s", $a[0], scalar(f());
2514 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2516 * If successful, the sprintf_ismc_info struct pointed to by info will be
2521 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2523 OP *pm, *constop, *kid;
2526 SSize_t nargs, nformats;
2527 STRLEN cur, total_len, variant;
2530 /* if sprintf's behaviour changes, die here so that someone
2531 * can decide whether to enhance this function or skip optimising
2532 * under those new circumstances */
2533 assert(!(o->op_flags & OPf_STACKED));
2534 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2535 assert(!(o->op_private & ~OPpARG4_MASK));
2537 pm = cUNOPo->op_first;
2538 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2540 constop = OpSIBLING(pm);
2541 if (!constop || constop->op_type != OP_CONST)
2543 sv = cSVOPx_sv(constop);
2544 if (SvMAGICAL(sv) || !SvPOK(sv))
2550 /* Scan format for %% and %s and work out how many %s there are.
2551 * Abandon if other format types are found.
2558 for (p = s; p < e; p++) {
2561 if (!UTF8_IS_INVARIANT(*p))
2567 return FALSE; /* lone % at end gives "Invalid conversion" */
2576 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2579 utf8 = cBOOL(SvUTF8(sv));
2583 /* scan args; they must all be in scalar cxt */
2586 kid = OpSIBLING(constop);
2589 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2592 kid = OpSIBLING(kid);
2595 if (nargs != nformats)
2596 return FALSE; /* e.g. sprintf("%s%s", $a); */
2599 info->nargs = nargs;
2602 info->total_len = total_len;
2603 info->variant = variant;
2611 /* S_maybe_multiconcat():
2613 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2614 * convert it (and its children) into an OP_MULTICONCAT. See the code
2615 * comments just before pp_multiconcat() for the full details of what
2616 * OP_MULTICONCAT supports.
2618 * Basically we're looking for an optree with a chain of OP_CONCATS down
2619 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2620 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2628 * STRINGIFY -- PADSV[$x]
2631 * ex-PUSHMARK -- CONCAT/S
2633 * CONCAT/S -- PADSV[$d]
2635 * CONCAT -- CONST["-"]
2637 * PADSV[$a] -- PADSV[$b]
2639 * Note that at this stage the OP_SASSIGN may have already been optimised
2640 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2644 S_maybe_multiconcat(pTHX_ OP *o)
2646 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2647 OP *topop; /* the top-most op in the concat tree (often equals o,
2648 unless there are assign/stringify ops above it */
2649 OP *parentop; /* the parent op of topop (or itself if no parent) */
2650 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2651 OP *targetop; /* the op corresponding to target=... or target.=... */
2652 OP *stringop; /* the OP_STRINGIFY op, if any */
2653 OP *nextop; /* used for recreating the op_next chain without consts */
2654 OP *kid; /* general-purpose op pointer */
2656 UNOP_AUX_item *lenp;
2657 char *const_str, *p;
2658 struct sprintf_ismc_info sprintf_info;
2660 /* store info about each arg in args[];
2661 * toparg is the highest used slot; argp is a general
2662 * pointer to args[] slots */
2664 void *p; /* initially points to const sv (or null for op);
2665 later, set to SvPV(constsv), with ... */
2666 STRLEN len; /* ... len set to SvPV(..., len) */
2667 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2671 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2674 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2675 the last-processed arg will the LHS of one,
2676 as args are processed in reverse order */
2677 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2678 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2679 U8 flags = 0; /* what will become the op_flags and ... */
2680 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2681 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2682 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2683 bool prev_was_const = FALSE; /* previous arg was a const */
2685 /* -----------------------------------------------------------------
2688 * Examine the optree non-destructively to determine whether it's
2689 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2690 * information about the optree in args[].
2700 assert( o->op_type == OP_SASSIGN
2701 || o->op_type == OP_CONCAT
2702 || o->op_type == OP_SPRINTF
2703 || o->op_type == OP_STRINGIFY);
2705 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2707 /* first see if, at the top of the tree, there is an assign,
2708 * append and/or stringify */
2710 if (topop->op_type == OP_SASSIGN) {
2712 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2714 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2716 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2719 topop = cBINOPo->op_first;
2720 targetop = OpSIBLING(topop);
2721 if (!targetop) /* probably some sort of syntax error */
2724 else if ( topop->op_type == OP_CONCAT
2725 && (topop->op_flags & OPf_STACKED)
2726 && (cUNOPo->op_first->op_flags & OPf_MOD)
2727 && (!(topop->op_private & OPpCONCAT_NESTED))
2732 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2733 * decide what to do about it */
2734 assert(!(o->op_private & OPpTARGET_MY));
2736 /* barf on unknown flags */
2737 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2738 private_flags |= OPpMULTICONCAT_APPEND;
2739 targetop = cBINOPo->op_first;
2741 topop = OpSIBLING(targetop);
2743 /* $x .= <FOO> gets optimised to rcatline instead */
2744 if (topop->op_type == OP_READLINE)
2749 /* Can targetop (the LHS) if it's a padsv, be be optimised
2750 * away and use OPpTARGET_MY instead?
2752 if ( (targetop->op_type == OP_PADSV)
2753 && !(targetop->op_private & OPpDEREF)
2754 && !(targetop->op_private & OPpPAD_STATE)
2755 /* we don't support 'my $x .= ...' */
2756 && ( o->op_type == OP_SASSIGN
2757 || !(targetop->op_private & OPpLVAL_INTRO))
2762 if (topop->op_type == OP_STRINGIFY) {
2763 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2767 /* barf on unknown flags */
2768 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2770 if ((topop->op_private & OPpTARGET_MY)) {
2771 if (o->op_type == OP_SASSIGN)
2772 return; /* can't have two assigns */
2776 private_flags |= OPpMULTICONCAT_STRINGIFY;
2778 topop = cBINOPx(topop)->op_first;
2779 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2780 topop = OpSIBLING(topop);
2783 if (topop->op_type == OP_SPRINTF) {
2784 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2786 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2787 nargs = sprintf_info.nargs;
2788 total_len = sprintf_info.total_len;
2789 variant = sprintf_info.variant;
2790 utf8 = sprintf_info.utf8;
2792 private_flags |= OPpMULTICONCAT_FAKE;
2794 /* we have an sprintf op rather than a concat optree.
2795 * Skip most of the code below which is associated with
2796 * processing that optree. We also skip phase 2, determining
2797 * whether its cost effective to optimise, since for sprintf,
2798 * multiconcat is *always* faster */
2801 /* note that even if the sprintf itself isn't multiconcatable,
2802 * the expression as a whole may be, e.g. in
2803 * $x .= sprintf("%d",...)
2804 * the sprintf op will be left as-is, but the concat/S op may
2805 * be upgraded to multiconcat
2808 else if (topop->op_type == OP_CONCAT) {
2809 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2812 if ((topop->op_private & OPpTARGET_MY)) {
2813 if (o->op_type == OP_SASSIGN || targmyop)
2814 return; /* can't have two assigns */
2819 /* Is it safe to convert a sassign/stringify/concat op into
2821 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
2822 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
2823 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2824 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
2825 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
2826 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2827 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
2828 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2830 /* Now scan the down the tree looking for a series of
2831 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2832 * stacked). For example this tree:
2837 * CONCAT/STACKED -- EXPR5
2839 * CONCAT/STACKED -- EXPR4
2845 * corresponds to an expression like
2847 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2849 * Record info about each EXPR in args[]: in particular, whether it is
2850 * a stringifiable OP_CONST and if so what the const sv is.
2852 * The reason why the last concat can't be STACKED is the difference
2855 * ((($a .= $a) .= $a) .= $a) .= $a
2858 * $a . $a . $a . $a . $a
2860 * The main difference between the optrees for those two constructs
2861 * is the presence of the last STACKED. As well as modifying $a,
2862 * the former sees the changed $a between each concat, so if $s is
2863 * initially 'a', the first returns 'a' x 16, while the latter returns
2864 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2874 if ( kid->op_type == OP_CONCAT
2878 k1 = cUNOPx(kid)->op_first;
2880 /* shouldn't happen except maybe after compile err? */
2884 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
2885 if (kid->op_private & OPpTARGET_MY)
2888 stacked_last = (kid->op_flags & OPf_STACKED);
2900 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
2901 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2903 /* At least two spare slots are needed to decompose both
2904 * concat args. If there are no slots left, continue to
2905 * examine the rest of the optree, but don't push new values
2906 * on args[]. If the optree as a whole is legal for conversion
2907 * (in particular that the last concat isn't STACKED), then
2908 * the first PERL_MULTICONCAT_MAXARG elements of the optree
2909 * can be converted into an OP_MULTICONCAT now, with the first
2910 * child of that op being the remainder of the optree -
2911 * which may itself later be converted to a multiconcat op
2915 /* the last arg is the rest of the optree */
2920 else if ( argop->op_type == OP_CONST
2921 && ((sv = cSVOPx_sv(argop)))
2922 /* defer stringification until runtime of 'constant'
2923 * things that might stringify variantly, e.g. the radix
2924 * point of NVs, or overloaded RVs */
2925 && (SvPOK(sv) || SvIOK(sv))
2926 && (!SvGMAGICAL(sv))
2929 utf8 |= cBOOL(SvUTF8(sv));
2932 /* this const may be demoted back to a plain arg later;
2933 * make sure we have enough arg slots left */
2935 prev_was_const = !prev_was_const;
2940 prev_was_const = FALSE;
2950 return; /* we don't support ((A.=B).=C)...) */
2952 /* look for two adjacent consts and don't fold them together:
2955 * $o->concat("a")->concat("b")
2958 * (but $o .= "a" . "b" should still fold)
2961 bool seen_nonconst = FALSE;
2962 for (argp = toparg; argp >= args; argp--) {
2963 if (argp->p == NULL) {
2964 seen_nonconst = TRUE;
2970 /* both previous and current arg were constants;
2971 * leave the current OP_CONST as-is */
2979 /* -----------------------------------------------------------------
2982 * At this point we have determined that the optree *can* be converted
2983 * into a multiconcat. Having gathered all the evidence, we now decide
2984 * whether it *should*.
2988 /* we need at least one concat action, e.g.:
2994 * otherwise we could be doing something like $x = "foo", which
2995 * if treated as as a concat, would fail to COW.
2997 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3000 /* Benchmarking seems to indicate that we gain if:
3001 * * we optimise at least two actions into a single multiconcat
3002 * (e.g concat+concat, sassign+concat);
3003 * * or if we can eliminate at least 1 OP_CONST;
3004 * * or if we can eliminate a padsv via OPpTARGET_MY
3008 /* eliminated at least one OP_CONST */
3010 /* eliminated an OP_SASSIGN */
3011 || o->op_type == OP_SASSIGN
3012 /* eliminated an OP_PADSV */
3013 || (!targmyop && is_targable)
3015 /* definitely a net gain to optimise */
3018 /* ... if not, what else? */
3020 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3021 * multiconcat is faster (due to not creating a temporary copy of
3022 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3028 && topop->op_type == OP_CONCAT
3030 PADOFFSET t = targmyop->op_targ;
3031 OP *k1 = cBINOPx(topop)->op_first;
3032 OP *k2 = cBINOPx(topop)->op_last;
3033 if ( k2->op_type == OP_PADSV
3035 && ( k1->op_type != OP_PADSV
3036 || k1->op_targ != t)
3041 /* need at least two concats */
3042 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3047 /* -----------------------------------------------------------------
3050 * At this point the optree has been verified as ok to be optimised
3051 * into an OP_MULTICONCAT. Now start changing things.
3056 /* stringify all const args and determine utf8ness */
3059 for (argp = args; argp <= toparg; argp++) {
3060 SV *sv = (SV*)argp->p;
3062 continue; /* not a const op */
3063 if (utf8 && !SvUTF8(sv))
3064 sv_utf8_upgrade_nomg(sv);
3065 argp->p = SvPV_nomg(sv, argp->len);
3066 total_len += argp->len;
3068 /* see if any strings would grow if converted to utf8 */
3070 char *p = (char*)argp->p;
3071 STRLEN len = argp->len;
3074 if (!UTF8_IS_INVARIANT(c))
3080 /* create and populate aux struct */
3084 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3085 sizeof(UNOP_AUX_item)
3087 PERL_MULTICONCAT_HEADER_SIZE
3088 + ((nargs + 1) * (variant ? 2 : 1))
3091 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3093 /* Extract all the non-const expressions from the concat tree then
3094 * dispose of the old tree, e.g. convert the tree from this:
3098 * STRINGIFY -- TARGET
3100 * ex-PUSHMARK -- CONCAT
3115 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3117 * except that if EXPRi is an OP_CONST, it's discarded.
3119 * During the conversion process, EXPR ops are stripped from the tree
3120 * and unshifted onto o. Finally, any of o's remaining original
3121 * childen are discarded and o is converted into an OP_MULTICONCAT.
3123 * In this middle of this, o may contain both: unshifted args on the
3124 * left, and some remaining original args on the right. lastkidop
3125 * is set to point to the right-most unshifted arg to delineate
3126 * between the two sets.
3131 /* create a copy of the format with the %'s removed, and record
3132 * the sizes of the const string segments in the aux struct */
3134 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3136 p = sprintf_info.start;
3139 for (; p < sprintf_info.end; p++) {
3143 (lenp++)->ssize = q - oldq;
3150 lenp->ssize = q - oldq;
3151 assert((STRLEN)(q - const_str) == total_len);
3153 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3154 * may or may not be topop) The pushmark and const ops need to be
3155 * kept in case they're an op_next entry point.
3157 lastkidop = cLISTOPx(topop)->op_last;
3158 kid = cUNOPx(topop)->op_first; /* pushmark */
3160 op_null(OpSIBLING(kid)); /* const */
3162 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3163 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3164 lastkidop->op_next = o;
3169 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3173 /* Concatenate all const strings into const_str.
3174 * Note that args[] contains the RHS args in reverse order, so
3175 * we scan args[] from top to bottom to get constant strings
3178 for (argp = toparg; argp >= args; argp--) {
3180 /* not a const op */
3181 (++lenp)->ssize = -1;
3183 STRLEN l = argp->len;
3184 Copy(argp->p, p, l, char);
3186 if (lenp->ssize == -1)
3197 for (argp = args; argp <= toparg; argp++) {
3198 /* only keep non-const args, except keep the first-in-next-chain
3199 * arg no matter what it is (but nulled if OP_CONST), because it
3200 * may be the entry point to this subtree from the previous
3203 bool last = (argp == toparg);
3206 /* set prev to the sibling *before* the arg to be cut out,
3207 * e.g. when cutting EXPR:
3212 * prev= CONCAT -- EXPR
3215 if (argp == args && kid->op_type != OP_CONCAT) {
3216 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3217 * so the expression to be cut isn't kid->op_last but
3220 /* find the op before kid */
3222 o2 = cUNOPx(parentop)->op_first;
3223 while (o2 && o2 != kid) {
3231 else if (kid == o && lastkidop)
3232 prev = last ? lastkidop : OpSIBLING(lastkidop);
3234 prev = last ? NULL : cUNOPx(kid)->op_first;
3236 if (!argp->p || last) {
3238 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3239 /* and unshift to front of o */
3240 op_sibling_splice(o, NULL, 0, aop);
3241 /* record the right-most op added to o: later we will
3242 * free anything to the right of it */
3245 aop->op_next = nextop;
3248 /* null the const at start of op_next chain */
3252 nextop = prev->op_next;
3255 /* the last two arguments are both attached to the same concat op */
3256 if (argp < toparg - 1)
3261 /* Populate the aux struct */
3263 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3264 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3265 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3266 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3267 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3269 /* if variant > 0, calculate a variant const string and lengths where
3270 * the utf8 version of the string will take 'variant' more bytes than
3274 char *p = const_str;
3275 STRLEN ulen = total_len + variant;
3276 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3277 UNOP_AUX_item *ulens = lens + (nargs + 1);
3278 char *up = (char*)PerlMemShared_malloc(ulen);
3281 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3282 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3284 for (n = 0; n < (nargs + 1); n++) {
3286 char * orig_up = up;
3287 for (i = (lens++)->ssize; i > 0; i--) {
3289 append_utf8_from_native_byte(c, (U8**)&up);
3291 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3296 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3297 * that op's first child - an ex-PUSHMARK - because the op_next of
3298 * the previous op may point to it (i.e. it's the entry point for
3303 ? op_sibling_splice(o, lastkidop, 1, NULL)
3304 : op_sibling_splice(stringop, NULL, 1, NULL);
3305 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3306 op_sibling_splice(o, NULL, 0, pmop);
3313 * target .= A.B.C...
3319 if (o->op_type == OP_SASSIGN) {
3320 /* Move the target subtree from being the last of o's children
3321 * to being the last of o's preserved children.
3322 * Note the difference between 'target = ...' and 'target .= ...':
3323 * for the former, target is executed last; for the latter,
3326 kid = OpSIBLING(lastkidop);
3327 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3328 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3329 lastkidop->op_next = kid->op_next;
3330 lastkidop = targetop;
3333 /* Move the target subtree from being the first of o's
3334 * original children to being the first of *all* o's children.
3337 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3338 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3341 /* if the RHS of .= doesn't contain a concat (e.g.
3342 * $x .= "foo"), it gets missed by the "strip ops from the
3343 * tree and add to o" loop earlier */
3344 assert(topop->op_type != OP_CONCAT);
3346 /* in e.g. $x .= "$y", move the $y expression
3347 * from being a child of OP_STRINGIFY to being the
3348 * second child of the OP_CONCAT
3350 assert(cUNOPx(stringop)->op_first == topop);
3351 op_sibling_splice(stringop, NULL, 1, NULL);
3352 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3354 assert(topop == OpSIBLING(cBINOPo->op_first));
3363 * my $lex = A.B.C...
3366 * The original padsv op is kept but nulled in case it's the
3367 * entry point for the optree (which it will be for
3370 private_flags |= OPpTARGET_MY;
3371 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3372 o->op_targ = targetop->op_targ;
3373 targetop->op_targ = 0;
3377 flags |= OPf_STACKED;
3379 else if (targmyop) {
3380 private_flags |= OPpTARGET_MY;
3381 if (o != targmyop) {
3382 o->op_targ = targmyop->op_targ;
3383 targmyop->op_targ = 0;
3387 /* detach the emaciated husk of the sprintf/concat optree and free it */
3389 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3395 /* and convert o into a multiconcat */
3397 o->op_flags = (flags|OPf_KIDS|stacked_last
3398 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3399 o->op_private = private_flags;
3400 o->op_type = OP_MULTICONCAT;
3401 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3402 cUNOP_AUXo->op_aux = aux;
3406 /* do all the final processing on an optree (e.g. running the peephole
3407 * optimiser on it), then attach it to cv (if cv is non-null)
3411 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3415 /* XXX for some reason, evals, require and main optrees are
3416 * never attached to their CV; instead they just hang off
3417 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3418 * and get manually freed when appropriate */
3420 startp = &CvSTART(cv);
3422 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3425 optree->op_private |= OPpREFCOUNTED;
3426 OpREFCNT_set(optree, 1);
3427 optimize_optree(optree);
3429 finalize_optree(optree);
3430 S_prune_chain_head(startp);
3433 /* now that optimizer has done its work, adjust pad values */
3434 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3435 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3441 =for apidoc optimize_optree
3443 This function applies some optimisations to the optree in top-down order.
3444 It is called before the peephole optimizer, which processes ops in
3445 execution order. Note that finalize_optree() also does a top-down scan,
3446 but is called *after* the peephole optimizer.
3452 Perl_optimize_optree(pTHX_ OP* o)
3454 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3457 SAVEVPTR(PL_curcop);
3465 /* helper for optimize_optree() which optimises on op then recurses
3466 * to optimise any children.
3470 S_optimize_op(pTHX_ OP* o)
3474 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3475 assert(o->op_type != OP_FREED);
3477 switch (o->op_type) {
3480 PL_curcop = ((COP*)o); /* for warnings */
3488 S_maybe_multiconcat(aTHX_ o);
3492 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3493 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3500 if (!(o->op_flags & OPf_KIDS))
3503 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3509 =for apidoc finalize_optree
3511 This function finalizes the optree. Should be called directly after
3512 the complete optree is built. It does some additional
3513 checking which can't be done in the normal C<ck_>xxx functions and makes
3514 the tree thread-safe.
3519 Perl_finalize_optree(pTHX_ OP* o)
3521 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3524 SAVEVPTR(PL_curcop);
3532 /* Relocate sv to the pad for thread safety.
3533 * Despite being a "constant", the SV is written to,
3534 * for reference counts, sv_upgrade() etc. */
3535 PERL_STATIC_INLINE void
3536 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3539 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3541 ix = pad_alloc(OP_CONST, SVf_READONLY);
3542 SvREFCNT_dec(PAD_SVl(ix));
3543 PAD_SETSV(ix, *svp);
3544 /* XXX I don't know how this isn't readonly already. */
3545 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3553 S_finalize_op(pTHX_ OP* o)
3555 PERL_ARGS_ASSERT_FINALIZE_OP;
3557 assert(o->op_type != OP_FREED);
3559 switch (o->op_type) {
3562 PL_curcop = ((COP*)o); /* for warnings */
3565 if (OpHAS_SIBLING(o)) {
3566 OP *sib = OpSIBLING(o);
3567 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3568 && ckWARN(WARN_EXEC)
3569 && OpHAS_SIBLING(sib))
3571 const OPCODE type = OpSIBLING(sib)->op_type;
3572 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3573 const line_t oldline = CopLINE(PL_curcop);
3574 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3575 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3576 "Statement unlikely to be reached");
3577 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3578 "\t(Maybe you meant system() when you said exec()?)\n");
3579 CopLINE_set(PL_curcop, oldline);
3586 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3587 GV * const gv = cGVOPo_gv;
3588 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3589 /* XXX could check prototype here instead of just carping */
3590 SV * const sv = sv_newmortal();
3591 gv_efullname3(sv, gv, NULL);
3592 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3593 "%" SVf "() called too early to check prototype",
3600 if (cSVOPo->op_private & OPpCONST_STRICT)
3601 no_bareword_allowed(o);
3605 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3610 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3611 case OP_METHOD_NAMED:
3612 case OP_METHOD_SUPER:
3613 case OP_METHOD_REDIR:
3614 case OP_METHOD_REDIR_SUPER:
3615 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3624 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3627 rop = (UNOP*)((BINOP*)o)->op_first;
3632 S_scalar_slice_warning(aTHX_ o);
3636 kid = OpSIBLING(cLISTOPo->op_first);
3637 if (/* I bet there's always a pushmark... */
3638 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3639 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3644 key_op = (SVOP*)(kid->op_type == OP_CONST
3646 : OpSIBLING(kLISTOP->op_first));
3648 rop = (UNOP*)((LISTOP*)o)->op_last;
3651 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3653 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
3657 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3661 S_scalar_slice_warning(aTHX_ o);
3665 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3666 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3673 if (o->op_flags & OPf_KIDS) {
3677 /* check that op_last points to the last sibling, and that
3678 * the last op_sibling/op_sibparent field points back to the
3679 * parent, and that the only ops with KIDS are those which are
3680 * entitled to them */
3681 U32 type = o->op_type;
3685 if (type == OP_NULL) {
3687 /* ck_glob creates a null UNOP with ex-type GLOB
3688 * (which is a list op. So pretend it wasn't a listop */
3689 if (type == OP_GLOB)
3692 family = PL_opargs[type] & OA_CLASS_MASK;
3694 has_last = ( family == OA_BINOP
3695 || family == OA_LISTOP
3696 || family == OA_PMOP
3697 || family == OA_LOOP
3699 assert( has_last /* has op_first and op_last, or ...
3700 ... has (or may have) op_first: */
3701 || family == OA_UNOP
3702 || family == OA_UNOP_AUX
3703 || family == OA_LOGOP
3704 || family == OA_BASEOP_OR_UNOP
3705 || family == OA_FILESTATOP
3706 || family == OA_LOOPEXOP
3707 || family == OA_METHOP
3708 || type == OP_CUSTOM
3709 || type == OP_NULL /* new_logop does this */
3712 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3713 # ifdef PERL_OP_PARENT
3714 if (!OpHAS_SIBLING(kid)) {
3716 assert(kid == cLISTOPo->op_last);
3717 assert(kid->op_sibparent == o);
3720 if (has_last && !OpHAS_SIBLING(kid))
3721 assert(kid == cLISTOPo->op_last);
3726 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3732 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3734 Propagate lvalue ("modifiable") context to an op and its children.
3735 C<type> represents the context type, roughly based on the type of op that
3736 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3737 because it has no op type of its own (it is signalled by a flag on
3740 This function detects things that can't be modified, such as C<$x+1>, and
3741 generates errors for them. For example, C<$x+1 = 2> would cause it to be
3742 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3744 It also flags things that need to behave specially in an lvalue context,
3745 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3751 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3754 PadnameLVALUE_on(pn);
3755 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3757 /* RT #127786: cv can be NULL due to an eval within the DB package
3758 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3759 * unless they contain an eval, but calling eval within DB
3760 * pretends the eval was done in the caller's scope.
3764 assert(CvPADLIST(cv));
3766 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3767 assert(PadnameLEN(pn));
3768 PadnameLVALUE_on(pn);
3773 S_vivifies(const OPCODE type)
3776 case OP_RV2AV: case OP_ASLICE:
3777 case OP_RV2HV: case OP_KVASLICE:
3778 case OP_RV2SV: case OP_HSLICE:
3779 case OP_AELEMFAST: case OP_KVHSLICE:
3788 S_lvref(pTHX_ OP *o, I32 type)
3792 switch (o->op_type) {
3794 for (kid = OpSIBLING(cUNOPo->op_first); kid;
3795 kid = OpSIBLING(kid))
3796 S_lvref(aTHX_ kid, type);
3801 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3802 o->op_flags |= OPf_STACKED;
3803 if (o->op_flags & OPf_PARENS) {
3804 if (o->op_private & OPpLVAL_INTRO) {
3805 yyerror(Perl_form(aTHX_ "Can't modify reference to "
3806 "localized parenthesized array in list assignment"));
3810 OpTYPE_set(o, OP_LVAVREF);
3811 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3812 o->op_flags |= OPf_MOD|OPf_REF;
3815 o->op_private |= OPpLVREF_AV;
3818 kid = cUNOPo->op_first;
3819 if (kid->op_type == OP_NULL)
3820 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3822 o->op_private = OPpLVREF_CV;
3823 if (kid->op_type == OP_GV)
3824 o->op_flags |= OPf_STACKED;
3825 else if (kid->op_type == OP_PADCV) {
3826 o->op_targ = kid->op_targ;
3828 op_free(cUNOPo->op_first);
3829 cUNOPo->op_first = NULL;
3830 o->op_flags &=~ OPf_KIDS;
3835 if (o->op_flags & OPf_PARENS) {
3837 yyerror(Perl_form(aTHX_ "Can't modify reference to "
3838 "parenthesized hash in list assignment"));
3841 o->op_private |= OPpLVREF_HV;
3845 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3846 o->op_flags |= OPf_STACKED;
3849 if (o->op_flags & OPf_PARENS) goto parenhash;
3850 o->op_private |= OPpLVREF_HV;
3853 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3856 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3857 if (o->op_flags & OPf_PARENS) goto slurpy;
3858 o->op_private |= OPpLVREF_AV;
3862 o->op_private |= OPpLVREF_ELEM;
3863 o->op_flags |= OPf_STACKED;
3867 OpTYPE_set(o, OP_LVREFSLICE);
3868 o->op_private &= OPpLVAL_INTRO;
3871 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3873 else if (!(o->op_flags & OPf_KIDS))
3875 if (o->op_targ != OP_LIST) {
3876 S_lvref(aTHX_ cBINOPo->op_first, type);
3881 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3882 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3883 S_lvref(aTHX_ kid, type);
3887 if (o->op_flags & OPf_PARENS)
3892 /* diag_listed_as: Can't modify reference to %s in %s assignment */
3893 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3894 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3900 OpTYPE_set(o, OP_LVREF);
3902 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3903 if (type == OP_ENTERLOOP)
3904 o->op_private |= OPpLVREF_ITER;
3907 PERL_STATIC_INLINE bool
3908 S_potential_mod_type(I32 type)
3910 /* Types that only potentially result in modification. */
3911 return type == OP_GREPSTART || type == OP_ENTERSUB
3912 || type == OP_REFGEN || type == OP_LEAVESUBLV;
3916 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3920 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3923 if (!o || (PL_parser && PL_parser->error_count))
3926 if ((o->op_private & OPpTARGET_MY)
3927 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3932 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
3934 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3936 switch (o->op_type) {
3941 if ((o->op_flags & OPf_PARENS))
3945 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3946 !(o->op_flags & OPf_STACKED)) {
3947 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3948 assert(cUNOPo->op_first->op_type == OP_NULL);
3949 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
3952 else { /* lvalue subroutine call */
3953 o->op_private |= OPpLVAL_INTRO;
3954 PL_modcount = RETURN_UNLIMITED_NUMBER;
3955 if (S_potential_mod_type(type)) {
3956 o->op_private |= OPpENTERSUB_INARGS;
3959 else { /* Compile-time error message: */
3960 OP *kid = cUNOPo->op_first;
3965 if (kid->op_type != OP_PUSHMARK) {
3966 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3968 "panic: unexpected lvalue entersub "
3969 "args: type/targ %ld:%" UVuf,
3970 (long)kid->op_type, (UV)kid->op_targ);
3971 kid = kLISTOP->op_first;
3973 while (OpHAS_SIBLING(kid))
3974 kid = OpSIBLING(kid);
3975 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3976 break; /* Postpone until runtime */
3979 kid = kUNOP->op_first;
3980 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3981 kid = kUNOP->op_first;
3982 if (kid->op_type == OP_NULL)
3984 "Unexpected constant lvalue entersub "
3985 "entry via type/targ %ld:%" UVuf,
3986 (long)kid->op_type, (UV)kid->op_targ);
3987 if (kid->op_type != OP_GV) {
3994 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3995 ? MUTABLE_CV(SvRV(gv))
4001 if (flags & OP_LVALUE_NO_CROAK)
4004 namesv = cv_name(cv, NULL, 0);
4005 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4006 "subroutine call of &%" SVf " in %s",
4007 SVfARG(namesv), PL_op_desc[type]),
4015 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4016 /* grep, foreach, subcalls, refgen */
4017 if (S_potential_mod_type(type))
4019 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4020 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4023 type ? PL_op_desc[type] : "local"));
4036 case OP_RIGHT_SHIFT:
4045 if (!(o->op_flags & OPf_STACKED))
4051 if (o->op_flags & OPf_STACKED) {
4055 if (!(o->op_private & OPpREPEAT_DOLIST))
4058 const I32 mods = PL_modcount;
4059 modkids(cBINOPo->op_first, type);
4060 if (type != OP_AASSIGN)
4062 kid = cBINOPo->op_last;
4063 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4064 const IV iv = SvIV(kSVOP_sv);
4065 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4067 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4070 PL_modcount = RETURN_UNLIMITED_NUMBER;
4076 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4077 op_lvalue(kid, type);
4082 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4083 PL_modcount = RETURN_UNLIMITED_NUMBER;
4084 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4085 fiable since some contexts need to know. */
4086 o->op_flags |= OPf_MOD;
4091 if (scalar_mod_type(o, type))
4093 ref(cUNOPo->op_first, o->op_type);
4100 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4101 if (type == OP_LEAVESUBLV && (
4102 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4103 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4105 o->op_private |= OPpMAYBE_LVSUB;
4109 PL_modcount = RETURN_UNLIMITED_NUMBER;
4114 if (type == OP_LEAVESUBLV)
4115 o->op_private |= OPpMAYBE_LVSUB;
4118 if (type == OP_LEAVESUBLV
4119 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4120 o->op_private |= OPpMAYBE_LVSUB;
4123 PL_hints |= HINT_BLOCK_SCOPE;
4124 if (type == OP_LEAVESUBLV)
4125 o->op_private |= OPpMAYBE_LVSUB;
4129 ref(cUNOPo->op_first, o->op_type);
4133 PL_hints |= HINT_BLOCK_SCOPE;
4143 case OP_AELEMFAST_LEX:
4150 PL_modcount = RETURN_UNLIMITED_NUMBER;
4151 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4153 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4154 fiable since some contexts need to know. */
4155 o->op_flags |= OPf_MOD;
4158 if (scalar_mod_type(o, type))
4160 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4161 && type == OP_LEAVESUBLV)
4162 o->op_private |= OPpMAYBE_LVSUB;
4166 if (!type) /* local() */
4167 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4168 PNfARG(PAD_COMPNAME(o->op_targ)));
4169 if (!(o->op_private & OPpLVAL_INTRO)
4170 || ( type != OP_SASSIGN && type != OP_AASSIGN
4171 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4172 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4180 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4184 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4190 if (type == OP_LEAVESUBLV)
4191 o->op_private |= OPpMAYBE_LVSUB;
4192 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4193 /* substr and vec */
4194 /* If this op is in merely potential (non-fatal) modifiable
4195 context, then apply OP_ENTERSUB context to
4196 the kid op (to avoid croaking). Other-
4197 wise pass this op’s own type so the correct op is mentioned
4198 in error messages. */
4199 op_lvalue(OpSIBLING(cBINOPo->op_first),
4200 S_potential_mod_type(type)
4208 ref(cBINOPo->op_first, o->op_type);
4209 if (type == OP_ENTERSUB &&
4210 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4211 o->op_private |= OPpLVAL_DEFER;
4212 if (type == OP_LEAVESUBLV)
4213 o->op_private |= OPpMAYBE_LVSUB;
4220 o->op_private |= OPpLVALUE;
4226 if (o->op_flags & OPf_KIDS)
4227 op_lvalue(cLISTOPo->op_last, type);
4232 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4234 else if (!(o->op_flags & OPf_KIDS))
4237 if (o->op_targ != OP_LIST) {
4238 OP *sib = OpSIBLING(cLISTOPo->op_first);
4239 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4246 * compared with things like OP_MATCH which have the argument
4252 * so handle specially to correctly get "Can't modify" croaks etc
4255 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4257 /* this should trigger a "Can't modify transliteration" err */
4258 op_lvalue(sib, type);
4260 op_lvalue(cBINOPo->op_first, type);
4266 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4267 /* elements might be in void context because the list is
4268 in scalar context or because they are attribute sub calls */
4269 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4270 op_lvalue(kid, type);
4278 if (type == OP_LEAVESUBLV
4279 || !S_vivifies(cLOGOPo->op_first->op_type))
4280 op_lvalue(cLOGOPo->op_first, type);
4281 if (type == OP_LEAVESUBLV
4282 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4283 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4287 if (type == OP_NULL) { /* local */
4289 if (!FEATURE_MYREF_IS_ENABLED)
4290 Perl_croak(aTHX_ "The experimental declared_refs "
4291 "feature is not enabled");
4292 Perl_ck_warner_d(aTHX_
4293 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4294 "Declaring references is experimental");
4295 op_lvalue(cUNOPo->op_first, OP_NULL);
4298 if (type != OP_AASSIGN && type != OP_SASSIGN
4299 && type != OP_ENTERLOOP)
4301 /* Don’t bother applying lvalue context to the ex-list. */
4302 kid = cUNOPx(cUNOPo->op_first)->op_first;
4303 assert (!OpHAS_SIBLING(kid));
4306 if (type == OP_NULL) /* local */
4308 if (type != OP_AASSIGN) goto nomod;
4309 kid = cUNOPo->op_first;
4312 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4313 S_lvref(aTHX_ kid, type);
4314 if (!PL_parser || PL_parser->error_count == ec) {
4315 if (!FEATURE_REFALIASING_IS_ENABLED)
4317 "Experimental aliasing via reference not enabled");
4318 Perl_ck_warner_d(aTHX_
4319 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4320 "Aliasing via reference is experimental");
4323 if (o->op_type == OP_REFGEN)
4324 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4329 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4330 /* This is actually @array = split. */
4331 PL_modcount = RETURN_UNLIMITED_NUMBER;
4337 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4341 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4342 their argument is a filehandle; thus \stat(".") should not set
4344 if (type == OP_REFGEN &&
4345 PL_check[o->op_type] == Perl_ck_ftst)
4348 if (type != OP_LEAVESUBLV)
4349 o->op_flags |= OPf_MOD;
4351 if (type == OP_AASSIGN || type == OP_SASSIGN)
4352 o->op_flags |= OPf_SPECIAL
4353 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4354 else if (!type) { /* local() */
4357 o->op_private |= OPpLVAL_INTRO;
4358 o->op_flags &= ~OPf_SPECIAL;
4359 PL_hints |= HINT_BLOCK_SCOPE;
4364 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4365 "Useless localization of %s", OP_DESC(o));
4368 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4369 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4370 o->op_flags |= OPf_REF;
4375 S_scalar_mod_type(const OP *o, I32 type)
4380 if (o && o->op_type == OP_RV2GV)
4404 case OP_RIGHT_SHIFT:
4433 S_is_handle_constructor(const OP *o, I32 numargs)
4435 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4437 switch (o->op_type) {
4445 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4458 S_refkids(pTHX_ OP *o, I32 type)
4460 if (o && o->op_flags & OPf_KIDS) {
4462 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4469 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4474 PERL_ARGS_ASSERT_DOREF;
4476 if (PL_parser && PL_parser->error_count)
4479 switch (o->op_type) {
4481 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4482 !(o->op_flags & OPf_STACKED)) {
4483 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4484 assert(cUNOPo->op_first->op_type == OP_NULL);
4485 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
4486 o->op_flags |= OPf_SPECIAL;
4488 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4489 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4490 : type == OP_RV2HV ? OPpDEREF_HV
4492 o->op_flags |= OPf_MOD;
4498 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4499 doref(kid, type, set_op_ref);
4502 if (type == OP_DEFINED)
4503 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4504 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4507 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4508 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4509 : type == OP_RV2HV ? OPpDEREF_HV
4511 o->op_flags |= OPf_MOD;
4518 o->op_flags |= OPf_REF;
4521 if (type == OP_DEFINED)
4522 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4523 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4529 o->op_flags |= OPf_REF;
4534 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4536 doref(cBINOPo->op_first, type, set_op_ref);
4540 doref(cBINOPo->op_first, o->op_type, set_op_ref);
4541 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4542 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4543 : type == OP_RV2HV ? OPpDEREF_HV
4545 o->op_flags |= OPf_MOD;
4555 if (!(o->op_flags & OPf_KIDS))
4557 doref(cLISTOPo->op_last, type, set_op_ref);
4567 S_dup_attrlist(pTHX_ OP *o)
4571 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4573 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4574 * where the first kid is OP_PUSHMARK and the remaining ones
4575 * are OP_CONST. We need to push the OP_CONST values.
4577 if (o->op_type == OP_CONST)
4578 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4580 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4582 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4583 if (o->op_type == OP_CONST)
4584 rop = op_append_elem(OP_LIST, rop,
4585 newSVOP(OP_CONST, o->op_flags,
4586 SvREFCNT_inc_NN(cSVOPo->op_sv)));
4593 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4595 PERL_ARGS_ASSERT_APPLY_ATTRS;
4597 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4599 /* fake up C<use attributes $pkg,$rv,@attrs> */
4601 #define ATTRSMODULE "attributes"
4602 #define ATTRSMODULE_PM "attributes.pm"
4605 aTHX_ PERL_LOADMOD_IMPORT_OPS,
4606 newSVpvs(ATTRSMODULE),
4608 op_prepend_elem(OP_LIST,
4609 newSVOP(OP_CONST, 0, stashsv),
4610 op_prepend_elem(OP_LIST,
4611 newSVOP(OP_CONST, 0,
4613 dup_attrlist(attrs))));
4618 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4620 OP *pack, *imop, *arg;
4621 SV *meth, *stashsv, **svp;
4623 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4628 assert(target->op_type == OP_PADSV ||
4629 target->op_type == OP_PADHV ||
4630 target->op_type == OP_PADAV);
4632 /* Ensure that attributes.pm is loaded. */
4633 /* Don't force the C<use> if we don't need it. */
4634 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4635 if (svp && *svp != &PL_sv_undef)
4636 NOOP; /* already in %INC */
4638 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4639 newSVpvs(ATTRSMODULE), NULL);
4641 /* Need package name for method call. */
4642 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4644 /* Build up the real arg-list. */
4645 stashsv = newSVhek(HvNAME_HEK(stash));
4647 arg = newOP(OP_PADSV, 0);
4648 arg->op_targ = target->op_targ;
4649 arg = op_prepend_elem(OP_LIST,
4650 newSVOP(OP_CONST, 0, stashsv),
4651 op_prepend_elem(OP_LIST,
4652 newUNOP(OP_REFGEN, 0,
4654 dup_attrlist(attrs)));
4656 /* Fake up a method call to import */
4657 meth = newSVpvs_share("import");
4658 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4659 op_append_elem(OP_LIST,
4660 op_prepend_elem(OP_LIST, pack, arg),
4661 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4663 /* Combine the ops. */
4664 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4668 =notfor apidoc apply_attrs_string
4670 Attempts to apply a list of attributes specified by the C<attrstr> and
4671 C<len> arguments to the subroutine identified by the C<cv> argument which
4672 is expected to be associated with the package identified by the C<stashpv>
4673 argument (see L<attributes>). It gets this wrong, though, in that it
4674 does not correctly identify the boundaries of the individual attribute
4675 specifications within C<attrstr>. This is not really intended for the
4676 public API, but has to be listed here for systems such as AIX which
4677 need an explicit export list for symbols. (It's called from XS code
4678 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
4679 to respect attribute syntax properly would be welcome.
4685 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4686 const char *attrstr, STRLEN len)
4690 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4693 len = strlen(attrstr);
4697 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4699 const char * const sstr = attrstr;
4700 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4701 attrs = op_append_elem(OP_LIST, attrs,
4702 newSVOP(OP_CONST, 0,
4703 newSVpvn(sstr, attrstr-sstr)));
4707 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4708 newSVpvs(ATTRSMODULE),
4709 NULL, op_prepend_elem(OP_LIST,
4710 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4711 op_prepend_elem(OP_LIST,
4712 newSVOP(OP_CONST, 0,
4713 newRV(MUTABLE_SV(cv))),
4718 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4721 OP *new_proto = NULL;
4726 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4732 if (o->op_type == OP_CONST) {
4733 pv = SvPV(cSVOPo_sv, pvlen);
4734 if (memBEGINs(pv, pvlen, "prototype(")) {
4735 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4736 SV ** const tmpo = cSVOPx_svp(o);
4737 SvREFCNT_dec(cSVOPo_sv);
4742 } else if (o->op_type == OP_LIST) {
4744 assert(o->op_flags & OPf_KIDS);
4745 lasto = cLISTOPo->op_first;
4746 assert(lasto->op_type == OP_PUSHMARK);
4747 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4748 if (o->op_type == OP_CONST) {
4749 pv = SvPV(cSVOPo_sv, pvlen);
4750 if (memBEGINs(pv, pvlen, "prototype(")) {
4751 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4752 SV ** const tmpo = cSVOPx_svp(o);
4753 SvREFCNT_dec(cSVOPo_sv);
4755 if (new_proto && ckWARN(WARN_MISC)) {
4757 const char * newp = SvPV(cSVOPo_sv, new_len);
4758 Perl_warner(aTHX_ packWARN(WARN_MISC),
4759 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4760 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4766 /* excise new_proto from the list */
4767 op_sibling_splice(*attrs, lasto, 1, NULL);
4774 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4775 would get pulled in with no real need */
4776 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4785 svname = sv_newmortal();
4786 gv_efullname3(svname, name, NULL);
4788 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4789 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4791 svname = (SV *)name;
4792 if (ckWARN(WARN_ILLEGALPROTO))
4793 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4795 if (*proto && ckWARN(WARN_PROTOTYPE)) {
4796 STRLEN old_len, new_len;
4797 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4798 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4800 if (curstash && svname == (SV *)name
4801 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4802 svname = sv_2mortal(newSVsv(PL_curstname));
4803 sv_catpvs(svname, "::");
4804 sv_catsv(svname, (SV *)name);
4807 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4808 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4810 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4811 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4821 S_cant_declare(pTHX_ OP *o)
4823 if (o->op_type == OP_NULL
4824 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4825 o = cUNOPo->op_first;
4826 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4827 o->op_type == OP_NULL
4828 && o->op_flags & OPf_SPECIAL
4831 PL_parser->in_my == KEY_our ? "our" :
4832 PL_parser->in_my == KEY_state ? "state" :
4837 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4840 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4842 PERL_ARGS_ASSERT_MY_KID;
4844 if (!o || (PL_parser && PL_parser->error_count))
4849 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4851 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4852 my_kid(kid, attrs, imopsp);
4854 } else if (type == OP_UNDEF || type == OP_STUB) {
4856 } else if (type == OP_RV2SV || /* "our" declaration */
4859 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4860 S_cant_declare(aTHX_ o);
4862 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4864 PL_parser->in_my = FALSE;
4865 PL_parser->in_my_stash = NULL;
4866 apply_attrs(GvSTASH(gv),
4867 (type == OP_RV2SV ? GvSVn(gv) :
4868 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4869 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4872 o->op_private |= OPpOUR_INTRO;
4875 else if (type == OP_REFGEN || type == OP_SREFGEN) {
4876 if (!FEATURE_MYREF_IS_ENABLED)
4877 Perl_croak(aTHX_ "The experimental declared_refs "
4878 "feature is not enabled");
4879 Perl_ck_warner_d(aTHX_
4880 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4881 "Declaring references is experimental");
4882 /* Kid is a nulled OP_LIST, handled above. */
4883 my_kid(cUNOPo->op_first, attrs, imopsp);
4886 else if (type != OP_PADSV &&
4889 type != OP_PUSHMARK)
4891 S_cant_declare(aTHX_ o);
4894 else if (attrs && type != OP_PUSHMARK) {
4898 PL_parser->in_my = FALSE;
4899 PL_parser->in_my_stash = NULL;
4901 /* check for C<my Dog $spot> when deciding package */
4902 stash = PAD_COMPNAME_TYPE(o->op_targ);
4904 stash = PL_curstash;
4905 apply_attrs_my(stash, o, attrs, imopsp);
4907 o->op_flags |= OPf_MOD;
4908 o->op_private |= OPpLVAL_INTRO;
4910 o->op_private |= OPpPAD_STATE;
4915 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4918 int maybe_scalar = 0;
4920 PERL_ARGS_ASSERT_MY_ATTRS;
4922 /* [perl #17376]: this appears to be premature, and results in code such as
4923 C< our(%x); > executing in list mode rather than void mode */
4925 if (o->op_flags & OPf_PARENS)
4935 o = my_kid(o, attrs, &rops);
4937 if (maybe_scalar && o->op_type == OP_PADSV) {
4938 o = scalar(op_append_list(OP_LIST, rops, o));
4939 o->op_private |= OPpLVAL_INTRO;
4942 /* The listop in rops might have a pushmark at the beginning,
4943 which will mess up list assignment. */
4944 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
4945 if (rops->op_type == OP_LIST &&
4946 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4948 OP * const pushmark = lrops->op_first;
4949 /* excise pushmark */
4950 op_sibling_splice(rops, NULL, 1, NULL);
4953 o = op_append_list(OP_LIST, o, rops);
4956 PL_parser->in_my = FALSE;
4957 PL_parser->in_my_stash = NULL;
4962 Perl_sawparens(pTHX_ OP *o)
4964 PERL_UNUSED_CONTEXT;
4966 o->op_flags |= OPf_PARENS;
4971 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4975 const OPCODE ltype = left->op_type;
4976 const OPCODE rtype = right->op_type;
4978 PERL_ARGS_ASSERT_BIND_MATCH;
4980 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4981 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4983 const char * const desc
4985 rtype == OP_SUBST || rtype == OP_TRANS
4986 || rtype == OP_TRANSR
4988 ? (int)rtype : OP_MATCH];
4989 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4991 S_op_varname(aTHX_ left);
4993 Perl_warner(aTHX_ packWARN(WARN_MISC),
4994 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4995 desc, SVfARG(name), SVfARG(name));
4997 const char * const sample = (isary
4998 ? "@array" : "%hash");
4999 Perl_warner(aTHX_ packWARN(WARN_MISC),
5000 "Applying %s to %s will act on scalar(%s)",
5001 desc, sample, sample);
5005 if (rtype == OP_CONST &&
5006 cSVOPx(right)->op_private & OPpCONST_BARE &&
5007 cSVOPx(right)->op_private & OPpCONST_STRICT)
5009 no_bareword_allowed(right);
5012 /* !~ doesn't make sense with /r, so error on it for now */
5013 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5015 /* diag_listed_as: Using !~ with %s doesn't make sense */
5016 yyerror("Using !~ with s///r doesn't make sense");
5017 if (rtype == OP_TRANSR && type == OP_NOT)
5018 /* diag_listed_as: Using !~ with %s doesn't make sense */
5019 yyerror("Using !~ with tr///r doesn't make sense");
5021 ismatchop = (rtype == OP_MATCH ||
5022 rtype == OP_SUBST ||
5023 rtype == OP_TRANS || rtype == OP_TRANSR)
5024 && !(right->op_flags & OPf_SPECIAL);
5025 if (ismatchop && right->op_private & OPpTARGET_MY) {
5027 right->op_private &= ~OPpTARGET_MY;
5029 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5030 if (left->op_type == OP_PADSV
5031 && !(left->op_private & OPpLVAL_INTRO))
5033 right->op_targ = left->op_targ;
5038 right->op_flags |= OPf_STACKED;
5039 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5040 ! (rtype == OP_TRANS &&
5041 right->op_private & OPpTRANS_IDENTICAL) &&
5042 ! (rtype == OP_SUBST &&
5043 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5044 left = op_lvalue(left, rtype);
5045 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5046 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5048 o = op_prepend_elem(rtype, scalar(left), right);
5051 return newUNOP(OP_NOT, 0, scalar(o));
5055 return bind_match(type, left,
5056 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5060 Perl_invert(pTHX_ OP *o)
5064 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5068 =for apidoc Amx|OP *|op_scope|OP *o
5070 Wraps up an op tree with some additional ops so that at runtime a dynamic
5071 scope will be created. The original ops run in the new dynamic scope,
5072 and then, provided that they exit normally, the scope will be unwound.
5073 The additional ops used to create and unwind the dynamic scope will
5074 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5075 instead if the ops are simple enough to not need the full dynamic scope
5082 Perl_op_scope(pTHX_ OP *o)
5086 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5087 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5088 OpTYPE_set(o, OP_LEAVE);
5090 else if (o->op_type == OP_LINESEQ) {
5092 OpTYPE_set(o, OP_SCOPE);
5093 kid = ((LISTOP*)o)->op_first;
5094 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5097 /* The following deals with things like 'do {1 for 1}' */
5098 kid = OpSIBLING(kid);
5100 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5105 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5111 Perl_op_unscope(pTHX_ OP *o)
5113 if (o && o->op_type == OP_LINESEQ) {
5114 OP *kid = cLISTOPo->op_first;
5115 for(; kid; kid = OpSIBLING(kid))
5116 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5123 =for apidoc Am|int|block_start|int full
5125 Handles compile-time scope entry.
5126 Arranges for hints to be restored on block
5127 exit and also handles pad sequence numbers to make lexical variables scope
5128 right. Returns a savestack index for use with C<block_end>.
5134 Perl_block_start(pTHX_ int full)
5136 const int retval = PL_savestack_ix;
5138 PL_compiling.cop_seq = PL_cop_seqmax;
5140 pad_block_start(full);
5142 PL_hints &= ~HINT_BLOCK_SCOPE;
5143 SAVECOMPILEWARNINGS();
5144 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5145 SAVEI32(PL_compiling.cop_seq);
5146 PL_compiling.cop_seq = 0;
5148 CALL_BLOCK_HOOKS(bhk_start, full);
5154 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5156 Handles compile-time scope exit. C<floor>
5157 is the savestack index returned by
5158 C<block_start>, and C<seq> is the body of the block. Returns the block,
5165 Perl_block_end(pTHX_ I32 floor, OP *seq)
5167 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5168 OP* retval = scalarseq(seq);
5171 /* XXX Is the null PL_parser check necessary here? */
5172 assert(PL_parser); /* Let’s find out under debugging builds. */
5173 if (PL_parser && PL_parser->parsed_sub) {
5174 o = newSTATEOP(0, NULL, NULL);
5176 retval = op_append_elem(OP_LINESEQ, retval, o);
5179 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5183 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5187 /* pad_leavemy has created a sequence of introcv ops for all my
5188 subs declared in the block. We have to replicate that list with
5189 clonecv ops, to deal with this situation:
5194 sub s1 { state sub foo { \&s2 } }
5197 Originally, I was going to have introcv clone the CV and turn
5198 off the stale flag. Since &s1 is declared before &s2, the
5199 introcv op for &s1 is executed (on sub entry) before the one for
5200 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5201 cloned, since it is a state sub) closes over &s2 and expects
5202 to see it in its outer CV’s pad. If the introcv op clones &s1,
5203 then &s2 is still marked stale. Since &s1 is not active, and
5204 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5205 ble will not stay shared’ warning. Because it is the same stub
5206 that will be used when the introcv op for &s2 is executed, clos-
5207 ing over it is safe. Hence, we have to turn off the stale flag
5208 on all lexical subs in the block before we clone any of them.
5209 Hence, having introcv clone the sub cannot work. So we create a
5210 list of ops like this:
5234 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5235 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5236 for (;; kid = OpSIBLING(kid)) {
5237 OP *newkid = newOP(OP_CLONECV, 0);
5238 newkid->op_targ = kid->op_targ;
5239 o = op_append_elem(OP_LINESEQ, o, newkid);
5240 if (kid == last) break;
5242 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5245 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5251 =head1 Compile-time scope hooks
5253 =for apidoc Aox||blockhook_register
5255 Register a set of hooks to be called when the Perl lexical scope changes
5256 at compile time. See L<perlguts/"Compile-time scope hooks">.
5262 Perl_blockhook_register(pTHX_ BHK *hk)
5264 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5266 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5270 Perl_newPROG(pTHX_ OP *o)
5274 PERL_ARGS_ASSERT_NEWPROG;
5281 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5282 ((PL_in_eval & EVAL_KEEPERR)
5283 ? OPf_SPECIAL : 0), o);
5286 assert(CxTYPE(cx) == CXt_EVAL);
5288 if ((cx->blk_gimme & G_WANT) == G_VOID)
5289 scalarvoid(PL_eval_root);
5290 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5293 scalar(PL_eval_root);
5295 start = op_linklist(PL_eval_root);
5296 PL_eval_root->op_next = 0;
5297 i = PL_savestack_ix;
5300 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5302 PL_savestack_ix = i;
5305 if (o->op_type == OP_STUB) {
5306 /* This block is entered if nothing is compiled for the main
5307 program. This will be the case for an genuinely empty main
5308 program, or one which only has BEGIN blocks etc, so already
5311 Historically (5.000) the guard above was !o. However, commit
5312 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5313 c71fccf11fde0068, changed perly.y so that newPROG() is now
5314 called with the output of block_end(), which returns a new
5315 OP_STUB for the case of an empty optree. ByteLoader (and
5316 maybe other things) also take this path, because they set up
5317 PL_main_start and PL_main_root directly, without generating an
5320 If the parsing the main program aborts (due to parse errors,
5321 or due to BEGIN or similar calling exit), then newPROG()
5322 isn't even called, and hence this code path and its cleanups
5323 are skipped. This shouldn't make a make a difference:
5324 * a non-zero return from perl_parse is a failure, and
5325 perl_destruct() should be called immediately.
5326 * however, if exit(0) is called during the parse, then
5327 perl_parse() returns 0, and perl_run() is called. As
5328 PL_main_start will be NULL, perl_run() will return
5329 promptly, and the exit code will remain 0.
5332 PL_comppad_name = 0;
5334 S_op_destroy(aTHX_ o);
5337 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5338 PL_curcop = &PL_compiling;
5339 start = LINKLIST(PL_main_root);
5340 PL_main_root->op_next = 0;
5341 S_process_optree(aTHX_ NULL, PL_main_root, start);
5342 cv_forget_slab(PL_compcv);
5345 /* Register with debugger */
5347 CV * const cv = get_cvs("DB::postponed", 0);
5351 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5353 call_sv(MUTABLE_SV(cv), G_DISCARD);
5360 Perl_localize(pTHX_ OP *o, I32 lex)
5362 PERL_ARGS_ASSERT_LOCALIZE;
5364 if (o->op_flags & OPf_PARENS)
5365 /* [perl #17376]: this appears to be premature, and results in code such as
5366 C< our(%x); > executing in list mode rather than void mode */
5373 if ( PL_parser->bufptr > PL_parser->oldbufptr
5374 && PL_parser->bufptr[-1] == ','
5375 && ckWARN(WARN_PARENTHESIS))
5377 char *s = PL_parser->bufptr;
5380 /* some heuristics to detect a potential error */
5381 while (*s && (strchr(", \t\n", *s)))
5385 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5387 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5390 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5392 while (*s && (strchr(", \t\n", *s)))
5398 if (sigil && (*s == ';' || *s == '=')) {
5399 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5400 "Parentheses missing around \"%s\" list",
5402 ? (PL_parser->in_my == KEY_our
5404 : PL_parser->in_my == KEY_state
5414 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5415 PL_parser->in_my = FALSE;
5416 PL_parser->in_my_stash = NULL;
5421 Perl_jmaybe(pTHX_ OP *o)
5423 PERL_ARGS_ASSERT_JMAYBE;
5425 if (o->op_type == OP_LIST) {
5427 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5428 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5433 PERL_STATIC_INLINE OP *
5434 S_op_std_init(pTHX_ OP *o)
5436 I32 type = o->op_type;
5438 PERL_ARGS_ASSERT_OP_STD_INIT;
5440 if (PL_opargs[type] & OA_RETSCALAR)
5442 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5443 o->op_targ = pad_alloc(type, SVs_PADTMP);
5448 PERL_STATIC_INLINE OP *
5449 S_op_integerize(pTHX_ OP *o)
5451 I32 type = o->op_type;
5453 PERL_ARGS_ASSERT_OP_INTEGERIZE;
5455 /* integerize op. */
5456 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5459 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5462 if (type == OP_NEGATE)
5463 /* XXX might want a ck_negate() for this */
5464 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5470 S_fold_constants(pTHX_ OP *const o)
5473 OP * volatile curop;
5475 volatile I32 type = o->op_type;
5477 SV * volatile sv = NULL;
5480 SV * const oldwarnhook = PL_warnhook;
5481 SV * const olddiehook = PL_diehook;
5483 U8 oldwarn = PL_dowarn;
5487 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5489 if (!(PL_opargs[type] & OA_FOLDCONST))
5498 #ifdef USE_LOCALE_CTYPE
5499 if (IN_LC_COMPILETIME(LC_CTYPE))
5508 #ifdef USE_LOCALE_COLLATE
5509 if (IN_LC_COMPILETIME(LC_COLLATE))
5514 /* XXX what about the numeric ops? */
5515 #ifdef USE_LOCALE_NUMERIC
5516 if (IN_LC_COMPILETIME(LC_NUMERIC))
5521 if (!OpHAS_SIBLING(cLISTOPo->op_first)
5522 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5525 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5526 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5528 const char *s = SvPVX_const(sv);
5529 while (s < SvEND(sv)) {
5530 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5537 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5540 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5541 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5545 if (PL_parser && PL_parser->error_count)
5546 goto nope; /* Don't try to run w/ errors */
5548 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5549 switch (curop->op_type) {
5551 if ( (curop->op_private & OPpCONST_BARE)
5552 && (curop->op_private & OPpCONST_STRICT)) {
5553 no_bareword_allowed(curop);
5561 /* Foldable; move to next op in list */
5565 /* No other op types are considered foldable */
5570 curop = LINKLIST(o);
5571 old_next = o->op_next;
5575 old_cxix = cxstack_ix;
5576 create_eval_scope(NULL, G_FAKINGEVAL);
5578 /* Verify that we don't need to save it: */
5579 assert(PL_curcop == &PL_compiling);
5580 StructCopy(&PL_compiling, ¬_compiling, COP);
5581 PL_curcop = ¬_compiling;
5582 /* The above ensures that we run with all the correct hints of the
5583 currently compiling COP, but that IN_PERL_RUNTIME is true. */
5584 assert(IN_PERL_RUNTIME);
5585 PL_warnhook = PERL_WARNHOOK_FATAL;
5589 /* Effective $^W=1. */
5590 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5591 PL_dowarn |= G_WARN_ON;
5596 sv = *(PL_stack_sp--);
5597 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
5598 pad_swipe(o->op_targ, FALSE);
5600 else if (SvTEMP(sv)) { /* grab mortal temp? */
5601 SvREFCNT_inc_simple_void(sv);
5604 else { assert(SvIMMORTAL(sv)); }
5607 /* Something tried to die. Abandon constant folding. */
5608 /* Pretend the error never happened. */
5610 o->op_next = old_next;
5614 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
5615 PL_warnhook = oldwarnhook;
5616 PL_diehook = olddiehook;
5617 /* XXX note that this croak may fail as we've already blown away
5618 * the stack - eg any nested evals */
5619 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5622 PL_dowarn = oldwarn;
5623 PL_warnhook = oldwarnhook;
5624 PL_diehook = olddiehook;
5625 PL_curcop = &PL_compiling;
5627 /* if we croaked, depending on how we croaked the eval scope
5628 * may or may not have already been popped */
5629 if (cxstack_ix > old_cxix) {
5630 assert(cxstack_ix == old_cxix + 1);
5631 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5632 delete_eval_scope();
5637 /* OP_STRINGIFY and constant folding are used to implement qq.
5638 Here the constant folding is an implementation detail that we
5639 want to hide. If the stringify op is itself already marked
5640 folded, however, then it is actually a folded join. */
5641 is_stringify = type == OP_STRINGIFY && !o->op_folded;
5646 else if (!SvIMMORTAL(sv)) {
5650 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5651 if (!is_stringify) newop->op_folded = 1;
5659 S_gen_constant_list(pTHX_ OP *o)
5662 OP *curop, *old_next;
5663 SV * const oldwarnhook = PL_warnhook;
5664 SV * const olddiehook = PL_diehook;
5666 U8 oldwarn = PL_dowarn;
5676 if (PL_parser && PL_parser->error_count)
5677 return o; /* Don't attempt to run with errors */
5679 curop = LINKLIST(o);
5680 old_next = o->op_next;
5682 op_was_null = o->op_type == OP_NULL;
5683 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5684 o->op_type = OP_CUSTOM;
5687 o->op_type = OP_NULL;
5688 S_prune_chain_head(&curop);
5691 old_cxix = cxstack_ix;
5692 create_eval_scope(NULL, G_FAKINGEVAL);
5694 old_curcop = PL_curcop;
5695 StructCopy(old_curcop, ¬_compiling, COP);
5696 PL_curcop = ¬_compiling;
5697 /* The above ensures that we run with all the correct hints of the
5698 current COP, but that IN_PERL_RUNTIME is true. */
5699 assert(IN_PERL_RUNTIME);
5700 PL_warnhook = PERL_WARNHOOK_FATAL;
5704 /* Effective $^W=1. */
5705 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5706 PL_dowarn |= G_WARN_ON;
5710 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5711 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5713 Perl_pp_pushmark(aTHX);
5716 assert (!(curop->op_flags & OPf_SPECIAL));
5717 assert(curop->op_type == OP_RANGE);
5718 Perl_pp_anonlist(aTHX);
5722 o->op_next = old_next;
5726 PL_warnhook = oldwarnhook;
5727 PL_diehook = olddiehook;
5728 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5733 PL_dowarn = oldwarn;
5734 PL_warnhook = oldwarnhook;
5735 PL_diehook = olddiehook;
5736 PL_curcop = old_curcop;
5738 if (cxstack_ix > old_cxix) {
5739 assert(cxstack_ix == old_cxix + 1);
5740 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5741 delete_eval_scope();
5746 OpTYPE_set(o, OP_RV2AV);
5747 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
5748 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
5749 o->op_opt = 0; /* needs to be revisited in rpeep() */
5750 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5752 /* replace subtree with an OP_CONST */
5753 curop = ((UNOP*)o)->op_first;
5754 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5757 if (AvFILLp(av) != -1)
5758 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5761 SvREADONLY_on(*svp);
5768 =head1 Optree Manipulation Functions
5771 /* List constructors */
5774 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5776 Append an item to the list of ops contained directly within a list-type
5777 op, returning the lengthened list. C<first> is the list-type op,
5778 and C<last> is the op to append to the list. C<optype> specifies the
5779 intended opcode for the list. If C<first> is not already a list of the
5780 right type, it will be upgraded into one. If either C<first> or C<last>
5781 is null, the other is returned unchanged.
5787 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5795 if (first->op_type != (unsigned)type
5796 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5798 return newLISTOP(type, 0, first, last);
5801 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5802 first->op_flags |= OPf_KIDS;
5807 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5809 Concatenate the lists of ops contained directly within two list-type ops,
5810 returning the combined list. C<first> and C<last> are the list-type ops
5811 to concatenate. C<optype> specifies the intended opcode for the list.
5812 If either C<first> or C<last> is not already a list of the right type,
5813 it will be upgraded into one. If either C<first> or C<last> is null,
5814 the other is returned unchanged.
5820 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5828 if (first->op_type != (unsigned)type)
5829 return op_prepend_elem(type, first, last);
5831 if (last->op_type != (unsigned)type)
5832 return op_append_elem(type, first, last);
5834 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5835 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5836 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5837 first->op_flags |= (last->op_flags & OPf_KIDS);
5839 S_op_destroy(aTHX_ last);
5845 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5847 Prepend an item to the list of ops contained directly within a list-type
5848 op, returning the lengthened list. C<first> is the op to prepend to the
5849 list, and C<last> is the list-type op. C<optype> specifies the intended
5850 opcode for the list. If C<last> is not already a list of the right type,
5851 it will be upgraded into one. If either C<first> or C<last> is null,
5852 the other is returned unchanged.
5858 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5866 if (last->op_type == (unsigned)type) {
5867 if (type == OP_LIST) { /* already a PUSHMARK there */
5868 /* insert 'first' after pushmark */
5869 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5870 if (!(first->op_flags & OPf_PARENS))
5871 last->op_flags &= ~OPf_PARENS;
5874 op_sibling_splice(last, NULL, 0, first);
5875 last->op_flags |= OPf_KIDS;
5879 return newLISTOP(type, 0, first, last);
5883 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5885 Converts C<o> into a list op if it is not one already, and then converts it
5886 into the specified C<type>, calling its check function, allocating a target if
5887 it needs one, and folding constants.
5889 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5890 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
5891 C<op_convert_list> to make it the right type.
5897 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5900 if (type < 0) type = -type, flags |= OPf_SPECIAL;
5901 if (!o || o->op_type != OP_LIST)
5902 o = force_list(o, 0);
5905 o->op_flags &= ~OPf_WANT;
5906 o->op_private &= ~OPpLVAL_INTRO;
5909 if (!(PL_opargs[type] & OA_MARK))
5910 op_null(cLISTOPo->op_first);
5912 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5913 if (kid2 && kid2->op_type == OP_COREARGS) {
5914 op_null(cLISTOPo->op_first);
5915 kid2->op_private |= OPpCOREARGS_PUSHMARK;
5919 if (type != OP_SPLIT)
5920 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5921 * ck_split() create a real PMOP and leave the op's type as listop
5922 * for now. Otherwise op_free() etc will crash.
5924 OpTYPE_set(o, type);
5926 o->op_flags |= flags;
5927 if (flags & OPf_FOLDED)
5930 o = CHECKOP(type, o);
5931 if (o->op_type != (unsigned)type)
5934 return fold_constants(op_integerize(op_std_init(o)));
5941 =head1 Optree construction
5943 =for apidoc Am|OP *|newNULLLIST
5945 Constructs, checks, and returns a new C<stub> op, which represents an
5946 empty list expression.
5952 Perl_newNULLLIST(pTHX)
5954 return newOP(OP_STUB, 0);
5957 /* promote o and any siblings to be a list if its not already; i.e.
5965 * pushmark - o - A - B
5967 * If nullit it true, the list op is nulled.
5971 S_force_list(pTHX_ OP *o, bool nullit)
5973 if (!o || o->op_type != OP_LIST) {
5976 /* manually detach any siblings then add them back later */
5977 rest = OpSIBLING(o);
5978 OpLASTSIB_set(o, NULL);
5980 o = newLISTOP(OP_LIST, 0, o, NULL);
5982 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5990 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
5992 Constructs, checks, and returns an op of any list type. C<type> is
5993 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
5994 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
5995 supply up to two ops to be direct children of the list op; they are
5996 consumed by this function and become part of the constructed op tree.
5998 For most list operators, the check function expects all the kid ops to be
5999 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6000 appropriate. What you want to do in that case is create an op of type
6001 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6002 See L</op_convert_list> for more information.
6009 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6014 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6015 || type == OP_CUSTOM);
6017 NewOp(1101, listop, 1, LISTOP);
6019 OpTYPE_set(listop, type);
6022 listop->op_flags = (U8)flags;
6026 else if (!first && last)
6029 OpMORESIB_set(first, last);
6030 listop->op_first = first;
6031 listop->op_last = last;
6032 if (type == OP_LIST) {
6033 OP* const pushop = newOP(OP_PUSHMARK, 0);
6034 OpMORESIB_set(pushop, first);
6035 listop->op_first = pushop;
6036 listop->op_flags |= OPf_KIDS;
6038 listop->op_last = pushop;
6040 if (listop->op_last)
6041 OpLASTSIB_set(listop->op_last, (OP*)listop);
6043 return CHECKOP(type, listop);
6047 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6049 Constructs, checks, and returns an op of any base type (any type that
6050 has no extra fields). C<type> is the opcode. C<flags> gives the
6051 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6058 Perl_newOP(pTHX_ I32 type, I32 flags)
6063 if (type == -OP_ENTEREVAL) {
6064 type = OP_ENTEREVAL;
6065 flags |= OPpEVAL_BYTES<<8;
6068 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6069 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6070 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6071 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6073 NewOp(1101, o, 1, OP);
6074 OpTYPE_set(o, type);
6075 o->op_flags = (U8)flags;
6078 o->op_private = (U8)(0 | (flags >> 8));
6079 if (PL_opargs[type] & OA_RETSCALAR)
6081 if (PL_opargs[type] & OA_TARGET)
6082 o->op_targ = pad_alloc(type, SVs_PADTMP);
6083 return CHECKOP(type, o);
6087 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6089 Constructs, checks, and returns an op of any unary type. C<type> is
6090 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6091 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6092 bits, the eight bits of C<op_private>, except that the bit with value 1
6093 is automatically set. C<first> supplies an optional op to be the direct
6094 child of the unary op; it is consumed by this function and become part
6095 of the constructed op tree.
6101 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6106 if (type == -OP_ENTEREVAL) {
6107 type = OP_ENTEREVAL;
6108 flags |= OPpEVAL_BYTES<<8;
6111 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6112 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6113 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6114 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6115 || type == OP_SASSIGN
6116 || type == OP_ENTERTRY
6117 || type == OP_CUSTOM
6118 || type == OP_NULL );
6121 first = newOP(OP_STUB, 0);
6122 if (PL_opargs[type] & OA_MARK)
6123 first = force_list(first, 1);
6125 NewOp(1101, unop, 1, UNOP);
6126 OpTYPE_set(unop, type);
6127 unop->op_first = first;
6128 unop->op_flags = (U8)(flags | OPf_KIDS);
6129 unop->op_private = (U8)(1 | (flags >> 8));
6131 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6132 OpLASTSIB_set(first, (OP*)unop);
6134 unop = (UNOP*) CHECKOP(type, unop);
6138 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6142 =for apidoc newUNOP_AUX
6144 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6145 initialised to C<aux>
6151 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6156 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6157 || type == OP_CUSTOM);
6159 NewOp(1101, unop, 1, UNOP_AUX);
6160 unop->op_type = (OPCODE)type;
6161 unop->op_ppaddr = PL_ppaddr[type];
6162 unop->op_first = first;
6163 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6164 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6167 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6168 OpLASTSIB_set(first, (OP*)unop);
6170 unop = (UNOP_AUX*) CHECKOP(type, unop);
6172 return op_std_init((OP *) unop);
6176 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6178 Constructs, checks, and returns an op of method type with a method name
6179 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6180 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6181 and, shifted up eight bits, the eight bits of C<op_private>, except that
6182 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6183 op which evaluates method name; it is consumed by this function and
6184 become part of the constructed op tree.
6185 Supported optypes: C<OP_METHOD>.
6191 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6195 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6196 || type == OP_CUSTOM);
6198 NewOp(1101, methop, 1, METHOP);
6200 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6201 methop->op_flags = (U8)(flags | OPf_KIDS);
6202 methop->op_u.op_first = dynamic_meth;
6203 methop->op_private = (U8)(1 | (flags >> 8));
6205 if (!OpHAS_SIBLING(dynamic_meth))
6206 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6210 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6211 methop->op_u.op_meth_sv = const_meth;
6212 methop->op_private = (U8)(0 | (flags >> 8));
6213 methop->op_next = (OP*)methop;
6217 methop->op_rclass_targ = 0;
6219 methop->op_rclass_sv = NULL;
6222 OpTYPE_set(methop, type);
6223 return CHECKOP(type, methop);
6227 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6228 PERL_ARGS_ASSERT_NEWMETHOP;
6229 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6233 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6235 Constructs, checks, and returns an op of method type with a constant
6236 method name. C<type> is the opcode. C<flags> gives the eight bits of
6237 C<op_flags>, and, shifted up eight bits, the eight bits of
6238 C<op_private>. C<const_meth> supplies a constant method name;
6239 it must be a shared COW string.
6240 Supported optypes: C<OP_METHOD_NAMED>.
6246 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6247 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6248 return newMETHOP_internal(type, flags, NULL, const_meth);
6252 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6254 Constructs, checks, and returns an op of any binary type. C<type>
6255 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6256 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6257 the eight bits of C<op_private>, except that the bit with value 1 or
6258 2 is automatically set as required. C<first> and C<last> supply up to
6259 two ops to be the direct children of the binary op; they are consumed
6260 by this function and become part of the constructed op tree.
6266 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6271 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6272 || type == OP_NULL || type == OP_CUSTOM);
6274 NewOp(1101, binop, 1, BINOP);
6277 first = newOP(OP_NULL, 0);
6279 OpTYPE_set(binop, type);
6280 binop->op_first = first;
6281 binop->op_flags = (U8)(flags | OPf_KIDS);
6284 binop->op_private = (U8)(1 | (flags >> 8));
6287 binop->op_private = (U8)(2 | (flags >> 8));
6288 OpMORESIB_set(first, last);
6291 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6292 OpLASTSIB_set(last, (OP*)binop);
6294 binop->op_last = OpSIBLING(binop->op_first);
6296 OpLASTSIB_set(binop->op_last, (OP*)binop);
6298 binop = (BINOP*)CHECKOP(type, binop);
6299 if (binop->op_next || binop->op_type != (OPCODE)type)
6302 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6305 /* Helper function for S_pmtrans(): comparison function to sort an array
6306 * of codepoint range pairs. Sorts by start point, or if equal, by end
6309 static int uvcompare(const void *a, const void *b)
6310 __attribute__nonnull__(1)
6311 __attribute__nonnull__(2)
6312 __attribute__pure__;
6313 static int uvcompare(const void *a, const void *b)
6315 if (*((const UV *)a) < (*(const UV *)b))
6317 if (*((const UV *)a) > (*(const UV *)b))
6319 if (*((const UV *)a+1) < (*(const UV *)b+1))
6321 if (*((const UV *)a+1) > (*(const UV *)b+1))
6326 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6327 * containing the search and replacement strings, assemble into
6328 * a translation table attached as o->op_pv.
6329 * Free expr and repl.
6330 * It expects the toker to have already set the
6331 * OPpTRANS_COMPLEMENT
6334 * flags as appropriate; this function may add
6337 * OPpTRANS_IDENTICAL
6343 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6345 SV * const tstr = ((SVOP*)expr)->op_sv;
6346 SV * const rstr = ((SVOP*)repl)->op_sv;
6349 const U8 *t = (U8*)SvPV_const(tstr, tlen);
6350 const U8 *r = (U8*)SvPV_const(rstr, rlen);
6354 SSize_t struct_size; /* malloced size of table struct */
6356 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6357 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6358 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6361 PERL_ARGS_ASSERT_PMTRANS;
6363 PL_hints |= HINT_BLOCK_SCOPE;
6366 o->op_private |= OPpTRANS_FROM_UTF;
6369 o->op_private |= OPpTRANS_TO_UTF;
6371 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6373 /* for utf8 translations, op_sv will be set to point to a swash
6374 * containing codepoint ranges. This is done by first assembling
6375 * a textual representation of the ranges in listsv then compiling
6376 * it using swash_init(). For more details of the textual format,
6377 * see L<perlunicode.pod/"User-Defined Character Properties"> .
6380 SV* const listsv = newSVpvs("# comment\n");
6382 const U8* tend = t + tlen;
6383 const U8* rend = r + rlen;
6399 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
6400 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
6403 const U32 flags = UTF8_ALLOW_DEFAULT;
6407 t = tsave = bytes_to_utf8(t, &len);
6410 if (!to_utf && rlen) {
6412 r = rsave = bytes_to_utf8(r, &len);
6416 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6417 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6422 * replace t/tlen/tend with a version that has the ranges
6425 U8 tmpbuf[UTF8_MAXBYTES+1];
6428 Newx(cp, 2*tlen, UV);
6430 transv = newSVpvs("");
6432 /* convert search string into array of (start,end) range
6433 * codepoint pairs stored in cp[]. Most "ranges" will start
6434 * and end at the same char */
6436 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6438 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6439 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6441 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6445 cp[2*i+1] = cp[2*i];
6450 /* sort the ranges */
6451 qsort(cp, i, 2*sizeof(UV), uvcompare);
6453 /* Create a utf8 string containing the complement of the
6454 * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6455 * then transv will contain the equivalent of:
6456 * join '', map chr, 0, ILLEGAL_UTF8_BYTE, A - 1,
6457 * B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6458 * D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6459 * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6462 for (j = 0; j < i; j++) {
6464 diff = val - nextmin;
6466 t = uvchr_to_utf8(tmpbuf,nextmin);
6467 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6469 U8 range_mark = ILLEGAL_UTF8_BYTE;
6470 t = uvchr_to_utf8(tmpbuf, val - 1);
6471 sv_catpvn(transv, (char *)&range_mark, 1);
6472 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6480 t = uvchr_to_utf8(tmpbuf,nextmin);
6481 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6483 U8 range_mark = ILLEGAL_UTF8_BYTE;
6484 sv_catpvn(transv, (char *)&range_mark, 1);
6486 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6487 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6488 t = (const U8*)SvPVX_const(transv);
6489 tlen = SvCUR(transv);
6493 else if (!rlen && !del) {
6494 r = t; rlen = tlen; rend = tend;
6498 if ((!rlen && !del) || t == r ||
6499 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6501 o->op_private |= OPpTRANS_IDENTICAL;
6505 /* extract char ranges from t and r and append them to listsv */
6507 while (t < tend || tfirst <= tlast) {
6508 /* see if we need more "t" chars */
6509 if (tfirst > tlast) {
6510 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6512 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6514 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6521 /* now see if we need more "r" chars */
6522 if (rfirst > rlast) {
6524 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6526 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6528 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6537 rfirst = rlast = 0xffffffff;
6541 /* now see which range will peter out first, if either. */
6542 tdiff = tlast - tfirst;
6543 rdiff = rlast - rfirst;
6544 tcount += tdiff + 1;
6545 rcount += rdiff + 1;
6552 if (rfirst == 0xffffffff) {
6553 diff = tdiff; /* oops, pretend rdiff is infinite */
6555 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6556 (long)tfirst, (long)tlast);
6558 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6562 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6563 (long)tfirst, (long)(tfirst + diff),
6566 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6567 (long)tfirst, (long)rfirst);
6569 if (rfirst + diff > max)
6570 max = rfirst + diff;
6572 grows = (tfirst < rfirst &&
6573 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6579 /* compile listsv into a swash and attach to o */
6587 else if (max > 0xff)
6592 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6594 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6595 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6596 PAD_SETSV(cPADOPo->op_padix, swash);
6598 SvREADONLY_on(swash);
6600 cSVOPo->op_sv = swash;
6602 SvREFCNT_dec(listsv);
6603 SvREFCNT_dec(transv);
6605 if (!del && havefinal && rlen)
6606 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6607 newSVuv((UV)final), 0);
6616 else if (rlast == 0xffffffff)
6622 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6623 * table. Entries with the value -1 indicate chars not to be
6624 * translated, while -2 indicates a search char without a
6625 * corresponding replacement char under /d.
6627 * Normally, the table has 256 slots. However, in the presence of
6628 * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6629 * added, and if there are enough replacement chars to start pairing
6630 * with the \x{100},... search chars, then a larger (> 256) table
6633 * In addition, regardless of whether under /c, an extra slot at the
6634 * end is used to store the final repeating char, or -3 under an empty
6635 * replacement list, or -2 under /d; which makes the runtime code
6638 * The toker will have already expanded char ranges in t and r.
6641 /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6642 * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6643 * The OPtrans_map struct already contains one slot; hence the -1.
6645 struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6646 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6648 cPVOPo->op_pv = (char*)tbl;
6653 /* in this branch, j is a count of 'consumed' (i.e. paired off
6654 * with a search char) replacement chars (so j <= rlen always)
6656 for (i = 0; i < tlen; i++)
6657 tbl->map[t[i]] = -1;
6659 for (i = 0, j = 0; i < 256; i++) {
6665 tbl->map[i] = r[j-1];
6667 tbl->map[i] = (short)i;
6670 tbl->map[i] = r[j++];
6672 if ( tbl->map[i] >= 0
6673 && UVCHR_IS_INVARIANT((UV)i)
6674 && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6684 /* More replacement chars than search chars:
6685 * store excess replacement chars at end of main table.
6688 struct_size += excess;
6689 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6690 struct_size + excess * sizeof(short));
6691 tbl->size += excess;
6692 cPVOPo->op_pv = (char*)tbl;
6694 for (i = 0; i < excess; i++)
6695 tbl->map[i + 256] = r[j+i];
6698 /* no more replacement chars than search chars */
6699 if (!rlen && !del && !squash)
6700 o->op_private |= OPpTRANS_IDENTICAL;
6703 tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
6706 if (!rlen && !del) {
6709 o->op_private |= OPpTRANS_IDENTICAL;
6711 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6712 o->op_private |= OPpTRANS_IDENTICAL;
6715 for (i = 0; i < 256; i++)
6717 for (i = 0, j = 0; i < tlen; i++,j++) {
6720 if (tbl->map[t[i]] == -1)
6721 tbl->map[t[i]] = -2;
6726 if (tbl->map[t[i]] == -1) {
6727 if ( UVCHR_IS_INVARIANT(t[i])
6728 && ! UVCHR_IS_INVARIANT(r[j]))
6730 tbl->map[t[i]] = r[j];
6733 tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
6736 /* both non-utf8 and utf8 code paths end up here */
6739 if(del && rlen == tlen) {
6740 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6741 } else if(rlen > tlen && !complement) {
6742 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6746 o->op_private |= OPpTRANS_GROWS;
6755 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6757 Constructs, checks, and returns an op of any pattern matching type.
6758 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
6759 and, shifted up eight bits, the eight bits of C<op_private>.
6765 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6770 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6771 || type == OP_CUSTOM);
6773 NewOp(1101, pmop, 1, PMOP);
6774 OpTYPE_set(pmop, type);
6775 pmop->op_flags = (U8)flags;
6776 pmop->op_private = (U8)(0 | (flags >> 8));
6777 if (PL_opargs[type] & OA_RETSCALAR)
6780 if (PL_hints & HINT_RE_TAINT)
6781 pmop->op_pmflags |= PMf_RETAINT;
6782 #ifdef USE_LOCALE_CTYPE
6783 if (IN_LC_COMPILETIME(LC_CTYPE)) {
6784 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6789 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6791 if (PL_hints & HINT_RE_FLAGS) {
6792 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6793 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6795 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6796 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6797 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6799 if (reflags && SvOK(reflags)) {
6800 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6806 assert(SvPOK(PL_regex_pad[0]));
6807 if (SvCUR(PL_regex_pad[0])) {
6808 /* Pop off the "packed" IV from the end. */
6809 SV *const repointer_list = PL_regex_pad[0];
6810 const char *p = SvEND(repointer_list) - sizeof(IV);
6811 const IV offset = *((IV*)p);
6813 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6815 SvEND_set(repointer_list, p);
6817 pmop->op_pmoffset = offset;
6818 /* This slot should be free, so assert this: */
6819 assert(PL_regex_pad[offset] == &PL_sv_undef);
6821 SV * const repointer = &PL_sv_undef;
6822 av_push(PL_regex_padav, repointer);
6823 pmop->op_pmoffset = av_tindex(PL_regex_padav);
6824 PL_regex_pad = AvARRAY(PL_regex_padav);
6828 return CHECKOP(type, pmop);
6836 /* Any pad names in scope are potentially lvalues. */
6837 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6838 PADNAME *pn = PAD_COMPNAME_SV(i);
6839 if (!pn || !PadnameLEN(pn))
6841 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6842 S_mark_padname_lvalue(aTHX_ pn);
6846 /* Given some sort of match op o, and an expression expr containing a
6847 * pattern, either compile expr into a regex and attach it to o (if it's
6848 * constant), or convert expr into a runtime regcomp op sequence (if it's
6851 * Flags currently has 2 bits of meaning:
6852 * 1: isreg indicates that the pattern is part of a regex construct, eg
6853 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6854 * split "pattern", which aren't. In the former case, expr will be a list
6855 * if the pattern contains more than one term (eg /a$b/).
6856 * 2: The pattern is for a split.
6858 * When the pattern has been compiled within a new anon CV (for
6859 * qr/(?{...})/ ), then floor indicates the savestack level just before
6860 * the new sub was created
6864 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6868 I32 repl_has_vars = 0;
6869 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6870 bool is_compiletime;
6872 bool isreg = cBOOL(flags & 1);
6873 bool is_split = cBOOL(flags & 2);
6875 PERL_ARGS_ASSERT_PMRUNTIME;
6878 return pmtrans(o, expr, repl);
6881 /* find whether we have any runtime or code elements;
6882 * at the same time, temporarily set the op_next of each DO block;
6883 * then when we LINKLIST, this will cause the DO blocks to be excluded
6884 * from the op_next chain (and from having LINKLIST recursively
6885 * applied to them). We fix up the DOs specially later */
6889 if (expr->op_type == OP_LIST) {
6891 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6892 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6894 assert(!o->op_next);
6895 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6896 assert(PL_parser && PL_parser->error_count);
6897 /* This can happen with qr/ (?{(^{})/. Just fake up
6898 the op we were expecting to see, to avoid crashing
6900 op_sibling_splice(expr, o, 0,
6901 newSVOP(OP_CONST, 0, &PL_sv_no));
6903 o->op_next = OpSIBLING(o);
6905 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
6909 else if (expr->op_type != OP_CONST)
6914 /* fix up DO blocks; treat each one as a separate little sub;
6915 * also, mark any arrays as LIST/REF */
6917 if (expr->op_type == OP_LIST) {
6919 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6921 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
6922 assert( !(o->op_flags & OPf_WANT));
6923 /* push the array rather than its contents. The regex
6924 * engine will retrieve and join the elements later */
6925 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
6929 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
6931 o->op_next = NULL; /* undo temporary hack from above */
6934 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
6935 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
6937 assert(leaveop->op_first->op_type == OP_ENTER);
6938 assert(OpHAS_SIBLING(leaveop->op_first));
6939 o->op_next = OpSIBLING(leaveop->op_first);
6941 assert(leaveop->op_flags & OPf_KIDS);
6942 assert(leaveop->op_last->op_next == (OP*)leaveop);
6943 leaveop->op_next = NULL; /* stop on last op */
6944 op_null((OP*)leaveop);
6948 OP *scope = cLISTOPo->op_first;
6949 assert(scope->op_type == OP_SCOPE);
6950 assert(scope->op_flags & OPf_KIDS);
6951 scope->op_next = NULL; /* stop on last op */
6955 /* XXX optimize_optree() must be called on o before
6956 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
6957 * currently cope with a peephole-optimised optree.
6958 * Calling optimize_optree() here ensures that condition
6959 * is met, but may mean optimize_optree() is applied
6960 * to the same optree later (where hopefully it won't do any
6961 * harm as it can't convert an op to multiconcat if it's
6962 * already been converted */
6965 /* have to peep the DOs individually as we've removed it from
6966 * the op_next chain */
6968 S_prune_chain_head(&(o->op_next));
6970 /* runtime finalizes as part of finalizing whole tree */
6974 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
6975 assert( !(expr->op_flags & OPf_WANT));
6976 /* push the array rather than its contents. The regex
6977 * engine will retrieve and join the elements later */
6978 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
6981 PL_hints |= HINT_BLOCK_SCOPE;
6983 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
6985 if (is_compiletime) {
6986 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
6987 regexp_engine const *eng = current_re_engine();
6990 /* make engine handle split ' ' specially */
6991 pm->op_pmflags |= PMf_SPLIT;
6992 rx_flags |= RXf_SPLIT;
6995 /* Skip compiling if parser found an error for this pattern */
6996 if (pm->op_pmflags & PMf_HAS_ERROR) {
7000 if (!has_code || !eng->op_comp) {
7001 /* compile-time simple constant pattern */
7003 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7004 /* whoops! we guessed that a qr// had a code block, but we
7005 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7006 * that isn't required now. Note that we have to be pretty
7007 * confident that nothing used that CV's pad while the
7008 * regex was parsed, except maybe op targets for \Q etc.
7009 * If there were any op targets, though, they should have
7010 * been stolen by constant folding.
7014 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7015 while (++i <= AvFILLp(PL_comppad)) {
7016 # ifdef USE_PAD_RESET
7017 /* under USE_PAD_RESET, pad swipe replaces a swiped
7018 * folded constant with a fresh padtmp */
7019 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7021 assert(!PL_curpad[i]);
7025 /* But we know that one op is using this CV's slab. */
7026 cv_forget_slab(PL_compcv);
7028 pm->op_pmflags &= ~PMf_HAS_CV;
7033 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7034 rx_flags, pm->op_pmflags)
7035 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7036 rx_flags, pm->op_pmflags)
7041 /* compile-time pattern that includes literal code blocks */
7042 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7045 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7048 if (pm->op_pmflags & PMf_HAS_CV) {
7050 /* this QR op (and the anon sub we embed it in) is never
7051 * actually executed. It's just a placeholder where we can
7052 * squirrel away expr in op_code_list without the peephole
7053 * optimiser etc processing it for a second time */
7054 OP *qr = newPMOP(OP_QR, 0);
7055 ((PMOP*)qr)->op_code_list = expr;
7057 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7058 SvREFCNT_inc_simple_void(PL_compcv);
7059 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7060 ReANY(re)->qr_anoncv = cv;
7062 /* attach the anon CV to the pad so that
7063 * pad_fixup_inner_anons() can find it */
7064 (void)pad_add_anon(cv, o->op_type);
7065 SvREFCNT_inc_simple_void(cv);
7068 pm->op_code_list = expr;
7073 /* runtime pattern: build chain of regcomp etc ops */
7075 PADOFFSET cv_targ = 0;
7077 reglist = isreg && expr->op_type == OP_LIST;
7082 pm->op_code_list = expr;
7083 /* don't free op_code_list; its ops are embedded elsewhere too */
7084 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7088 /* make engine handle split ' ' specially */
7089 pm->op_pmflags |= PMf_SPLIT;
7091 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7092 * to allow its op_next to be pointed past the regcomp and
7093 * preceding stacking ops;
7094 * OP_REGCRESET is there to reset taint before executing the
7096 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7097 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7099 if (pm->op_pmflags & PMf_HAS_CV) {
7100 /* we have a runtime qr with literal code. This means
7101 * that the qr// has been wrapped in a new CV, which
7102 * means that runtime consts, vars etc will have been compiled
7103 * against a new pad. So... we need to execute those ops
7104 * within the environment of the new CV. So wrap them in a call
7105 * to a new anon sub. i.e. for
7109 * we build an anon sub that looks like
7111 * sub { "a", $b, '(?{...})' }
7113 * and call it, passing the returned list to regcomp.
7114 * Or to put it another way, the list of ops that get executed
7118 * ------ -------------------
7119 * pushmark (for regcomp)
7120 * pushmark (for entersub)
7124 * regcreset regcreset
7126 * const("a") const("a")
7128 * const("(?{...})") const("(?{...})")
7133 SvREFCNT_inc_simple_void(PL_compcv);
7134 CvLVALUE_on(PL_compcv);
7135 /* these lines are just an unrolled newANONATTRSUB */
7136 expr = newSVOP(OP_ANONCODE, 0,
7137 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7138 cv_targ = expr->op_targ;
7139 expr = newUNOP(OP_REFGEN, 0, expr);
7141 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7144 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7145 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7146 | (reglist ? OPf_STACKED : 0);
7147 rcop->op_targ = cv_targ;
7149 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
7150 if (PL_hints & HINT_RE_EVAL)
7151 S_set_haseval(aTHX);
7153 /* establish postfix order */
7154 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7156 rcop->op_next = expr;
7157 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7160 rcop->op_next = LINKLIST(expr);
7161 expr->op_next = (OP*)rcop;
7164 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7170 /* If we are looking at s//.../e with a single statement, get past
7171 the implicit do{}. */
7172 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7173 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7174 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7177 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7178 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7179 && !OpHAS_SIBLING(sib))
7182 if (curop->op_type == OP_CONST)
7184 else if (( (curop->op_type == OP_RV2SV ||
7185 curop->op_type == OP_RV2AV ||
7186 curop->op_type == OP_RV2HV ||
7187 curop->op_type == OP_RV2GV)
7188 && cUNOPx(curop)->op_first
7189 && cUNOPx(curop)->op_first->op_type == OP_GV )
7190 || curop->op_type == OP_PADSV
7191 || curop->op_type == OP_PADAV
7192 || curop->op_type == OP_PADHV
7193 || curop->op_type == OP_PADANY) {
7201 || !RX_PRELEN(PM_GETRE(pm))
7202 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7204 pm->op_pmflags |= PMf_CONST; /* const for long enough */
7205 op_prepend_elem(o->op_type, scalar(repl), o);
7208 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7209 rcop->op_private = 1;
7211 /* establish postfix order */
7212 rcop->op_next = LINKLIST(repl);
7213 repl->op_next = (OP*)rcop;
7215 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7216 assert(!(pm->op_pmflags & PMf_ONCE));
7217 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7226 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7228 Constructs, checks, and returns an op of any type that involves an
7229 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
7230 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
7231 takes ownership of one reference to it.
7237 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7242 PERL_ARGS_ASSERT_NEWSVOP;
7244 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7245 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7246 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7247 || type == OP_CUSTOM);
7249 NewOp(1101, svop, 1, SVOP);
7250 OpTYPE_set(svop, type);
7252 svop->op_next = (OP*)svop;
7253 svop->op_flags = (U8)flags;
7254 svop->op_private = (U8)(0 | (flags >> 8));
7255 if (PL_opargs[type] & OA_RETSCALAR)
7257 if (PL_opargs[type] & OA_TARGET)
7258 svop->op_targ = pad_alloc(type, SVs_PADTMP);
7259 return CHECKOP(type, svop);
7263 =for apidoc Am|OP *|newDEFSVOP|
7265 Constructs and returns an op to access C<$_>.
7271 Perl_newDEFSVOP(pTHX)
7273 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7279 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7281 Constructs, checks, and returns an op of any type that involves a
7282 reference to a pad element. C<type> is the opcode. C<flags> gives the
7283 eight bits of C<op_flags>. A pad slot is automatically allocated, and
7284 is populated with C<sv>; this function takes ownership of one reference
7287 This function only exists if Perl has been compiled to use ithreads.
7293 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7298 PERL_ARGS_ASSERT_NEWPADOP;
7300 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7301 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7302 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7303 || type == OP_CUSTOM);
7305 NewOp(1101, padop, 1, PADOP);
7306 OpTYPE_set(padop, type);
7308 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7309 SvREFCNT_dec(PAD_SVl(padop->op_padix));
7310 PAD_SETSV(padop->op_padix, sv);
7312 padop->op_next = (OP*)padop;
7313 padop->op_flags = (U8)flags;
7314 if (PL_opargs[type] & OA_RETSCALAR)
7316 if (PL_opargs[type] & OA_TARGET)
7317 padop->op_targ = pad_alloc(type, SVs_PADTMP);
7318 return CHECKOP(type, padop);
7321 #endif /* USE_ITHREADS */
7324 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7326 Constructs, checks, and returns an op of any type that involves an
7327 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
7328 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
7329 reference; calling this function does not transfer ownership of any
7336 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7338 PERL_ARGS_ASSERT_NEWGVOP;
7341 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7343 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7348 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7350 Constructs, checks, and returns an op of any type that involves an
7351 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
7352 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
7353 Depending on the op type, the memory referenced by C<pv> may be freed
7354 when the op is destroyed. If the op is of a freeing type, C<pv> must
7355 have been allocated using C<PerlMemShared_malloc>.
7361 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7364 const bool utf8 = cBOOL(flags & SVf_UTF8);
7369 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7370 || type == OP_RUNCV || type == OP_CUSTOM
7371 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7373 NewOp(1101, pvop, 1, PVOP);
7374 OpTYPE_set(pvop, type);
7376 pvop->op_next = (OP*)pvop;
7377 pvop->op_flags = (U8)flags;
7378 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7379 if (PL_opargs[type] & OA_RETSCALAR)
7381 if (PL_opargs[type] & OA_TARGET)
7382 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7383 return CHECKOP(type, pvop);
7387 Perl_package(pTHX_ OP *o)
7389 SV *const sv = cSVOPo->op_sv;
7391 PERL_ARGS_ASSERT_PACKAGE;
7393 SAVEGENERICSV(PL_curstash);
7394 save_item(PL_curstname);
7396 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7398 sv_setsv(PL_curstname, sv);
7400 PL_hints |= HINT_BLOCK_SCOPE;
7401 PL_parser->copline = NOLINE;
7407 Perl_package_version( pTHX_ OP *v )
7409 U32 savehints = PL_hints;
7410 PERL_ARGS_ASSERT_PACKAGE_VERSION;
7411 PL_hints &= ~HINT_STRICT_VARS;
7412 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7413 PL_hints = savehints;
7418 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7423 SV *use_version = NULL;
7425 PERL_ARGS_ASSERT_UTILIZE;
7427 if (idop->op_type != OP_CONST)
7428 Perl_croak(aTHX_ "Module name must be constant");
7433 SV * const vesv = ((SVOP*)version)->op_sv;
7435 if (!arg && !SvNIOKp(vesv)) {
7442 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7443 Perl_croak(aTHX_ "Version number must be a constant number");
7445 /* Make copy of idop so we don't free it twice */
7446 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7448 /* Fake up a method call to VERSION */
7449 meth = newSVpvs_share("VERSION");
7450 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7451 op_append_elem(OP_LIST,
7452 op_prepend_elem(OP_LIST, pack, version),
7453 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7457 /* Fake up an import/unimport */
7458 if (arg && arg->op_type == OP_STUB) {
7459 imop = arg; /* no import on explicit () */
7461 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7462 imop = NULL; /* use 5.0; */
7464 use_version = ((SVOP*)idop)->op_sv;
7466 idop->op_private |= OPpCONST_NOVER;
7471 /* Make copy of idop so we don't free it twice */
7472 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7474 /* Fake up a method call to import/unimport */
7476 ? newSVpvs_share("import") : newSVpvs_share("unimport");
7477 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7478 op_append_elem(OP_LIST,
7479 op_prepend_elem(OP_LIST, pack, arg),
7480 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7484 /* Fake up the BEGIN {}, which does its thing immediately. */
7486 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7489 op_append_elem(OP_LINESEQ,
7490 op_append_elem(OP_LINESEQ,
7491 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7492 newSTATEOP(0, NULL, veop)),
7493 newSTATEOP(0, NULL, imop) ));
7497 * feature bundle that corresponds to the required version. */
7498 use_version = sv_2mortal(new_version(use_version));
7499 S_enable_feature_bundle(aTHX_ use_version);
7501 /* If a version >= 5.11.0 is requested, strictures are on by default! */
7502 if (vcmp(use_version,
7503 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7504 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7505 PL_hints |= HINT_STRICT_REFS;
7506 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7507 PL_hints |= HINT_STRICT_SUBS;
7508 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7509 PL_hints |= HINT_STRICT_VARS;
7511 /* otherwise they are off */
7513 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7514 PL_hints &= ~HINT_STRICT_REFS;
7515 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7516 PL_hints &= ~HINT_STRICT_SUBS;
7517 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7518 PL_hints &= ~HINT_STRICT_VARS;
7522 /* The "did you use incorrect case?" warning used to be here.
7523 * The problem is that on case-insensitive filesystems one
7524 * might get false positives for "use" (and "require"):
7525 * "use Strict" or "require CARP" will work. This causes
7526 * portability problems for the script: in case-strict
7527 * filesystems the script will stop working.
7529 * The "incorrect case" warning checked whether "use Foo"
7530 * imported "Foo" to your namespace, but that is wrong, too:
7531 * there is no requirement nor promise in the language that
7532 * a Foo.pm should or would contain anything in package "Foo".
7534 * There is very little Configure-wise that can be done, either:
7535 * the case-sensitivity of the build filesystem of Perl does not
7536 * help in guessing the case-sensitivity of the runtime environment.
7539 PL_hints |= HINT_BLOCK_SCOPE;
7540 PL_parser->copline = NOLINE;
7541 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7545 =head1 Embedding Functions
7547 =for apidoc load_module
7549 Loads the module whose name is pointed to by the string part of C<name>.
7550 Note that the actual module name, not its filename, should be given.
7551 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7552 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7553 trailing arguments can be used to specify arguments to the module's C<import()>
7554 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7555 on the flags. The flags argument is a bitwise-ORed collection of any of
7556 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7557 (or 0 for no flags).
7559 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7560 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7561 the trailing optional arguments may be omitted entirely. Otherwise, if
7562 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7563 exactly one C<OP*>, containing the op tree that produces the relevant import
7564 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7565 will be used as import arguments; and the list must be terminated with C<(SV*)
7566 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7567 set, the trailing C<NULL> pointer is needed even if no import arguments are
7568 desired. The reference count for each specified C<SV*> argument is
7569 decremented. In addition, the C<name> argument is modified.
7571 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7577 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7581 PERL_ARGS_ASSERT_LOAD_MODULE;
7583 va_start(args, ver);
7584 vload_module(flags, name, ver, &args);
7588 #ifdef PERL_IMPLICIT_CONTEXT
7590 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7594 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7595 va_start(args, ver);
7596 vload_module(flags, name, ver, &args);
7602 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7605 OP * const modname = newSVOP(OP_CONST, 0, name);
7607 PERL_ARGS_ASSERT_VLOAD_MODULE;
7609 modname->op_private |= OPpCONST_BARE;
7611 veop = newSVOP(OP_CONST, 0, ver);
7615 if (flags & PERL_LOADMOD_NOIMPORT) {
7616 imop = sawparens(newNULLLIST());
7618 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7619 imop = va_arg(*args, OP*);
7624 sv = va_arg(*args, SV*);
7626 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7627 sv = va_arg(*args, SV*);
7631 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7632 * that it has a PL_parser to play with while doing that, and also
7633 * that it doesn't mess with any existing parser, by creating a tmp
7634 * new parser with lex_start(). This won't actually be used for much,
7635 * since pp_require() will create another parser for the real work.
7636 * The ENTER/LEAVE pair protect callers from any side effects of use. */
7639 SAVEVPTR(PL_curcop);
7640 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7641 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
7642 veop, modname, imop);
7646 PERL_STATIC_INLINE OP *
7647 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7649 return newUNOP(OP_ENTERSUB, OPf_STACKED,
7650 newLISTOP(OP_LIST, 0, arg,
7651 newUNOP(OP_RV2CV, 0,
7652 newGVOP(OP_GV, 0, gv))));
7656 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7661 PERL_ARGS_ASSERT_DOFILE;
7663 if (!force_builtin && (gv = gv_override("do", 2))) {
7664 doop = S_new_entersubop(aTHX_ gv, term);
7667 doop = newUNOP(OP_DOFILE, 0, scalar(term));
7673 =head1 Optree construction
7675 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7677 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
7678 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7679 be set automatically, and, shifted up eight bits, the eight bits of
7680 C<op_private>, except that the bit with value 1 or 2 is automatically
7681 set as required. C<listval> and C<subscript> supply the parameters of
7682 the slice; they are consumed by this function and become part of the
7683 constructed op tree.
7689 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7691 return newBINOP(OP_LSLICE, flags,
7692 list(force_list(subscript, 1)),
7693 list(force_list(listval, 1)) );
7696 #define ASSIGN_LIST 1
7697 #define ASSIGN_REF 2
7700 S_assignment_type(pTHX_ const OP *o)
7709 if (o->op_type == OP_SREFGEN)
7711 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7712 type = kid->op_type;
7713 flags = o->op_flags | kid->op_flags;
7714 if (!(flags & OPf_PARENS)
7715 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7716 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7720 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7721 o = cUNOPo->op_first;
7722 flags = o->op_flags;
7727 if (type == OP_COND_EXPR) {
7728 OP * const sib = OpSIBLING(cLOGOPo->op_first);
7729 const I32 t = assignment_type(sib);
7730 const I32 f = assignment_type(OpSIBLING(sib));
7732 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7734 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7735 yyerror("Assignment to both a list and a scalar");
7739 if (type == OP_LIST &&
7740 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7741 o->op_private & OPpLVAL_INTRO)
7744 if (type == OP_LIST || flags & OPf_PARENS ||
7745 type == OP_RV2AV || type == OP_RV2HV ||
7746 type == OP_ASLICE || type == OP_HSLICE ||
7747 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7750 if (type == OP_PADAV || type == OP_PADHV)
7753 if (type == OP_RV2SV)
7760 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7762 const PADOFFSET target = padop->op_targ;
7763 OP *const other = newOP(OP_PADSV,
7765 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7766 OP *const first = newOP(OP_NULL, 0);
7767 OP *const nullop = newCONDOP(0, first, initop, other);
7768 /* XXX targlex disabled for now; see ticket #124160
7769 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7771 OP *const condop = first->op_next;
7773 OpTYPE_set(condop, OP_ONCE);
7774 other->op_targ = target;
7775 nullop->op_flags |= OPf_WANT_SCALAR;
7777 /* Store the initializedness of state vars in a separate
7780 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7781 /* hijacking PADSTALE for uninitialized state variables */
7782 SvPADSTALE_on(PAD_SVl(condop->op_targ));
7788 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7790 Constructs, checks, and returns an assignment op. C<left> and C<right>
7791 supply the parameters of the assignment; they are consumed by this
7792 function and become part of the constructed op tree.
7794 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7795 a suitable conditional optree is constructed. If C<optype> is the opcode
7796 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7797 performs the binary operation and assigns the result to the left argument.
7798 Either way, if C<optype> is non-zero then C<flags> has no effect.
7800 If C<optype> is zero, then a plain scalar or list assignment is
7801 constructed. Which type of assignment it is is automatically determined.
7802 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7803 will be set automatically, and, shifted up eight bits, the eight bits
7804 of C<op_private>, except that the bit with value 1 or 2 is automatically
7811 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7817 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7818 right = scalar(right);
7819 return newLOGOP(optype, 0,
7820 op_lvalue(scalar(left), optype),
7821 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7824 return newBINOP(optype, OPf_STACKED,
7825 op_lvalue(scalar(left), optype), scalar(right));
7829 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7830 OP *state_var_op = NULL;
7831 static const char no_list_state[] = "Initialization of state variables"
7832 " in list currently forbidden";
7835 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7836 left->op_private &= ~ OPpSLICEWARNING;
7839 left = op_lvalue(left, OP_AASSIGN);
7840 curop = list(force_list(left, 1));
7841 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7842 o->op_private = (U8)(0 | (flags >> 8));
7844 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7846 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7847 if (!(left->op_flags & OPf_PARENS) &&
7848 lop->op_type == OP_PUSHMARK &&
7849 (vop = OpSIBLING(lop)) &&
7850 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7851 !(vop->op_flags & OPf_PARENS) &&
7852 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7853 (OPpLVAL_INTRO|OPpPAD_STATE) &&
7854 (eop = OpSIBLING(vop)) &&
7855 eop->op_type == OP_ENTERSUB &&
7856 !OpHAS_SIBLING(eop)) {
7860 if ((lop->op_type == OP_PADSV ||
7861 lop->op_type == OP_PADAV ||
7862 lop->op_type == OP_PADHV ||
7863 lop->op_type == OP_PADANY)
7864 && (lop->op_private & OPpPAD_STATE)
7866 yyerror(no_list_state);
7867 lop = OpSIBLING(lop);
7871 else if ( (left->op_private & OPpLVAL_INTRO)
7872 && (left->op_private & OPpPAD_STATE)
7873 && ( left->op_type == OP_PADSV
7874 || left->op_type == OP_PADAV
7875 || left->op_type == OP_PADHV
7876 || left->op_type == OP_PADANY)
7878 /* All single variable list context state assignments, hence
7888 if (left->op_flags & OPf_PARENS)
7889 yyerror(no_list_state);
7891 state_var_op = left;
7894 /* optimise @a = split(...) into:
7895 * @{expr}: split(..., @{expr}) (where @a is not flattened)
7896 * @a, my @a, local @a: split(...) (where @a is attached to
7897 * the split op itself)
7901 && right->op_type == OP_SPLIT
7902 /* don't do twice, e.g. @b = (@a = split) */
7903 && !(right->op_private & OPpSPLIT_ASSIGN))
7907 if ( ( left->op_type == OP_RV2AV
7908 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
7909 || left->op_type == OP_PADAV)
7911 /* @pkg or @lex or local @pkg' or 'my @lex' */
7915 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
7916 = cPADOPx(gvop)->op_padix;
7917 cPADOPx(gvop)->op_padix = 0; /* steal it */
7919 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
7920 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
7921 cSVOPx(gvop)->op_sv = NULL; /* steal it */
7923 right->op_private |=
7924 left->op_private & OPpOUR_INTRO;
7927 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
7928 left->op_targ = 0; /* steal it */
7929 right->op_private |= OPpSPLIT_LEX;
7931 right->op_private |= left->op_private & OPpLVAL_INTRO;
7934 tmpop = cUNOPo->op_first; /* to list (nulled) */
7935 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
7936 assert(OpSIBLING(tmpop) == right);
7937 assert(!OpHAS_SIBLING(right));
7938 /* detach the split subtreee from the o tree,
7939 * then free the residual o tree */
7940 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
7941 op_free(o); /* blow off assign */
7942 right->op_private |= OPpSPLIT_ASSIGN;
7943 right->op_flags &= ~OPf_WANT;
7944 /* "I don't know and I don't care." */
7947 else if (left->op_type == OP_RV2AV) {
7950 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
7951 assert(OpSIBLING(pushop) == left);
7952 /* Detach the array ... */
7953 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
7954 /* ... and attach it to the split. */
7955 op_sibling_splice(right, cLISTOPx(right)->op_last,
7957 right->op_flags |= OPf_STACKED;
7958 /* Detach split and expunge aassign as above. */
7961 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
7962 ((LISTOP*)right)->op_last->op_type == OP_CONST)
7964 /* convert split(...,0) to split(..., PL_modcount+1) */
7966 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
7967 SV * const sv = *svp;
7968 if (SvIOK(sv) && SvIVX(sv) == 0)
7970 if (right->op_private & OPpSPLIT_IMPLIM) {
7971 /* our own SV, created in ck_split */
7973 sv_setiv(sv, PL_modcount+1);
7976 /* SV may belong to someone else */
7978 *svp = newSViv(PL_modcount+1);
7985 o = S_newONCEOP(aTHX_ o, state_var_op);
7988 if (assign_type == ASSIGN_REF)
7989 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
7991 right = newOP(OP_UNDEF, 0);
7992 if (right->op_type == OP_READLINE) {
7993 right->op_flags |= OPf_STACKED;
7994 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
7998 o = newBINOP(OP_SASSIGN, flags,
7999 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8005 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
8007 Constructs a state op (COP). The state op is normally a C<nextstate> op,
8008 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8009 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8010 If C<label> is non-null, it supplies the name of a label to attach to
8011 the state op; this function takes ownership of the memory pointed at by
8012 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
8015 If C<o> is null, the state op is returned. Otherwise the state op is
8016 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
8017 is consumed by this function and becomes part of the returned op tree.
8023 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8026 const U32 seq = intro_my();
8027 const U32 utf8 = flags & SVf_UTF8;
8030 PL_parser->parsed_sub = 0;
8034 NewOp(1101, cop, 1, COP);
8035 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8036 OpTYPE_set(cop, OP_DBSTATE);
8039 OpTYPE_set(cop, OP_NEXTSTATE);
8041 cop->op_flags = (U8)flags;
8042 CopHINTS_set(cop, PL_hints);
8044 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8046 cop->op_next = (OP*)cop;
8049 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8050 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8052 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8054 PL_hints |= HINT_BLOCK_SCOPE;
8055 /* It seems that we need to defer freeing this pointer, as other parts
8056 of the grammar end up wanting to copy it after this op has been
8061 if (PL_parser->preambling != NOLINE) {
8062 CopLINE_set(cop, PL_parser->preambling);
8063 PL_parser->copline = NOLINE;
8065 else if (PL_parser->copline == NOLINE)
8066 CopLINE_set(cop, CopLINE(PL_curcop));
8068 CopLINE_set(cop, PL_parser->copline);
8069 PL_parser->copline = NOLINE;
8072 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
8074 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8076 CopSTASH_set(cop, PL_curstash);
8078 if (cop->op_type == OP_DBSTATE) {
8079 /* this line can have a breakpoint - store the cop in IV */
8080 AV *av = CopFILEAVx(PL_curcop);
8082 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8083 if (svp && *svp != &PL_sv_undef ) {
8084 (void)SvIOK_on(*svp);
8085 SvIV_set(*svp, PTR2IV(cop));
8090 if (flags & OPf_SPECIAL)
8092 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8096 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
8098 Constructs, checks, and returns a logical (flow control) op. C<type>
8099 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
8100 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8101 the eight bits of C<op_private>, except that the bit with value 1 is
8102 automatically set. C<first> supplies the expression controlling the
8103 flow, and C<other> supplies the side (alternate) chain of ops; they are
8104 consumed by this function and become part of the constructed op tree.
8110 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8112 PERL_ARGS_ASSERT_NEWLOGOP;
8114 return new_logop(type, flags, &first, &other);
8118 S_search_const(pTHX_ OP *o)
8120 PERL_ARGS_ASSERT_SEARCH_CONST;
8122 switch (o->op_type) {
8126 if (o->op_flags & OPf_KIDS)
8127 return search_const(cUNOPo->op_first);
8134 if (!(o->op_flags & OPf_KIDS))
8136 kid = cLISTOPo->op_first;
8138 switch (kid->op_type) {
8142 kid = OpSIBLING(kid);
8145 if (kid != cLISTOPo->op_last)
8151 kid = cLISTOPo->op_last;
8153 return search_const(kid);
8161 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8169 int prepend_not = 0;
8171 PERL_ARGS_ASSERT_NEW_LOGOP;
8176 /* [perl #59802]: Warn about things like "return $a or $b", which
8177 is parsed as "(return $a) or $b" rather than "return ($a or
8178 $b)". NB: This also applies to xor, which is why we do it
8181 switch (first->op_type) {
8185 /* XXX: Perhaps we should emit a stronger warning for these.
8186 Even with the high-precedence operator they don't seem to do
8189 But until we do, fall through here.
8195 /* XXX: Currently we allow people to "shoot themselves in the
8196 foot" by explicitly writing "(return $a) or $b".
8198 Warn unless we are looking at the result from folding or if
8199 the programmer explicitly grouped the operators like this.
8200 The former can occur with e.g.
8202 use constant FEATURE => ( $] >= ... );
8203 sub { not FEATURE and return or do_stuff(); }
8205 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8206 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8207 "Possible precedence issue with control flow operator");
8208 /* XXX: Should we optimze this to "return $a;" (i.e. remove
8214 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8215 return newBINOP(type, flags, scalar(first), scalar(other));
8217 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8218 || type == OP_CUSTOM);
8220 scalarboolean(first);
8222 /* search for a constant op that could let us fold the test */
8223 if ((cstop = search_const(first))) {
8224 if (cstop->op_private & OPpCONST_STRICT)
8225 no_bareword_allowed(cstop);
8226 else if ((cstop->op_private & OPpCONST_BARE))
8227 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8228 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
8229 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8230 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8231 /* Elide the (constant) lhs, since it can't affect the outcome */
8233 if (other->op_type == OP_CONST)
8234 other->op_private |= OPpCONST_SHORTCIRCUIT;
8236 if (other->op_type == OP_LEAVE)
8237 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8238 else if (other->op_type == OP_MATCH
8239 || other->op_type == OP_SUBST
8240 || other->op_type == OP_TRANSR
8241 || other->op_type == OP_TRANS)
8242 /* Mark the op as being unbindable with =~ */
8243 other->op_flags |= OPf_SPECIAL;
8245 other->op_folded = 1;
8249 /* Elide the rhs, since the outcome is entirely determined by
8250 * the (constant) lhs */
8252 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8253 const OP *o2 = other;
8254 if ( ! (o2->op_type == OP_LIST
8255 && (( o2 = cUNOPx(o2)->op_first))
8256 && o2->op_type == OP_PUSHMARK
8257 && (( o2 = OpSIBLING(o2))) )
8260 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8261 || o2->op_type == OP_PADHV)
8262 && o2->op_private & OPpLVAL_INTRO
8263 && !(o2->op_private & OPpPAD_STATE))
8265 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8266 "Deprecated use of my() in false conditional. "
8267 "This will be a fatal error in Perl 5.30");
8271 if (cstop->op_type == OP_CONST)
8272 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8277 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8278 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8280 const OP * const k1 = ((UNOP*)first)->op_first;
8281 const OP * const k2 = OpSIBLING(k1);
8283 switch (first->op_type)
8286 if (k2 && k2->op_type == OP_READLINE
8287 && (k2->op_flags & OPf_STACKED)
8288 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8290 warnop = k2->op_type;
8295 if (k1->op_type == OP_READDIR
8296 || k1->op_type == OP_GLOB
8297 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8298 || k1->op_type == OP_EACH
8299 || k1->op_type == OP_AEACH)
8301 warnop = ((k1->op_type == OP_NULL)
8302 ? (OPCODE)k1->op_targ : k1->op_type);
8307 const line_t oldline = CopLINE(PL_curcop);
8308 /* This ensures that warnings are reported at the first line
8309 of the construction, not the last. */
8310 CopLINE_set(PL_curcop, PL_parser->copline);
8311 Perl_warner(aTHX_ packWARN(WARN_MISC),
8312 "Value of %s%s can be \"0\"; test with defined()",
8314 ((warnop == OP_READLINE || warnop == OP_GLOB)
8315 ? " construct" : "() operator"));
8316 CopLINE_set(PL_curcop, oldline);
8320 /* optimize AND and OR ops that have NOTs as children */
8321 if (first->op_type == OP_NOT
8322 && (first->op_flags & OPf_KIDS)
8323 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8324 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8326 if (type == OP_AND || type == OP_OR) {
8332 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8334 prepend_not = 1; /* prepend a NOT op later */
8339 logop = alloc_LOGOP(type, first, LINKLIST(other));
8340 logop->op_flags |= (U8)flags;
8341 logop->op_private = (U8)(1 | (flags >> 8));
8343 /* establish postfix order */
8344 logop->op_next = LINKLIST(first);
8345 first->op_next = (OP*)logop;
8346 assert(!OpHAS_SIBLING(first));
8347 op_sibling_splice((OP*)logop, first, 0, other);
8349 CHECKOP(type,logop);
8351 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8352 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8360 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8362 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8363 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8364 will be set automatically, and, shifted up eight bits, the eight bits of
8365 C<op_private>, except that the bit with value 1 is automatically set.
8366 C<first> supplies the expression selecting between the two branches,
8367 and C<trueop> and C<falseop> supply the branches; they are consumed by
8368 this function and become part of the constructed op tree.
8374 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8382 PERL_ARGS_ASSERT_NEWCONDOP;
8385 return newLOGOP(OP_AND, 0, first, trueop);
8387 return newLOGOP(OP_OR, 0, first, falseop);
8389 scalarboolean(first);
8390 if ((cstop = search_const(first))) {
8391 /* Left or right arm of the conditional? */
8392 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8393 OP *live = left ? trueop : falseop;
8394 OP *const dead = left ? falseop : trueop;
8395 if (cstop->op_private & OPpCONST_BARE &&
8396 cstop->op_private & OPpCONST_STRICT) {
8397 no_bareword_allowed(cstop);
8401 if (live->op_type == OP_LEAVE)
8402 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8403 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8404 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8405 /* Mark the op as being unbindable with =~ */
8406 live->op_flags |= OPf_SPECIAL;
8407 live->op_folded = 1;
8410 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8411 logop->op_flags |= (U8)flags;
8412 logop->op_private = (U8)(1 | (flags >> 8));
8413 logop->op_next = LINKLIST(falseop);
8415 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8418 /* establish postfix order */
8419 start = LINKLIST(first);
8420 first->op_next = (OP*)logop;
8422 /* make first, trueop, falseop siblings */
8423 op_sibling_splice((OP*)logop, first, 0, trueop);
8424 op_sibling_splice((OP*)logop, trueop, 0, falseop);
8426 o = newUNOP(OP_NULL, 0, (OP*)logop);
8428 trueop->op_next = falseop->op_next = o;
8435 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8437 Constructs and returns a C<range> op, with subordinate C<flip> and
8438 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
8439 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8440 for both the C<flip> and C<range> ops, except that the bit with value
8441 1 is automatically set. C<left> and C<right> supply the expressions
8442 controlling the endpoints of the range; they are consumed by this function
8443 and become part of the constructed op tree.
8449 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8457 PERL_ARGS_ASSERT_NEWRANGE;
8459 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8460 range->op_flags = OPf_KIDS;
8461 leftstart = LINKLIST(left);
8462 range->op_private = (U8)(1 | (flags >> 8));
8464 /* make left and right siblings */
8465 op_sibling_splice((OP*)range, left, 0, right);
8467 range->op_next = (OP*)range;
8468 flip = newUNOP(OP_FLIP, flags, (OP*)range);
8469 flop = newUNOP(OP_FLOP, 0, flip);
8470 o = newUNOP(OP_NULL, 0, flop);
8472 range->op_next = leftstart;
8474 left->op_next = flip;
8475 right->op_next = flop;
8478 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8479 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8481 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8482 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8483 SvPADTMP_on(PAD_SV(flip->op_targ));
8485 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8486 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8488 /* check barewords before they might be optimized aways */
8489 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8490 no_bareword_allowed(left);
8491 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8492 no_bareword_allowed(right);
8495 if (!flip->op_private || !flop->op_private)
8496 LINKLIST(o); /* blow off optimizer unless constant */
8502 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8504 Constructs, checks, and returns an op tree expressing a loop. This is
8505 only a loop in the control flow through the op tree; it does not have
8506 the heavyweight loop structure that allows exiting the loop by C<last>
8507 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
8508 top-level op, except that some bits will be set automatically as required.
8509 C<expr> supplies the expression controlling loop iteration, and C<block>
8510 supplies the body of the loop; they are consumed by this function and
8511 become part of the constructed op tree. C<debuggable> is currently
8512 unused and should always be 1.
8518 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8522 const bool once = block && block->op_flags & OPf_SPECIAL &&
8523 block->op_type == OP_NULL;
8525 PERL_UNUSED_ARG(debuggable);
8529 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8530 || ( expr->op_type == OP_NOT
8531 && cUNOPx(expr)->op_first->op_type == OP_CONST
8532 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8535 /* Return the block now, so that S_new_logop does not try to
8537 return block; /* do {} while 0 does once */
8538 if (expr->op_type == OP_READLINE
8539 || expr->op_type == OP_READDIR
8540 || expr->op_type == OP_GLOB
8541 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8542 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8543 expr = newUNOP(OP_DEFINED, 0,
8544 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8545 } else if (expr->op_flags & OPf_KIDS) {
8546 const OP * const k1 = ((UNOP*)expr)->op_first;
8547 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8548 switch (expr->op_type) {
8550 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8551 && (k2->op_flags & OPf_STACKED)
8552 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8553 expr = newUNOP(OP_DEFINED, 0, expr);
8557 if (k1 && (k1->op_type == OP_READDIR
8558 || k1->op_type == OP_GLOB
8559 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8560 || k1->op_type == OP_EACH
8561 || k1->op_type == OP_AEACH))
8562 expr = newUNOP(OP_DEFINED, 0, expr);
8568 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8569 * op, in listop. This is wrong. [perl #27024] */
8571 block = newOP(OP_NULL, 0);
8572 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8573 o = new_logop(OP_AND, 0, &expr, &listop);
8580 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8582 if (once && o != listop)
8584 assert(cUNOPo->op_first->op_type == OP_AND
8585 || cUNOPo->op_first->op_type == OP_OR);
8586 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8590 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
8592 o->op_flags |= flags;
8594 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8599 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8601 Constructs, checks, and returns an op tree expressing a C<while> loop.
8602 This is a heavyweight loop, with structure that allows exiting the loop
8603 by C<last> and suchlike.
8605 C<loop> is an optional preconstructed C<enterloop> op to use in the
8606 loop; if it is null then a suitable op will be constructed automatically.
8607 C<expr> supplies the loop's controlling expression. C<block> supplies the
8608 main body of the loop, and C<cont> optionally supplies a C<continue> block
8609 that operates as a second half of the body. All of these optree inputs
8610 are consumed by this function and become part of the constructed op tree.
8612 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8613 op and, shifted up eight bits, the eight bits of C<op_private> for
8614 the C<leaveloop> op, except that (in both cases) some bits will be set
8615 automatically. C<debuggable> is currently unused and should always be 1.
8616 C<has_my> can be supplied as true to force the
8617 loop body to be enclosed in its own scope.
8623 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8624 OP *expr, OP *block, OP *cont, I32 has_my)
8633 PERL_UNUSED_ARG(debuggable);
8636 if (expr->op_type == OP_READLINE
8637 || expr->op_type == OP_READDIR
8638 || expr->op_type == OP_GLOB
8639 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8640 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8641 expr = newUNOP(OP_DEFINED, 0,
8642 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8643 } else if (expr->op_flags & OPf_KIDS) {
8644 const OP * const k1 = ((UNOP*)expr)->op_first;
8645 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8646 switch (expr->op_type) {
8648 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8649 && (k2->op_flags & OPf_STACKED)
8650 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8651 expr = newUNOP(OP_DEFINED, 0, expr);
8655 if (k1 && (k1->op_type == OP_READDIR
8656 || k1->op_type == OP_GLOB
8657 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8658 || k1->op_type == OP_EACH
8659 || k1->op_type == OP_AEACH))
8660 expr = newUNOP(OP_DEFINED, 0, expr);
8667 block = newOP(OP_NULL, 0);
8668 else if (cont || has_my) {
8669 block = op_scope(block);
8673 next = LINKLIST(cont);
8676 OP * const unstack = newOP(OP_UNSTACK, 0);
8679 cont = op_append_elem(OP_LINESEQ, cont, unstack);
8683 listop = op_append_list(OP_LINESEQ, block, cont);
8685 redo = LINKLIST(listop);
8689 o = new_logop(OP_AND, 0, &expr, &listop);
8690 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8692 return expr; /* listop already freed by new_logop */
8695 ((LISTOP*)listop)->op_last->op_next =
8696 (o == listop ? redo : LINKLIST(o));
8702 NewOp(1101,loop,1,LOOP);
8703 OpTYPE_set(loop, OP_ENTERLOOP);
8704 loop->op_private = 0;
8705 loop->op_next = (OP*)loop;
8708 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8710 loop->op_redoop = redo;
8711 loop->op_lastop = o;
8712 o->op_private |= loopflags;
8715 loop->op_nextop = next;
8717 loop->op_nextop = o;
8719 o->op_flags |= flags;
8720 o->op_private |= (flags >> 8);
8725 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8727 Constructs, checks, and returns an op tree expressing a C<foreach>
8728 loop (iteration through a list of values). This is a heavyweight loop,
8729 with structure that allows exiting the loop by C<last> and suchlike.
8731 C<sv> optionally supplies the variable that will be aliased to each
8732 item in turn; if null, it defaults to C<$_>.
8733 C<expr> supplies the list of values to iterate over. C<block> supplies
8734 the main body of the loop, and C<cont> optionally supplies a C<continue>
8735 block that operates as a second half of the body. All of these optree
8736 inputs are consumed by this function and become part of the constructed
8739 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8740 op and, shifted up eight bits, the eight bits of C<op_private> for
8741 the C<leaveloop> op, except that (in both cases) some bits will be set
8748 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8753 PADOFFSET padoff = 0;
8757 PERL_ARGS_ASSERT_NEWFOROP;
8760 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
8761 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8762 OpTYPE_set(sv, OP_RV2GV);
8764 /* The op_type check is needed to prevent a possible segfault
8765 * if the loop variable is undeclared and 'strict vars' is in
8766 * effect. This is illegal but is nonetheless parsed, so we
8767 * may reach this point with an OP_CONST where we're expecting
8770 if (cUNOPx(sv)->op_first->op_type == OP_GV
8771 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8772 iterpflags |= OPpITER_DEF;
8774 else if (sv->op_type == OP_PADSV) { /* private variable */
8775 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8776 padoff = sv->op_targ;
8780 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8782 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8785 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8787 PADNAME * const pn = PAD_COMPNAME(padoff);
8788 const char * const name = PadnamePV(pn);
8790 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8791 iterpflags |= OPpITER_DEF;
8795 sv = newGVOP(OP_GV, 0, PL_defgv);
8796 iterpflags |= OPpITER_DEF;
8799 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8800 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8801 iterflags |= OPf_STACKED;
8803 else if (expr->op_type == OP_NULL &&
8804 (expr->op_flags & OPf_KIDS) &&
8805 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8807 /* Basically turn for($x..$y) into the same as for($x,$y), but we
8808 * set the STACKED flag to indicate that these values are to be
8809 * treated as min/max values by 'pp_enteriter'.
8811 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8812 LOGOP* const range = (LOGOP*) flip->op_first;
8813 OP* const left = range->op_first;
8814 OP* const right = OpSIBLING(left);
8817 range->op_flags &= ~OPf_KIDS;
8818 /* detach range's children */
8819 op_sibling_splice((OP*)range, NULL, -1, NULL);
8821 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8822 listop->op_first->op_next = range->op_next;
8823 left->op_next = range->op_other;
8824 right->op_next = (OP*)listop;
8825 listop->op_next = listop->op_first;
8828 expr = (OP*)(listop);
8830 iterflags |= OPf_STACKED;
8833 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8836 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8837 op_append_elem(OP_LIST, list(expr),
8839 assert(!loop->op_next);
8840 /* for my $x () sets OPpLVAL_INTRO;
8841 * for our $x () sets OPpOUR_INTRO */
8842 loop->op_private = (U8)iterpflags;
8843 if (loop->op_slabbed
8844 && DIFF(loop, OpSLOT(loop)->opslot_next)
8845 < SIZE_TO_PSIZE(sizeof(LOOP)))
8848 NewOp(1234,tmp,1,LOOP);
8849 Copy(loop,tmp,1,LISTOP);
8850 #ifdef PERL_OP_PARENT
8851 assert(loop->op_last->op_sibparent == (OP*)loop);
8852 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8854 S_op_destroy(aTHX_ (OP*)loop);
8857 else if (!loop->op_slabbed)
8859 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8860 #ifdef PERL_OP_PARENT
8861 OpLASTSIB_set(loop->op_last, (OP*)loop);
8864 loop->op_targ = padoff;
8865 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8870 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8872 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8873 or C<last>). C<type> is the opcode. C<label> supplies the parameter
8874 determining the target of the op; it is consumed by this function and
8875 becomes part of the constructed op tree.
8881 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8885 PERL_ARGS_ASSERT_NEWLOOPEX;
8887 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8888 || type == OP_CUSTOM);
8890 if (type != OP_GOTO) {
8891 /* "last()" means "last" */
8892 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8893 o = newOP(type, OPf_SPECIAL);
8897 /* Check whether it's going to be a goto &function */
8898 if (label->op_type == OP_ENTERSUB
8899 && !(label->op_flags & OPf_STACKED))
8900 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8903 /* Check for a constant argument */
8904 if (label->op_type == OP_CONST) {
8905 SV * const sv = ((SVOP *)label)->op_sv;
8907 const char *s = SvPV_const(sv,l);
8908 if (l == strlen(s)) {
8910 SvUTF8(((SVOP*)label)->op_sv),
8912 SvPV_nolen_const(((SVOP*)label)->op_sv)));
8916 /* If we have already created an op, we do not need the label. */
8919 else o = newUNOP(type, OPf_STACKED, label);
8921 PL_hints |= HINT_BLOCK_SCOPE;
8925 /* if the condition is a literal array or hash
8926 (or @{ ... } etc), make a reference to it.
8929 S_ref_array_or_hash(pTHX_ OP *cond)
8932 && (cond->op_type == OP_RV2AV
8933 || cond->op_type == OP_PADAV
8934 || cond->op_type == OP_RV2HV
8935 || cond->op_type == OP_PADHV))
8937 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
8940 && (cond->op_type == OP_ASLICE
8941 || cond->op_type == OP_KVASLICE
8942 || cond->op_type == OP_HSLICE
8943 || cond->op_type == OP_KVHSLICE)) {
8945 /* anonlist now needs a list from this op, was previously used in
8947 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
8948 cond->op_flags |= OPf_WANT_LIST;
8950 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
8957 /* These construct the optree fragments representing given()
8960 entergiven and enterwhen are LOGOPs; the op_other pointer
8961 points up to the associated leave op. We need this so we
8962 can put it in the context and make break/continue work.
8963 (Also, of course, pp_enterwhen will jump straight to
8964 op_other if the match fails.)
8968 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
8969 I32 enter_opcode, I32 leave_opcode,
8970 PADOFFSET entertarg)
8976 PERL_ARGS_ASSERT_NEWGIVWHENOP;
8977 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
8979 enterop = alloc_LOGOP(enter_opcode, block, NULL);
8980 enterop->op_targ = 0;
8981 enterop->op_private = 0;
8983 o = newUNOP(leave_opcode, 0, (OP *) enterop);
8986 /* prepend cond if we have one */
8987 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
8989 o->op_next = LINKLIST(cond);
8990 cond->op_next = (OP *) enterop;
8993 /* This is a default {} block */
8994 enterop->op_flags |= OPf_SPECIAL;
8995 o ->op_flags |= OPf_SPECIAL;
8997 o->op_next = (OP *) enterop;
9000 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9001 entergiven and enterwhen both
9004 enterop->op_next = LINKLIST(block);
9005 block->op_next = enterop->op_other = o;
9010 /* Does this look like a boolean operation? For these purposes
9011 a boolean operation is:
9012 - a subroutine call [*]
9013 - a logical connective
9014 - a comparison operator
9015 - a filetest operator, with the exception of -s -M -A -C
9016 - defined(), exists() or eof()
9017 - /$re/ or $foo =~ /$re/
9019 [*] possibly surprising
9022 S_looks_like_bool(pTHX_ const OP *o)
9024 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9026 switch(o->op_type) {
9029 return looks_like_bool(cLOGOPo->op_first);
9033 OP* sibl = OpSIBLING(cLOGOPo->op_first);
9036 looks_like_bool(cLOGOPo->op_first)
9037 && looks_like_bool(sibl));
9043 o->op_flags & OPf_KIDS
9044 && looks_like_bool(cUNOPo->op_first));
9048 case OP_NOT: case OP_XOR:
9050 case OP_EQ: case OP_NE: case OP_LT:
9051 case OP_GT: case OP_LE: case OP_GE:
9053 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
9054 case OP_I_GT: case OP_I_LE: case OP_I_GE:
9056 case OP_SEQ: case OP_SNE: case OP_SLT:
9057 case OP_SGT: case OP_SLE: case OP_SGE:
9061 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
9062 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
9063 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
9064 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
9065 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
9066 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
9067 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
9068 case OP_FTTEXT: case OP_FTBINARY:
9070 case OP_DEFINED: case OP_EXISTS:
9071 case OP_MATCH: case OP_EOF:
9078 /* Detect comparisons that have been optimized away */
9079 if (cSVOPo->op_sv == &PL_sv_yes
9080 || cSVOPo->op_sv == &PL_sv_no)
9093 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
9095 Constructs, checks, and returns an op tree expressing a C<given> block.
9096 C<cond> supplies the expression to whose value C<$_> will be locally
9097 aliased, and C<block> supplies the body of the C<given> construct; they
9098 are consumed by this function and become part of the constructed op tree.
9099 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9105 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9107 PERL_ARGS_ASSERT_NEWGIVENOP;
9108 PERL_UNUSED_ARG(defsv_off);
9111 return newGIVWHENOP(
9112 ref_array_or_hash(cond),
9114 OP_ENTERGIVEN, OP_LEAVEGIVEN,
9119 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9121 Constructs, checks, and returns an op tree expressing a C<when> block.
9122 C<cond> supplies the test expression, and C<block> supplies the block
9123 that will be executed if the test evaluates to true; they are consumed
9124 by this function and become part of the constructed op tree. C<cond>
9125 will be interpreted DWIMically, often as a comparison against C<$_>,
9126 and may be null to generate a C<default> block.
9132 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9134 const bool cond_llb = (!cond || looks_like_bool(cond));
9137 PERL_ARGS_ASSERT_NEWWHENOP;
9142 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9144 scalar(ref_array_or_hash(cond)));
9147 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9150 /* must not conflict with SVf_UTF8 */
9151 #define CV_CKPROTO_CURSTASH 0x1
9154 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9155 const STRLEN len, const U32 flags)
9157 SV *name = NULL, *msg;
9158 const char * cvp = SvROK(cv)
9159 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9160 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9163 STRLEN clen = CvPROTOLEN(cv), plen = len;
9165 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9167 if (p == NULL && cvp == NULL)
9170 if (!ckWARN_d(WARN_PROTOTYPE))
9174 p = S_strip_spaces(aTHX_ p, &plen);
9175 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9176 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9177 if (plen == clen && memEQ(cvp, p, plen))
9180 if (flags & SVf_UTF8) {
9181 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9185 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9191 msg = sv_newmortal();
9196 gv_efullname3(name = sv_newmortal(), gv, NULL);
9197 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9198 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9199 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9200 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9201 sv_catpvs(name, "::");
9203 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9204 assert (CvNAMED(SvRV_const(gv)));
9205 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9207 else sv_catsv(name, (SV *)gv);
9209 else name = (SV *)gv;
9211 sv_setpvs(msg, "Prototype mismatch:");
9213 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9215 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9216 UTF8fARG(SvUTF8(cv),clen,cvp)
9219 sv_catpvs(msg, ": none");
9220 sv_catpvs(msg, " vs ");
9222 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9224 sv_catpvs(msg, "none");
9225 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9228 static void const_sv_xsub(pTHX_ CV* cv);
9229 static void const_av_xsub(pTHX_ CV* cv);
9233 =head1 Optree Manipulation Functions
9235 =for apidoc cv_const_sv
9237 If C<cv> is a constant sub eligible for inlining, returns the constant
9238 value returned by the sub. Otherwise, returns C<NULL>.
9240 Constant subs can be created with C<newCONSTSUB> or as described in
9241 L<perlsub/"Constant Functions">.
9246 Perl_cv_const_sv(const CV *const cv)
9251 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9253 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9254 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9259 Perl_cv_const_sv_or_av(const CV * const cv)
9263 if (SvROK(cv)) return SvRV((SV *)cv);
9264 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9265 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9268 /* op_const_sv: examine an optree to determine whether it's in-lineable.
9269 * Can be called in 2 ways:
9272 * look for a single OP_CONST with attached value: return the value
9274 * allow_lex && !CvCONST(cv);
9276 * examine the clone prototype, and if contains only a single
9277 * OP_CONST, return the value; or if it contains a single PADSV ref-
9278 * erencing an outer lexical, turn on CvCONST to indicate the CV is
9279 * a candidate for "constizing" at clone time, and return NULL.
9283 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9291 for (; o; o = o->op_next) {
9292 const OPCODE type = o->op_type;
9294 if (type == OP_NEXTSTATE || type == OP_LINESEQ
9296 || type == OP_PUSHMARK)
9298 if (type == OP_DBSTATE)
9300 if (type == OP_LEAVESUB)
9304 if (type == OP_CONST && cSVOPo->op_sv)
9306 else if (type == OP_UNDEF && !o->op_private) {
9310 else if (allow_lex && type == OP_PADSV) {
9311 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9313 sv = &PL_sv_undef; /* an arbitrary non-null value */
9331 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9332 PADNAME * const name, SV ** const const_svp)
9338 if (CvFLAGS(PL_compcv)) {
9339 /* might have had built-in attrs applied */
9340 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9341 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9342 && ckWARN(WARN_MISC))
9344 /* protect against fatal warnings leaking compcv */
9345 SAVEFREESV(PL_compcv);
9346 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9347 SvREFCNT_inc_simple_void_NN(PL_compcv);
9350 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9351 & ~(CVf_LVALUE * pureperl));
9356 /* redundant check for speed: */
9357 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9358 const line_t oldline = CopLINE(PL_curcop);
9361 : sv_2mortal(newSVpvn_utf8(
9362 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9364 if (PL_parser && PL_parser->copline != NOLINE)
9365 /* This ensures that warnings are reported at the first
9366 line of a redefinition, not the last. */
9367 CopLINE_set(PL_curcop, PL_parser->copline);
9368 /* protect against fatal warnings leaking compcv */
9369 SAVEFREESV(PL_compcv);
9370 report_redefined_cv(namesv, cv, const_svp);
9371 SvREFCNT_inc_simple_void_NN(PL_compcv);
9372 CopLINE_set(PL_curcop, oldline);
9379 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9384 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9387 CV *compcv = PL_compcv;
9390 PADOFFSET pax = o->op_targ;
9391 CV *outcv = CvOUTSIDE(PL_compcv);
9394 bool reusable = FALSE;
9396 #ifdef PERL_DEBUG_READONLY_OPS
9397 OPSLAB *slab = NULL;
9400 PERL_ARGS_ASSERT_NEWMYSUB;
9402 PL_hints |= HINT_BLOCK_SCOPE;
9404 /* Find the pad slot for storing the new sub.
9405 We cannot use PL_comppad, as it is the pad owned by the new sub. We
9406 need to look in CvOUTSIDE and find the pad belonging to the enclos-
9407 ing sub. And then we need to dig deeper if this is a lexical from
9409 my sub foo; sub { sub foo { } }
9412 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9413 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9414 pax = PARENT_PAD_INDEX(name);
9415 outcv = CvOUTSIDE(outcv);
9420 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9421 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9422 spot = (CV **)svspot;
9424 if (!(PL_parser && PL_parser->error_count))
9425 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9428 assert(proto->op_type == OP_CONST);
9429 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9430 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9440 if (PL_parser && PL_parser->error_count) {
9442 SvREFCNT_dec(PL_compcv);
9447 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9449 svspot = (SV **)(spot = &clonee);
9451 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9454 assert (SvTYPE(*spot) == SVt_PVCV);
9456 hek = CvNAME_HEK(*spot);
9460 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9461 CvNAME_HEK_set(*spot, hek =
9464 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9468 CvLEXICAL_on(*spot);
9470 cv = PadnamePROTOCV(name);
9471 svspot = (SV **)(spot = &PadnamePROTOCV(name));
9475 /* This makes sub {}; work as expected. */
9476 if (block->op_type == OP_STUB) {
9477 const line_t l = PL_parser->copline;
9479 block = newSTATEOP(0, NULL, 0);
9480 PL_parser->copline = l;
9482 block = CvLVALUE(compcv)
9483 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9484 ? newUNOP(OP_LEAVESUBLV, 0,
9485 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9486 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9487 start = LINKLIST(block);
9489 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9490 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9498 const bool exists = CvROOT(cv) || CvXSUB(cv);
9500 /* if the subroutine doesn't exist and wasn't pre-declared
9501 * with a prototype, assume it will be AUTOLOADed,
9502 * skipping the prototype check
9504 if (exists || SvPOK(cv))
9505 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9507 /* already defined? */
9509 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9515 /* just a "sub foo;" when &foo is already defined */
9520 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9527 SvREFCNT_inc_simple_void_NN(const_sv);
9528 SvFLAGS(const_sv) |= SVs_PADTMP;
9530 assert(!CvROOT(cv) && !CvCONST(cv));
9534 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9535 CvFILE_set_from_cop(cv, PL_curcop);
9536 CvSTASH_set(cv, PL_curstash);
9539 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
9540 CvXSUBANY(cv).any_ptr = const_sv;
9541 CvXSUB(cv) = const_sv_xsub;
9545 CvFLAGS(cv) |= CvMETHOD(compcv);
9547 SvREFCNT_dec(compcv);
9552 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9553 determine whether this sub definition is in the same scope as its
9554 declaration. If this sub definition is inside an inner named pack-
9555 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9556 the package sub. So check PadnameOUTER(name) too.
9558 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9559 assert(!CvWEAKOUTSIDE(compcv));
9560 SvREFCNT_dec(CvOUTSIDE(compcv));
9561 CvWEAKOUTSIDE_on(compcv);
9563 /* XXX else do we have a circular reference? */
9565 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
9566 /* transfer PL_compcv to cv */
9568 cv_flags_t preserved_flags =
9569 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9570 PADLIST *const temp_padl = CvPADLIST(cv);
9571 CV *const temp_cv = CvOUTSIDE(cv);
9572 const cv_flags_t other_flags =
9573 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9574 OP * const cvstart = CvSTART(cv);
9578 CvFLAGS(compcv) | preserved_flags;
9579 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9580 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9581 CvPADLIST_set(cv, CvPADLIST(compcv));
9582 CvOUTSIDE(compcv) = temp_cv;
9583 CvPADLIST_set(compcv, temp_padl);
9584 CvSTART(cv) = CvSTART(compcv);
9585 CvSTART(compcv) = cvstart;
9586 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9587 CvFLAGS(compcv) |= other_flags;
9589 if (CvFILE(cv) && CvDYNFILE(cv)) {
9590 Safefree(CvFILE(cv));
9593 /* inner references to compcv must be fixed up ... */
9594 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9595 if (PERLDB_INTER)/* Advice debugger on the new sub. */
9596 ++PL_sub_generation;
9599 /* Might have had built-in attributes applied -- propagate them. */
9600 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9602 /* ... before we throw it away */
9603 SvREFCNT_dec(compcv);
9604 PL_compcv = compcv = cv;
9613 if (!CvNAME_HEK(cv)) {
9614 if (hek) (void)share_hek_hek(hek);
9618 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9619 hek = share_hek(PadnamePV(name)+1,
9620 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9623 CvNAME_HEK_set(cv, hek);
9629 CvFILE_set_from_cop(cv, PL_curcop);
9630 CvSTASH_set(cv, PL_curstash);
9633 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9635 SvUTF8_on(MUTABLE_SV(cv));
9639 /* If we assign an optree to a PVCV, then we've defined a
9640 * subroutine that the debugger could be able to set a breakpoint
9641 * in, so signal to pp_entereval that it should not throw away any
9642 * saved lines at scope exit. */
9644 PL_breakable_sub_gen++;
9646 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9647 itself has a refcount. */
9649 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9650 #ifdef PERL_DEBUG_READONLY_OPS
9651 slab = (OPSLAB *)CvSTART(cv);
9653 S_process_optree(aTHX_ cv, block, start);
9658 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9659 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9663 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9664 SV * const tmpstr = sv_newmortal();
9665 GV * const db_postponed = gv_fetchpvs("DB::postponed",
9666 GV_ADDMULTI, SVt_PVHV);
9668 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9671 (long)CopLINE(PL_curcop));
9672 if (HvNAME_HEK(PL_curstash)) {
9673 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9674 sv_catpvs(tmpstr, "::");
9677 sv_setpvs(tmpstr, "__ANON__::");
9679 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9680 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9681 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9682 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9683 hv = GvHVn(db_postponed);
9684 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9685 CV * const pcv = GvCV(db_postponed);
9691 call_sv(MUTABLE_SV(pcv), G_DISCARD);
9699 assert(CvDEPTH(outcv));
9701 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9703 cv_clone_into(clonee, *spot);
9704 else *spot = cv_clone(clonee);
9705 SvREFCNT_dec_NN(clonee);
9709 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9710 PADOFFSET depth = CvDEPTH(outcv);
9713 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9715 *svspot = SvREFCNT_inc_simple_NN(cv);
9716 SvREFCNT_dec(oldcv);
9722 PL_parser->copline = NOLINE;
9724 #ifdef PERL_DEBUG_READONLY_OPS
9733 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9735 Construct a Perl subroutine, also performing some surrounding jobs.
9737 This function is expected to be called in a Perl compilation context,
9738 and some aspects of the subroutine are taken from global variables
9739 associated with compilation. In particular, C<PL_compcv> represents
9740 the subroutine that is currently being compiled. It must be non-null
9741 when this function is called, and some aspects of the subroutine being
9742 constructed are taken from it. The constructed subroutine may actually
9743 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9745 If C<block> is null then the subroutine will have no body, and for the
9746 time being it will be an error to call it. This represents a forward
9747 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
9748 non-null then it provides the Perl code of the subroutine body, which
9749 will be executed when the subroutine is called. This body includes
9750 any argument unwrapping code resulting from a subroutine signature or
9751 similar. The pad use of the code must correspond to the pad attached
9752 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
9753 C<leavesublv> op; this function will add such an op. C<block> is consumed
9754 by this function and will become part of the constructed subroutine.
9756 C<proto> specifies the subroutine's prototype, unless one is supplied
9757 as an attribute (see below). If C<proto> is null, then the subroutine
9758 will not have a prototype. If C<proto> is non-null, it must point to a
9759 C<const> op whose value is a string, and the subroutine will have that
9760 string as its prototype. If a prototype is supplied as an attribute, the
9761 attribute takes precedence over C<proto>, but in that case C<proto> should
9762 preferably be null. In any case, C<proto> is consumed by this function.
9764 C<attrs> supplies attributes to be applied the subroutine. A handful of
9765 attributes take effect by built-in means, being applied to C<PL_compcv>
9766 immediately when seen. Other attributes are collected up and attached
9767 to the subroutine by this route. C<attrs> may be null to supply no
9768 attributes, or point to a C<const> op for a single attribute, or point
9769 to a C<list> op whose children apart from the C<pushmark> are C<const>
9770 ops for one or more attributes. Each C<const> op must be a string,
9771 giving the attribute name optionally followed by parenthesised arguments,
9772 in the manner in which attributes appear in Perl source. The attributes
9773 will be applied to the sub by this function. C<attrs> is consumed by
9776 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9777 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
9778 must point to a C<const> op, which will be consumed by this function,
9779 and its string value supplies a name for the subroutine. The name may
9780 be qualified or unqualified, and if it is unqualified then a default
9781 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
9782 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9783 by which the subroutine will be named.
9785 If there is already a subroutine of the specified name, then the new
9786 sub will either replace the existing one in the glob or be merged with
9787 the existing one. A warning may be generated about redefinition.
9789 If the subroutine has one of a few special names, such as C<BEGIN> or
9790 C<END>, then it will be claimed by the appropriate queue for automatic
9791 running of phase-related subroutines. In this case the relevant glob will
9792 be left not containing any subroutine, even if it did contain one before.
9793 In the case of C<BEGIN>, the subroutine will be executed and the reference
9794 to it disposed of before this function returns.
9796 The function returns a pointer to the constructed subroutine. If the sub
9797 is anonymous then ownership of one counted reference to the subroutine
9798 is transferred to the caller. If the sub is named then the caller does
9799 not get ownership of a reference. In most such cases, where the sub
9800 has a non-phase name, the sub will be alive at the point it is returned
9801 by virtue of being contained in the glob that names it. A phase-named
9802 subroutine will usually be alive by virtue of the reference owned by the
9803 phase's automatic run queue. But a C<BEGIN> subroutine, having already
9804 been executed, will quite likely have been destroyed already by the
9805 time this function returns, making it erroneous for the caller to make
9806 any use of the returned pointer. It is the caller's responsibility to
9807 ensure that it knows which of these situations applies.
9814 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9815 OP *block, bool o_is_gv)
9819 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9821 CV *cv = NULL; /* the previous CV with this name, if any */
9823 const bool ec = PL_parser && PL_parser->error_count;
9824 /* If the subroutine has no body, no attributes, and no builtin attributes
9825 then it's just a sub declaration, and we may be able to get away with
9826 storing with a placeholder scalar in the symbol table, rather than a
9827 full CV. If anything is present then it will take a full CV to
9829 const I32 gv_fetch_flags
9830 = ec ? GV_NOADD_NOINIT :
9831 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9832 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9834 const char * const name =
9835 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9837 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9838 bool evanescent = FALSE;
9840 #ifdef PERL_DEBUG_READONLY_OPS
9841 OPSLAB *slab = NULL;
9849 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
9850 hek and CvSTASH pointer together can imply the GV. If the name
9851 contains a package name, then GvSTASH(CvGV(cv)) may differ from
9852 CvSTASH, so forego the optimisation if we find any.
9853 Also, we may be called from load_module at run time, so
9854 PL_curstash (which sets CvSTASH) may not point to the stash the
9855 sub is stored in. */
9856 /* XXX This optimization is currently disabled for packages other
9857 than main, since there was too much CPAN breakage. */
9859 ec ? GV_NOADD_NOINIT
9860 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9861 || PL_curstash != PL_defstash
9862 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9864 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9865 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9867 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9868 SV * const sv = sv_newmortal();
9869 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9870 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9871 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9872 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9874 } else if (PL_curstash) {
9875 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9878 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9884 move_proto_attr(&proto, &attrs, gv, 0);
9887 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9892 assert(proto->op_type == OP_CONST);
9893 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9894 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9910 SvREFCNT_dec(PL_compcv);
9915 if (name && block) {
9916 const char *s = (char *) my_memrchr(name, ':', namlen);
9918 if (strEQ(s, "BEGIN")) {
9919 if (PL_in_eval & EVAL_KEEPERR)
9920 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
9922 SV * const errsv = ERRSV;
9923 /* force display of errors found but not reported */
9924 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
9925 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
9932 if (!block && SvTYPE(gv) != SVt_PVGV) {
9933 /* If we are not defining a new sub and the existing one is not a
9935 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
9936 /* We are applying attributes to an existing sub, so we need it
9937 upgraded if it is a constant. */
9938 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
9939 gv_init_pvn(gv, PL_curstash, name, namlen,
9940 SVf_UTF8 * name_is_utf8);
9942 else { /* Maybe prototype now, and had at maximum
9943 a prototype or const/sub ref before. */
9944 if (SvTYPE(gv) > SVt_NULL) {
9945 cv_ckproto_len_flags((const CV *)gv,
9946 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
9952 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
9954 SvUTF8_on(MUTABLE_SV(gv));
9957 sv_setiv(MUTABLE_SV(gv), -1);
9960 SvREFCNT_dec(PL_compcv);
9961 cv = PL_compcv = NULL;
9966 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
9970 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
9976 /* This makes sub {}; work as expected. */
9977 if (block->op_type == OP_STUB) {
9978 const line_t l = PL_parser->copline;
9980 block = newSTATEOP(0, NULL, 0);
9981 PL_parser->copline = l;
9983 block = CvLVALUE(PL_compcv)
9984 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
9985 && (!isGV(gv) || !GvASSUMECV(gv)))
9986 ? newUNOP(OP_LEAVESUBLV, 0,
9987 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9988 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9989 start = LINKLIST(block);
9991 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
9993 S_op_const_sv(aTHX_ start, PL_compcv,
9994 cBOOL(CvCLONE(PL_compcv)));
10001 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10002 cv_ckproto_len_flags((const CV *)gv,
10003 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10004 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10006 /* All the other code for sub redefinition warnings expects the
10007 clobbered sub to be a CV. Instead of making all those code
10008 paths more complex, just inline the RV version here. */
10009 const line_t oldline = CopLINE(PL_curcop);
10010 assert(IN_PERL_COMPILETIME);
10011 if (PL_parser && PL_parser->copline != NOLINE)
10012 /* This ensures that warnings are reported at the first
10013 line of a redefinition, not the last. */
10014 CopLINE_set(PL_curcop, PL_parser->copline);
10015 /* protect against fatal warnings leaking compcv */
10016 SAVEFREESV(PL_compcv);
10018 if (ckWARN(WARN_REDEFINE)
10019 || ( ckWARN_d(WARN_REDEFINE)
10020 && ( !const_sv || SvRV(gv) == const_sv
10021 || sv_cmp(SvRV(gv), const_sv) ))) {
10023 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10024 "Constant subroutine %" SVf " redefined",
10025 SVfARG(cSVOPo->op_sv));
10028 SvREFCNT_inc_simple_void_NN(PL_compcv);
10029 CopLINE_set(PL_curcop, oldline);
10030 SvREFCNT_dec(SvRV(gv));
10035 const bool exists = CvROOT(cv) || CvXSUB(cv);
10037 /* if the subroutine doesn't exist and wasn't pre-declared
10038 * with a prototype, assume it will be AUTOLOADed,
10039 * skipping the prototype check
10041 if (exists || SvPOK(cv))
10042 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10043 /* already defined (or promised)? */
10044 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10045 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10051 /* just a "sub foo;" when &foo is already defined */
10052 SAVEFREESV(PL_compcv);
10059 SvREFCNT_inc_simple_void_NN(const_sv);
10060 SvFLAGS(const_sv) |= SVs_PADTMP;
10062 assert(!CvROOT(cv) && !CvCONST(cv));
10063 cv_forget_slab(cv);
10064 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10065 CvXSUBANY(cv).any_ptr = const_sv;
10066 CvXSUB(cv) = const_sv_xsub;
10070 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10073 if (isGV(gv) || CvMETHOD(PL_compcv)) {
10074 if (name && isGV(gv))
10075 GvCV_set(gv, NULL);
10076 cv = newCONSTSUB_flags(
10077 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10081 assert(SvREFCNT((SV*)cv) != 0);
10082 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10086 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10087 prepare_SV_for_RV((SV *)gv);
10088 SvOK_off((SV *)gv);
10091 SvRV_set(gv, const_sv);
10095 SvREFCNT_dec(PL_compcv);
10100 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10101 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10104 if (cv) { /* must reuse cv if autoloaded */
10105 /* transfer PL_compcv to cv */
10107 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10108 PADLIST *const temp_av = CvPADLIST(cv);
10109 CV *const temp_cv = CvOUTSIDE(cv);
10110 const cv_flags_t other_flags =
10111 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10112 OP * const cvstart = CvSTART(cv);
10116 assert(!CvCVGV_RC(cv));
10117 assert(CvGV(cv) == gv);
10122 PERL_HASH(hash, name, namlen);
10132 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10134 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10135 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10136 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10137 CvOUTSIDE(PL_compcv) = temp_cv;
10138 CvPADLIST_set(PL_compcv, temp_av);
10139 CvSTART(cv) = CvSTART(PL_compcv);
10140 CvSTART(PL_compcv) = cvstart;
10141 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10142 CvFLAGS(PL_compcv) |= other_flags;
10144 if (CvFILE(cv) && CvDYNFILE(cv)) {
10145 Safefree(CvFILE(cv));
10147 CvFILE_set_from_cop(cv, PL_curcop);
10148 CvSTASH_set(cv, PL_curstash);
10150 /* inner references to PL_compcv must be fixed up ... */
10151 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10152 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10153 ++PL_sub_generation;
10156 /* Might have had built-in attributes applied -- propagate them. */
10157 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10159 /* ... before we throw it away */
10160 SvREFCNT_dec(PL_compcv);
10165 if (name && isGV(gv)) {
10168 if (HvENAME_HEK(GvSTASH(gv)))
10169 /* sub Foo::bar { (shift)+1 } */
10170 gv_method_changed(gv);
10174 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10175 prepare_SV_for_RV((SV *)gv);
10176 SvOK_off((SV *)gv);
10179 SvRV_set(gv, (SV *)cv);
10180 if (HvENAME_HEK(PL_curstash))
10181 mro_method_changed_in(PL_curstash);
10185 assert(SvREFCNT((SV*)cv) != 0);
10187 if (!CvHASGV(cv)) {
10193 PERL_HASH(hash, name, namlen);
10194 CvNAME_HEK_set(cv, share_hek(name,
10200 CvFILE_set_from_cop(cv, PL_curcop);
10201 CvSTASH_set(cv, PL_curstash);
10205 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10207 SvUTF8_on(MUTABLE_SV(cv));
10211 /* If we assign an optree to a PVCV, then we've defined a
10212 * subroutine that the debugger could be able to set a breakpoint
10213 * in, so signal to pp_entereval that it should not throw away any
10214 * saved lines at scope exit. */
10216 PL_breakable_sub_gen++;
10217 CvROOT(cv) = block;
10218 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10219 itself has a refcount. */
10221 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10222 #ifdef PERL_DEBUG_READONLY_OPS
10223 slab = (OPSLAB *)CvSTART(cv);
10225 S_process_optree(aTHX_ cv, block, start);
10230 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10231 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10232 ? GvSTASH(CvGV(cv))
10236 apply_attrs(stash, MUTABLE_SV(cv), attrs);
10238 SvREFCNT_inc_simple_void_NN(cv);
10241 if (block && has_name) {
10242 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10243 SV * const tmpstr = cv_name(cv,NULL,0);
10244 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10245 GV_ADDMULTI, SVt_PVHV);
10247 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10248 CopFILE(PL_curcop),
10250 (long)CopLINE(PL_curcop));
10251 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10252 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10253 hv = GvHVn(db_postponed);
10254 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10255 CV * const pcv = GvCV(db_postponed);
10261 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10267 if (PL_parser && PL_parser->error_count)
10268 clear_special_blocks(name, gv, cv);
10271 process_special_blocks(floor, name, gv, cv);
10277 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10279 PL_parser->copline = NOLINE;
10280 LEAVE_SCOPE(floor);
10282 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10284 #ifdef PERL_DEBUG_READONLY_OPS
10288 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10289 pad_add_weakref(cv);
10295 S_clear_special_blocks(pTHX_ const char *const fullname,
10296 GV *const gv, CV *const cv) {
10300 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10302 colon = strrchr(fullname,':');
10303 name = colon ? colon + 1 : fullname;
10305 if ((*name == 'B' && strEQ(name, "BEGIN"))
10306 || (*name == 'E' && strEQ(name, "END"))
10307 || (*name == 'U' && strEQ(name, "UNITCHECK"))
10308 || (*name == 'C' && strEQ(name, "CHECK"))
10309 || (*name == 'I' && strEQ(name, "INIT"))) {
10314 GvCV_set(gv, NULL);
10315 SvREFCNT_dec_NN(MUTABLE_SV(cv));
10319 /* Returns true if the sub has been freed. */
10321 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10325 const char *const colon = strrchr(fullname,':');
10326 const char *const name = colon ? colon + 1 : fullname;
10328 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10330 if (*name == 'B') {
10331 if (strEQ(name, "BEGIN")) {
10332 const I32 oldscope = PL_scopestack_ix;
10335 if (floor) LEAVE_SCOPE(floor);
10337 PUSHSTACKi(PERLSI_REQUIRE);
10338 SAVECOPFILE(&PL_compiling);
10339 SAVECOPLINE(&PL_compiling);
10340 SAVEVPTR(PL_curcop);
10342 DEBUG_x( dump_sub(gv) );
10343 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10344 GvCV_set(gv,0); /* cv has been hijacked */
10345 call_list(oldscope, PL_beginav);
10349 return !PL_savebegin;
10354 if (*name == 'E') {
10355 if strEQ(name, "END") {
10356 DEBUG_x( dump_sub(gv) );
10357 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10360 } else if (*name == 'U') {
10361 if (strEQ(name, "UNITCHECK")) {
10362 /* It's never too late to run a unitcheck block */
10363 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10367 } else if (*name == 'C') {
10368 if (strEQ(name, "CHECK")) {
10370 /* diag_listed_as: Too late to run %s block */
10371 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10372 "Too late to run CHECK block");
10373 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10377 } else if (*name == 'I') {
10378 if (strEQ(name, "INIT")) {
10380 /* diag_listed_as: Too late to run %s block */
10381 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10382 "Too late to run INIT block");
10383 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10389 DEBUG_x( dump_sub(gv) );
10391 GvCV_set(gv,0); /* cv has been hijacked */
10397 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10399 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10400 rather than of counted length, and no flags are set. (This means that
10401 C<name> is always interpreted as Latin-1.)
10407 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10409 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10413 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10415 Construct a constant subroutine, also performing some surrounding
10416 jobs. A scalar constant-valued subroutine is eligible for inlining
10417 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10418 123 }>>. Other kinds of constant subroutine have other treatment.
10420 The subroutine will have an empty prototype and will ignore any arguments
10421 when called. Its constant behaviour is determined by C<sv>. If C<sv>
10422 is null, the subroutine will yield an empty list. If C<sv> points to a
10423 scalar, the subroutine will always yield that scalar. If C<sv> points
10424 to an array, the subroutine will always yield a list of the elements of
10425 that array in list context, or the number of elements in the array in
10426 scalar context. This function takes ownership of one counted reference
10427 to the scalar or array, and will arrange for the object to live as long
10428 as the subroutine does. If C<sv> points to a scalar then the inlining
10429 assumes that the value of the scalar will never change, so the caller
10430 must ensure that the scalar is not subsequently written to. If C<sv>
10431 points to an array then no such assumption is made, so it is ostensibly
10432 safe to mutate the array or its elements, but whether this is really
10433 supported has not been determined.
10435 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10436 Other aspects of the subroutine will be left in their default state.
10437 The caller is free to mutate the subroutine beyond its initial state
10438 after this function has returned.
10440 If C<name> is null then the subroutine will be anonymous, with its
10441 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10442 subroutine will be named accordingly, referenced by the appropriate glob.
10443 C<name> is a string of length C<len> bytes giving a sigilless symbol
10444 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10445 otherwise. The name may be either qualified or unqualified. If the
10446 name is unqualified then it defaults to being in the stash specified by
10447 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10448 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10451 C<flags> should not have bits set other than C<SVf_UTF8>.
10453 If there is already a subroutine of the specified name, then the new sub
10454 will replace the existing one in the glob. A warning may be generated
10455 about the redefinition.
10457 If the subroutine has one of a few special names, such as C<BEGIN> or
10458 C<END>, then it will be claimed by the appropriate queue for automatic
10459 running of phase-related subroutines. In this case the relevant glob will
10460 be left not containing any subroutine, even if it did contain one before.
10461 Execution of the subroutine will likely be a no-op, unless C<sv> was
10462 a tied array or the caller modified the subroutine in some interesting
10463 way before it was executed. In the case of C<BEGIN>, the treatment is
10464 buggy: the sub will be executed when only half built, and may be deleted
10465 prematurely, possibly causing a crash.
10467 The function returns a pointer to the constructed subroutine. If the sub
10468 is anonymous then ownership of one counted reference to the subroutine
10469 is transferred to the caller. If the sub is named then the caller does
10470 not get ownership of a reference. In most such cases, where the sub
10471 has a non-phase name, the sub will be alive at the point it is returned
10472 by virtue of being contained in the glob that names it. A phase-named
10473 subroutine will usually be alive by virtue of the reference owned by
10474 the phase's automatic run queue. A C<BEGIN> subroutine may have been
10475 destroyed already by the time this function returns, but currently bugs
10476 occur in that case before the caller gets control. It is the caller's
10477 responsibility to ensure that it knows which of these situations applies.
10483 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10487 const char *const file = CopFILE(PL_curcop);
10491 if (IN_PERL_RUNTIME) {
10492 /* at runtime, it's not safe to manipulate PL_curcop: it may be
10493 * an op shared between threads. Use a non-shared COP for our
10495 SAVEVPTR(PL_curcop);
10496 SAVECOMPILEWARNINGS();
10497 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10498 PL_curcop = &PL_compiling;
10500 SAVECOPLINE(PL_curcop);
10501 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10504 PL_hints &= ~HINT_BLOCK_SCOPE;
10507 SAVEGENERICSV(PL_curstash);
10508 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10511 /* Protect sv against leakage caused by fatal warnings. */
10512 if (sv) SAVEFREESV(sv);
10514 /* file becomes the CvFILE. For an XS, it's usually static storage,
10515 and so doesn't get free()d. (It's expected to be from the C pre-
10516 processor __FILE__ directive). But we need a dynamically allocated one,
10517 and we need it to get freed. */
10518 cv = newXS_len_flags(name, len,
10519 sv && SvTYPE(sv) == SVt_PVAV
10522 file ? file : "", "",
10523 &sv, XS_DYNAMIC_FILENAME | flags);
10525 assert(SvREFCNT((SV*)cv) != 0);
10526 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10535 =for apidoc U||newXS
10537 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
10538 static storage, as it is used directly as CvFILE(), without a copy being made.
10544 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10546 PERL_ARGS_ASSERT_NEWXS;
10547 return newXS_len_flags(
10548 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10553 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10554 const char *const filename, const char *const proto,
10557 PERL_ARGS_ASSERT_NEWXS_FLAGS;
10558 return newXS_len_flags(
10559 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10564 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10566 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10567 return newXS_len_flags(
10568 name, strlen(name), subaddr, NULL, NULL, NULL, 0
10573 =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
10575 Construct an XS subroutine, also performing some surrounding jobs.
10577 The subroutine will have the entry point C<subaddr>. It will have
10578 the prototype specified by the nul-terminated string C<proto>, or
10579 no prototype if C<proto> is null. The prototype string is copied;
10580 the caller can mutate the supplied string afterwards. If C<filename>
10581 is non-null, it must be a nul-terminated filename, and the subroutine
10582 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
10583 point directly to the supplied string, which must be static. If C<flags>
10584 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10587 Other aspects of the subroutine will be left in their default state.
10588 If anything else needs to be done to the subroutine for it to function
10589 correctly, it is the caller's responsibility to do that after this
10590 function has constructed it. However, beware of the subroutine
10591 potentially being destroyed before this function returns, as described
10594 If C<name> is null then the subroutine will be anonymous, with its
10595 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10596 subroutine will be named accordingly, referenced by the appropriate glob.
10597 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10598 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10599 The name may be either qualified or unqualified, with the stash defaulting
10600 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
10601 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10602 they have there, such as C<GV_ADDWARN>. The symbol is always added to
10603 the stash if necessary, with C<GV_ADDMULTI> semantics.
10605 If there is already a subroutine of the specified name, then the new sub
10606 will replace the existing one in the glob. A warning may be generated
10607 about the redefinition. If the old subroutine was C<CvCONST> then the
10608 decision about whether to warn is influenced by an expectation about
10609 whether the new subroutine will become a constant of similar value.
10610 That expectation is determined by C<const_svp>. (Note that the call to
10611 this function doesn't make the new subroutine C<CvCONST> in any case;
10612 that is left to the caller.) If C<const_svp> is null then it indicates
10613 that the new subroutine will not become a constant. If C<const_svp>
10614 is non-null then it indicates that the new subroutine will become a
10615 constant, and it points to an C<SV*> that provides the constant value
10616 that the subroutine will have.
10618 If the subroutine has one of a few special names, such as C<BEGIN> or
10619 C<END>, then it will be claimed by the appropriate queue for automatic
10620 running of phase-related subroutines. In this case the relevant glob will
10621 be left not containing any subroutine, even if it did contain one before.
10622 In the case of C<BEGIN>, the subroutine will be executed and the reference
10623 to it disposed of before this function returns, and also before its
10624 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
10625 constructed by this function to be ready for execution then the caller
10626 must prevent this happening by giving the subroutine a different name.
10628 The function returns a pointer to the constructed subroutine. If the sub
10629 is anonymous then ownership of one counted reference to the subroutine
10630 is transferred to the caller. If the sub is named then the caller does
10631 not get ownership of a reference. In most such cases, where the sub
10632 has a non-phase name, the sub will be alive at the point it is returned
10633 by virtue of being contained in the glob that names it. A phase-named
10634 subroutine will usually be alive by virtue of the reference owned by the
10635 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10636 been executed, will quite likely have been destroyed already by the
10637 time this function returns, making it erroneous for the caller to make
10638 any use of the returned pointer. It is the caller's responsibility to
10639 ensure that it knows which of these situations applies.
10645 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10646 XSUBADDR_t subaddr, const char *const filename,
10647 const char *const proto, SV **const_svp,
10651 bool interleave = FALSE;
10652 bool evanescent = FALSE;
10654 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10657 GV * const gv = gv_fetchpvn(
10658 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10659 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10660 sizeof("__ANON__::__ANON__") - 1,
10661 GV_ADDMULTI | flags, SVt_PVCV);
10663 if ((cv = (name ? GvCV(gv) : NULL))) {
10665 /* just a cached method */
10669 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10670 /* already defined (or promised) */
10671 /* Redundant check that allows us to avoid creating an SV
10672 most of the time: */
10673 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10674 report_redefined_cv(newSVpvn_flags(
10675 name,len,(flags&SVf_UTF8)|SVs_TEMP
10686 if (cv) /* must reuse cv if autoloaded */
10689 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10693 if (HvENAME_HEK(GvSTASH(gv)))
10694 gv_method_changed(gv); /* newXS */
10698 assert(SvREFCNT((SV*)cv) != 0);
10702 /* XSUBs can't be perl lang/perl5db.pl debugged
10703 if (PERLDB_LINE_OR_SAVESRC)
10704 (void)gv_fetchfile(filename); */
10705 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10706 if (flags & XS_DYNAMIC_FILENAME) {
10708 CvFILE(cv) = savepv(filename);
10710 /* NOTE: not copied, as it is expected to be an external constant string */
10711 CvFILE(cv) = (char *)filename;
10714 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10715 CvFILE(cv) = (char*)PL_xsubfilename;
10718 CvXSUB(cv) = subaddr;
10719 #ifndef PERL_IMPLICIT_CONTEXT
10720 CvHSCXT(cv) = &PL_stack_sp;
10726 evanescent = process_special_blocks(0, name, gv, cv);
10729 } /* <- not a conditional branch */
10732 assert(evanescent || SvREFCNT((SV*)cv) != 0);
10734 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10735 if (interleave) LEAVE;
10736 assert(evanescent || SvREFCNT((SV*)cv) != 0);
10741 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10743 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10745 PERL_ARGS_ASSERT_NEWSTUB;
10746 assert(!GvCVu(gv));
10749 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10750 gv_method_changed(gv);
10752 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10756 CvGV_set(cv, cvgv);
10757 CvFILE_set_from_cop(cv, PL_curcop);
10758 CvSTASH_set(cv, PL_curstash);
10764 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10771 if (PL_parser && PL_parser->error_count) {
10777 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10778 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10781 if ((cv = GvFORM(gv))) {
10782 if (ckWARN(WARN_REDEFINE)) {
10783 const line_t oldline = CopLINE(PL_curcop);
10784 if (PL_parser && PL_parser->copline != NOLINE)
10785 CopLINE_set(PL_curcop, PL_parser->copline);
10787 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10788 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10790 /* diag_listed_as: Format %s redefined */
10791 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10792 "Format STDOUT redefined");
10794 CopLINE_set(PL_curcop, oldline);
10799 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10801 CvFILE_set_from_cop(cv, PL_curcop);
10804 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10806 start = LINKLIST(root);
10808 S_process_optree(aTHX_ cv, root, start);
10809 cv_forget_slab(cv);
10814 PL_parser->copline = NOLINE;
10815 LEAVE_SCOPE(floor);
10816 PL_compiling.cop_seq = 0;
10820 Perl_newANONLIST(pTHX_ OP *o)
10822 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10826 Perl_newANONHASH(pTHX_ OP *o)
10828 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10832 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10834 return newANONATTRSUB(floor, proto, NULL, block);
10838 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10840 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10842 newSVOP(OP_ANONCODE, 0,
10844 if (CvANONCONST(cv))
10845 anoncode = newUNOP(OP_ANONCONST, 0,
10846 op_convert_list(OP_ENTERSUB,
10847 OPf_STACKED|OPf_WANT_SCALAR,
10849 return newUNOP(OP_REFGEN, 0, anoncode);
10853 Perl_oopsAV(pTHX_ OP *o)
10857 PERL_ARGS_ASSERT_OOPSAV;
10859 switch (o->op_type) {
10862 OpTYPE_set(o, OP_PADAV);
10863 return ref(o, OP_RV2AV);
10867 OpTYPE_set(o, OP_RV2AV);
10872 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10879 Perl_oopsHV(pTHX_ OP *o)
10883 PERL_ARGS_ASSERT_OOPSHV;
10885 switch (o->op_type) {
10888 OpTYPE_set(o, OP_PADHV);
10889 return ref(o, OP_RV2HV);
10893 OpTYPE_set(o, OP_RV2HV);
10894 /* rv2hv steals the bottom bit for its own uses */
10895 o->op_private &= ~OPpARG1_MASK;
10900 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
10907 Perl_newAVREF(pTHX_ OP *o)
10911 PERL_ARGS_ASSERT_NEWAVREF;
10913 if (o->op_type == OP_PADANY) {
10914 OpTYPE_set(o, OP_PADAV);
10917 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
10918 Perl_croak(aTHX_ "Can't use an array as a reference");
10920 return newUNOP(OP_RV2AV, 0, scalar(o));
10924 Perl_newGVREF(pTHX_ I32 type, OP *o)
10926 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
10927 return newUNOP(OP_NULL, 0, o);
10928 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
10932 Perl_newHVREF(pTHX_ OP *o)
10936 PERL_ARGS_ASSERT_NEWHVREF;
10938 if (o->op_type == OP_PADANY) {
10939 OpTYPE_set(o, OP_PADHV);
10942 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
10943 Perl_croak(aTHX_ "Can't use a hash as a reference");
10945 return newUNOP(OP_RV2HV, 0, scalar(o));
10949 Perl_newCVREF(pTHX_ I32 flags, OP *o)
10951 if (o->op_type == OP_PADANY) {
10953 OpTYPE_set(o, OP_PADCV);
10955 return newUNOP(OP_RV2CV, flags, scalar(o));
10959 Perl_newSVREF(pTHX_ OP *o)
10963 PERL_ARGS_ASSERT_NEWSVREF;
10965 if (o->op_type == OP_PADANY) {
10966 OpTYPE_set(o, OP_PADSV);
10970 return newUNOP(OP_RV2SV, 0, scalar(o));
10973 /* Check routines. See the comments at the top of this file for details
10974 * on when these are called */
10977 Perl_ck_anoncode(pTHX_ OP *o)
10979 PERL_ARGS_ASSERT_CK_ANONCODE;
10981 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
10982 cSVOPo->op_sv = NULL;
10987 S_io_hints(pTHX_ OP *o)
10989 #if O_BINARY != 0 || O_TEXT != 0
10991 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
10993 SV **svp = hv_fetchs(table, "open_IN", FALSE);
10996 const char *d = SvPV_const(*svp, len);
10997 const I32 mode = mode_from_discipline(d, len);
10998 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11000 if (mode & O_BINARY)
11001 o->op_private |= OPpOPEN_IN_RAW;
11005 o->op_private |= OPpOPEN_IN_CRLF;
11009 svp = hv_fetchs(table, "open_OUT", FALSE);
11012 const char *d = SvPV_const(*svp, len);
11013 const I32 mode = mode_from_discipline(d, len);
11014 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11016 if (mode & O_BINARY)
11017 o->op_private |= OPpOPEN_OUT_RAW;
11021 o->op_private |= OPpOPEN_OUT_CRLF;
11026 PERL_UNUSED_CONTEXT;
11027 PERL_UNUSED_ARG(o);
11032 Perl_ck_backtick(pTHX_ OP *o)
11037 PERL_ARGS_ASSERT_CK_BACKTICK;
11039 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11040 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11041 && (gv = gv_override("readpipe",8)))
11043 /* detach rest of siblings from o and its first child */
11044 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11045 newop = S_new_entersubop(aTHX_ gv, sibl);
11047 else if (!(o->op_flags & OPf_KIDS))
11048 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11053 S_io_hints(aTHX_ o);
11058 Perl_ck_bitop(pTHX_ OP *o)
11060 PERL_ARGS_ASSERT_CK_BITOP;
11062 o->op_private = (U8)(PL_hints & HINT_INTEGER);
11064 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11065 && OP_IS_INFIX_BIT(o->op_type))
11067 const OP * const left = cBINOPo->op_first;
11068 const OP * const right = OpSIBLING(left);
11069 if ((OP_IS_NUMCOMPARE(left->op_type) &&
11070 (left->op_flags & OPf_PARENS) == 0) ||
11071 (OP_IS_NUMCOMPARE(right->op_type) &&
11072 (right->op_flags & OPf_PARENS) == 0))
11073 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11074 "Possible precedence problem on bitwise %s operator",
11075 o->op_type == OP_BIT_OR
11076 ||o->op_type == OP_NBIT_OR ? "|"
11077 : o->op_type == OP_BIT_AND
11078 ||o->op_type == OP_NBIT_AND ? "&"
11079 : o->op_type == OP_BIT_XOR
11080 ||o->op_type == OP_NBIT_XOR ? "^"
11081 : o->op_type == OP_SBIT_OR ? "|."
11082 : o->op_type == OP_SBIT_AND ? "&." : "^."
11088 PERL_STATIC_INLINE bool
11089 is_dollar_bracket(pTHX_ const OP * const o)
11092 PERL_UNUSED_CONTEXT;
11093 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11094 && (kid = cUNOPx(o)->op_first)
11095 && kid->op_type == OP_GV
11096 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11099 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11102 Perl_ck_cmp(pTHX_ OP *o)
11108 OP *indexop, *constop, *start;
11112 PERL_ARGS_ASSERT_CK_CMP;
11114 is_eq = ( o->op_type == OP_EQ
11115 || o->op_type == OP_NE
11116 || o->op_type == OP_I_EQ
11117 || o->op_type == OP_I_NE);
11119 if (!is_eq && ckWARN(WARN_SYNTAX)) {
11120 const OP *kid = cUNOPo->op_first;
11123 ( is_dollar_bracket(aTHX_ kid)
11124 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11126 || ( kid->op_type == OP_CONST
11127 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11131 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11132 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11135 /* convert (index(...) == -1) and variations into
11136 * (r)index/BOOL(,NEG)
11141 indexop = cUNOPo->op_first;
11142 constop = OpSIBLING(indexop);
11144 if (indexop->op_type == OP_CONST) {
11146 indexop = OpSIBLING(constop);
11151 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11154 /* ($lex = index(....)) == -1 */
11155 if (indexop->op_private & OPpTARGET_MY)
11158 if (constop->op_type != OP_CONST)
11161 sv = cSVOPx_sv(constop);
11162 if (!(sv && SvIOK_notUV(sv)))
11166 if (iv != -1 && iv != 0)
11170 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11171 if (!(iv0 ^ reverse))
11175 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11180 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11181 if (!(iv0 ^ reverse))
11185 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11190 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11196 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11202 indexop->op_flags &= ~OPf_PARENS;
11203 indexop->op_flags |= (o->op_flags & OPf_PARENS);
11204 indexop->op_private |= OPpTRUEBOOL;
11206 indexop->op_private |= OPpINDEX_BOOLNEG;
11207 /* cut out the index op and free the eq,const ops */
11208 (void)op_sibling_splice(o, start, 1, NULL);
11216 Perl_ck_concat(pTHX_ OP *o)
11218 const OP * const kid = cUNOPo->op_first;
11220 PERL_ARGS_ASSERT_CK_CONCAT;
11221 PERL_UNUSED_CONTEXT;
11223 /* reuse the padtmp returned by the concat child */
11224 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11225 !(kUNOP->op_first->op_flags & OPf_MOD))
11227 o->op_flags |= OPf_STACKED;
11228 o->op_private |= OPpCONCAT_NESTED;
11234 Perl_ck_spair(pTHX_ OP *o)
11238 PERL_ARGS_ASSERT_CK_SPAIR;
11240 if (o->op_flags & OPf_KIDS) {
11244 const OPCODE type = o->op_type;
11245 o = modkids(ck_fun(o), type);
11246 kid = cUNOPo->op_first;
11247 kidkid = kUNOP->op_first;
11248 newop = OpSIBLING(kidkid);
11250 const OPCODE type = newop->op_type;
11251 if (OpHAS_SIBLING(newop))
11253 if (o->op_type == OP_REFGEN
11254 && ( type == OP_RV2CV
11255 || ( !(newop->op_flags & OPf_PARENS)
11256 && ( type == OP_RV2AV || type == OP_PADAV
11257 || type == OP_RV2HV || type == OP_PADHV))))
11258 NOOP; /* OK (allow srefgen for \@a and \%h) */
11259 else if (OP_GIMME(newop,0) != G_SCALAR)
11262 /* excise first sibling */
11263 op_sibling_splice(kid, NULL, 1, NULL);
11266 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11267 * and OP_CHOMP into OP_SCHOMP */
11268 o->op_ppaddr = PL_ppaddr[++o->op_type];
11273 Perl_ck_delete(pTHX_ OP *o)
11275 PERL_ARGS_ASSERT_CK_DELETE;
11279 if (o->op_flags & OPf_KIDS) {
11280 OP * const kid = cUNOPo->op_first;
11281 switch (kid->op_type) {
11283 o->op_flags |= OPf_SPECIAL;
11286 o->op_private |= OPpSLICE;
11289 o->op_flags |= OPf_SPECIAL;
11294 o->op_flags |= OPf_SPECIAL;
11297 o->op_private |= OPpKVSLICE;
11300 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11301 "element or slice");
11303 if (kid->op_private & OPpLVAL_INTRO)
11304 o->op_private |= OPpLVAL_INTRO;
11311 Perl_ck_eof(pTHX_ OP *o)
11313 PERL_ARGS_ASSERT_CK_EOF;
11315 if (o->op_flags & OPf_KIDS) {
11317 if (cLISTOPo->op_first->op_type == OP_STUB) {
11319 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11324 kid = cLISTOPo->op_first;
11325 if (kid->op_type == OP_RV2GV)
11326 kid->op_private |= OPpALLOW_FAKE;
11333 Perl_ck_eval(pTHX_ OP *o)
11337 PERL_ARGS_ASSERT_CK_EVAL;
11339 PL_hints |= HINT_BLOCK_SCOPE;
11340 if (o->op_flags & OPf_KIDS) {
11341 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11344 if (o->op_type == OP_ENTERTRY) {
11347 /* cut whole sibling chain free from o */
11348 op_sibling_splice(o, NULL, -1, NULL);
11351 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11353 /* establish postfix order */
11354 enter->op_next = (OP*)enter;
11356 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11357 OpTYPE_set(o, OP_LEAVETRY);
11358 enter->op_other = o;
11363 S_set_haseval(aTHX);
11367 const U8 priv = o->op_private;
11369 /* the newUNOP will recursively call ck_eval(), which will handle
11370 * all the stuff at the end of this function, like adding
11373 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11375 o->op_targ = (PADOFFSET)PL_hints;
11376 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11377 if ((PL_hints & HINT_LOCALIZE_HH) != 0
11378 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11379 /* Store a copy of %^H that pp_entereval can pick up. */
11380 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11381 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11382 /* append hhop to only child */
11383 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11385 o->op_private |= OPpEVAL_HAS_HH;
11387 if (!(o->op_private & OPpEVAL_BYTES)
11388 && FEATURE_UNIEVAL_IS_ENABLED)
11389 o->op_private |= OPpEVAL_UNICODE;
11394 Perl_ck_exec(pTHX_ OP *o)
11396 PERL_ARGS_ASSERT_CK_EXEC;
11398 if (o->op_flags & OPf_STACKED) {
11401 kid = OpSIBLING(cUNOPo->op_first);
11402 if (kid->op_type == OP_RV2GV)
11411 Perl_ck_exists(pTHX_ OP *o)
11413 PERL_ARGS_ASSERT_CK_EXISTS;
11416 if (o->op_flags & OPf_KIDS) {
11417 OP * const kid = cUNOPo->op_first;
11418 if (kid->op_type == OP_ENTERSUB) {
11419 (void) ref(kid, o->op_type);
11420 if (kid->op_type != OP_RV2CV
11421 && !(PL_parser && PL_parser->error_count))
11423 "exists argument is not a subroutine name");
11424 o->op_private |= OPpEXISTS_SUB;
11426 else if (kid->op_type == OP_AELEM)
11427 o->op_flags |= OPf_SPECIAL;
11428 else if (kid->op_type != OP_HELEM)
11429 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11430 "element or a subroutine");
11437 Perl_ck_rvconst(pTHX_ OP *o)
11440 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11442 PERL_ARGS_ASSERT_CK_RVCONST;
11444 if (o->op_type == OP_RV2HV)
11445 /* rv2hv steals the bottom bit for its own uses */
11446 o->op_private &= ~OPpARG1_MASK;
11448 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11450 if (kid->op_type == OP_CONST) {
11453 SV * const kidsv = kid->op_sv;
11455 /* Is it a constant from cv_const_sv()? */
11456 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11459 if (SvTYPE(kidsv) == SVt_PVAV) return o;
11460 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11461 const char *badthing;
11462 switch (o->op_type) {
11464 badthing = "a SCALAR";
11467 badthing = "an ARRAY";
11470 badthing = "a HASH";
11478 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11479 SVfARG(kidsv), badthing);
11482 * This is a little tricky. We only want to add the symbol if we
11483 * didn't add it in the lexer. Otherwise we get duplicate strict
11484 * warnings. But if we didn't add it in the lexer, we must at
11485 * least pretend like we wanted to add it even if it existed before,
11486 * or we get possible typo warnings. OPpCONST_ENTERED says
11487 * whether the lexer already added THIS instance of this symbol.
11489 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11490 gv = gv_fetchsv(kidsv,
11491 o->op_type == OP_RV2CV
11492 && o->op_private & OPpMAY_RETURN_CONSTANT
11494 : iscv | !(kid->op_private & OPpCONST_ENTERED),
11497 : o->op_type == OP_RV2SV
11499 : o->op_type == OP_RV2AV
11501 : o->op_type == OP_RV2HV
11508 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11509 && SvTYPE(SvRV(gv)) != SVt_PVCV)
11510 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11512 OpTYPE_set(kid, OP_GV);
11513 SvREFCNT_dec(kid->op_sv);
11514 #ifdef USE_ITHREADS
11515 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11516 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11517 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11518 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11519 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11521 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11523 kid->op_private = 0;
11524 /* FAKE globs in the symbol table cause weird bugs (#77810) */
11532 Perl_ck_ftst(pTHX_ OP *o)
11535 const I32 type = o->op_type;
11537 PERL_ARGS_ASSERT_CK_FTST;
11539 if (o->op_flags & OPf_REF) {
11542 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11543 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11544 const OPCODE kidtype = kid->op_type;
11546 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11547 && !kid->op_folded) {
11548 OP * const newop = newGVOP(type, OPf_REF,
11549 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11554 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11555 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11557 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11558 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11559 array_passed_to_stat, name);
11562 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11563 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11566 scalar((OP *) kid);
11567 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11568 o->op_private |= OPpFT_ACCESS;
11569 if (type != OP_STAT && type != OP_LSTAT
11570 && PL_check[kidtype] == Perl_ck_ftst
11571 && kidtype != OP_STAT && kidtype != OP_LSTAT
11573 o->op_private |= OPpFT_STACKED;
11574 kid->op_private |= OPpFT_STACKING;
11575 if (kidtype == OP_FTTTY && (
11576 !(kid->op_private & OPpFT_STACKED)
11577 || kid->op_private & OPpFT_AFTER_t
11579 o->op_private |= OPpFT_AFTER_t;
11584 if (type == OP_FTTTY)
11585 o = newGVOP(type, OPf_REF, PL_stdingv);
11587 o = newUNOP(type, 0, newDEFSVOP());
11593 Perl_ck_fun(pTHX_ OP *o)
11595 const int type = o->op_type;
11596 I32 oa = PL_opargs[type] >> OASHIFT;
11598 PERL_ARGS_ASSERT_CK_FUN;
11600 if (o->op_flags & OPf_STACKED) {
11601 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11602 oa &= ~OA_OPTIONAL;
11604 return no_fh_allowed(o);
11607 if (o->op_flags & OPf_KIDS) {
11608 OP *prev_kid = NULL;
11609 OP *kid = cLISTOPo->op_first;
11611 bool seen_optional = FALSE;
11613 if (kid->op_type == OP_PUSHMARK ||
11614 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11617 kid = OpSIBLING(kid);
11619 if (kid && kid->op_type == OP_COREARGS) {
11620 bool optional = FALSE;
11623 if (oa & OA_OPTIONAL) optional = TRUE;
11626 if (optional) o->op_private |= numargs;
11631 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11632 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11633 kid = newDEFSVOP();
11634 /* append kid to chain */
11635 op_sibling_splice(o, prev_kid, 0, kid);
11637 seen_optional = TRUE;
11644 /* list seen where single (scalar) arg expected? */
11645 if (numargs == 1 && !(oa >> 4)
11646 && kid->op_type == OP_LIST && type != OP_SCALAR)
11648 return too_many_arguments_pv(o,PL_op_desc[type], 0);
11650 if (type != OP_DELETE) scalar(kid);
11661 if ((type == OP_PUSH || type == OP_UNSHIFT)
11662 && !OpHAS_SIBLING(kid))
11663 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11664 "Useless use of %s with no values",
11667 if (kid->op_type == OP_CONST
11668 && ( !SvROK(cSVOPx_sv(kid))
11669 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
11671 bad_type_pv(numargs, "array", o, kid);
11672 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11673 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11674 PL_op_desc[type]), 0);
11677 op_lvalue(kid, type);
11681 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11682 bad_type_pv(numargs, "hash", o, kid);
11683 op_lvalue(kid, type);
11687 /* replace kid with newop in chain */
11689 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11690 newop->op_next = newop;
11695 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11696 if (kid->op_type == OP_CONST &&
11697 (kid->op_private & OPpCONST_BARE))
11699 OP * const newop = newGVOP(OP_GV, 0,
11700 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11701 /* replace kid with newop in chain */
11702 op_sibling_splice(o, prev_kid, 1, newop);
11706 else if (kid->op_type == OP_READLINE) {
11707 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11708 bad_type_pv(numargs, "HANDLE", o, kid);
11711 I32 flags = OPf_SPECIAL;
11713 PADOFFSET targ = 0;
11715 /* is this op a FH constructor? */
11716 if (is_handle_constructor(o,numargs)) {
11717 const char *name = NULL;
11720 bool want_dollar = TRUE;
11723 /* Set a flag to tell rv2gv to vivify
11724 * need to "prove" flag does not mean something
11725 * else already - NI-S 1999/05/07
11728 if (kid->op_type == OP_PADSV) {
11730 = PAD_COMPNAME_SV(kid->op_targ);
11731 name = PadnamePV (pn);
11732 len = PadnameLEN(pn);
11733 name_utf8 = PadnameUTF8(pn);
11735 else if (kid->op_type == OP_RV2SV
11736 && kUNOP->op_first->op_type == OP_GV)
11738 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11740 len = GvNAMELEN(gv);
11741 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11743 else if (kid->op_type == OP_AELEM
11744 || kid->op_type == OP_HELEM)
11747 OP *op = ((BINOP*)kid)->op_first;
11751 const char * const a =
11752 kid->op_type == OP_AELEM ?
11754 if (((op->op_type == OP_RV2AV) ||
11755 (op->op_type == OP_RV2HV)) &&
11756 (firstop = ((UNOP*)op)->op_first) &&
11757 (firstop->op_type == OP_GV)) {
11758 /* packagevar $a[] or $h{} */
11759 GV * const gv = cGVOPx_gv(firstop);
11762 Perl_newSVpvf(aTHX_
11767 else if (op->op_type == OP_PADAV
11768 || op->op_type == OP_PADHV) {
11769 /* lexicalvar $a[] or $h{} */
11770 const char * const padname =
11771 PAD_COMPNAME_PV(op->op_targ);
11774 Perl_newSVpvf(aTHX_
11780 name = SvPV_const(tmpstr, len);
11781 name_utf8 = SvUTF8(tmpstr);
11782 sv_2mortal(tmpstr);
11786 name = "__ANONIO__";
11788 want_dollar = FALSE;
11790 op_lvalue(kid, type);
11794 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11795 namesv = PAD_SVl(targ);
11796 if (want_dollar && *name != '$')
11797 sv_setpvs(namesv, "$");
11800 sv_catpvn(namesv, name, len);
11801 if ( name_utf8 ) SvUTF8_on(namesv);
11805 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11807 kid->op_targ = targ;
11808 kid->op_private |= priv;
11814 if ((type == OP_UNDEF || type == OP_POS)
11815 && numargs == 1 && !(oa >> 4)
11816 && kid->op_type == OP_LIST)
11817 return too_many_arguments_pv(o,PL_op_desc[type], 0);
11818 op_lvalue(scalar(kid), type);
11823 kid = OpSIBLING(kid);
11825 /* FIXME - should the numargs or-ing move after the too many
11826 * arguments check? */
11827 o->op_private |= numargs;
11829 return too_many_arguments_pv(o,OP_DESC(o), 0);
11832 else if (PL_opargs[type] & OA_DEFGV) {
11833 /* Ordering of these two is important to keep f_map.t passing. */
11835 return newUNOP(type, 0, newDEFSVOP());
11839 while (oa & OA_OPTIONAL)
11841 if (oa && oa != OA_LIST)
11842 return too_few_arguments_pv(o,OP_DESC(o), 0);
11848 Perl_ck_glob(pTHX_ OP *o)
11852 PERL_ARGS_ASSERT_CK_GLOB;
11855 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11856 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11858 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11862 * \ null - const(wildcard)
11867 * \ mark - glob - rv2cv
11868 * | \ gv(CORE::GLOBAL::glob)
11870 * \ null - const(wildcard)
11872 o->op_flags |= OPf_SPECIAL;
11873 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11874 o = S_new_entersubop(aTHX_ gv, o);
11875 o = newUNOP(OP_NULL, 0, o);
11876 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11879 else o->op_flags &= ~OPf_SPECIAL;
11880 #if !defined(PERL_EXTERNAL_GLOB)
11881 if (!PL_globhook) {
11883 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11884 newSVpvs("File::Glob"), NULL, NULL, NULL);
11887 #endif /* !PERL_EXTERNAL_GLOB */
11888 gv = (GV *)newSV(0);
11889 gv_init(gv, 0, "", 0, 0);
11891 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11892 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11898 Perl_ck_grep(pTHX_ OP *o)
11902 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
11904 PERL_ARGS_ASSERT_CK_GREP;
11906 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
11908 if (o->op_flags & OPf_STACKED) {
11909 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
11910 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
11911 return no_fh_allowed(o);
11912 o->op_flags &= ~OPf_STACKED;
11914 kid = OpSIBLING(cLISTOPo->op_first);
11915 if (type == OP_MAPWHILE)
11920 if (PL_parser && PL_parser->error_count)
11922 kid = OpSIBLING(cLISTOPo->op_first);
11923 if (kid->op_type != OP_NULL)
11924 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
11925 kid = kUNOP->op_first;
11927 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
11928 kid->op_next = (OP*)gwop;
11929 o->op_private = gwop->op_private = 0;
11930 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
11932 kid = OpSIBLING(cLISTOPo->op_first);
11933 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
11934 op_lvalue(kid, OP_GREPSTART);
11940 Perl_ck_index(pTHX_ OP *o)
11942 PERL_ARGS_ASSERT_CK_INDEX;
11944 if (o->op_flags & OPf_KIDS) {
11945 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
11947 kid = OpSIBLING(kid); /* get past "big" */
11948 if (kid && kid->op_type == OP_CONST) {
11949 const bool save_taint = TAINT_get;
11950 SV *sv = kSVOP->op_sv;
11951 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
11952 && SvOK(sv) && !SvROK(sv))
11955 sv_copypv(sv, kSVOP->op_sv);
11956 SvREFCNT_dec_NN(kSVOP->op_sv);
11959 if (SvOK(sv)) fbm_compile(sv, 0);
11960 TAINT_set(save_taint);
11961 #ifdef NO_TAINT_SUPPORT
11962 PERL_UNUSED_VAR(save_taint);
11970 Perl_ck_lfun(pTHX_ OP *o)
11972 const OPCODE type = o->op_type;
11974 PERL_ARGS_ASSERT_CK_LFUN;
11976 return modkids(ck_fun(o), type);
11980 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
11982 PERL_ARGS_ASSERT_CK_DEFINED;
11984 if ((o->op_flags & OPf_KIDS)) {
11985 switch (cUNOPo->op_first->op_type) {
11988 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
11989 " (Maybe you should just omit the defined()?)");
11990 NOT_REACHED; /* NOTREACHED */
11994 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
11995 " (Maybe you should just omit the defined()?)");
11996 NOT_REACHED; /* NOTREACHED */
12007 Perl_ck_readline(pTHX_ OP *o)
12009 PERL_ARGS_ASSERT_CK_READLINE;
12011 if (o->op_flags & OPf_KIDS) {
12012 OP *kid = cLISTOPo->op_first;
12013 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12017 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12025 Perl_ck_rfun(pTHX_ OP *o)
12027 const OPCODE type = o->op_type;
12029 PERL_ARGS_ASSERT_CK_RFUN;
12031 return refkids(ck_fun(o), type);
12035 Perl_ck_listiob(pTHX_ OP *o)
12039 PERL_ARGS_ASSERT_CK_LISTIOB;
12041 kid = cLISTOPo->op_first;
12043 o = force_list(o, 1);
12044 kid = cLISTOPo->op_first;
12046 if (kid->op_type == OP_PUSHMARK)
12047 kid = OpSIBLING(kid);
12048 if (kid && o->op_flags & OPf_STACKED)
12049 kid = OpSIBLING(kid);
12050 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
12051 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12052 && !kid->op_folded) {
12053 o->op_flags |= OPf_STACKED; /* make it a filehandle */
12055 /* replace old const op with new OP_RV2GV parent */
12056 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12057 OP_RV2GV, OPf_REF);
12058 kid = OpSIBLING(kid);
12063 op_append_elem(o->op_type, o, newDEFSVOP());
12065 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12066 return listkids(o);
12070 Perl_ck_smartmatch(pTHX_ OP *o)
12073 PERL_ARGS_ASSERT_CK_SMARTMATCH;
12074 if (0 == (o->op_flags & OPf_SPECIAL)) {
12075 OP *first = cBINOPo->op_first;
12076 OP *second = OpSIBLING(first);
12078 /* Implicitly take a reference to an array or hash */
12080 /* remove the original two siblings, then add back the
12081 * (possibly different) first and second sibs.
12083 op_sibling_splice(o, NULL, 1, NULL);
12084 op_sibling_splice(o, NULL, 1, NULL);
12085 first = ref_array_or_hash(first);
12086 second = ref_array_or_hash(second);
12087 op_sibling_splice(o, NULL, 0, second);
12088 op_sibling_splice(o, NULL, 0, first);
12090 /* Implicitly take a reference to a regular expression */
12091 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12092 OpTYPE_set(first, OP_QR);
12094 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12095 OpTYPE_set(second, OP_QR);
12104 S_maybe_targlex(pTHX_ OP *o)
12106 OP * const kid = cLISTOPo->op_first;
12107 /* has a disposable target? */
12108 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12109 && !(kid->op_flags & OPf_STACKED)
12110 /* Cannot steal the second time! */
12111 && !(kid->op_private & OPpTARGET_MY)
12114 OP * const kkid = OpSIBLING(kid);
12116 /* Can just relocate the target. */
12117 if (kkid && kkid->op_type == OP_PADSV
12118 && (!(kkid->op_private & OPpLVAL_INTRO)
12119 || kkid->op_private & OPpPAD_STATE))
12121 kid->op_targ = kkid->op_targ;
12123 /* Now we do not need PADSV and SASSIGN.
12124 * Detach kid and free the rest. */
12125 op_sibling_splice(o, NULL, 1, NULL);
12127 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
12135 Perl_ck_sassign(pTHX_ OP *o)
12138 OP * const kid = cBINOPo->op_first;
12140 PERL_ARGS_ASSERT_CK_SASSIGN;
12142 if (OpHAS_SIBLING(kid)) {
12143 OP *kkid = OpSIBLING(kid);
12144 /* For state variable assignment with attributes, kkid is a list op
12145 whose op_last is a padsv. */
12146 if ((kkid->op_type == OP_PADSV ||
12147 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12148 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12151 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12152 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12153 return S_newONCEOP(aTHX_ o, kkid);
12156 return S_maybe_targlex(aTHX_ o);
12161 Perl_ck_match(pTHX_ OP *o)
12163 PERL_UNUSED_CONTEXT;
12164 PERL_ARGS_ASSERT_CK_MATCH;
12170 Perl_ck_method(pTHX_ OP *o)
12172 SV *sv, *methsv, *rclass;
12173 const char* method;
12176 STRLEN len, nsplit = 0, i;
12178 OP * const kid = cUNOPo->op_first;
12180 PERL_ARGS_ASSERT_CK_METHOD;
12181 if (kid->op_type != OP_CONST) return o;
12185 /* replace ' with :: */
12186 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12187 SvEND(sv) - SvPVX(sv) )))
12190 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12193 method = SvPVX_const(sv);
12195 utf8 = SvUTF8(sv) ? -1 : 1;
12197 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12202 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12204 if (!nsplit) { /* $proto->method() */
12206 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12209 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12211 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12214 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12215 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12216 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12217 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12219 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12220 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12222 #ifdef USE_ITHREADS
12223 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12225 cMETHOPx(new_op)->op_rclass_sv = rclass;
12232 Perl_ck_null(pTHX_ OP *o)
12234 PERL_ARGS_ASSERT_CK_NULL;
12235 PERL_UNUSED_CONTEXT;
12240 Perl_ck_open(pTHX_ OP *o)
12242 PERL_ARGS_ASSERT_CK_OPEN;
12244 S_io_hints(aTHX_ o);
12246 /* In case of three-arg dup open remove strictness
12247 * from the last arg if it is a bareword. */
12248 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12249 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
12253 if ((last->op_type == OP_CONST) && /* The bareword. */
12254 (last->op_private & OPpCONST_BARE) &&
12255 (last->op_private & OPpCONST_STRICT) &&
12256 (oa = OpSIBLING(first)) && /* The fh. */
12257 (oa = OpSIBLING(oa)) && /* The mode. */
12258 (oa->op_type == OP_CONST) &&
12259 SvPOK(((SVOP*)oa)->op_sv) &&
12260 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12261 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
12262 (last == OpSIBLING(oa))) /* The bareword. */
12263 last->op_private &= ~OPpCONST_STRICT;
12269 Perl_ck_prototype(pTHX_ OP *o)
12271 PERL_ARGS_ASSERT_CK_PROTOTYPE;
12272 if (!(o->op_flags & OPf_KIDS)) {
12274 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12280 Perl_ck_refassign(pTHX_ OP *o)
12282 OP * const right = cLISTOPo->op_first;
12283 OP * const left = OpSIBLING(right);
12284 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12287 PERL_ARGS_ASSERT_CK_REFASSIGN;
12289 assert (left->op_type == OP_SREFGEN);
12292 /* we use OPpPAD_STATE in refassign to mean either of those things,
12293 * and the code assumes the two flags occupy the same bit position
12294 * in the various ops below */
12295 assert(OPpPAD_STATE == OPpOUR_INTRO);
12297 switch (varop->op_type) {
12299 o->op_private |= OPpLVREF_AV;
12302 o->op_private |= OPpLVREF_HV;
12306 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12307 o->op_targ = varop->op_targ;
12308 varop->op_targ = 0;
12309 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12313 o->op_private |= OPpLVREF_AV;
12315 NOT_REACHED; /* NOTREACHED */
12317 o->op_private |= OPpLVREF_HV;
12321 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12322 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12324 /* Point varop to its GV kid, detached. */
12325 varop = op_sibling_splice(varop, NULL, -1, NULL);
12329 OP * const kidparent =
12330 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12331 OP * const kid = cUNOPx(kidparent)->op_first;
12332 o->op_private |= OPpLVREF_CV;
12333 if (kid->op_type == OP_GV) {
12335 goto detach_and_stack;
12337 if (kid->op_type != OP_PADCV) goto bad;
12338 o->op_targ = kid->op_targ;
12344 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12345 o->op_private |= OPpLVREF_ELEM;
12348 /* Detach varop. */
12349 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12353 /* diag_listed_as: Can't modify reference to %s in %s assignment */
12354 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12359 if (!FEATURE_REFALIASING_IS_ENABLED)
12361 "Experimental aliasing via reference not enabled");
12362 Perl_ck_warner_d(aTHX_
12363 packWARN(WARN_EXPERIMENTAL__REFALIASING),
12364 "Aliasing via reference is experimental");
12366 o->op_flags |= OPf_STACKED;
12367 op_sibling_splice(o, right, 1, varop);
12370 o->op_flags &=~ OPf_STACKED;
12371 op_sibling_splice(o, right, 1, NULL);
12378 Perl_ck_repeat(pTHX_ OP *o)
12380 PERL_ARGS_ASSERT_CK_REPEAT;
12382 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12384 o->op_private |= OPpREPEAT_DOLIST;
12385 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12386 kids = force_list(kids, 1); /* promote it to a list */
12387 op_sibling_splice(o, NULL, 0, kids); /* and add back */
12395 Perl_ck_require(pTHX_ OP *o)
12399 PERL_ARGS_ASSERT_CK_REQUIRE;
12401 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
12402 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12406 if (kid->op_type == OP_CONST) {
12407 SV * const sv = kid->op_sv;
12408 U32 const was_readonly = SvREADONLY(sv);
12409 if (kid->op_private & OPpCONST_BARE) {
12414 if (was_readonly) {
12415 SvREADONLY_off(sv);
12417 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12422 /* treat ::foo::bar as foo::bar */
12423 if (len >= 2 && s[0] == ':' && s[1] == ':')
12424 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12426 DIE(aTHX_ "Bareword in require maps to empty filename");
12428 for (; s < end; s++) {
12429 if (*s == ':' && s[1] == ':') {
12431 Move(s+2, s+1, end - s - 1, char);
12435 SvEND_set(sv, end);
12436 sv_catpvs(sv, ".pm");
12437 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12438 hek = share_hek(SvPVX(sv),
12439 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12441 sv_sethek(sv, hek);
12443 SvFLAGS(sv) |= was_readonly;
12445 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12448 if (SvREFCNT(sv) > 1) {
12449 kid->op_sv = newSVpvn_share(
12450 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12451 SvREFCNT_dec_NN(sv);
12456 if (was_readonly) SvREADONLY_off(sv);
12457 PERL_HASH(hash, s, len);
12459 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12461 sv_sethek(sv, hek);
12463 SvFLAGS(sv) |= was_readonly;
12469 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12470 /* handle override, if any */
12471 && (gv = gv_override("require", 7))) {
12473 if (o->op_flags & OPf_KIDS) {
12474 kid = cUNOPo->op_first;
12475 op_sibling_splice(o, NULL, -1, NULL);
12478 kid = newDEFSVOP();
12481 newop = S_new_entersubop(aTHX_ gv, kid);
12489 Perl_ck_return(pTHX_ OP *o)
12493 PERL_ARGS_ASSERT_CK_RETURN;
12495 kid = OpSIBLING(cLISTOPo->op_first);
12496 if (PL_compcv && CvLVALUE(PL_compcv)) {
12497 for (; kid; kid = OpSIBLING(kid))
12498 op_lvalue(kid, OP_LEAVESUBLV);
12505 Perl_ck_select(pTHX_ OP *o)
12510 PERL_ARGS_ASSERT_CK_SELECT;
12512 if (o->op_flags & OPf_KIDS) {
12513 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12514 if (kid && OpHAS_SIBLING(kid)) {
12515 OpTYPE_set(o, OP_SSELECT);
12517 return fold_constants(op_integerize(op_std_init(o)));
12521 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12522 if (kid && kid->op_type == OP_RV2GV)
12523 kid->op_private &= ~HINT_STRICT_REFS;
12528 Perl_ck_shift(pTHX_ OP *o)
12530 const I32 type = o->op_type;
12532 PERL_ARGS_ASSERT_CK_SHIFT;
12534 if (!(o->op_flags & OPf_KIDS)) {
12537 if (!CvUNIQUE(PL_compcv)) {
12538 o->op_flags |= OPf_SPECIAL;
12542 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12544 return newUNOP(type, 0, scalar(argop));
12546 return scalar(ck_fun(o));
12550 Perl_ck_sort(pTHX_ OP *o)
12554 HV * const hinthv =
12555 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12558 PERL_ARGS_ASSERT_CK_SORT;
12561 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12563 const I32 sorthints = (I32)SvIV(*svp);
12564 if ((sorthints & HINT_SORT_STABLE) != 0)
12565 o->op_private |= OPpSORT_STABLE;
12566 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12567 o->op_private |= OPpSORT_UNSTABLE;
12571 if (o->op_flags & OPf_STACKED)
12573 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12575 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
12576 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
12578 /* if the first arg is a code block, process it and mark sort as
12580 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12582 if (kid->op_type == OP_LEAVE)
12583 op_null(kid); /* wipe out leave */
12584 /* Prevent execution from escaping out of the sort block. */
12587 /* provide scalar context for comparison function/block */
12588 kid = scalar(firstkid);
12589 kid->op_next = kid;
12590 o->op_flags |= OPf_SPECIAL;
12592 else if (kid->op_type == OP_CONST
12593 && kid->op_private & OPpCONST_BARE) {
12597 const char * const name = SvPV(kSVOP_sv, len);
12599 assert (len < 256);
12600 Copy(name, tmpbuf+1, len, char);
12601 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12602 if (off != NOT_IN_PAD) {
12603 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12605 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12606 sv_catpvs(fq, "::");
12607 sv_catsv(fq, kSVOP_sv);
12608 SvREFCNT_dec_NN(kSVOP_sv);
12612 OP * const padop = newOP(OP_PADCV, 0);
12613 padop->op_targ = off;
12614 /* replace the const op with the pad op */
12615 op_sibling_splice(firstkid, NULL, 1, padop);
12621 firstkid = OpSIBLING(firstkid);
12624 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12625 /* provide list context for arguments */
12628 op_lvalue(kid, OP_GREPSTART);
12634 /* for sort { X } ..., where X is one of
12635 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12636 * elide the second child of the sort (the one containing X),
12637 * and set these flags as appropriate
12641 * Also, check and warn on lexical $a, $b.
12645 S_simplify_sort(pTHX_ OP *o)
12647 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12651 const char *gvname;
12654 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12656 kid = kUNOP->op_first; /* get past null */
12657 if (!(have_scopeop = kid->op_type == OP_SCOPE)
12658 && kid->op_type != OP_LEAVE)
12660 kid = kLISTOP->op_last; /* get past scope */
12661 switch(kid->op_type) {
12665 if (!have_scopeop) goto padkids;
12670 k = kid; /* remember this node*/
12671 if (kBINOP->op_first->op_type != OP_RV2SV
12672 || kBINOP->op_last ->op_type != OP_RV2SV)
12675 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12676 then used in a comparison. This catches most, but not
12677 all cases. For instance, it catches
12678 sort { my($a); $a <=> $b }
12680 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12681 (although why you'd do that is anyone's guess).
12685 if (!ckWARN(WARN_SYNTAX)) return;
12686 kid = kBINOP->op_first;
12688 if (kid->op_type == OP_PADSV) {
12689 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12690 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12691 && ( PadnamePV(name)[1] == 'a'
12692 || PadnamePV(name)[1] == 'b' ))
12693 /* diag_listed_as: "my %s" used in sort comparison */
12694 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12695 "\"%s %s\" used in sort comparison",
12696 PadnameIsSTATE(name)
12701 } while ((kid = OpSIBLING(kid)));
12704 kid = kBINOP->op_first; /* get past cmp */
12705 if (kUNOP->op_first->op_type != OP_GV)
12707 kid = kUNOP->op_first; /* get past rv2sv */
12709 if (GvSTASH(gv) != PL_curstash)
12711 gvname = GvNAME(gv);
12712 if (*gvname == 'a' && gvname[1] == '\0')
12714 else if (*gvname == 'b' && gvname[1] == '\0')
12719 kid = k; /* back to cmp */
12720 /* already checked above that it is rv2sv */
12721 kid = kBINOP->op_last; /* down to 2nd arg */
12722 if (kUNOP->op_first->op_type != OP_GV)
12724 kid = kUNOP->op_first; /* get past rv2sv */
12726 if (GvSTASH(gv) != PL_curstash)
12728 gvname = GvNAME(gv);
12730 ? !(*gvname == 'a' && gvname[1] == '\0')
12731 : !(*gvname == 'b' && gvname[1] == '\0'))
12733 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12735 o->op_private |= OPpSORT_DESCEND;
12736 if (k->op_type == OP_NCMP)
12737 o->op_private |= OPpSORT_NUMERIC;
12738 if (k->op_type == OP_I_NCMP)
12739 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12740 kid = OpSIBLING(cLISTOPo->op_first);
12741 /* cut out and delete old block (second sibling) */
12742 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12747 Perl_ck_split(pTHX_ OP *o)
12753 PERL_ARGS_ASSERT_CK_SPLIT;
12755 assert(o->op_type == OP_LIST);
12757 if (o->op_flags & OPf_STACKED)
12758 return no_fh_allowed(o);
12760 kid = cLISTOPo->op_first;
12761 /* delete leading NULL node, then add a CONST if no other nodes */
12762 assert(kid->op_type == OP_NULL);
12763 op_sibling_splice(o, NULL, 1,
12764 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12766 kid = cLISTOPo->op_first;
12768 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12769 /* remove match expression, and replace with new optree with
12770 * a match op at its head */
12771 op_sibling_splice(o, NULL, 1, NULL);
12772 /* pmruntime will handle split " " behavior with flag==2 */
12773 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12774 op_sibling_splice(o, NULL, 0, kid);
12777 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12779 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12780 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12781 "Use of /g modifier is meaningless in split");
12784 /* eliminate the split op, and move the match op (plus any children)
12785 * into its place, then convert the match op into a split op. i.e.
12787 * SPLIT MATCH SPLIT(ex-MATCH)
12789 * MATCH - A - B - C => R - A - B - C => R - A - B - C
12795 * (R, if it exists, will be a regcomp op)
12798 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12799 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12800 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12801 OpTYPE_set(kid, OP_SPLIT);
12802 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
12803 kid->op_private = o->op_private;
12806 kid = sibs; /* kid is now the string arg of the split */
12809 kid = newDEFSVOP();
12810 op_append_elem(OP_SPLIT, o, kid);
12814 kid = OpSIBLING(kid);
12816 kid = newSVOP(OP_CONST, 0, newSViv(0));
12817 op_append_elem(OP_SPLIT, o, kid);
12818 o->op_private |= OPpSPLIT_IMPLIM;
12822 if (OpHAS_SIBLING(kid))
12823 return too_many_arguments_pv(o,OP_DESC(o), 0);
12829 Perl_ck_stringify(pTHX_ OP *o)
12831 OP * const kid = OpSIBLING(cUNOPo->op_first);
12832 PERL_ARGS_ASSERT_CK_STRINGIFY;
12833 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12834 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
12835 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
12836 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12838 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12846 Perl_ck_join(pTHX_ OP *o)
12848 OP * const kid = OpSIBLING(cLISTOPo->op_first);
12850 PERL_ARGS_ASSERT_CK_JOIN;
12852 if (kid && kid->op_type == OP_MATCH) {
12853 if (ckWARN(WARN_SYNTAX)) {
12854 const REGEXP *re = PM_GETRE(kPMOP);
12856 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12857 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12858 : newSVpvs_flags( "STRING", SVs_TEMP );
12859 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12860 "/%" SVf "/ should probably be written as \"%" SVf "\"",
12861 SVfARG(msg), SVfARG(msg));
12865 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12866 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12867 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12868 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12870 const OP * const bairn = OpSIBLING(kid); /* the list */
12871 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12872 && OP_GIMME(bairn,0) == G_SCALAR)
12874 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12875 op_sibling_splice(o, kid, 1, NULL));
12885 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12887 Examines an op, which is expected to identify a subroutine at runtime,
12888 and attempts to determine at compile time which subroutine it identifies.
12889 This is normally used during Perl compilation to determine whether
12890 a prototype can be applied to a function call. C<cvop> is the op
12891 being considered, normally an C<rv2cv> op. A pointer to the identified
12892 subroutine is returned, if it could be determined statically, and a null
12893 pointer is returned if it was not possible to determine statically.
12895 Currently, the subroutine can be identified statically if the RV that the
12896 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
12897 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
12898 suitable if the constant value must be an RV pointing to a CV. Details of
12899 this process may change in future versions of Perl. If the C<rv2cv> op
12900 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
12901 the subroutine statically: this flag is used to suppress compile-time
12902 magic on a subroutine call, forcing it to use default runtime behaviour.
12904 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
12905 of a GV reference is modified. If a GV was examined and its CV slot was
12906 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
12907 If the op is not optimised away, and the CV slot is later populated with
12908 a subroutine having a prototype, that flag eventually triggers the warning
12909 "called too early to check prototype".
12911 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
12912 of returning a pointer to the subroutine it returns a pointer to the
12913 GV giving the most appropriate name for the subroutine in this context.
12914 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
12915 (C<CvANON>) subroutine that is referenced through a GV it will be the
12916 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
12917 A null pointer is returned as usual if there is no statically-determinable
12923 /* shared by toke.c:yylex */
12925 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
12927 PADNAME *name = PAD_COMPNAME(off);
12928 CV *compcv = PL_compcv;
12929 while (PadnameOUTER(name)) {
12930 assert(PARENT_PAD_INDEX(name));
12931 compcv = CvOUTSIDE(compcv);
12932 name = PadlistNAMESARRAY(CvPADLIST(compcv))
12933 [off = PARENT_PAD_INDEX(name)];
12935 assert(!PadnameIsOUR(name));
12936 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
12937 return PadnamePROTOCV(name);
12939 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
12943 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
12948 PERL_ARGS_ASSERT_RV2CV_OP_CV;
12949 if (flags & ~RV2CVOPCV_FLAG_MASK)
12950 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
12951 if (cvop->op_type != OP_RV2CV)
12953 if (cvop->op_private & OPpENTERSUB_AMPER)
12955 if (!(cvop->op_flags & OPf_KIDS))
12957 rvop = cUNOPx(cvop)->op_first;
12958 switch (rvop->op_type) {
12960 gv = cGVOPx_gv(rvop);
12962 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
12963 cv = MUTABLE_CV(SvRV(gv));
12967 if (flags & RV2CVOPCV_RETURN_STUB)
12973 if (flags & RV2CVOPCV_MARK_EARLY)
12974 rvop->op_private |= OPpEARLY_CV;
12979 SV *rv = cSVOPx_sv(rvop);
12982 cv = (CV*)SvRV(rv);
12986 cv = find_lexical_cv(rvop->op_targ);
12991 } NOT_REACHED; /* NOTREACHED */
12993 if (SvTYPE((SV*)cv) != SVt_PVCV)
12995 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
12996 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13000 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13001 if (CvLEXICAL(cv) || CvNAMED(cv))
13003 if (!CvANON(cv) || !gv)
13013 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
13015 Performs the default fixup of the arguments part of an C<entersub>
13016 op tree. This consists of applying list context to each of the
13017 argument ops. This is the standard treatment used on a call marked
13018 with C<&>, or a method call, or a call through a subroutine reference,
13019 or any other call where the callee can't be identified at compile time,
13020 or a call where the callee has no prototype.
13026 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13030 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13032 aop = cUNOPx(entersubop)->op_first;
13033 if (!OpHAS_SIBLING(aop))
13034 aop = cUNOPx(aop)->op_first;
13035 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13036 /* skip the extra attributes->import() call implicitly added in
13037 * something like foo(my $x : bar)
13039 if ( aop->op_type == OP_ENTERSUB
13040 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13044 op_lvalue(aop, OP_ENTERSUB);
13050 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
13052 Performs the fixup of the arguments part of an C<entersub> op tree
13053 based on a subroutine prototype. This makes various modifications to
13054 the argument ops, from applying context up to inserting C<refgen> ops,
13055 and checking the number and syntactic types of arguments, as directed by
13056 the prototype. This is the standard treatment used on a subroutine call,
13057 not marked with C<&>, where the callee can be identified at compile time
13058 and has a prototype.
13060 C<protosv> supplies the subroutine prototype to be applied to the call.
13061 It may be a normal defined scalar, of which the string value will be used.
13062 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13063 that has been cast to C<SV*>) which has a prototype. The prototype
13064 supplied, in whichever form, does not need to match the actual callee
13065 referenced by the op tree.
13067 If the argument ops disagree with the prototype, for example by having
13068 an unacceptable number of arguments, a valid op tree is returned anyway.
13069 The error is reflected in the parser state, normally resulting in a single
13070 exception at the top level of parsing which covers all the compilation
13071 errors that occurred. In the error message, the callee is referred to
13072 by the name defined by the C<namegv> parameter.
13078 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13081 const char *proto, *proto_end;
13082 OP *aop, *prev, *cvop, *parent;
13085 I32 contextclass = 0;
13086 const char *e = NULL;
13087 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13088 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13089 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13090 "flags=%lx", (unsigned long) SvFLAGS(protosv));
13091 if (SvTYPE(protosv) == SVt_PVCV)
13092 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13093 else proto = SvPV(protosv, proto_len);
13094 proto = S_strip_spaces(aTHX_ proto, &proto_len);
13095 proto_end = proto + proto_len;
13096 parent = entersubop;
13097 aop = cUNOPx(entersubop)->op_first;
13098 if (!OpHAS_SIBLING(aop)) {
13100 aop = cUNOPx(aop)->op_first;
13103 aop = OpSIBLING(aop);
13104 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13105 while (aop != cvop) {
13108 if (proto >= proto_end)
13110 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13111 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13112 SVfARG(namesv)), SvUTF8(namesv));
13122 /* _ must be at the end */
13123 if (proto[1] && !strchr(";@%", proto[1]))
13139 if ( o3->op_type != OP_UNDEF
13140 && (o3->op_type != OP_SREFGEN
13141 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13143 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13145 bad_type_gv(arg, namegv, o3,
13146 arg == 1 ? "block or sub {}" : "sub {}");
13149 /* '*' allows any scalar type, including bareword */
13152 if (o3->op_type == OP_RV2GV)
13153 goto wrapref; /* autoconvert GLOB -> GLOBref */
13154 else if (o3->op_type == OP_CONST)
13155 o3->op_private &= ~OPpCONST_STRICT;
13161 if (o3->op_type == OP_RV2AV ||
13162 o3->op_type == OP_PADAV ||
13163 o3->op_type == OP_RV2HV ||
13164 o3->op_type == OP_PADHV
13170 case '[': case ']':
13177 switch (*proto++) {
13179 if (contextclass++ == 0) {
13180 e = (char *) memchr(proto, ']', proto_end - proto);
13181 if (!e || e == proto)
13189 if (contextclass) {
13190 const char *p = proto;
13191 const char *const end = proto;
13193 while (*--p != '[')
13194 /* \[$] accepts any scalar lvalue */
13196 && Perl_op_lvalue_flags(aTHX_
13198 OP_READ, /* not entersub */
13201 bad_type_gv(arg, namegv, o3,
13202 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13207 if (o3->op_type == OP_RV2GV)
13210 bad_type_gv(arg, namegv, o3, "symbol");
13213 if (o3->op_type == OP_ENTERSUB
13214 && !(o3->op_flags & OPf_STACKED))
13217 bad_type_gv(arg, namegv, o3, "subroutine");
13220 if (o3->op_type == OP_RV2SV ||
13221 o3->op_type == OP_PADSV ||
13222 o3->op_type == OP_HELEM ||
13223 o3->op_type == OP_AELEM)
13225 if (!contextclass) {
13226 /* \$ accepts any scalar lvalue */
13227 if (Perl_op_lvalue_flags(aTHX_
13229 OP_READ, /* not entersub */
13232 bad_type_gv(arg, namegv, o3, "scalar");
13236 if (o3->op_type == OP_RV2AV ||
13237 o3->op_type == OP_PADAV)
13239 o3->op_flags &=~ OPf_PARENS;
13243 bad_type_gv(arg, namegv, o3, "array");
13246 if (o3->op_type == OP_RV2HV ||
13247 o3->op_type == OP_PADHV)
13249 o3->op_flags &=~ OPf_PARENS;
13253 bad_type_gv(arg, namegv, o3, "hash");
13256 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13258 if (contextclass && e) {
13263 default: goto oops;
13273 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13274 SVfARG(cv_name((CV *)namegv, NULL, 0)),
13279 op_lvalue(aop, OP_ENTERSUB);
13281 aop = OpSIBLING(aop);
13283 if (aop == cvop && *proto == '_') {
13284 /* generate an access to $_ */
13285 op_sibling_splice(parent, prev, 0, newDEFSVOP());
13287 if (!optional && proto_end > proto &&
13288 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13290 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13291 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13292 SVfARG(namesv)), SvUTF8(namesv));
13298 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13300 Performs the fixup of the arguments part of an C<entersub> op tree either
13301 based on a subroutine prototype or using default list-context processing.
13302 This is the standard treatment used on a subroutine call, not marked
13303 with C<&>, where the callee can be identified at compile time.
13305 C<protosv> supplies the subroutine prototype to be applied to the call,
13306 or indicates that there is no prototype. It may be a normal scalar,
13307 in which case if it is defined then the string value will be used
13308 as a prototype, and if it is undefined then there is no prototype.
13309 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13310 that has been cast to C<SV*>), of which the prototype will be used if it
13311 has one. The prototype (or lack thereof) supplied, in whichever form,
13312 does not need to match the actual callee referenced by the op tree.
13314 If the argument ops disagree with the prototype, for example by having
13315 an unacceptable number of arguments, a valid op tree is returned anyway.
13316 The error is reflected in the parser state, normally resulting in a single
13317 exception at the top level of parsing which covers all the compilation
13318 errors that occurred. In the error message, the callee is referred to
13319 by the name defined by the C<namegv> parameter.
13325 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13326 GV *namegv, SV *protosv)
13328 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13329 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13330 return ck_entersub_args_proto(entersubop, namegv, protosv);
13332 return ck_entersub_args_list(entersubop);
13336 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13338 IV cvflags = SvIVX(protosv);
13339 int opnum = cvflags & 0xffff;
13340 OP *aop = cUNOPx(entersubop)->op_first;
13342 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13346 if (!OpHAS_SIBLING(aop))
13347 aop = cUNOPx(aop)->op_first;
13348 aop = OpSIBLING(aop);
13349 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13351 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13352 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13353 SVfARG(namesv)), SvUTF8(namesv));
13356 op_free(entersubop);
13357 switch(cvflags >> 16) {
13358 case 'F': return newSVOP(OP_CONST, 0,
13359 newSVpv(CopFILE(PL_curcop),0));
13360 case 'L': return newSVOP(
13362 Perl_newSVpvf(aTHX_
13363 "%" IVdf, (IV)CopLINE(PL_curcop)
13366 case 'P': return newSVOP(OP_CONST, 0,
13368 ? newSVhek(HvNAME_HEK(PL_curstash))
13373 NOT_REACHED; /* NOTREACHED */
13376 OP *prev, *cvop, *first, *parent;
13379 parent = entersubop;
13380 if (!OpHAS_SIBLING(aop)) {
13382 aop = cUNOPx(aop)->op_first;
13385 first = prev = aop;
13386 aop = OpSIBLING(aop);
13387 /* find last sibling */
13389 OpHAS_SIBLING(cvop);
13390 prev = cvop, cvop = OpSIBLING(cvop))
13392 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13393 /* Usually, OPf_SPECIAL on an op with no args means that it had
13394 * parens, but these have their own meaning for that flag: */
13395 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13396 && opnum != OP_DELETE && opnum != OP_EXISTS)
13397 flags |= OPf_SPECIAL;
13398 /* excise cvop from end of sibling chain */
13399 op_sibling_splice(parent, prev, 1, NULL);
13401 if (aop == cvop) aop = NULL;
13403 /* detach remaining siblings from the first sibling, then
13404 * dispose of original optree */
13407 op_sibling_splice(parent, first, -1, NULL);
13408 op_free(entersubop);
13410 if (cvflags == (OP_ENTEREVAL | (1<<16)))
13411 flags |= OPpEVAL_BYTES <<8;
13413 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13415 case OA_BASEOP_OR_UNOP:
13416 case OA_FILESTATOP:
13417 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13420 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13421 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13422 SVfARG(namesv)), SvUTF8(namesv));
13425 return opnum == OP_RUNCV
13426 ? newPVOP(OP_RUNCV,0,NULL)
13429 return op_convert_list(opnum,0,aop);
13432 NOT_REACHED; /* NOTREACHED */
13437 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13439 Retrieves the function that will be used to fix up a call to C<cv>.
13440 Specifically, the function is applied to an C<entersub> op tree for a
13441 subroutine call, not marked with C<&>, where the callee can be identified
13442 at compile time as C<cv>.
13444 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13445 for it is returned in C<*ckobj_p>, and control flags are returned in
13446 C<*ckflags_p>. The function is intended to be called in this manner:
13448 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13450 In this call, C<entersubop> is a pointer to the C<entersub> op,
13451 which may be replaced by the check function, and C<namegv> supplies
13452 the name that should be used by the check function to refer
13453 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13454 It is permitted to apply the check function in non-standard situations,
13455 such as to a call to a different subroutine or to a method call.
13457 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
13458 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13459 instead, anything that can be used as the first argument to L</cv_name>.
13460 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13461 check function requires C<namegv> to be a genuine GV.
13463 By default, the check function is
13464 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13465 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13466 flag is clear. This implements standard prototype processing. It can
13467 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13469 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13470 indicates that the caller only knows about the genuine GV version of
13471 C<namegv>, and accordingly the corresponding bit will always be set in
13472 C<*ckflags_p>, regardless of the check function's recorded requirements.
13473 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13474 indicates the caller knows about the possibility of passing something
13475 other than a GV as C<namegv>, and accordingly the corresponding bit may
13476 be either set or clear in C<*ckflags_p>, indicating the check function's
13477 recorded requirements.
13479 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13480 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13481 (for which see above). All other bits should be clear.
13483 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13485 The original form of L</cv_get_call_checker_flags>, which does not return
13486 checker flags. When using a checker function returned by this function,
13487 it is only safe to call it with a genuine GV as its C<namegv> argument.
13493 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13494 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13497 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13498 PERL_UNUSED_CONTEXT;
13499 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13501 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13502 *ckobj_p = callmg->mg_obj;
13503 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13505 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13506 *ckobj_p = (SV*)cv;
13507 *ckflags_p = gflags & MGf_REQUIRE_GV;
13512 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13515 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13516 PERL_UNUSED_CONTEXT;
13517 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13522 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13524 Sets the function that will be used to fix up a call to C<cv>.
13525 Specifically, the function is applied to an C<entersub> op tree for a
13526 subroutine call, not marked with C<&>, where the callee can be identified
13527 at compile time as C<cv>.
13529 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13530 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13531 The function should be defined like this:
13533 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13535 It is intended to be called in this manner:
13537 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13539 In this call, C<entersubop> is a pointer to the C<entersub> op,
13540 which may be replaced by the check function, and C<namegv> supplies
13541 the name that should be used by the check function to refer
13542 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13543 It is permitted to apply the check function in non-standard situations,
13544 such as to a call to a different subroutine or to a method call.
13546 C<namegv> may not actually be a GV. For efficiency, perl may pass a
13547 CV or other SV instead. Whatever is passed can be used as the first
13548 argument to L</cv_name>. You can force perl to pass a GV by including
13549 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13551 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13552 bit currently has a defined meaning (for which see above). All other
13553 bits should be clear.
13555 The current setting for a particular CV can be retrieved by
13556 L</cv_get_call_checker_flags>.
13558 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13560 The original form of L</cv_set_call_checker_flags>, which passes it the
13561 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
13562 of that flag setting is that the check function is guaranteed to get a
13563 genuine GV as its C<namegv> argument.
13569 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13571 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13572 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13576 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13577 SV *ckobj, U32 ckflags)
13579 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13580 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13581 if (SvMAGICAL((SV*)cv))
13582 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13585 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13586 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13588 if (callmg->mg_flags & MGf_REFCOUNTED) {
13589 SvREFCNT_dec(callmg->mg_obj);
13590 callmg->mg_flags &= ~MGf_REFCOUNTED;
13592 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13593 callmg->mg_obj = ckobj;
13594 if (ckobj != (SV*)cv) {
13595 SvREFCNT_inc_simple_void_NN(ckobj);
13596 callmg->mg_flags |= MGf_REFCOUNTED;
13598 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13599 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13604 S_entersub_alloc_targ(pTHX_ OP * const o)
13606 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13607 o->op_private |= OPpENTERSUB_HASTARG;
13611 Perl_ck_subr(pTHX_ OP *o)
13616 SV **const_class = NULL;
13618 PERL_ARGS_ASSERT_CK_SUBR;
13620 aop = cUNOPx(o)->op_first;
13621 if (!OpHAS_SIBLING(aop))
13622 aop = cUNOPx(aop)->op_first;
13623 aop = OpSIBLING(aop);
13624 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13625 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13626 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13628 o->op_private &= ~1;
13629 o->op_private |= (PL_hints & HINT_STRICT_REFS);
13630 if (PERLDB_SUB && PL_curstash != PL_debstash)
13631 o->op_private |= OPpENTERSUB_DB;
13632 switch (cvop->op_type) {
13634 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13638 case OP_METHOD_NAMED:
13639 case OP_METHOD_SUPER:
13640 case OP_METHOD_REDIR:
13641 case OP_METHOD_REDIR_SUPER:
13642 o->op_flags |= OPf_REF;
13643 if (aop->op_type == OP_CONST) {
13644 aop->op_private &= ~OPpCONST_STRICT;
13645 const_class = &cSVOPx(aop)->op_sv;
13647 else if (aop->op_type == OP_LIST) {
13648 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13649 if (sib && sib->op_type == OP_CONST) {
13650 sib->op_private &= ~OPpCONST_STRICT;
13651 const_class = &cSVOPx(sib)->op_sv;
13654 /* make class name a shared cow string to speedup method calls */
13655 /* constant string might be replaced with object, f.e. bigint */
13656 if (const_class && SvPOK(*const_class)) {
13658 const char* str = SvPV(*const_class, len);
13660 SV* const shared = newSVpvn_share(
13661 str, SvUTF8(*const_class)
13662 ? -(SSize_t)len : (SSize_t)len,
13665 if (SvREADONLY(*const_class))
13666 SvREADONLY_on(shared);
13667 SvREFCNT_dec(*const_class);
13668 *const_class = shared;
13675 S_entersub_alloc_targ(aTHX_ o);
13676 return ck_entersub_args_list(o);
13678 Perl_call_checker ckfun;
13681 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13682 if (CvISXSUB(cv) || !CvROOT(cv))
13683 S_entersub_alloc_targ(aTHX_ o);
13685 /* The original call checker API guarantees that a GV will be
13686 be provided with the right name. So, if the old API was
13687 used (or the REQUIRE_GV flag was passed), we have to reify
13688 the CV’s GV, unless this is an anonymous sub. This is not
13689 ideal for lexical subs, as its stringification will include
13690 the package. But it is the best we can do. */
13691 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13692 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13695 else namegv = MUTABLE_GV(cv);
13696 /* After a syntax error in a lexical sub, the cv that
13697 rv2cv_op_cv returns may be a nameless stub. */
13698 if (!namegv) return ck_entersub_args_list(o);
13701 return ckfun(aTHX_ o, namegv, ckobj);
13706 Perl_ck_svconst(pTHX_ OP *o)
13708 SV * const sv = cSVOPo->op_sv;
13709 PERL_ARGS_ASSERT_CK_SVCONST;
13710 PERL_UNUSED_CONTEXT;
13711 #ifdef PERL_COPY_ON_WRITE
13712 /* Since the read-only flag may be used to protect a string buffer, we
13713 cannot do copy-on-write with existing read-only scalars that are not
13714 already copy-on-write scalars. To allow $_ = "hello" to do COW with
13715 that constant, mark the constant as COWable here, if it is not
13716 already read-only. */
13717 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13720 # ifdef PERL_DEBUG_READONLY_COW
13730 Perl_ck_trunc(pTHX_ OP *o)
13732 PERL_ARGS_ASSERT_CK_TRUNC;
13734 if (o->op_flags & OPf_KIDS) {
13735 SVOP *kid = (SVOP*)cUNOPo->op_first;
13737 if (kid->op_type == OP_NULL)
13738 kid = (SVOP*)OpSIBLING(kid);
13739 if (kid && kid->op_type == OP_CONST &&
13740 (kid->op_private & OPpCONST_BARE) &&
13743 o->op_flags |= OPf_SPECIAL;
13744 kid->op_private &= ~OPpCONST_STRICT;
13751 Perl_ck_substr(pTHX_ OP *o)
13753 PERL_ARGS_ASSERT_CK_SUBSTR;
13756 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13757 OP *kid = cLISTOPo->op_first;
13759 if (kid->op_type == OP_NULL)
13760 kid = OpSIBLING(kid);
13762 /* Historically, substr(delete $foo{bar},...) has been allowed
13763 with 4-arg substr. Keep it working by applying entersub
13765 op_lvalue(kid, OP_ENTERSUB);
13772 Perl_ck_tell(pTHX_ OP *o)
13774 PERL_ARGS_ASSERT_CK_TELL;
13776 if (o->op_flags & OPf_KIDS) {
13777 OP *kid = cLISTOPo->op_first;
13778 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13779 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13785 Perl_ck_each(pTHX_ OP *o)
13788 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13789 const unsigned orig_type = o->op_type;
13791 PERL_ARGS_ASSERT_CK_EACH;
13794 switch (kid->op_type) {
13800 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13801 : orig_type == OP_KEYS ? OP_AKEYS
13805 if (kid->op_private == OPpCONST_BARE
13806 || !SvROK(cSVOPx_sv(kid))
13807 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13808 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
13813 qerror(Perl_mess(aTHX_
13814 "Experimental %s on scalar is now forbidden",
13815 PL_op_desc[orig_type]));
13817 bad_type_pv(1, "hash or array", o, kid);
13825 Perl_ck_length(pTHX_ OP *o)
13827 PERL_ARGS_ASSERT_CK_LENGTH;
13831 if (ckWARN(WARN_SYNTAX)) {
13832 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13836 const bool hash = kid->op_type == OP_PADHV
13837 || kid->op_type == OP_RV2HV;
13838 switch (kid->op_type) {
13843 name = S_op_varname(aTHX_ kid);
13849 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13850 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13852 SVfARG(name), hash ? "keys " : "", SVfARG(name)
13855 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13856 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13857 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13859 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13860 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13861 "length() used on @array (did you mean \"scalar(@array)\"?)");
13871 ---------------------------------------------------------
13873 Common vars in list assignment
13875 There now follows some enums and static functions for detecting
13876 common variables in list assignments. Here is a little essay I wrote
13877 for myself when trying to get my head around this. DAPM.
13881 First some random observations:
13883 * If a lexical var is an alias of something else, e.g.
13884 for my $x ($lex, $pkg, $a[0]) {...}
13885 then the act of aliasing will increase the reference count of the SV
13887 * If a package var is an alias of something else, it may still have a
13888 reference count of 1, depending on how the alias was created, e.g.
13889 in *a = *b, $a may have a refcount of 1 since the GP is shared
13890 with a single GvSV pointer to the SV. So If it's an alias of another
13891 package var, then RC may be 1; if it's an alias of another scalar, e.g.
13892 a lexical var or an array element, then it will have RC > 1.
13894 * There are many ways to create a package alias; ultimately, XS code
13895 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
13896 run-time tracing mechanisms are unlikely to be able to catch all cases.
13898 * When the LHS is all my declarations, the same vars can't appear directly
13899 on the RHS, but they can indirectly via closures, aliasing and lvalue
13900 subs. But those techniques all involve an increase in the lexical
13901 scalar's ref count.
13903 * When the LHS is all lexical vars (but not necessarily my declarations),
13904 it is possible for the same lexicals to appear directly on the RHS, and
13905 without an increased ref count, since the stack isn't refcounted.
13906 This case can be detected at compile time by scanning for common lex
13907 vars with PL_generation.
13909 * lvalue subs defeat common var detection, but they do at least
13910 return vars with a temporary ref count increment. Also, you can't
13911 tell at compile time whether a sub call is lvalue.
13916 A: There are a few circumstances where there definitely can't be any
13919 LHS empty: () = (...);
13920 RHS empty: (....) = ();
13921 RHS contains only constants or other 'can't possibly be shared'
13922 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
13923 i.e. they only contain ops not marked as dangerous, whose children
13924 are also not dangerous;
13926 LHS contains a single scalar element: e.g. ($x) = (....); because
13927 after $x has been modified, it won't be used again on the RHS;
13928 RHS contains a single element with no aggregate on LHS: e.g.
13929 ($a,$b,$c) = ($x); again, once $a has been modified, its value
13930 won't be used again.
13932 B: If LHS are all 'my' lexical var declarations (or safe ops, which
13935 my ($a, $b, @c) = ...;
13937 Due to closure and goto tricks, these vars may already have content.
13938 For the same reason, an element on the RHS may be a lexical or package
13939 alias of one of the vars on the left, or share common elements, for
13942 my ($x,$y) = f(); # $x and $y on both sides
13943 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
13948 my @a = @$ra; # elements of @a on both sides
13949 sub f { @a = 1..4; \@a }
13952 First, just consider scalar vars on LHS:
13954 RHS is safe only if (A), or in addition,
13955 * contains only lexical *scalar* vars, where neither side's
13956 lexicals have been flagged as aliases
13958 If RHS is not safe, then it's always legal to check LHS vars for
13959 RC==1, since the only RHS aliases will always be associated
13962 Note that in particular, RHS is not safe if:
13964 * it contains package scalar vars; e.g.:
13967 my ($x, $y) = (2, $x_alias);
13968 sub f { $x = 1; *x_alias = \$x; }
13970 * It contains other general elements, such as flattened or
13971 * spliced or single array or hash elements, e.g.
13974 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
13978 use feature 'refaliasing';
13979 \($a[0], $a[1]) = \($y,$x);
13982 It doesn't matter if the array/hash is lexical or package.
13984 * it contains a function call that happens to be an lvalue
13985 sub which returns one or more of the above, e.g.
13996 (so a sub call on the RHS should be treated the same
13997 as having a package var on the RHS).
13999 * any other "dangerous" thing, such an op or built-in that
14000 returns one of the above, e.g. pp_preinc
14003 If RHS is not safe, what we can do however is at compile time flag
14004 that the LHS are all my declarations, and at run time check whether
14005 all the LHS have RC == 1, and if so skip the full scan.
14007 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14009 Here the issue is whether there can be elements of @a on the RHS
14010 which will get prematurely freed when @a is cleared prior to
14011 assignment. This is only a problem if the aliasing mechanism
14012 is one which doesn't increase the refcount - only if RC == 1
14013 will the RHS element be prematurely freed.
14015 Because the array/hash is being INTROed, it or its elements
14016 can't directly appear on the RHS:
14018 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14020 but can indirectly, e.g.:
14024 sub f { @a = 1..3; \@a }
14026 So if the RHS isn't safe as defined by (A), we must always
14027 mortalise and bump the ref count of any remaining RHS elements
14028 when assigning to a non-empty LHS aggregate.
14030 Lexical scalars on the RHS aren't safe if they've been involved in
14033 use feature 'refaliasing';
14036 \(my $lex) = \$pkg;
14037 my @a = ($lex,3); # equivalent to ($a[0],3)
14044 Similarly with lexical arrays and hashes on the RHS:
14058 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14059 my $a; ($a, my $b) = (....);
14061 The difference between (B) and (C) is that it is now physically
14062 possible for the LHS vars to appear on the RHS too, where they
14063 are not reference counted; but in this case, the compile-time
14064 PL_generation sweep will detect such common vars.
14066 So the rules for (C) differ from (B) in that if common vars are
14067 detected, the runtime "test RC==1" optimisation can no longer be used,
14068 and a full mark and sweep is required
14070 D: As (C), but in addition the LHS may contain package vars.
14072 Since package vars can be aliased without a corresponding refcount
14073 increase, all bets are off. It's only safe if (A). E.g.
14075 my ($x, $y) = (1,2);
14077 for $x_alias ($x) {
14078 ($x_alias, $y) = (3, $x); # whoops
14081 Ditto for LHS aggregate package vars.
14083 E: Any other dangerous ops on LHS, e.g.
14084 (f(), $a[0], @$r) = (...);
14086 this is similar to (E) in that all bets are off. In addition, it's
14087 impossible to determine at compile time whether the LHS
14088 contains a scalar or an aggregate, e.g.
14090 sub f : lvalue { @a }
14093 * ---------------------------------------------------------
14097 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14098 * that at least one of the things flagged was seen.
14102 AAS_MY_SCALAR = 0x001, /* my $scalar */
14103 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
14104 AAS_LEX_SCALAR = 0x004, /* $lexical */
14105 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
14106 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14107 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
14108 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
14109 AAS_DANGEROUS = 0x080, /* an op (other than the above)
14110 that's flagged OA_DANGEROUS */
14111 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
14112 not in any of the categories above */
14113 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
14118 /* helper function for S_aassign_scan().
14119 * check a PAD-related op for commonality and/or set its generation number.
14120 * Returns a boolean indicating whether its shared */
14123 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14125 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14126 /* lexical used in aliasing */
14130 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14132 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14139 Helper function for OPpASSIGN_COMMON* detection in rpeep().
14140 It scans the left or right hand subtree of the aassign op, and returns a
14141 set of flags indicating what sorts of things it found there.
14142 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14143 set PL_generation on lexical vars; if the latter, we see if
14144 PL_generation matches.
14145 'top' indicates whether we're recursing or at the top level.
14146 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14147 This fn will increment it by the number seen. It's not intended to
14148 be an accurate count (especially as many ops can push a variable
14149 number of SVs onto the stack); rather it's used as to test whether there
14150 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14154 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14157 bool kid_top = FALSE;
14159 /* first, look for a solitary @_ on the RHS */
14162 && (o->op_flags & OPf_KIDS)
14163 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14165 OP *kid = cUNOPo->op_first;
14166 if ( ( kid->op_type == OP_PUSHMARK
14167 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14168 && ((kid = OpSIBLING(kid)))
14169 && !OpHAS_SIBLING(kid)
14170 && kid->op_type == OP_RV2AV
14171 && !(kid->op_flags & OPf_REF)
14172 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14173 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14174 && ((kid = cUNOPx(kid)->op_first))
14175 && kid->op_type == OP_GV
14176 && cGVOPx_gv(kid) == PL_defgv
14178 flags |= AAS_DEFAV;
14181 switch (o->op_type) {
14184 return AAS_PKG_SCALAR;
14189 /* if !top, could be e.g. @a[0,1] */
14190 if (top && (o->op_flags & OPf_REF))
14191 return (o->op_private & OPpLVAL_INTRO)
14192 ? AAS_MY_AGG : AAS_LEX_AGG;
14193 return AAS_DANGEROUS;
14197 int comm = S_aassign_padcheck(aTHX_ o, rhs)
14198 ? AAS_LEX_SCALAR_COMM : 0;
14200 return (o->op_private & OPpLVAL_INTRO)
14201 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14207 if (cUNOPx(o)->op_first->op_type != OP_GV)
14208 return AAS_DANGEROUS; /* @{expr}, %{expr} */
14210 /* if !top, could be e.g. @a[0,1] */
14211 if (top && (o->op_flags & OPf_REF))
14212 return AAS_PKG_AGG;
14213 return AAS_DANGEROUS;
14217 if (cUNOPx(o)->op_first->op_type != OP_GV) {
14219 return AAS_DANGEROUS; /* ${expr} */
14221 return AAS_PKG_SCALAR; /* $pkg */
14224 if (o->op_private & OPpSPLIT_ASSIGN) {
14225 /* the assign in @a = split() has been optimised away
14226 * and the @a attached directly to the split op
14227 * Treat the array as appearing on the RHS, i.e.
14228 * ... = (@a = split)
14233 if (o->op_flags & OPf_STACKED)
14234 /* @{expr} = split() - the array expression is tacked
14235 * on as an extra child to split - process kid */
14236 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14239 /* ... else array is directly attached to split op */
14241 if (PL_op->op_private & OPpSPLIT_LEX)
14242 return (o->op_private & OPpLVAL_INTRO)
14243 ? AAS_MY_AGG : AAS_LEX_AGG;
14245 return AAS_PKG_AGG;
14248 /* other args of split can't be returned */
14249 return AAS_SAFE_SCALAR;
14252 /* undef counts as a scalar on the RHS:
14253 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
14254 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
14258 flags = AAS_SAFE_SCALAR;
14263 /* these are all no-ops; they don't push a potentially common SV
14264 * onto the stack, so they are neither AAS_DANGEROUS nor
14265 * AAS_SAFE_SCALAR */
14268 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14273 /* these do nothing but may have children; but their children
14274 * should also be treated as top-level */
14279 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14281 flags = AAS_DANGEROUS;
14285 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
14286 && (o->op_private & OPpTARGET_MY))
14289 return S_aassign_padcheck(aTHX_ o, rhs)
14290 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14293 /* if its an unrecognised, non-dangerous op, assume that it
14294 * it the cause of at least one safe scalar */
14296 flags = AAS_SAFE_SCALAR;
14300 /* XXX this assumes that all other ops are "transparent" - i.e. that
14301 * they can return some of their children. While this true for e.g.
14302 * sort and grep, it's not true for e.g. map. We really need a
14303 * 'transparent' flag added to regen/opcodes
14305 if (o->op_flags & OPf_KIDS) {
14307 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14308 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14314 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14315 and modify the optree to make them work inplace */
14318 S_inplace_aassign(pTHX_ OP *o) {
14320 OP *modop, *modop_pushmark;
14322 OP *oleft, *oleft_pushmark;
14324 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14326 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14328 assert(cUNOPo->op_first->op_type == OP_NULL);
14329 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14330 assert(modop_pushmark->op_type == OP_PUSHMARK);
14331 modop = OpSIBLING(modop_pushmark);
14333 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14336 /* no other operation except sort/reverse */
14337 if (OpHAS_SIBLING(modop))
14340 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14341 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14343 if (modop->op_flags & OPf_STACKED) {
14344 /* skip sort subroutine/block */
14345 assert(oright->op_type == OP_NULL);
14346 oright = OpSIBLING(oright);
14349 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14350 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14351 assert(oleft_pushmark->op_type == OP_PUSHMARK);
14352 oleft = OpSIBLING(oleft_pushmark);
14354 /* Check the lhs is an array */
14356 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14357 || OpHAS_SIBLING(oleft)
14358 || (oleft->op_private & OPpLVAL_INTRO)
14362 /* Only one thing on the rhs */
14363 if (OpHAS_SIBLING(oright))
14366 /* check the array is the same on both sides */
14367 if (oleft->op_type == OP_RV2AV) {
14368 if (oright->op_type != OP_RV2AV
14369 || !cUNOPx(oright)->op_first
14370 || cUNOPx(oright)->op_first->op_type != OP_GV
14371 || cUNOPx(oleft )->op_first->op_type != OP_GV
14372 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14373 cGVOPx_gv(cUNOPx(oright)->op_first)
14377 else if (oright->op_type != OP_PADAV
14378 || oright->op_targ != oleft->op_targ
14382 /* This actually is an inplace assignment */
14384 modop->op_private |= OPpSORT_INPLACE;
14386 /* transfer MODishness etc from LHS arg to RHS arg */
14387 oright->op_flags = oleft->op_flags;
14389 /* remove the aassign op and the lhs */
14391 op_null(oleft_pushmark);
14392 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14393 op_null(cUNOPx(oleft)->op_first);
14399 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14400 * that potentially represent a series of one or more aggregate derefs
14401 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14402 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14403 * additional ops left in too).
14405 * The caller will have already verified that the first few ops in the
14406 * chain following 'start' indicate a multideref candidate, and will have
14407 * set 'orig_o' to the point further on in the chain where the first index
14408 * expression (if any) begins. 'orig_action' specifies what type of
14409 * beginning has already been determined by the ops between start..orig_o
14410 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
14412 * 'hints' contains any hints flags that need adding (currently just
14413 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14417 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14421 UNOP_AUX_item *arg_buf = NULL;
14422 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
14423 int index_skip = -1; /* don't output index arg on this action */
14425 /* similar to regex compiling, do two passes; the first pass
14426 * determines whether the op chain is convertible and calculates the
14427 * buffer size; the second pass populates the buffer and makes any
14428 * changes necessary to ops (such as moving consts to the pad on
14429 * threaded builds).
14431 * NB: for things like Coverity, note that both passes take the same
14432 * path through the logic tree (except for 'if (pass)' bits), since
14433 * both passes are following the same op_next chain; and in
14434 * particular, if it would return early on the second pass, it would
14435 * already have returned early on the first pass.
14437 for (pass = 0; pass < 2; pass++) {
14439 UV action = orig_action;
14440 OP *first_elem_op = NULL; /* first seen aelem/helem */
14441 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
14442 int action_count = 0; /* number of actions seen so far */
14443 int action_ix = 0; /* action_count % (actions per IV) */
14444 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
14445 bool is_last = FALSE; /* no more derefs to follow */
14446 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14447 UNOP_AUX_item *arg = arg_buf;
14448 UNOP_AUX_item *action_ptr = arg_buf;
14451 action_ptr->uv = 0;
14455 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14456 case MDEREF_HV_gvhv_helem:
14457 next_is_hash = TRUE;
14459 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14460 case MDEREF_AV_gvav_aelem:
14462 #ifdef USE_ITHREADS
14463 arg->pad_offset = cPADOPx(start)->op_padix;
14464 /* stop it being swiped when nulled */
14465 cPADOPx(start)->op_padix = 0;
14467 arg->sv = cSVOPx(start)->op_sv;
14468 cSVOPx(start)->op_sv = NULL;
14474 case MDEREF_HV_padhv_helem:
14475 case MDEREF_HV_padsv_vivify_rv2hv_helem:
14476 next_is_hash = TRUE;
14478 case MDEREF_AV_padav_aelem:
14479 case MDEREF_AV_padsv_vivify_rv2av_aelem:
14481 arg->pad_offset = start->op_targ;
14482 /* we skip setting op_targ = 0 for now, since the intact
14483 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14484 reset_start_targ = TRUE;
14489 case MDEREF_HV_pop_rv2hv_helem:
14490 next_is_hash = TRUE;
14492 case MDEREF_AV_pop_rv2av_aelem:
14496 NOT_REACHED; /* NOTREACHED */
14501 /* look for another (rv2av/hv; get index;
14502 * aelem/helem/exists/delele) sequence */
14507 UV index_type = MDEREF_INDEX_none;
14509 if (action_count) {
14510 /* if this is not the first lookup, consume the rv2av/hv */
14512 /* for N levels of aggregate lookup, we normally expect
14513 * that the first N-1 [ah]elem ops will be flagged as
14514 * /DEREF (so they autovivifiy if necessary), and the last
14515 * lookup op not to be.
14516 * For other things (like @{$h{k1}{k2}}) extra scope or
14517 * leave ops can appear, so abandon the effort in that
14519 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14522 /* rv2av or rv2hv sKR/1 */
14524 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14525 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14526 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14529 /* at this point, we wouldn't expect any of these
14530 * possible private flags:
14531 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14532 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14534 ASSUME(!(o->op_private &
14535 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14537 hints = (o->op_private & OPpHINT_STRICT_REFS);
14539 /* make sure the type of the previous /DEREF matches the
14540 * type of the next lookup */
14541 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14544 action = next_is_hash
14545 ? MDEREF_HV_vivify_rv2hv_helem
14546 : MDEREF_AV_vivify_rv2av_aelem;
14550 /* if this is the second pass, and we're at the depth where
14551 * previously we encountered a non-simple index expression,
14552 * stop processing the index at this point */
14553 if (action_count != index_skip) {
14555 /* look for one or more simple ops that return an array
14556 * index or hash key */
14558 switch (o->op_type) {
14560 /* it may be a lexical var index */
14561 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14562 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14563 ASSUME(!(o->op_private &
14564 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14566 if ( OP_GIMME(o,0) == G_SCALAR
14567 && !(o->op_flags & (OPf_REF|OPf_MOD))
14568 && o->op_private == 0)
14571 arg->pad_offset = o->op_targ;
14573 index_type = MDEREF_INDEX_padsv;
14579 if (next_is_hash) {
14580 /* it's a constant hash index */
14581 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14582 /* "use constant foo => FOO; $h{+foo}" for
14583 * some weird FOO, can leave you with constants
14584 * that aren't simple strings. It's not worth
14585 * the extra hassle for those edge cases */
14590 OP * helem_op = o->op_next;
14592 ASSUME( helem_op->op_type == OP_HELEM
14593 || helem_op->op_type == OP_NULL);
14594 if (helem_op->op_type == OP_HELEM) {
14595 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14596 if ( helem_op->op_private & OPpLVAL_INTRO
14597 || rop->op_type != OP_RV2HV
14601 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
14603 #ifdef USE_ITHREADS
14604 /* Relocate sv to the pad for thread safety */
14605 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14606 arg->pad_offset = o->op_targ;
14609 arg->sv = cSVOPx_sv(o);
14614 /* it's a constant array index */
14616 SV *ix_sv = cSVOPo->op_sv;
14621 if ( action_count == 0
14624 && ( action == MDEREF_AV_padav_aelem
14625 || action == MDEREF_AV_gvav_aelem)
14627 maybe_aelemfast = TRUE;
14631 SvREFCNT_dec_NN(cSVOPo->op_sv);
14635 /* we've taken ownership of the SV */
14636 cSVOPo->op_sv = NULL;
14638 index_type = MDEREF_INDEX_const;
14643 /* it may be a package var index */
14645 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14646 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14647 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14648 || o->op_private != 0
14653 if (kid->op_type != OP_RV2SV)
14656 ASSUME(!(kid->op_flags &
14657 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14658 |OPf_SPECIAL|OPf_PARENS)));
14659 ASSUME(!(kid->op_private &
14661 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14662 |OPpDEREF|OPpLVAL_INTRO)));
14663 if( (kid->op_flags &~ OPf_PARENS)
14664 != (OPf_WANT_SCALAR|OPf_KIDS)
14665 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14670 #ifdef USE_ITHREADS
14671 arg->pad_offset = cPADOPx(o)->op_padix;
14672 /* stop it being swiped when nulled */
14673 cPADOPx(o)->op_padix = 0;
14675 arg->sv = cSVOPx(o)->op_sv;
14676 cSVOPo->op_sv = NULL;
14680 index_type = MDEREF_INDEX_gvsv;
14685 } /* action_count != index_skip */
14687 action |= index_type;
14690 /* at this point we have either:
14691 * * detected what looks like a simple index expression,
14692 * and expect the next op to be an [ah]elem, or
14693 * an nulled [ah]elem followed by a delete or exists;
14694 * * found a more complex expression, so something other
14695 * than the above follows.
14698 /* possibly an optimised away [ah]elem (where op_next is
14699 * exists or delete) */
14700 if (o->op_type == OP_NULL)
14703 /* at this point we're looking for an OP_AELEM, OP_HELEM,
14704 * OP_EXISTS or OP_DELETE */
14706 /* if something like arybase (a.k.a $[ ) is in scope,
14707 * abandon optimisation attempt */
14708 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14709 && PL_check[o->op_type] != Perl_ck_null)
14711 /* similarly for customised exists and delete */
14712 if ( (o->op_type == OP_EXISTS)
14713 && PL_check[o->op_type] != Perl_ck_exists)
14715 if ( (o->op_type == OP_DELETE)
14716 && PL_check[o->op_type] != Perl_ck_delete)
14719 if ( o->op_type != OP_AELEM
14720 || (o->op_private &
14721 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14723 maybe_aelemfast = FALSE;
14725 /* look for aelem/helem/exists/delete. If it's not the last elem
14726 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14727 * flags; if it's the last, then it mustn't have
14728 * OPpDEREF_AV/HV, but may have lots of other flags, like
14729 * OPpLVAL_INTRO etc
14732 if ( index_type == MDEREF_INDEX_none
14733 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
14734 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14738 /* we have aelem/helem/exists/delete with valid simple index */
14740 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14741 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
14742 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14744 /* This doesn't make much sense but is legal:
14745 * @{ local $x[0][0] } = 1
14746 * Since scope exit will undo the autovivification,
14747 * don't bother in the first place. The OP_LEAVE
14748 * assertion is in case there are other cases of both
14749 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14750 * exit that would undo the local - in which case this
14751 * block of code would need rethinking.
14753 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14755 OP *n = o->op_next;
14756 while (n && ( n->op_type == OP_NULL
14757 || n->op_type == OP_LIST))
14759 assert(n && n->op_type == OP_LEAVE);
14761 o->op_private &= ~OPpDEREF;
14766 ASSUME(!(o->op_flags &
14767 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14768 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14770 ok = (o->op_flags &~ OPf_PARENS)
14771 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14772 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14774 else if (o->op_type == OP_EXISTS) {
14775 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14776 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14777 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14778 ok = !(o->op_private & ~OPpARG1_MASK);
14780 else if (o->op_type == OP_DELETE) {
14781 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14782 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14783 ASSUME(!(o->op_private &
14784 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14785 /* don't handle slices or 'local delete'; the latter
14786 * is fairly rare, and has a complex runtime */
14787 ok = !(o->op_private & ~OPpARG1_MASK);
14788 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14789 /* skip handling run-tome error */
14790 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14793 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14794 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14795 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14796 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14797 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14798 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14803 if (!first_elem_op)
14807 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14812 action |= MDEREF_FLAG_last;
14816 /* at this point we have something that started
14817 * promisingly enough (with rv2av or whatever), but failed
14818 * to find a simple index followed by an
14819 * aelem/helem/exists/delete. If this is the first action,
14820 * give up; but if we've already seen at least one
14821 * aelem/helem, then keep them and add a new action with
14822 * MDEREF_INDEX_none, which causes it to do the vivify
14823 * from the end of the previous lookup, and do the deref,
14824 * but stop at that point. So $a[0][expr] will do one
14825 * av_fetch, vivify and deref, then continue executing at
14830 index_skip = action_count;
14831 action |= MDEREF_FLAG_last;
14832 if (index_type != MDEREF_INDEX_none)
14837 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14840 /* if there's no space for the next action, create a new slot
14841 * for it *before* we start adding args for that action */
14842 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14849 } /* while !is_last */
14857 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14858 if (index_skip == -1) {
14859 mderef->op_flags = o->op_flags
14860 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14861 if (o->op_type == OP_EXISTS)
14862 mderef->op_private = OPpMULTIDEREF_EXISTS;
14863 else if (o->op_type == OP_DELETE)
14864 mderef->op_private = OPpMULTIDEREF_DELETE;
14866 mderef->op_private = o->op_private
14867 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14869 /* accumulate strictness from every level (although I don't think
14870 * they can actually vary) */
14871 mderef->op_private |= hints;
14873 /* integrate the new multideref op into the optree and the
14876 * In general an op like aelem or helem has two child
14877 * sub-trees: the aggregate expression (a_expr) and the
14878 * index expression (i_expr):
14884 * The a_expr returns an AV or HV, while the i-expr returns an
14885 * index. In general a multideref replaces most or all of a
14886 * multi-level tree, e.g.
14902 * With multideref, all the i_exprs will be simple vars or
14903 * constants, except that i_expr1 may be arbitrary in the case
14904 * of MDEREF_INDEX_none.
14906 * The bottom-most a_expr will be either:
14907 * 1) a simple var (so padXv or gv+rv2Xv);
14908 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
14909 * so a simple var with an extra rv2Xv;
14910 * 3) or an arbitrary expression.
14912 * 'start', the first op in the execution chain, will point to
14913 * 1),2): the padXv or gv op;
14914 * 3): the rv2Xv which forms the last op in the a_expr
14915 * execution chain, and the top-most op in the a_expr
14918 * For all cases, the 'start' node is no longer required,
14919 * but we can't free it since one or more external nodes
14920 * may point to it. E.g. consider
14921 * $h{foo} = $a ? $b : $c
14922 * Here, both the op_next and op_other branches of the
14923 * cond_expr point to the gv[*h] of the hash expression, so
14924 * we can't free the 'start' op.
14926 * For expr->[...], we need to save the subtree containing the
14927 * expression; for the other cases, we just need to save the
14929 * So in all cases, we null the start op and keep it around by
14930 * making it the child of the multideref op; for the expr->
14931 * case, the expr will be a subtree of the start node.
14933 * So in the simple 1,2 case the optree above changes to
14939 * ex-gv (or ex-padxv)
14941 * with the op_next chain being
14943 * -> ex-gv -> multideref -> op-following-ex-exists ->
14945 * In the 3 case, we have
14958 * -> rest-of-a_expr subtree ->
14959 * ex-rv2xv -> multideref -> op-following-ex-exists ->
14962 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
14963 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
14964 * multideref attached as the child, e.g.
14970 * ex-rv2av - i_expr1
14978 /* if we free this op, don't free the pad entry */
14979 if (reset_start_targ)
14980 start->op_targ = 0;
14983 /* Cut the bit we need to save out of the tree and attach to
14984 * the multideref op, then free the rest of the tree */
14986 /* find parent of node to be detached (for use by splice) */
14988 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
14989 || orig_action == MDEREF_HV_pop_rv2hv_helem)
14991 /* there is an arbitrary expression preceding us, e.g.
14992 * expr->[..]? so we need to save the 'expr' subtree */
14993 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
14994 p = cUNOPx(p)->op_first;
14995 ASSUME( start->op_type == OP_RV2AV
14996 || start->op_type == OP_RV2HV);
14999 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15000 * above for exists/delete. */
15001 while ( (p->op_flags & OPf_KIDS)
15002 && cUNOPx(p)->op_first != start
15004 p = cUNOPx(p)->op_first;
15006 ASSUME(cUNOPx(p)->op_first == start);
15008 /* detach from main tree, and re-attach under the multideref */
15009 op_sibling_splice(mderef, NULL, 0,
15010 op_sibling_splice(p, NULL, 1, NULL));
15013 start->op_next = mderef;
15015 mderef->op_next = index_skip == -1 ? o->op_next : o;
15017 /* excise and free the original tree, and replace with
15018 * the multideref op */
15019 p = op_sibling_splice(top_op, NULL, -1, mderef);
15028 Size_t size = arg - arg_buf;
15030 if (maybe_aelemfast && action_count == 1)
15033 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15034 sizeof(UNOP_AUX_item) * (size + 1));
15035 /* for dumping etc: store the length in a hidden first slot;
15036 * we set the op_aux pointer to the second slot */
15037 arg_buf->uv = size;
15040 } /* for (pass = ...) */
15043 /* See if the ops following o are such that o will always be executed in
15044 * boolean context: that is, the SV which o pushes onto the stack will
15045 * only ever be consumed by later ops via SvTRUE(sv) or similar.
15046 * If so, set a suitable private flag on o. Normally this will be
15047 * bool_flag; but see below why maybe_flag is needed too.
15049 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15050 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15051 * already be taken, so you'll have to give that op two different flags.
15053 * More explanation of 'maybe_flag' and 'safe_and' parameters.
15054 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15055 * those underlying ops) short-circuit, which means that rather than
15056 * necessarily returning a truth value, they may return the LH argument,
15057 * which may not be boolean. For example in $x = (keys %h || -1), keys
15058 * should return a key count rather than a boolean, even though its
15059 * sort-of being used in boolean context.
15061 * So we only consider such logical ops to provide boolean context to
15062 * their LH argument if they themselves are in void or boolean context.
15063 * However, sometimes the context isn't known until run-time. In this
15064 * case the op is marked with the maybe_flag flag it.
15066 * Consider the following.
15068 * sub f { ....; if (%h) { .... } }
15070 * This is actually compiled as
15072 * sub f { ....; %h && do { .... } }
15074 * Here we won't know until runtime whether the final statement (and hence
15075 * the &&) is in void context and so is safe to return a boolean value.
15076 * So mark o with maybe_flag rather than the bool_flag.
15077 * Note that there is cost associated with determining context at runtime
15078 * (e.g. a call to block_gimme()), so it may not be worth setting (at
15079 * compile time) and testing (at runtime) maybe_flag if the scalar verses
15080 * boolean costs savings are marginal.
15082 * However, we can do slightly better with && (compared to || and //):
15083 * this op only returns its LH argument when that argument is false. In
15084 * this case, as long as the op promises to return a false value which is
15085 * valid in both boolean and scalar contexts, we can mark an op consumed
15086 * by && with bool_flag rather than maybe_flag.
15087 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15088 * than &PL_sv_no for a false result in boolean context, then it's safe. An
15089 * op which promises to handle this case is indicated by setting safe_and
15094 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15099 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15101 /* OPpTARGET_MY and boolean context probably don't mix well.
15102 * If someone finds a valid use case, maybe add an extra flag to this
15103 * function which indicates its safe to do so for this op? */
15104 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
15105 && (o->op_private & OPpTARGET_MY)));
15110 switch (lop->op_type) {
15115 /* these two consume the stack argument in the scalar case,
15116 * and treat it as a boolean in the non linenumber case */
15119 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15120 || (lop->op_private & OPpFLIP_LINENUM))
15126 /* these never leave the original value on the stack */
15135 /* OR DOR and AND evaluate their arg as a boolean, but then may
15136 * leave the original scalar value on the stack when following the
15137 * op_next route. If not in void context, we need to ensure
15138 * that whatever follows consumes the arg only in boolean context
15150 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15154 else if (!(lop->op_flags & OPf_WANT)) {
15155 /* unknown context - decide at runtime */
15167 lop = lop->op_next;
15170 o->op_private |= flag;
15175 /* mechanism for deferring recursion in rpeep() */
15177 #define MAX_DEFERRED 4
15181 if (defer_ix == (MAX_DEFERRED-1)) { \
15182 OP **defer = defer_queue[defer_base]; \
15183 CALL_RPEEP(*defer); \
15184 S_prune_chain_head(defer); \
15185 defer_base = (defer_base + 1) % MAX_DEFERRED; \
15188 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15191 #define IS_AND_OP(o) (o->op_type == OP_AND)
15192 #define IS_OR_OP(o) (o->op_type == OP_OR)
15195 /* A peephole optimizer. We visit the ops in the order they're to execute.
15196 * See the comments at the top of this file for more details about when
15197 * peep() is called */
15200 Perl_rpeep(pTHX_ OP *o)
15204 OP* oldoldop = NULL;
15205 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15206 int defer_base = 0;
15209 if (!o || o->op_opt)
15212 assert(o->op_type != OP_FREED);
15216 SAVEVPTR(PL_curcop);
15217 for (;; o = o->op_next) {
15218 if (o && o->op_opt)
15221 while (defer_ix >= 0) {
15223 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15224 CALL_RPEEP(*defer);
15225 S_prune_chain_head(defer);
15232 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15233 assert(!oldoldop || oldoldop->op_next == oldop);
15234 assert(!oldop || oldop->op_next == o);
15236 /* By default, this op has now been optimised. A couple of cases below
15237 clear this again. */
15241 /* look for a series of 1 or more aggregate derefs, e.g.
15242 * $a[1]{foo}[$i]{$k}
15243 * and replace with a single OP_MULTIDEREF op.
15244 * Each index must be either a const, or a simple variable,
15246 * First, look for likely combinations of starting ops,
15247 * corresponding to (global and lexical variants of)
15249 * $r->[...] $r->{...}
15250 * (preceding expression)->[...]
15251 * (preceding expression)->{...}
15252 * and if so, call maybe_multideref() to do a full inspection
15253 * of the op chain and if appropriate, replace with an
15261 switch (o2->op_type) {
15263 /* $pkg[..] : gv[*pkg]
15264 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
15266 /* Fail if there are new op flag combinations that we're
15267 * not aware of, rather than:
15268 * * silently failing to optimise, or
15269 * * silently optimising the flag away.
15270 * If this ASSUME starts failing, examine what new flag
15271 * has been added to the op, and decide whether the
15272 * optimisation should still occur with that flag, then
15273 * update the code accordingly. This applies to all the
15274 * other ASSUMEs in the block of code too.
15276 ASSUME(!(o2->op_flags &
15277 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15278 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15282 if (o2->op_type == OP_RV2AV) {
15283 action = MDEREF_AV_gvav_aelem;
15287 if (o2->op_type == OP_RV2HV) {
15288 action = MDEREF_HV_gvhv_helem;
15292 if (o2->op_type != OP_RV2SV)
15295 /* at this point we've seen gv,rv2sv, so the only valid
15296 * construct left is $pkg->[] or $pkg->{} */
15298 ASSUME(!(o2->op_flags & OPf_STACKED));
15299 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15300 != (OPf_WANT_SCALAR|OPf_MOD))
15303 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15304 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15305 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15307 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
15308 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15312 if (o2->op_type == OP_RV2AV) {
15313 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15316 if (o2->op_type == OP_RV2HV) {
15317 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15323 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15325 ASSUME(!(o2->op_flags &
15326 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15327 if ((o2->op_flags &
15328 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15329 != (OPf_WANT_SCALAR|OPf_MOD))
15332 ASSUME(!(o2->op_private &
15333 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15334 /* skip if state or intro, or not a deref */
15335 if ( o2->op_private != OPpDEREF_AV
15336 && o2->op_private != OPpDEREF_HV)
15340 if (o2->op_type == OP_RV2AV) {
15341 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15344 if (o2->op_type == OP_RV2HV) {
15345 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15352 /* $lex[..]: padav[@lex:1,2] sR *
15353 * or $lex{..}: padhv[%lex:1,2] sR */
15354 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15355 OPf_REF|OPf_SPECIAL)));
15356 if ((o2->op_flags &
15357 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15358 != (OPf_WANT_SCALAR|OPf_REF))
15360 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15362 /* OPf_PARENS isn't currently used in this case;
15363 * if that changes, let us know! */
15364 ASSUME(!(o2->op_flags & OPf_PARENS));
15366 /* at this point, we wouldn't expect any of the remaining
15367 * possible private flags:
15368 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15369 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15371 * OPpSLICEWARNING shouldn't affect runtime
15373 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15375 action = o2->op_type == OP_PADAV
15376 ? MDEREF_AV_padav_aelem
15377 : MDEREF_HV_padhv_helem;
15379 S_maybe_multideref(aTHX_ o, o2, action, 0);
15385 action = o2->op_type == OP_RV2AV
15386 ? MDEREF_AV_pop_rv2av_aelem
15387 : MDEREF_HV_pop_rv2hv_helem;
15390 /* (expr)->[...]: rv2av sKR/1;
15391 * (expr)->{...}: rv2hv sKR/1; */
15393 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15395 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15396 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15397 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15400 /* at this point, we wouldn't expect any of these
15401 * possible private flags:
15402 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15403 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15405 ASSUME(!(o2->op_private &
15406 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15408 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15412 S_maybe_multideref(aTHX_ o, o2, action, hints);
15421 switch (o->op_type) {
15423 PL_curcop = ((COP*)o); /* for warnings */
15426 PL_curcop = ((COP*)o); /* for warnings */
15428 /* Optimise a "return ..." at the end of a sub to just be "...".
15429 * This saves 2 ops. Before:
15430 * 1 <;> nextstate(main 1 -e:1) v ->2
15431 * 4 <@> return K ->5
15432 * 2 <0> pushmark s ->3
15433 * - <1> ex-rv2sv sK/1 ->4
15434 * 3 <#> gvsv[*cat] s ->4
15437 * - <@> return K ->-
15438 * - <0> pushmark s ->2
15439 * - <1> ex-rv2sv sK/1 ->-
15440 * 2 <$> gvsv(*cat) s ->3
15443 OP *next = o->op_next;
15444 OP *sibling = OpSIBLING(o);
15445 if ( OP_TYPE_IS(next, OP_PUSHMARK)
15446 && OP_TYPE_IS(sibling, OP_RETURN)
15447 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15448 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15449 ||OP_TYPE_IS(sibling->op_next->op_next,
15451 && cUNOPx(sibling)->op_first == next
15452 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15455 /* Look through the PUSHMARK's siblings for one that
15456 * points to the RETURN */
15457 OP *top = OpSIBLING(next);
15458 while (top && top->op_next) {
15459 if (top->op_next == sibling) {
15460 top->op_next = sibling->op_next;
15461 o->op_next = next->op_next;
15464 top = OpSIBLING(top);
15469 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15471 * This latter form is then suitable for conversion into padrange
15472 * later on. Convert:
15474 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15478 * nextstate1 -> listop -> nextstate3
15480 * pushmark -> padop1 -> padop2
15482 if (o->op_next && (
15483 o->op_next->op_type == OP_PADSV
15484 || o->op_next->op_type == OP_PADAV
15485 || o->op_next->op_type == OP_PADHV
15487 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15488 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15489 && o->op_next->op_next->op_next && (
15490 o->op_next->op_next->op_next->op_type == OP_PADSV
15491 || o->op_next->op_next->op_next->op_type == OP_PADAV
15492 || o->op_next->op_next->op_next->op_type == OP_PADHV
15494 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15495 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15496 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15497 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15499 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15502 ns2 = pad1->op_next;
15503 pad2 = ns2->op_next;
15504 ns3 = pad2->op_next;
15506 /* we assume here that the op_next chain is the same as
15507 * the op_sibling chain */
15508 assert(OpSIBLING(o) == pad1);
15509 assert(OpSIBLING(pad1) == ns2);
15510 assert(OpSIBLING(ns2) == pad2);
15511 assert(OpSIBLING(pad2) == ns3);
15513 /* excise and delete ns2 */
15514 op_sibling_splice(NULL, pad1, 1, NULL);
15517 /* excise pad1 and pad2 */
15518 op_sibling_splice(NULL, o, 2, NULL);
15520 /* create new listop, with children consisting of:
15521 * a new pushmark, pad1, pad2. */
15522 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15523 newop->op_flags |= OPf_PARENS;
15524 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15526 /* insert newop between o and ns3 */
15527 op_sibling_splice(NULL, o, 0, newop);
15529 /*fixup op_next chain */
15530 newpm = cUNOPx(newop)->op_first; /* pushmark */
15531 o ->op_next = newpm;
15532 newpm->op_next = pad1;
15533 pad1 ->op_next = pad2;
15534 pad2 ->op_next = newop; /* listop */
15535 newop->op_next = ns3;
15537 /* Ensure pushmark has this flag if padops do */
15538 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15539 newpm->op_flags |= OPf_MOD;
15545 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15546 to carry two labels. For now, take the easier option, and skip
15547 this optimisation if the first NEXTSTATE has a label. */
15548 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15549 OP *nextop = o->op_next;
15550 while (nextop && nextop->op_type == OP_NULL)
15551 nextop = nextop->op_next;
15553 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15556 oldop->op_next = nextop;
15558 /* Skip (old)oldop assignment since the current oldop's
15559 op_next already points to the next op. */
15566 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15567 if (o->op_next->op_private & OPpTARGET_MY) {
15568 if (o->op_flags & OPf_STACKED) /* chained concats */
15569 break; /* ignore_optimization */
15571 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15572 o->op_targ = o->op_next->op_targ;
15573 o->op_next->op_targ = 0;
15574 o->op_private |= OPpTARGET_MY;
15577 op_null(o->op_next);
15581 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15582 break; /* Scalar stub must produce undef. List stub is noop */
15586 if (o->op_targ == OP_NEXTSTATE
15587 || o->op_targ == OP_DBSTATE)
15589 PL_curcop = ((COP*)o);
15591 /* XXX: We avoid setting op_seq here to prevent later calls
15592 to rpeep() from mistakenly concluding that optimisation
15593 has already occurred. This doesn't fix the real problem,
15594 though (See 20010220.007 (#5874)). AMS 20010719 */
15595 /* op_seq functionality is now replaced by op_opt */
15603 oldop->op_next = o->op_next;
15617 convert repeat into a stub with no kids.
15619 if (o->op_next->op_type == OP_CONST
15620 || ( o->op_next->op_type == OP_PADSV
15621 && !(o->op_next->op_private & OPpLVAL_INTRO))
15622 || ( o->op_next->op_type == OP_GV
15623 && o->op_next->op_next->op_type == OP_RV2SV
15624 && !(o->op_next->op_next->op_private
15625 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15627 const OP *kid = o->op_next->op_next;
15628 if (o->op_next->op_type == OP_GV)
15629 kid = kid->op_next;
15630 /* kid is now the ex-list. */
15631 if (kid->op_type == OP_NULL
15632 && (kid = kid->op_next)->op_type == OP_CONST
15633 /* kid is now the repeat count. */
15634 && kid->op_next->op_type == OP_REPEAT
15635 && kid->op_next->op_private & OPpREPEAT_DOLIST
15636 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15637 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15640 o = kid->op_next; /* repeat */
15641 oldop->op_next = o;
15642 op_free(cBINOPo->op_first);
15643 op_free(cBINOPo->op_last );
15644 o->op_flags &=~ OPf_KIDS;
15645 /* stub is a baseop; repeat is a binop */
15646 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15647 OpTYPE_set(o, OP_STUB);
15653 /* Convert a series of PAD ops for my vars plus support into a
15654 * single padrange op. Basically
15656 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15658 * becomes, depending on circumstances, one of
15660 * padrange ----------------------------------> (list) -> rest
15661 * padrange --------------------------------------------> rest
15663 * where all the pad indexes are sequential and of the same type
15665 * We convert the pushmark into a padrange op, then skip
15666 * any other pad ops, and possibly some trailing ops.
15667 * Note that we don't null() the skipped ops, to make it
15668 * easier for Deparse to undo this optimisation (and none of
15669 * the skipped ops are holding any resourses). It also makes
15670 * it easier for find_uninit_var(), as it can just ignore
15671 * padrange, and examine the original pad ops.
15675 OP *followop = NULL; /* the op that will follow the padrange op */
15678 PADOFFSET base = 0; /* init only to stop compiler whining */
15679 bool gvoid = 0; /* init only to stop compiler whining */
15680 bool defav = 0; /* seen (...) = @_ */
15681 bool reuse = 0; /* reuse an existing padrange op */
15683 /* look for a pushmark -> gv[_] -> rv2av */
15688 if ( p->op_type == OP_GV
15689 && cGVOPx_gv(p) == PL_defgv
15690 && (rv2av = p->op_next)
15691 && rv2av->op_type == OP_RV2AV
15692 && !(rv2av->op_flags & OPf_REF)
15693 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15694 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15696 q = rv2av->op_next;
15697 if (q->op_type == OP_NULL)
15699 if (q->op_type == OP_PUSHMARK) {
15709 /* scan for PAD ops */
15711 for (p = p->op_next; p; p = p->op_next) {
15712 if (p->op_type == OP_NULL)
15715 if (( p->op_type != OP_PADSV
15716 && p->op_type != OP_PADAV
15717 && p->op_type != OP_PADHV
15719 /* any private flag other than INTRO? e.g. STATE */
15720 || (p->op_private & ~OPpLVAL_INTRO)
15724 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15726 if ( p->op_type == OP_PADAV
15728 && p->op_next->op_type == OP_CONST
15729 && p->op_next->op_next
15730 && p->op_next->op_next->op_type == OP_AELEM
15734 /* for 1st padop, note what type it is and the range
15735 * start; for the others, check that it's the same type
15736 * and that the targs are contiguous */
15738 intro = (p->op_private & OPpLVAL_INTRO);
15740 gvoid = OP_GIMME(p,0) == G_VOID;
15743 if ((p->op_private & OPpLVAL_INTRO) != intro)
15745 /* Note that you'd normally expect targs to be
15746 * contiguous in my($a,$b,$c), but that's not the case
15747 * when external modules start doing things, e.g.
15748 * Function::Parameters */
15749 if (p->op_targ != base + count)
15751 assert(p->op_targ == base + count);
15752 /* Either all the padops or none of the padops should
15753 be in void context. Since we only do the optimisa-
15754 tion for av/hv when the aggregate itself is pushed
15755 on to the stack (one item), there is no need to dis-
15756 tinguish list from scalar context. */
15757 if (gvoid != (OP_GIMME(p,0) == G_VOID))
15761 /* for AV, HV, only when we're not flattening */
15762 if ( p->op_type != OP_PADSV
15764 && !(p->op_flags & OPf_REF)
15768 if (count >= OPpPADRANGE_COUNTMASK)
15771 /* there's a biggest base we can fit into a
15772 * SAVEt_CLEARPADRANGE in pp_padrange.
15773 * (The sizeof() stuff will be constant-folded, and is
15774 * intended to avoid getting "comparison is always false"
15775 * compiler warnings. See the comments above
15776 * MEM_WRAP_CHECK for more explanation on why we do this
15777 * in a weird way to avoid compiler warnings.)
15780 && (8*sizeof(base) >
15781 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15783 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15785 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15789 /* Success! We've got another valid pad op to optimise away */
15791 followop = p->op_next;
15794 if (count < 1 || (count == 1 && !defav))
15797 /* pp_padrange in specifically compile-time void context
15798 * skips pushing a mark and lexicals; in all other contexts
15799 * (including unknown till runtime) it pushes a mark and the
15800 * lexicals. We must be very careful then, that the ops we
15801 * optimise away would have exactly the same effect as the
15803 * In particular in void context, we can only optimise to
15804 * a padrange if we see the complete sequence
15805 * pushmark, pad*v, ...., list
15806 * which has the net effect of leaving the markstack as it
15807 * was. Not pushing onto the stack (whereas padsv does touch
15808 * the stack) makes no difference in void context.
15812 if (followop->op_type == OP_LIST
15813 && OP_GIMME(followop,0) == G_VOID
15816 followop = followop->op_next; /* skip OP_LIST */
15818 /* consolidate two successive my(...);'s */
15821 && oldoldop->op_type == OP_PADRANGE
15822 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15823 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15824 && !(oldoldop->op_flags & OPf_SPECIAL)
15827 assert(oldoldop->op_next == oldop);
15828 assert( oldop->op_type == OP_NEXTSTATE
15829 || oldop->op_type == OP_DBSTATE);
15830 assert(oldop->op_next == o);
15833 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15835 /* Do not assume pad offsets for $c and $d are con-
15840 if ( oldoldop->op_targ + old_count == base
15841 && old_count < OPpPADRANGE_COUNTMASK - count) {
15842 base = oldoldop->op_targ;
15843 count += old_count;
15848 /* if there's any immediately following singleton
15849 * my var's; then swallow them and the associated
15851 * my ($a,$b); my $c; my $d;
15853 * my ($a,$b,$c,$d);
15856 while ( ((p = followop->op_next))
15857 && ( p->op_type == OP_PADSV
15858 || p->op_type == OP_PADAV
15859 || p->op_type == OP_PADHV)
15860 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15861 && (p->op_private & OPpLVAL_INTRO) == intro
15862 && !(p->op_private & ~OPpLVAL_INTRO)
15864 && ( p->op_next->op_type == OP_NEXTSTATE
15865 || p->op_next->op_type == OP_DBSTATE)
15866 && count < OPpPADRANGE_COUNTMASK
15867 && base + count == p->op_targ
15870 followop = p->op_next;
15878 assert(oldoldop->op_type == OP_PADRANGE);
15879 oldoldop->op_next = followop;
15880 oldoldop->op_private = (intro | count);
15886 /* Convert the pushmark into a padrange.
15887 * To make Deparse easier, we guarantee that a padrange was
15888 * *always* formerly a pushmark */
15889 assert(o->op_type == OP_PUSHMARK);
15890 o->op_next = followop;
15891 OpTYPE_set(o, OP_PADRANGE);
15893 /* bit 7: INTRO; bit 6..0: count */
15894 o->op_private = (intro | count);
15895 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
15896 | gvoid * OPf_WANT_VOID
15897 | (defav ? OPf_SPECIAL : 0));
15903 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15904 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15909 /*'keys %h' in void or scalar context: skip the OP_KEYS
15910 * and perform the functionality directly in the RV2HV/PADHV
15913 if (o->op_flags & OPf_REF) {
15914 OP *k = o->op_next;
15915 U8 want = (k->op_flags & OPf_WANT);
15917 && k->op_type == OP_KEYS
15918 && ( want == OPf_WANT_VOID
15919 || want == OPf_WANT_SCALAR)
15920 && !(k->op_private & OPpMAYBE_LVSUB)
15921 && !(k->op_flags & OPf_MOD)
15923 o->op_next = k->op_next;
15924 o->op_flags &= ~(OPf_REF|OPf_WANT);
15925 o->op_flags |= want;
15926 o->op_private |= (o->op_type == OP_PADHV ?
15927 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
15928 /* for keys(%lex), hold onto the OP_KEYS's targ
15929 * since padhv doesn't have its own targ to return
15931 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
15936 /* see if %h is used in boolean context */
15937 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15938 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
15941 if (o->op_type != OP_PADHV)
15945 if ( o->op_type == OP_PADAV
15946 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
15948 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15951 /* Skip over state($x) in void context. */
15952 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
15953 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
15955 oldop->op_next = o->op_next;
15956 goto redo_nextstate;
15958 if (o->op_type != OP_PADAV)
15962 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
15963 OP* const pop = (o->op_type == OP_PADAV) ?
15964 o->op_next : o->op_next->op_next;
15966 if (pop && pop->op_type == OP_CONST &&
15967 ((PL_op = pop->op_next)) &&
15968 pop->op_next->op_type == OP_AELEM &&
15969 !(pop->op_next->op_private &
15970 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
15971 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
15974 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
15975 no_bareword_allowed(pop);
15976 if (o->op_type == OP_GV)
15977 op_null(o->op_next);
15978 op_null(pop->op_next);
15980 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
15981 o->op_next = pop->op_next->op_next;
15982 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
15983 o->op_private = (U8)i;
15984 if (o->op_type == OP_GV) {
15987 o->op_type = OP_AELEMFAST;
15990 o->op_type = OP_AELEMFAST_LEX;
15992 if (o->op_type != OP_GV)
15996 /* Remove $foo from the op_next chain in void context. */
15998 && ( o->op_next->op_type == OP_RV2SV
15999 || o->op_next->op_type == OP_RV2AV
16000 || o->op_next->op_type == OP_RV2HV )
16001 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16002 && !(o->op_next->op_private & OPpLVAL_INTRO))
16004 oldop->op_next = o->op_next->op_next;
16005 /* Reprocess the previous op if it is a nextstate, to
16006 allow double-nextstate optimisation. */
16008 if (oldop->op_type == OP_NEXTSTATE) {
16015 o = oldop->op_next;
16018 else if (o->op_next->op_type == OP_RV2SV) {
16019 if (!(o->op_next->op_private & OPpDEREF)) {
16020 op_null(o->op_next);
16021 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16023 o->op_next = o->op_next->op_next;
16024 OpTYPE_set(o, OP_GVSV);
16027 else if (o->op_next->op_type == OP_READLINE
16028 && o->op_next->op_next->op_type == OP_CONCAT
16029 && (o->op_next->op_next->op_flags & OPf_STACKED))
16031 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16032 OpTYPE_set(o, OP_RCATLINE);
16033 o->op_flags |= OPf_STACKED;
16034 op_null(o->op_next->op_next);
16035 op_null(o->op_next);
16046 while (cLOGOP->op_other->op_type == OP_NULL)
16047 cLOGOP->op_other = cLOGOP->op_other->op_next;
16048 while (o->op_next && ( o->op_type == o->op_next->op_type
16049 || o->op_next->op_type == OP_NULL))
16050 o->op_next = o->op_next->op_next;
16052 /* If we're an OR and our next is an AND in void context, we'll
16053 follow its op_other on short circuit, same for reverse.
16054 We can't do this with OP_DOR since if it's true, its return
16055 value is the underlying value which must be evaluated
16059 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16060 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16062 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16064 o->op_next = ((LOGOP*)o->op_next)->op_other;
16066 DEFER(cLOGOP->op_other);
16071 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16072 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16081 case OP_ARGDEFELEM:
16082 while (cLOGOP->op_other->op_type == OP_NULL)
16083 cLOGOP->op_other = cLOGOP->op_other->op_next;
16084 DEFER(cLOGOP->op_other);
16089 while (cLOOP->op_redoop->op_type == OP_NULL)
16090 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16091 while (cLOOP->op_nextop->op_type == OP_NULL)
16092 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16093 while (cLOOP->op_lastop->op_type == OP_NULL)
16094 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16095 /* a while(1) loop doesn't have an op_next that escapes the
16096 * loop, so we have to explicitly follow the op_lastop to
16097 * process the rest of the code */
16098 DEFER(cLOOP->op_lastop);
16102 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16103 DEFER(cLOGOPo->op_other);
16107 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16108 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16109 assert(!(cPMOP->op_pmflags & PMf_ONCE));
16110 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16111 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16112 cPMOP->op_pmstashstartu.op_pmreplstart
16113 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16114 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16120 if (o->op_flags & OPf_SPECIAL) {
16121 /* first arg is a code block */
16122 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16123 OP * kid = cUNOPx(nullop)->op_first;
16125 assert(nullop->op_type == OP_NULL);
16126 assert(kid->op_type == OP_SCOPE
16127 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16128 /* since OP_SORT doesn't have a handy op_other-style
16129 * field that can point directly to the start of the code
16130 * block, store it in the otherwise-unused op_next field
16131 * of the top-level OP_NULL. This will be quicker at
16132 * run-time, and it will also allow us to remove leading
16133 * OP_NULLs by just messing with op_nexts without
16134 * altering the basic op_first/op_sibling layout. */
16135 kid = kLISTOP->op_first;
16137 (kid->op_type == OP_NULL
16138 && ( kid->op_targ == OP_NEXTSTATE
16139 || kid->op_targ == OP_DBSTATE ))
16140 || kid->op_type == OP_STUB
16141 || kid->op_type == OP_ENTER
16142 || (PL_parser && PL_parser->error_count));
16143 nullop->op_next = kid->op_next;
16144 DEFER(nullop->op_next);
16147 /* check that RHS of sort is a single plain array */
16148 oright = cUNOPo->op_first;
16149 if (!oright || oright->op_type != OP_PUSHMARK)
16152 if (o->op_private & OPpSORT_INPLACE)
16155 /* reverse sort ... can be optimised. */
16156 if (!OpHAS_SIBLING(cUNOPo)) {
16157 /* Nothing follows us on the list. */
16158 OP * const reverse = o->op_next;
16160 if (reverse->op_type == OP_REVERSE &&
16161 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16162 OP * const pushmark = cUNOPx(reverse)->op_first;
16163 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16164 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16165 /* reverse -> pushmark -> sort */
16166 o->op_private |= OPpSORT_REVERSE;
16168 pushmark->op_next = oright->op_next;
16178 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16180 LISTOP *enter, *exlist;
16182 if (o->op_private & OPpSORT_INPLACE)
16185 enter = (LISTOP *) o->op_next;
16188 if (enter->op_type == OP_NULL) {
16189 enter = (LISTOP *) enter->op_next;
16193 /* for $a (...) will have OP_GV then OP_RV2GV here.
16194 for (...) just has an OP_GV. */
16195 if (enter->op_type == OP_GV) {
16196 gvop = (OP *) enter;
16197 enter = (LISTOP *) enter->op_next;
16200 if (enter->op_type == OP_RV2GV) {
16201 enter = (LISTOP *) enter->op_next;
16207 if (enter->op_type != OP_ENTERITER)
16210 iter = enter->op_next;
16211 if (!iter || iter->op_type != OP_ITER)
16214 expushmark = enter->op_first;
16215 if (!expushmark || expushmark->op_type != OP_NULL
16216 || expushmark->op_targ != OP_PUSHMARK)
16219 exlist = (LISTOP *) OpSIBLING(expushmark);
16220 if (!exlist || exlist->op_type != OP_NULL
16221 || exlist->op_targ != OP_LIST)
16224 if (exlist->op_last != o) {
16225 /* Mmm. Was expecting to point back to this op. */
16228 theirmark = exlist->op_first;
16229 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16232 if (OpSIBLING(theirmark) != o) {
16233 /* There's something between the mark and the reverse, eg
16234 for (1, reverse (...))
16239 ourmark = ((LISTOP *)o)->op_first;
16240 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16243 ourlast = ((LISTOP *)o)->op_last;
16244 if (!ourlast || ourlast->op_next != o)
16247 rv2av = OpSIBLING(ourmark);
16248 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16249 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16250 /* We're just reversing a single array. */
16251 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16252 enter->op_flags |= OPf_STACKED;
16255 /* We don't have control over who points to theirmark, so sacrifice
16257 theirmark->op_next = ourmark->op_next;
16258 theirmark->op_flags = ourmark->op_flags;
16259 ourlast->op_next = gvop ? gvop : (OP *) enter;
16262 enter->op_private |= OPpITER_REVERSED;
16263 iter->op_private |= OPpITER_REVERSED;
16267 o = oldop->op_next;
16269 NOT_REACHED; /* NOTREACHED */
16275 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16276 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16281 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16282 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16285 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16287 sv = newRV((SV *)PL_compcv);
16291 OpTYPE_set(o, OP_CONST);
16292 o->op_flags |= OPf_SPECIAL;
16293 cSVOPo->op_sv = sv;
16298 if (OP_GIMME(o,0) == G_VOID
16299 || ( o->op_next->op_type == OP_LINESEQ
16300 && ( o->op_next->op_next->op_type == OP_LEAVESUB
16301 || ( o->op_next->op_next->op_type == OP_RETURN
16302 && !CvLVALUE(PL_compcv)))))
16304 OP *right = cBINOP->op_first;
16323 OP *left = OpSIBLING(right);
16324 if (left->op_type == OP_SUBSTR
16325 && (left->op_private & 7) < 4) {
16327 /* cut out right */
16328 op_sibling_splice(o, NULL, 1, NULL);
16329 /* and insert it as second child of OP_SUBSTR */
16330 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16332 left->op_private |= OPpSUBSTR_REPL_FIRST;
16334 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16341 int l, r, lr, lscalars, rscalars;
16343 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16344 Note that we do this now rather than in newASSIGNOP(),
16345 since only by now are aliased lexicals flagged as such
16347 See the essay "Common vars in list assignment" above for
16348 the full details of the rationale behind all the conditions
16351 PL_generation sorcery:
16352 To detect whether there are common vars, the global var
16353 PL_generation is incremented for each assign op we scan.
16354 Then we run through all the lexical variables on the LHS,
16355 of the assignment, setting a spare slot in each of them to
16356 PL_generation. Then we scan the RHS, and if any lexicals
16357 already have that value, we know we've got commonality.
16358 Also, if the generation number is already set to
16359 PERL_INT_MAX, then the variable is involved in aliasing, so
16360 we also have potential commonality in that case.
16366 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
16369 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16373 /* After looking for things which are *always* safe, this main
16374 * if/else chain selects primarily based on the type of the
16375 * LHS, gradually working its way down from the more dangerous
16376 * to the more restrictive and thus safer cases */
16378 if ( !l /* () = ....; */
16379 || !r /* .... = (); */
16380 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16381 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16382 || (lscalars < 2) /* ($x, undef) = ... */
16384 NOOP; /* always safe */
16386 else if (l & AAS_DANGEROUS) {
16387 /* always dangerous */
16388 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16389 o->op_private |= OPpASSIGN_COMMON_AGG;
16391 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16392 /* package vars are always dangerous - too many
16393 * aliasing possibilities */
16394 if (l & AAS_PKG_SCALAR)
16395 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16396 if (l & AAS_PKG_AGG)
16397 o->op_private |= OPpASSIGN_COMMON_AGG;
16399 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16400 |AAS_LEX_SCALAR|AAS_LEX_AGG))
16402 /* LHS contains only lexicals and safe ops */
16404 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16405 o->op_private |= OPpASSIGN_COMMON_AGG;
16407 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16408 if (lr & AAS_LEX_SCALAR_COMM)
16409 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16410 else if ( !(l & AAS_LEX_SCALAR)
16411 && (r & AAS_DEFAV))
16415 * as scalar-safe for performance reasons.
16416 * (it will still have been marked _AGG if necessary */
16419 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16420 /* if there are only lexicals on the LHS and no
16421 * common ones on the RHS, then we assume that the
16422 * only way those lexicals could also get
16423 * on the RHS is via some sort of dereffing or
16426 * ($lex, $x) = (1, $$r)
16427 * and in this case we assume the var must have
16428 * a bumped ref count. So if its ref count is 1,
16429 * it must only be on the LHS.
16431 o->op_private |= OPpASSIGN_COMMON_RC1;
16436 * may have to handle aggregate on LHS, but we can't
16437 * have common scalars. */
16440 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16442 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16443 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16448 /* see if ref() is used in boolean context */
16449 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16450 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16454 /* see if the op is used in known boolean context,
16455 * but not if OA_TARGLEX optimisation is enabled */
16456 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16457 && !(o->op_private & OPpTARGET_MY)
16459 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16463 /* see if the op is used in known boolean context */
16464 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16465 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16469 Perl_cpeep_t cpeep =
16470 XopENTRYCUSTOM(o, xop_peep);
16472 cpeep(aTHX_ o, oldop);
16477 /* did we just null the current op? If so, re-process it to handle
16478 * eliding "empty" ops from the chain */
16479 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16492 Perl_peep(pTHX_ OP *o)
16498 =head1 Custom Operators
16500 =for apidoc Ao||custom_op_xop
16501 Return the XOP structure for a given custom op. This macro should be
16502 considered internal to C<OP_NAME> and the other access macros: use them instead.
16503 This macro does call a function. Prior
16504 to 5.19.6, this was implemented as a
16511 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16517 static const XOP xop_null = { 0, 0, 0, 0, 0 };
16519 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16520 assert(o->op_type == OP_CUSTOM);
16522 /* This is wrong. It assumes a function pointer can be cast to IV,
16523 * which isn't guaranteed, but this is what the old custom OP code
16524 * did. In principle it should be safer to Copy the bytes of the
16525 * pointer into a PV: since the new interface is hidden behind
16526 * functions, this can be changed later if necessary. */
16527 /* Change custom_op_xop if this ever happens */
16528 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16531 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16533 /* assume noone will have just registered a desc */
16534 if (!he && PL_custom_op_names &&
16535 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16540 /* XXX does all this need to be shared mem? */
16541 Newxz(xop, 1, XOP);
16542 pv = SvPV(HeVAL(he), l);
16543 XopENTRY_set(xop, xop_name, savepvn(pv, l));
16544 if (PL_custom_op_descs &&
16545 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16547 pv = SvPV(HeVAL(he), l);
16548 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16550 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16554 xop = (XOP *)&xop_null;
16556 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16560 if(field == XOPe_xop_ptr) {
16563 const U32 flags = XopFLAGS(xop);
16564 if(flags & field) {
16566 case XOPe_xop_name:
16567 any.xop_name = xop->xop_name;
16569 case XOPe_xop_desc:
16570 any.xop_desc = xop->xop_desc;
16572 case XOPe_xop_class:
16573 any.xop_class = xop->xop_class;
16575 case XOPe_xop_peep:
16576 any.xop_peep = xop->xop_peep;
16579 NOT_REACHED; /* NOTREACHED */
16584 case XOPe_xop_name:
16585 any.xop_name = XOPd_xop_name;
16587 case XOPe_xop_desc:
16588 any.xop_desc = XOPd_xop_desc;
16590 case XOPe_xop_class:
16591 any.xop_class = XOPd_xop_class;
16593 case XOPe_xop_peep:
16594 any.xop_peep = XOPd_xop_peep;
16597 NOT_REACHED; /* NOTREACHED */
16602 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16603 * op.c: In function 'Perl_custom_op_get_field':
16604 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16605 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16606 * expands to assert(0), which expands to ((0) ? (void)0 :
16607 * __assert(...)), and gcc doesn't know that __assert can never return. */
16613 =for apidoc Ao||custom_op_register
16614 Register a custom op. See L<perlguts/"Custom Operators">.
16620 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16624 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16626 /* see the comment in custom_op_xop */
16627 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16629 if (!PL_custom_ops)
16630 PL_custom_ops = newHV();
16632 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16633 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16638 =for apidoc core_prototype
16640 This function assigns the prototype of the named core function to C<sv>, or
16641 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
16642 C<NULL> if the core function has no prototype. C<code> is a code as returned
16643 by C<keyword()>. It must not be equal to 0.
16649 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16652 int i = 0, n = 0, seen_question = 0, defgv = 0;
16654 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16655 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16656 bool nullret = FALSE;
16658 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16662 if (!sv) sv = sv_newmortal();
16664 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16666 switch (code < 0 ? -code : code) {
16667 case KEY_and : case KEY_chop: case KEY_chomp:
16668 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
16669 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
16670 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
16671 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
16672 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
16673 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
16674 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
16675 case KEY_x : case KEY_xor :
16676 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16677 case KEY_glob: retsetpvs("_;", OP_GLOB);
16678 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
16679 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
16680 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
16681 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
16682 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16684 case KEY_evalbytes:
16685 name = "entereval"; break;
16693 while (i < MAXO) { /* The slow way. */
16694 if (strEQ(name, PL_op_name[i])
16695 || strEQ(name, PL_op_desc[i]))
16697 if (nullret) { assert(opnum); *opnum = i; return NULL; }
16704 defgv = PL_opargs[i] & OA_DEFGV;
16705 oa = PL_opargs[i] >> OASHIFT;
16707 if (oa & OA_OPTIONAL && !seen_question && (
16708 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16713 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16714 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16715 /* But globs are already references (kinda) */
16716 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16720 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16721 && !scalar_mod_type(NULL, i)) {
16726 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16730 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16731 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16732 str[n-1] = '_'; defgv = 0;
16736 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16738 sv_setpvn(sv, str, n - 1);
16739 if (opnum) *opnum = i;
16744 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16747 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16750 PERL_ARGS_ASSERT_CORESUB_OP;
16754 return op_append_elem(OP_LINESEQ,
16757 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16764 o = newUNOP(OP_AVHVSWITCH,0,argop);
16765 o->op_private = opnum-OP_EACH;
16767 case OP_SELECT: /* which represents OP_SSELECT as well */
16772 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16773 newSVOP(OP_CONST, 0, newSVuv(1))
16775 coresub_op(newSVuv((UV)OP_SSELECT), 0,
16777 coresub_op(coreargssv, 0, OP_SELECT)
16781 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16783 return op_append_elem(
16786 opnum == OP_WANTARRAY || opnum == OP_RUNCV
16787 ? OPpOFFBYONE << 8 : 0)
16789 case OA_BASEOP_OR_UNOP:
16790 if (opnum == OP_ENTEREVAL) {
16791 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16792 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16794 else o = newUNOP(opnum,0,argop);
16795 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16798 if (is_handle_constructor(o, 1))
16799 argop->op_private |= OPpCOREARGS_DEREF1;
16800 if (scalar_mod_type(NULL, opnum))
16801 argop->op_private |= OPpCOREARGS_SCALARMOD;
16805 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16806 if (is_handle_constructor(o, 2))
16807 argop->op_private |= OPpCOREARGS_DEREF2;
16808 if (opnum == OP_SUBSTR) {
16809 o->op_private |= OPpMAYBE_LVSUB;
16818 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16819 SV * const *new_const_svp)
16821 const char *hvname;
16822 bool is_const = !!CvCONST(old_cv);
16823 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16825 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16827 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16829 /* They are 2 constant subroutines generated from
16830 the same constant. This probably means that
16831 they are really the "same" proxy subroutine
16832 instantiated in 2 places. Most likely this is
16833 when a constant is exported twice. Don't warn.
16836 (ckWARN(WARN_REDEFINE)
16838 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16839 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16840 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16841 strEQ(hvname, "autouse"))
16845 && ckWARN_d(WARN_REDEFINE)
16846 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16849 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16851 ? "Constant subroutine %" SVf " redefined"
16852 : "Subroutine %" SVf " redefined",
16857 =head1 Hook manipulation
16859 These functions provide convenient and thread-safe means of manipulating
16866 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16868 Puts a C function into the chain of check functions for a specified op
16869 type. This is the preferred way to manipulate the L</PL_check> array.
16870 C<opcode> specifies which type of op is to be affected. C<new_checker>
16871 is a pointer to the C function that is to be added to that opcode's
16872 check chain, and C<old_checker_p> points to the storage location where a
16873 pointer to the next function in the chain will be stored. The value of
16874 C<new_checker> is written into the L</PL_check> array, while the value
16875 previously stored there is written to C<*old_checker_p>.
16877 L</PL_check> is global to an entire process, and a module wishing to
16878 hook op checking may find itself invoked more than once per process,
16879 typically in different threads. To handle that situation, this function
16880 is idempotent. The location C<*old_checker_p> must initially (once
16881 per process) contain a null pointer. A C variable of static duration
16882 (declared at file scope, typically also marked C<static> to give
16883 it internal linkage) will be implicitly initialised appropriately,
16884 if it does not have an explicit initialiser. This function will only
16885 actually modify the check chain if it finds C<*old_checker_p> to be null.
16886 This function is also thread safe on the small scale. It uses appropriate
16887 locking to avoid race conditions in accessing L</PL_check>.
16889 When this function is called, the function referenced by C<new_checker>
16890 must be ready to be called, except for C<*old_checker_p> being unfilled.
16891 In a threading situation, C<new_checker> may be called immediately,
16892 even before this function has returned. C<*old_checker_p> will always
16893 be appropriately set before C<new_checker> is called. If C<new_checker>
16894 decides not to do anything special with an op that it is given (which
16895 is the usual case for most uses of op check hooking), it must chain the
16896 check function referenced by C<*old_checker_p>.
16898 Taken all together, XS code to hook an op checker should typically look
16899 something like this:
16901 static Perl_check_t nxck_frob;
16902 static OP *myck_frob(pTHX_ OP *op) {
16904 op = nxck_frob(aTHX_ op);
16909 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
16911 If you want to influence compilation of calls to a specific subroutine,
16912 then use L</cv_set_call_checker_flags> rather than hooking checking of
16913 all C<entersub> ops.
16919 Perl_wrap_op_checker(pTHX_ Optype opcode,
16920 Perl_check_t new_checker, Perl_check_t *old_checker_p)
16924 PERL_UNUSED_CONTEXT;
16925 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
16926 if (*old_checker_p) return;
16927 OP_CHECK_MUTEX_LOCK;
16928 if (!*old_checker_p) {
16929 *old_checker_p = PL_check[opcode];
16930 PL_check[opcode] = new_checker;
16932 OP_CHECK_MUTEX_UNLOCK;
16937 /* Efficient sub that returns a constant scalar value. */
16939 const_sv_xsub(pTHX_ CV* cv)
16942 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
16943 PERL_UNUSED_ARG(items);
16953 const_av_xsub(pTHX_ CV* cv)
16956 AV * const av = MUTABLE_AV(XSANY.any_ptr);
16964 if (SvRMAGICAL(av))
16965 Perl_croak(aTHX_ "Magical list constants are not supported");
16966 if (GIMME_V != G_ARRAY) {
16968 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
16971 EXTEND(SP, AvFILLp(av)+1);
16972 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
16973 XSRETURN(AvFILLp(av)+1);
16978 * ex: set ts=8 sts=4 sw=4 et: