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;
1548 logop->op_flags = OPf_KIDS;
1549 while (kid && OpHAS_SIBLING(kid))
1550 kid = OpSIBLING(kid);
1552 OpLASTSIB_set(kid, (OP*)logop);
1557 /* Contextualizers */
1560 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1562 Applies a syntactic context to an op tree representing an expression.
1563 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1564 or C<G_VOID> to specify the context to apply. The modified op tree
1571 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1573 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1575 case G_SCALAR: return scalar(o);
1576 case G_ARRAY: return list(o);
1577 case G_VOID: return scalarvoid(o);
1579 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1586 =for apidoc Am|OP*|op_linklist|OP *o
1587 This function is the implementation of the L</LINKLIST> macro. It should
1588 not be called directly.
1594 Perl_op_linklist(pTHX_ OP *o)
1598 PERL_ARGS_ASSERT_OP_LINKLIST;
1603 /* establish postfix order */
1604 first = cUNOPo->op_first;
1607 o->op_next = LINKLIST(first);
1610 OP *sibl = OpSIBLING(kid);
1612 kid->op_next = LINKLIST(sibl);
1627 S_scalarkids(pTHX_ OP *o)
1629 if (o && o->op_flags & OPf_KIDS) {
1631 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1638 S_scalarboolean(pTHX_ OP *o)
1640 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1642 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1643 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1644 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1645 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1646 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1647 if (ckWARN(WARN_SYNTAX)) {
1648 const line_t oldline = CopLINE(PL_curcop);
1650 if (PL_parser && PL_parser->copline != NOLINE) {
1651 /* This ensures that warnings are reported at the first line
1652 of the conditional, not the last. */
1653 CopLINE_set(PL_curcop, PL_parser->copline);
1655 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1656 CopLINE_set(PL_curcop, oldline);
1663 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1666 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1667 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1669 const char funny = o->op_type == OP_PADAV
1670 || o->op_type == OP_RV2AV ? '@' : '%';
1671 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1673 if (cUNOPo->op_first->op_type != OP_GV
1674 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1676 return varname(gv, funny, 0, NULL, 0, subscript_type);
1679 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1684 S_op_varname(pTHX_ const OP *o)
1686 return S_op_varname_subscript(aTHX_ o, 1);
1690 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1691 { /* or not so pretty :-) */
1692 if (o->op_type == OP_CONST) {
1694 if (SvPOK(*retsv)) {
1696 *retsv = sv_newmortal();
1697 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1698 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1700 else if (!SvOK(*retsv))
1703 else *retpv = "...";
1707 S_scalar_slice_warning(pTHX_ const OP *o)
1710 const bool h = o->op_type == OP_HSLICE
1711 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1717 SV *keysv = NULL; /* just to silence compiler warnings */
1718 const char *key = NULL;
1720 if (!(o->op_private & OPpSLICEWARNING))
1722 if (PL_parser && PL_parser->error_count)
1723 /* This warning can be nonsensical when there is a syntax error. */
1726 kid = cLISTOPo->op_first;
1727 kid = OpSIBLING(kid); /* get past pushmark */
1728 /* weed out false positives: any ops that can return lists */
1729 switch (kid->op_type) {
1755 /* Don't warn if we have a nulled list either. */
1756 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1759 assert(OpSIBLING(kid));
1760 name = S_op_varname(aTHX_ OpSIBLING(kid));
1761 if (!name) /* XS module fiddling with the op tree */
1763 S_op_pretty(aTHX_ kid, &keysv, &key);
1764 assert(SvPOK(name));
1765 sv_chop(name,SvPVX(name)+1);
1767 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1768 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1769 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1771 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1772 lbrack, key, rbrack);
1774 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1775 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1776 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1778 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1779 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1783 Perl_scalar(pTHX_ OP *o)
1787 /* assumes no premature commitment */
1788 if (!o || (PL_parser && PL_parser->error_count)
1789 || (o->op_flags & OPf_WANT)
1790 || o->op_type == OP_RETURN)
1795 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1797 switch (o->op_type) {
1799 scalar(cBINOPo->op_first);
1800 if (o->op_private & OPpREPEAT_DOLIST) {
1801 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1802 assert(kid->op_type == OP_PUSHMARK);
1803 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1804 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1805 o->op_private &=~ OPpREPEAT_DOLIST;
1812 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1822 if (o->op_flags & OPf_KIDS) {
1823 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1829 kid = cLISTOPo->op_first;
1831 kid = OpSIBLING(kid);
1834 OP *sib = OpSIBLING(kid);
1835 if (sib && kid->op_type != OP_LEAVEWHEN
1836 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1837 || ( sib->op_targ != OP_NEXTSTATE
1838 && sib->op_targ != OP_DBSTATE )))
1844 PL_curcop = &PL_compiling;
1849 kid = cLISTOPo->op_first;
1852 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1857 /* Warn about scalar context */
1858 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1859 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1862 const char *key = NULL;
1864 /* This warning can be nonsensical when there is a syntax error. */
1865 if (PL_parser && PL_parser->error_count)
1868 if (!ckWARN(WARN_SYNTAX)) break;
1870 kid = cLISTOPo->op_first;
1871 kid = OpSIBLING(kid); /* get past pushmark */
1872 assert(OpSIBLING(kid));
1873 name = S_op_varname(aTHX_ OpSIBLING(kid));
1874 if (!name) /* XS module fiddling with the op tree */
1876 S_op_pretty(aTHX_ kid, &keysv, &key);
1877 assert(SvPOK(name));
1878 sv_chop(name,SvPVX(name)+1);
1880 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1881 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1882 "%%%" SVf "%c%s%c in scalar context better written "
1883 "as $%" SVf "%c%s%c",
1884 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1885 lbrack, key, rbrack);
1887 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1888 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1889 "%%%" SVf "%c%" SVf "%c in scalar context better "
1890 "written as $%" SVf "%c%" SVf "%c",
1891 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1892 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1899 Perl_scalarvoid(pTHX_ OP *arg)
1904 SSize_t defer_stack_alloc = 0;
1905 SSize_t defer_ix = -1;
1906 OP **defer_stack = NULL;
1909 PERL_ARGS_ASSERT_SCALARVOID;
1913 SV *useless_sv = NULL;
1914 const char* useless = NULL;
1916 if (o->op_type == OP_NEXTSTATE
1917 || o->op_type == OP_DBSTATE
1918 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1919 || o->op_targ == OP_DBSTATE)))
1920 PL_curcop = (COP*)o; /* for warning below */
1922 /* assumes no premature commitment */
1923 want = o->op_flags & OPf_WANT;
1924 if ((want && want != OPf_WANT_SCALAR)
1925 || (PL_parser && PL_parser->error_count)
1926 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1931 if ((o->op_private & OPpTARGET_MY)
1932 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1934 /* newASSIGNOP has already applied scalar context, which we
1935 leave, as if this op is inside SASSIGN. */
1939 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1941 switch (o->op_type) {
1943 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1947 if (o->op_flags & OPf_STACKED)
1949 if (o->op_type == OP_REPEAT)
1950 scalar(cBINOPo->op_first);
1953 if (o->op_private == 4)
1988 case OP_GETSOCKNAME:
1989 case OP_GETPEERNAME:
1994 case OP_GETPRIORITY:
2019 useless = OP_DESC(o);
2029 case OP_AELEMFAST_LEX:
2033 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2034 /* Otherwise it's "Useless use of grep iterator" */
2035 useless = OP_DESC(o);
2039 if (!(o->op_private & OPpSPLIT_ASSIGN))
2040 useless = OP_DESC(o);
2044 kid = cUNOPo->op_first;
2045 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2046 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2049 useless = "negative pattern binding (!~)";
2053 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2054 useless = "non-destructive substitution (s///r)";
2058 useless = "non-destructive transliteration (tr///r)";
2065 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2066 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2067 useless = "a variable";
2072 if (cSVOPo->op_private & OPpCONST_STRICT)
2073 no_bareword_allowed(o);
2075 if (ckWARN(WARN_VOID)) {
2077 /* don't warn on optimised away booleans, eg
2078 * use constant Foo, 5; Foo || print; */
2079 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2081 /* the constants 0 and 1 are permitted as they are
2082 conventionally used as dummies in constructs like
2083 1 while some_condition_with_side_effects; */
2084 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2086 else if (SvPOK(sv)) {
2087 SV * const dsv = newSVpvs("");
2089 = Perl_newSVpvf(aTHX_
2091 pv_pretty(dsv, SvPVX_const(sv),
2092 SvCUR(sv), 32, NULL, NULL,
2094 | PERL_PV_ESCAPE_NOCLEAR
2095 | PERL_PV_ESCAPE_UNI_DETECT));
2096 SvREFCNT_dec_NN(dsv);
2098 else if (SvOK(sv)) {
2099 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2102 useless = "a constant (undef)";
2105 op_null(o); /* don't execute or even remember it */
2109 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2113 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2117 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2121 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2126 UNOP *refgen, *rv2cv;
2129 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2132 rv2gv = ((BINOP *)o)->op_last;
2133 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2136 refgen = (UNOP *)((BINOP *)o)->op_first;
2138 if (!refgen || (refgen->op_type != OP_REFGEN
2139 && refgen->op_type != OP_SREFGEN))
2142 exlist = (LISTOP *)refgen->op_first;
2143 if (!exlist || exlist->op_type != OP_NULL
2144 || exlist->op_targ != OP_LIST)
2147 if (exlist->op_first->op_type != OP_PUSHMARK
2148 && exlist->op_first != exlist->op_last)
2151 rv2cv = (UNOP*)exlist->op_last;
2153 if (rv2cv->op_type != OP_RV2CV)
2156 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2157 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2158 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2160 o->op_private |= OPpASSIGN_CV_TO_GV;
2161 rv2gv->op_private |= OPpDONT_INIT_GV;
2162 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2174 kid = cLOGOPo->op_first;
2175 if (kid->op_type == OP_NOT
2176 && (kid->op_flags & OPf_KIDS)) {
2177 if (o->op_type == OP_AND) {
2178 OpTYPE_set(o, OP_OR);
2180 OpTYPE_set(o, OP_AND);
2190 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2191 if (!(kid->op_flags & OPf_KIDS))
2198 if (o->op_flags & OPf_STACKED)
2205 if (!(o->op_flags & OPf_KIDS))
2216 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2217 if (!(kid->op_flags & OPf_KIDS))
2223 /* If the first kid after pushmark is something that the padrange
2224 optimisation would reject, then null the list and the pushmark.
2226 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2227 && ( !(kid = OpSIBLING(kid))
2228 || ( kid->op_type != OP_PADSV
2229 && kid->op_type != OP_PADAV
2230 && kid->op_type != OP_PADHV)
2231 || kid->op_private & ~OPpLVAL_INTRO
2232 || !(kid = OpSIBLING(kid))
2233 || ( kid->op_type != OP_PADSV
2234 && kid->op_type != OP_PADAV
2235 && kid->op_type != OP_PADHV)
2236 || kid->op_private & ~OPpLVAL_INTRO)
2238 op_null(cUNOPo->op_first); /* NULL the pushmark */
2239 op_null(o); /* NULL the list */
2251 /* mortalise it, in case warnings are fatal. */
2252 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2253 "Useless use of %" SVf " in void context",
2254 SVfARG(sv_2mortal(useless_sv)));
2257 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2258 "Useless use of %s in void context",
2261 } while ( (o = POP_DEFERRED_OP()) );
2263 Safefree(defer_stack);
2269 S_listkids(pTHX_ OP *o)
2271 if (o && o->op_flags & OPf_KIDS) {
2273 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2280 Perl_list(pTHX_ OP *o)
2284 /* assumes no premature commitment */
2285 if (!o || (o->op_flags & OPf_WANT)
2286 || (PL_parser && PL_parser->error_count)
2287 || o->op_type == OP_RETURN)
2292 if ((o->op_private & OPpTARGET_MY)
2293 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2295 return o; /* As if inside SASSIGN */
2298 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2300 switch (o->op_type) {
2302 list(cBINOPo->op_first);
2305 if (o->op_private & OPpREPEAT_DOLIST
2306 && !(o->op_flags & OPf_STACKED))
2308 list(cBINOPo->op_first);
2309 kid = cBINOPo->op_last;
2310 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2311 && SvIVX(kSVOP_sv) == 1)
2313 op_null(o); /* repeat */
2314 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2316 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2323 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2331 if (!(o->op_flags & OPf_KIDS))
2333 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2334 list(cBINOPo->op_first);
2335 return gen_constant_list(o);
2341 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2342 op_null(cUNOPo->op_first); /* NULL the pushmark */
2343 op_null(o); /* NULL the list */
2348 kid = cLISTOPo->op_first;
2350 kid = OpSIBLING(kid);
2353 OP *sib = OpSIBLING(kid);
2354 if (sib && kid->op_type != OP_LEAVEWHEN)
2360 PL_curcop = &PL_compiling;
2364 kid = cLISTOPo->op_first;
2371 S_scalarseq(pTHX_ OP *o)
2374 const OPCODE type = o->op_type;
2376 if (type == OP_LINESEQ || type == OP_SCOPE ||
2377 type == OP_LEAVE || type == OP_LEAVETRY)
2380 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2381 if ((sib = OpSIBLING(kid))
2382 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2383 || ( sib->op_targ != OP_NEXTSTATE
2384 && sib->op_targ != OP_DBSTATE )))
2389 PL_curcop = &PL_compiling;
2391 o->op_flags &= ~OPf_PARENS;
2392 if (PL_hints & HINT_BLOCK_SCOPE)
2393 o->op_flags |= OPf_PARENS;
2396 o = newOP(OP_STUB, 0);
2401 S_modkids(pTHX_ OP *o, I32 type)
2403 if (o && o->op_flags & OPf_KIDS) {
2405 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2406 op_lvalue(kid, type);
2412 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2413 * const fields. Also, convert CONST keys to HEK-in-SVs.
2414 * rop is the op that retrieves the hash;
2415 * key_op is the first key
2419 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2425 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2427 if (rop->op_first->op_type == OP_PADSV)
2428 /* @$hash{qw(keys here)} */
2429 rop = (UNOP*)rop->op_first;
2431 /* @{$hash}{qw(keys here)} */
2432 if (rop->op_first->op_type == OP_SCOPE
2433 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2435 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2442 lexname = NULL; /* just to silence compiler warnings */
2443 fields = NULL; /* just to silence compiler warnings */
2447 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2448 SvPAD_TYPED(lexname))
2449 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2450 && isGV(*fields) && GvHV(*fields);
2452 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2454 if (key_op->op_type != OP_CONST)
2456 svp = cSVOPx_svp(key_op);
2458 /* make sure it's not a bareword under strict subs */
2459 if (key_op->op_private & OPpCONST_BARE &&
2460 key_op->op_private & OPpCONST_STRICT)
2462 no_bareword_allowed((OP*)key_op);
2465 /* Make the CONST have a shared SV */
2466 if ( !SvIsCOW_shared_hash(sv = *svp)
2467 && SvTYPE(sv) < SVt_PVMG
2472 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2473 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2474 SvREFCNT_dec_NN(sv);
2479 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2481 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2482 "in variable %" PNf " of type %" HEKf,
2483 SVfARG(*svp), PNfARG(lexname),
2484 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2489 /* info returned by S_sprintf_is_multiconcatable() */
2491 struct sprintf_ismc_info {
2492 SSize_t nargs; /* num of args to sprintf (not including the format) */
2493 char *start; /* start of raw format string */
2494 char *end; /* bytes after end of raw format string */
2495 STRLEN total_len; /* total length (in bytes) of format string, not
2496 including '%s' and half of '%%' */
2497 STRLEN variant; /* number of bytes by which total_len_p would grow
2498 if upgraded to utf8 */
2499 bool utf8; /* whether the format is utf8 */
2503 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2504 * i.e. its format argument is a const string with only '%s' and '%%'
2505 * formats, and the number of args is known, e.g.
2506 * sprintf "a=%s f=%s", $a[0], scalar(f());
2508 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2510 * If successful, the sprintf_ismc_info struct pointed to by info will be
2515 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2517 OP *pm, *constop, *kid;
2520 SSize_t nargs, nformats;
2521 STRLEN cur, total_len, variant;
2524 /* if sprintf's behaviour changes, die here so that someone
2525 * can decide whether to enhance this function or skip optimising
2526 * under those new circumstances */
2527 assert(!(o->op_flags & OPf_STACKED));
2528 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2529 assert(!(o->op_private & ~OPpARG4_MASK));
2531 pm = cUNOPo->op_first;
2532 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2534 constop = OpSIBLING(pm);
2535 if (!constop || constop->op_type != OP_CONST)
2537 sv = cSVOPx_sv(constop);
2538 if (SvMAGICAL(sv) || !SvPOK(sv))
2544 /* Scan format for %% and %s and work out how many %s there are.
2545 * Abandon if other format types are found.
2552 for (p = s; p < e; p++) {
2555 if (!UTF8_IS_INVARIANT(*p))
2561 return FALSE; /* lone % at end gives "Invalid conversion" */
2570 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2573 utf8 = cBOOL(SvUTF8(sv));
2577 /* scan args; they must all be in scalar cxt */
2580 kid = OpSIBLING(constop);
2583 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2586 kid = OpSIBLING(kid);
2589 if (nargs != nformats)
2590 return FALSE; /* e.g. sprintf("%s%s", $a); */
2593 info->nargs = nargs;
2596 info->total_len = total_len;
2597 info->variant = variant;
2605 /* S_maybe_multiconcat():
2607 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2608 * convert it (and its children) into an OP_MULTICONCAT. See the code
2609 * comments just before pp_multiconcat() for the full details of what
2610 * OP_MULTICONCAT supports.
2612 * Basically we're looking for an optree with a chain of OP_CONCATS down
2613 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2614 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2622 * STRINGIFY -- PADSV[$x]
2625 * ex-PUSHMARK -- CONCAT/S
2627 * CONCAT/S -- PADSV[$d]
2629 * CONCAT -- CONST["-"]
2631 * PADSV[$a] -- PADSV[$b]
2633 * Note that at this stage the OP_SASSIGN may have already been optimised
2634 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2638 S_maybe_multiconcat(pTHX_ OP *o)
2640 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2641 OP *topop; /* the top-most op in the concat tree (often equals o,
2642 unless there are assign/stringify ops above it */
2643 OP *parentop; /* the parent op of topop (or itself if no parent) */
2644 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2645 OP *targetop; /* the op corresponding to target=... or target.=... */
2646 OP *stringop; /* the OP_STRINGIFY op, if any */
2647 OP *nextop; /* used for recreating the op_next chain without consts */
2648 OP *kid; /* general-purpose op pointer */
2650 UNOP_AUX_item *lenp;
2651 char *const_str, *p;
2652 struct sprintf_ismc_info sprintf_info;
2654 /* store info about each arg in args[];
2655 * toparg is the highest used slot; argp is a general
2656 * pointer to args[] slots */
2658 void *p; /* initially points to const sv (or null for op);
2659 later, set to SvPV(constsv), with ... */
2660 STRLEN len; /* ... len set to SvPV(..., len) */
2661 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2667 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2668 the last-processed arg will the LHS of one,
2669 as args are processed in reverse order */
2670 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2671 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2672 U8 flags = 0; /* what will become the op_flags and ... */
2673 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2674 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2675 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2677 /* -----------------------------------------------------------------
2680 * Examine the optree non-destructively to determine whether it's
2681 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2682 * information about the optree in args[].
2692 assert( o->op_type == OP_SASSIGN
2693 || o->op_type == OP_CONCAT
2694 || o->op_type == OP_SPRINTF
2695 || o->op_type == OP_STRINGIFY);
2697 /* first see if, at the top of the tree, there is an assign,
2698 * append and/or stringify */
2700 if (topop->op_type == OP_SASSIGN) {
2702 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2704 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2706 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2709 topop = cBINOPo->op_first;
2710 targetop = OpSIBLING(topop);
2711 if (!targetop) /* probably some sort of syntax error */
2714 else if ( topop->op_type == OP_CONCAT
2715 && (topop->op_flags & OPf_STACKED)
2716 && (cUNOPo->op_first->op_flags & OPf_MOD))
2720 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2721 * decide what to do about it */
2722 assert(!(o->op_private & OPpTARGET_MY));
2724 /* barf on unknown flags */
2725 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2726 private_flags |= OPpMULTICONCAT_APPEND;
2727 targetop = cBINOPo->op_first;
2729 topop = OpSIBLING(targetop);
2731 /* $x .= <FOO> gets optimised to rcatline instead */
2732 if (topop->op_type == OP_READLINE)
2737 /* Can targetop (the LHS) if it's a padsv, be be optimised
2738 * away and use OPpTARGET_MY instead?
2740 if ( (targetop->op_type == OP_PADSV)
2741 && !(targetop->op_private & OPpDEREF)
2742 && !(targetop->op_private & OPpPAD_STATE)
2743 /* we don't support 'my $x .= ...' */
2744 && ( o->op_type == OP_SASSIGN
2745 || !(targetop->op_private & OPpLVAL_INTRO))
2750 if (topop->op_type == OP_STRINGIFY) {
2751 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2755 /* barf on unknown flags */
2756 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2758 if ((topop->op_private & OPpTARGET_MY)) {
2759 if (o->op_type == OP_SASSIGN)
2760 return; /* can't have two assigns */
2764 private_flags |= OPpMULTICONCAT_STRINGIFY;
2766 topop = cBINOPx(topop)->op_first;
2767 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2768 topop = OpSIBLING(topop);
2771 if (topop->op_type == OP_SPRINTF) {
2772 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2774 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2775 nargs = sprintf_info.nargs;
2776 total_len = sprintf_info.total_len;
2777 variant = sprintf_info.variant;
2778 utf8 = sprintf_info.utf8;
2780 private_flags |= OPpMULTICONCAT_FAKE;
2782 /* we have an sprintf op rather than a concat optree.
2783 * Skip most of the code below which is associated with
2784 * processing that optree. We also skip phase 2, determining
2785 * whether its cost effective to optimise, since for sprintf,
2786 * multiconcat is *always* faster */
2789 /* note that even if the sprintf itself isn't multiconcatable,
2790 * the expression as a whole may be, e.g. in
2791 * $x .= sprintf("%d",...)
2792 * the sprintf op will be left as-is, but the concat/S op may
2793 * be upgraded to multiconcat
2796 else if (topop->op_type == OP_CONCAT) {
2797 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2800 if ((topop->op_private & OPpTARGET_MY)) {
2801 if (o->op_type == OP_SASSIGN || targmyop)
2802 return; /* can't have two assigns */
2807 /* Is it safe to convert a sassign/stringify/concat op into
2809 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
2810 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
2811 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2812 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
2813 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
2814 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2815 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
2816 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2818 /* Now scan the down the tree looking for a series of
2819 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2820 * stacked). For example this tree:
2825 * CONCAT/STACKED -- EXPR5
2827 * CONCAT/STACKED -- EXPR4
2833 * corresponds to an expression like
2835 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2837 * Record info about each EXPR in args[]: in particular, whether it is
2838 * a stringifiable OP_CONST and if so what the const sv is.
2840 * The reason why the last concat can't be STACKED is the difference
2843 * ((($a .= $a) .= $a) .= $a) .= $a
2846 * $a . $a . $a . $a . $a
2848 * The main difference between the optrees for those two constructs
2849 * is the presence of the last STACKED. As well as modifying $a,
2850 * the former sees the changed $a between each concat, so if $s is
2851 * initially 'a', the first returns 'a' x 16, while the latter returns
2852 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2862 if ( kid->op_type == OP_CONCAT
2866 k1 = cUNOPx(kid)->op_first;
2868 /* shouldn't happen except maybe after compile err? */
2872 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
2873 if (kid->op_private & OPpTARGET_MY)
2876 stacked_last = (kid->op_flags & OPf_STACKED);
2888 if ( nargs > PERL_MULTICONCAT_MAXARG - 2
2889 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2891 /* At least two spare slots are needed to decompose both
2892 * concat args. If there are no slots left, continue to
2893 * examine the rest of the optree, but don't push new values
2894 * on args[]. If the optree as a whole is legal for conversion
2895 * (in particular that the last concat isn't STACKED), then
2896 * the first PERL_MULTICONCAT_MAXARG elements of the optree
2897 * can be converted into an OP_MULTICONCAT now, with the first
2898 * child of that op being the remainder of the optree -
2899 * which may itself later be converted to a multiconcat op
2903 /* the last arg is the rest of the optree */
2908 else if ( argop->op_type == OP_CONST
2909 && ((sv = cSVOPx_sv(argop)))
2910 /* defer stringification until runtime of 'constant'
2911 * things that might stringify variantly, e.g. the radix
2912 * point of NVs, or overloaded RVs */
2913 && (SvPOK(sv) || SvIOK(sv))
2914 && (!SvGMAGICAL(sv))
2917 utf8 |= cBOOL(SvUTF8(sv));
2932 return; /* we don't support ((A.=B).=C)...) */
2934 /* -----------------------------------------------------------------
2937 * At this point we have determined that the optree *can* be converted
2938 * into a multiconcat. Having gathered all the evidence, we now decide
2939 * whether it *should*.
2943 /* we need at least one concat action, e.g.:
2949 * otherwise we could be doing something like $x = "foo", which
2950 * if treated as as a concat, would fail to COW.
2952 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
2955 /* Benchmarking seems to indicate that we gain if:
2956 * * we optimise at least two actions into a single multiconcat
2957 * (e.g concat+concat, sassign+concat);
2958 * * or if we can eliminate at least 1 OP_CONST;
2959 * * or if we can eliminate a padsv via OPpTARGET_MY
2963 /* eliminated at least one OP_CONST */
2965 /* eliminated an OP_SASSIGN */
2966 || o->op_type == OP_SASSIGN
2967 /* eliminated an OP_PADSV */
2968 || (!targmyop && is_targable)
2970 /* definitely a net gain to optimise */
2973 /* ... if not, what else? */
2975 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
2976 * multiconcat is faster (due to not creating a temporary copy of
2977 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
2983 && topop->op_type == OP_CONCAT
2985 PADOFFSET t = targmyop->op_targ;
2986 OP *k1 = cBINOPx(topop)->op_first;
2987 OP *k2 = cBINOPx(topop)->op_last;
2988 if ( k2->op_type == OP_PADSV
2990 && ( k1->op_type != OP_PADSV
2991 || k1->op_targ != t)
2996 /* need at least two concats */
2997 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3002 /* -----------------------------------------------------------------
3005 * At this point the optree has been verified as ok to be optimised
3006 * into an OP_MULTICONCAT. Now start changing things.
3011 /* stringify all const args and determine utf8ness */
3014 for (argp = args; argp <= toparg; argp++) {
3015 SV *sv = (SV*)argp->p;
3017 continue; /* not a const op */
3018 if (utf8 && !SvUTF8(sv))
3019 sv_utf8_upgrade_nomg(sv);
3020 argp->p = SvPV_nomg(sv, argp->len);
3021 total_len += argp->len;
3023 /* see if any strings would grow if converted to utf8 */
3025 char *p = (char*)argp->p;
3026 STRLEN len = argp->len;
3029 if (!UTF8_IS_INVARIANT(c))
3035 /* create and populate aux struct */
3039 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3040 sizeof(UNOP_AUX_item)
3042 PERL_MULTICONCAT_HEADER_SIZE
3043 + ((nargs + 1) * (variant ? 2 : 1))
3046 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3048 /* Extract all the non-const expressions from the concat tree then
3049 * dispose of the old tree, e.g. convert the tree from this:
3053 * STRINGIFY -- TARGET
3055 * ex-PUSHMARK -- CONCAT
3070 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3072 * except that if EXPRi is an OP_CONST, it's discarded.
3074 * During the conversion process, EXPR ops are stripped from the tree
3075 * and unshifted onto o. Finally, any of o's remaining original
3076 * childen are discarded and o is converted into an OP_MULTICONCAT.
3078 * In this middle of this, o may contain both: unshifted args on the
3079 * left, and some remaining original args on the right. lastkidop
3080 * is set to point to the right-most unshifted arg to delineate
3081 * between the two sets.
3086 /* create a copy of the format with the %'s removed, and record
3087 * the sizes of the const string segments in the aux struct */
3089 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3091 p = sprintf_info.start;
3094 for (; p < sprintf_info.end; p++) {
3098 (lenp++)->ssize = q - oldq;
3105 lenp->ssize = q - oldq;
3106 assert((STRLEN)(q - const_str) == total_len);
3108 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3109 * may or may not be topop) The pushmark and const ops need to be
3110 * kept in case they're an op_next entry point.
3112 lastkidop = cLISTOPx(topop)->op_last;
3113 kid = cUNOPx(topop)->op_first; /* pushmark */
3115 op_null(OpSIBLING(kid)); /* const */
3117 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3118 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3119 lastkidop->op_next = o;
3124 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3128 /* Concatenate all const strings into const_str.
3129 * Note that args[] contains the RHS args in reverse order, so
3130 * we scan args[] from top to bottom to get constant strings
3133 for (argp = toparg; argp >= args; argp--) {
3135 /* not a const op */
3136 (++lenp)->ssize = -1;
3138 STRLEN l = argp->len;
3139 Copy(argp->p, p, l, char);
3141 if (lenp->ssize == -1)
3152 for (argp = args; argp <= toparg; argp++) {
3153 /* only keep non-const args, except keep the first-in-next-chain
3154 * arg no matter what it is (but nulled if OP_CONST), because it
3155 * may be the entry point to this subtree from the previous
3158 bool last = (argp == toparg);
3161 /* set prev to the sibling *before* the arg to be cut out,
3167 * prev= CONST -- EXPR
3170 if (argp == args && kid->op_type != OP_CONCAT) {
3171 /* in e.g. '$x . = f(1)' there's no RHS concat tree
3172 * so the expression to be cut isn't kid->op_last but
3175 /* find the op before kid */
3177 o2 = cUNOPx(parentop)->op_first;
3178 while (o2 && o2 != kid) {
3186 else if (kid == o && lastkidop)
3187 prev = last ? lastkidop : OpSIBLING(lastkidop);
3189 prev = last ? NULL : cUNOPx(kid)->op_first;
3191 if (!argp->p || last) {
3193 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3194 /* and unshift to front of o */
3195 op_sibling_splice(o, NULL, 0, aop);
3196 /* record the right-most op added to o: later we will
3197 * free anything to the right of it */
3200 aop->op_next = nextop;
3203 /* null the const at start of op_next chain */
3207 nextop = prev->op_next;
3210 /* the last two arguments are both attached to the same concat op */
3211 if (argp < toparg - 1)
3216 /* Populate the aux struct */
3218 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3219 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3220 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3221 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3222 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3224 /* if variant > 0, calculate a variant const string and lengths where
3225 * the utf8 version of the string will take 'variant' more bytes than
3229 char *p = const_str;
3230 STRLEN ulen = total_len + variant;
3231 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3232 UNOP_AUX_item *ulens = lens + (nargs + 1);
3233 char *up = (char*)PerlMemShared_malloc(ulen);
3236 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3237 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3239 for (n = 0; n < (nargs + 1); n++) {
3241 char * orig_up = up;
3242 for (i = (lens++)->ssize; i > 0; i--) {
3244 append_utf8_from_native_byte(c, (U8**)&up);
3246 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3251 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3252 * that op's first child - an ex-PUSHMARK - because the op_next of
3253 * the previous op may point to it (i.e. it's the entry point for
3258 ? op_sibling_splice(o, lastkidop, 1, NULL)
3259 : op_sibling_splice(stringop, NULL, 1, NULL);
3260 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3261 op_sibling_splice(o, NULL, 0, pmop);
3268 * target .= A.B.C...
3274 if (o->op_type == OP_SASSIGN) {
3275 /* Move the target subtree from being the last of o's children
3276 * to being the last of o's preserved children.
3277 * Note the difference between 'target = ...' and 'target .= ...':
3278 * for the former, target is executed last; for the latter,
3281 kid = OpSIBLING(lastkidop);
3282 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3283 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3284 lastkidop->op_next = kid->op_next;
3285 lastkidop = targetop;
3288 /* Move the target subtree from being the first of o's
3289 * original children to being the first of *all* o's children.
3292 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3293 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3296 /* if the RHS of .= doesn't contain a concat (e.g.
3297 * $x .= "foo"), it gets missed by the "strip ops from the
3298 * tree and add to o" loop earlier */
3299 assert(topop->op_type != OP_CONCAT);
3301 /* in e.g. $x .= "$y", move the $y expression
3302 * from being a child of OP_STRINGIFY to being the
3303 * second child of the OP_CONCAT
3305 assert(cUNOPx(stringop)->op_first == topop);
3306 op_sibling_splice(stringop, NULL, 1, NULL);
3307 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3309 assert(topop == OpSIBLING(cBINOPo->op_first));
3318 * my $lex = A.B.C...
3321 * The original padsv op is kept but nulled in case it's the
3322 * entry point for the optree (which it will be for
3325 private_flags |= OPpTARGET_MY;
3326 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3327 o->op_targ = targetop->op_targ;
3328 targetop->op_targ = 0;
3332 flags |= OPf_STACKED;
3334 else if (targmyop) {
3335 private_flags |= OPpTARGET_MY;
3336 if (o != targmyop) {
3337 o->op_targ = targmyop->op_targ;
3338 targmyop->op_targ = 0;
3342 /* detach the emaciated husk of the sprintf/concat optree and free it */
3344 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3350 /* and convert o into a multiconcat */
3352 o->op_flags = (flags|OPf_KIDS|stacked_last
3353 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3354 o->op_private = private_flags;
3355 o->op_type = OP_MULTICONCAT;
3356 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3357 cUNOP_AUXo->op_aux = aux;
3361 /* do all the final processing on an optree (e.g. running the peephole
3362 * optimiser on it), then attach it to cv (if cv is non-null)
3366 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3370 /* XXX for some reason, evals, require and main optrees are
3371 * never attached to their CV; instead they just hang off
3372 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3373 * and get manually freed when appropriate */
3375 startp = &CvSTART(cv);
3377 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3380 optree->op_private |= OPpREFCOUNTED;
3381 OpREFCNT_set(optree, 1);
3382 optimize_optree(optree);
3384 finalize_optree(optree);
3385 S_prune_chain_head(startp);
3388 /* now that optimizer has done its work, adjust pad values */
3389 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3390 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3396 =for apidoc optimize_optree
3398 This function applies some optimisations to the optree in top-down order.
3399 It is called before the peephole optimizer, which processes ops in
3400 execution order. Note that finalize_optree() also does a top-down scan,
3401 but is called *after* the peephole optimizer.
3407 Perl_optimize_optree(pTHX_ OP* o)
3409 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3412 SAVEVPTR(PL_curcop);
3420 /* helper for optimize_optree() which optimises on op then recurses
3421 * to optimise any children.
3425 S_optimize_op(pTHX_ OP* o)
3429 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3430 assert(o->op_type != OP_FREED);
3432 switch (o->op_type) {
3435 PL_curcop = ((COP*)o); /* for warnings */
3443 S_maybe_multiconcat(aTHX_ o);
3447 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3448 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3455 if (!(o->op_flags & OPf_KIDS))
3458 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3464 =for apidoc finalize_optree
3466 This function finalizes the optree. Should be called directly after
3467 the complete optree is built. It does some additional
3468 checking which can't be done in the normal C<ck_>xxx functions and makes
3469 the tree thread-safe.
3474 Perl_finalize_optree(pTHX_ OP* o)
3476 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3479 SAVEVPTR(PL_curcop);
3487 /* Relocate sv to the pad for thread safety.
3488 * Despite being a "constant", the SV is written to,
3489 * for reference counts, sv_upgrade() etc. */
3490 PERL_STATIC_INLINE void
3491 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3494 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3496 ix = pad_alloc(OP_CONST, SVf_READONLY);
3497 SvREFCNT_dec(PAD_SVl(ix));
3498 PAD_SETSV(ix, *svp);
3499 /* XXX I don't know how this isn't readonly already. */
3500 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3508 S_finalize_op(pTHX_ OP* o)
3510 PERL_ARGS_ASSERT_FINALIZE_OP;
3512 assert(o->op_type != OP_FREED);
3514 switch (o->op_type) {
3517 PL_curcop = ((COP*)o); /* for warnings */
3520 if (OpHAS_SIBLING(o)) {
3521 OP *sib = OpSIBLING(o);
3522 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3523 && ckWARN(WARN_EXEC)
3524 && OpHAS_SIBLING(sib))
3526 const OPCODE type = OpSIBLING(sib)->op_type;
3527 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3528 const line_t oldline = CopLINE(PL_curcop);
3529 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3530 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3531 "Statement unlikely to be reached");
3532 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3533 "\t(Maybe you meant system() when you said exec()?)\n");
3534 CopLINE_set(PL_curcop, oldline);
3541 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3542 GV * const gv = cGVOPo_gv;
3543 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3544 /* XXX could check prototype here instead of just carping */
3545 SV * const sv = sv_newmortal();
3546 gv_efullname3(sv, gv, NULL);
3547 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3548 "%" SVf "() called too early to check prototype",
3555 if (cSVOPo->op_private & OPpCONST_STRICT)
3556 no_bareword_allowed(o);
3560 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3565 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3566 case OP_METHOD_NAMED:
3567 case OP_METHOD_SUPER:
3568 case OP_METHOD_REDIR:
3569 case OP_METHOD_REDIR_SUPER:
3570 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3579 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3582 rop = (UNOP*)((BINOP*)o)->op_first;
3587 S_scalar_slice_warning(aTHX_ o);
3591 kid = OpSIBLING(cLISTOPo->op_first);
3592 if (/* I bet there's always a pushmark... */
3593 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3594 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3599 key_op = (SVOP*)(kid->op_type == OP_CONST
3601 : OpSIBLING(kLISTOP->op_first));
3603 rop = (UNOP*)((LISTOP*)o)->op_last;
3606 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3608 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
3612 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3616 S_scalar_slice_warning(aTHX_ o);
3620 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3621 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3628 if (o->op_flags & OPf_KIDS) {
3632 /* check that op_last points to the last sibling, and that
3633 * the last op_sibling/op_sibparent field points back to the
3634 * parent, and that the only ops with KIDS are those which are
3635 * entitled to them */
3636 U32 type = o->op_type;
3640 if (type == OP_NULL) {
3642 /* ck_glob creates a null UNOP with ex-type GLOB
3643 * (which is a list op. So pretend it wasn't a listop */
3644 if (type == OP_GLOB)
3647 family = PL_opargs[type] & OA_CLASS_MASK;
3649 has_last = ( family == OA_BINOP
3650 || family == OA_LISTOP
3651 || family == OA_PMOP
3652 || family == OA_LOOP
3654 assert( has_last /* has op_first and op_last, or ...
3655 ... has (or may have) op_first: */
3656 || family == OA_UNOP
3657 || family == OA_UNOP_AUX
3658 || family == OA_LOGOP
3659 || family == OA_BASEOP_OR_UNOP
3660 || family == OA_FILESTATOP
3661 || family == OA_LOOPEXOP
3662 || family == OA_METHOP
3663 || type == OP_CUSTOM
3664 || type == OP_NULL /* new_logop does this */
3667 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3668 # ifdef PERL_OP_PARENT
3669 if (!OpHAS_SIBLING(kid)) {
3671 assert(kid == cLISTOPo->op_last);
3672 assert(kid->op_sibparent == o);
3675 if (has_last && !OpHAS_SIBLING(kid))
3676 assert(kid == cLISTOPo->op_last);
3681 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3687 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3689 Propagate lvalue ("modifiable") context to an op and its children.
3690 C<type> represents the context type, roughly based on the type of op that
3691 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3692 because it has no op type of its own (it is signalled by a flag on
3695 This function detects things that can't be modified, such as C<$x+1>, and
3696 generates errors for them. For example, C<$x+1 = 2> would cause it to be
3697 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3699 It also flags things that need to behave specially in an lvalue context,
3700 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3706 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3709 PadnameLVALUE_on(pn);
3710 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3712 /* RT #127786: cv can be NULL due to an eval within the DB package
3713 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3714 * unless they contain an eval, but calling eval within DB
3715 * pretends the eval was done in the caller's scope.
3719 assert(CvPADLIST(cv));
3721 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3722 assert(PadnameLEN(pn));
3723 PadnameLVALUE_on(pn);
3728 S_vivifies(const OPCODE type)
3731 case OP_RV2AV: case OP_ASLICE:
3732 case OP_RV2HV: case OP_KVASLICE:
3733 case OP_RV2SV: case OP_HSLICE:
3734 case OP_AELEMFAST: case OP_KVHSLICE:
3743 S_lvref(pTHX_ OP *o, I32 type)
3747 switch (o->op_type) {
3749 for (kid = OpSIBLING(cUNOPo->op_first); kid;
3750 kid = OpSIBLING(kid))
3751 S_lvref(aTHX_ kid, type);
3756 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3757 o->op_flags |= OPf_STACKED;
3758 if (o->op_flags & OPf_PARENS) {
3759 if (o->op_private & OPpLVAL_INTRO) {
3760 yyerror(Perl_form(aTHX_ "Can't modify reference to "
3761 "localized parenthesized array in list assignment"));
3765 OpTYPE_set(o, OP_LVAVREF);
3766 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3767 o->op_flags |= OPf_MOD|OPf_REF;
3770 o->op_private |= OPpLVREF_AV;
3773 kid = cUNOPo->op_first;
3774 if (kid->op_type == OP_NULL)
3775 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3777 o->op_private = OPpLVREF_CV;
3778 if (kid->op_type == OP_GV)
3779 o->op_flags |= OPf_STACKED;
3780 else if (kid->op_type == OP_PADCV) {
3781 o->op_targ = kid->op_targ;
3783 op_free(cUNOPo->op_first);
3784 cUNOPo->op_first = NULL;
3785 o->op_flags &=~ OPf_KIDS;
3790 if (o->op_flags & OPf_PARENS) {
3792 yyerror(Perl_form(aTHX_ "Can't modify reference to "
3793 "parenthesized hash in list assignment"));
3796 o->op_private |= OPpLVREF_HV;
3800 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3801 o->op_flags |= OPf_STACKED;
3804 if (o->op_flags & OPf_PARENS) goto parenhash;
3805 o->op_private |= OPpLVREF_HV;
3808 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3811 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3812 if (o->op_flags & OPf_PARENS) goto slurpy;
3813 o->op_private |= OPpLVREF_AV;
3817 o->op_private |= OPpLVREF_ELEM;
3818 o->op_flags |= OPf_STACKED;
3822 OpTYPE_set(o, OP_LVREFSLICE);
3823 o->op_private &= OPpLVAL_INTRO;
3826 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3828 else if (!(o->op_flags & OPf_KIDS))
3830 if (o->op_targ != OP_LIST) {
3831 S_lvref(aTHX_ cBINOPo->op_first, type);
3836 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3837 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3838 S_lvref(aTHX_ kid, type);
3842 if (o->op_flags & OPf_PARENS)
3847 /* diag_listed_as: Can't modify reference to %s in %s assignment */
3848 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3849 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3855 OpTYPE_set(o, OP_LVREF);
3857 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3858 if (type == OP_ENTERLOOP)
3859 o->op_private |= OPpLVREF_ITER;
3862 PERL_STATIC_INLINE bool
3863 S_potential_mod_type(I32 type)
3865 /* Types that only potentially result in modification. */
3866 return type == OP_GREPSTART || type == OP_ENTERSUB
3867 || type == OP_REFGEN || type == OP_LEAVESUBLV;
3871 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3875 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3878 if (!o || (PL_parser && PL_parser->error_count))
3881 if ((o->op_private & OPpTARGET_MY)
3882 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3887 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
3889 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3891 switch (o->op_type) {
3896 if ((o->op_flags & OPf_PARENS))
3900 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3901 !(o->op_flags & OPf_STACKED)) {
3902 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3903 assert(cUNOPo->op_first->op_type == OP_NULL);
3904 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
3907 else { /* lvalue subroutine call */
3908 o->op_private |= OPpLVAL_INTRO;
3909 PL_modcount = RETURN_UNLIMITED_NUMBER;
3910 if (S_potential_mod_type(type)) {
3911 o->op_private |= OPpENTERSUB_INARGS;
3914 else { /* Compile-time error message: */
3915 OP *kid = cUNOPo->op_first;
3920 if (kid->op_type != OP_PUSHMARK) {
3921 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3923 "panic: unexpected lvalue entersub "
3924 "args: type/targ %ld:%" UVuf,
3925 (long)kid->op_type, (UV)kid->op_targ);
3926 kid = kLISTOP->op_first;
3928 while (OpHAS_SIBLING(kid))
3929 kid = OpSIBLING(kid);
3930 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3931 break; /* Postpone until runtime */
3934 kid = kUNOP->op_first;
3935 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3936 kid = kUNOP->op_first;
3937 if (kid->op_type == OP_NULL)
3939 "Unexpected constant lvalue entersub "
3940 "entry via type/targ %ld:%" UVuf,
3941 (long)kid->op_type, (UV)kid->op_targ);
3942 if (kid->op_type != OP_GV) {
3949 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3950 ? MUTABLE_CV(SvRV(gv))
3956 if (flags & OP_LVALUE_NO_CROAK)
3959 namesv = cv_name(cv, NULL, 0);
3960 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
3961 "subroutine call of &%" SVf " in %s",
3962 SVfARG(namesv), PL_op_desc[type]),
3970 if (flags & OP_LVALUE_NO_CROAK) return NULL;
3971 /* grep, foreach, subcalls, refgen */
3972 if (S_potential_mod_type(type))
3974 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
3975 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
3978 type ? PL_op_desc[type] : "local"));
3991 case OP_RIGHT_SHIFT:
4000 if (!(o->op_flags & OPf_STACKED))
4006 if (o->op_flags & OPf_STACKED) {
4010 if (!(o->op_private & OPpREPEAT_DOLIST))
4013 const I32 mods = PL_modcount;
4014 modkids(cBINOPo->op_first, type);
4015 if (type != OP_AASSIGN)
4017 kid = cBINOPo->op_last;
4018 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4019 const IV iv = SvIV(kSVOP_sv);
4020 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4022 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4025 PL_modcount = RETURN_UNLIMITED_NUMBER;
4031 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4032 op_lvalue(kid, type);
4037 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4038 PL_modcount = RETURN_UNLIMITED_NUMBER;
4039 return o; /* Treat \(@foo) like ordinary list. */
4043 if (scalar_mod_type(o, type))
4045 ref(cUNOPo->op_first, o->op_type);
4052 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4053 if (type == OP_LEAVESUBLV && (
4054 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4055 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4057 o->op_private |= OPpMAYBE_LVSUB;
4061 PL_modcount = RETURN_UNLIMITED_NUMBER;
4066 if (type == OP_LEAVESUBLV)
4067 o->op_private |= OPpMAYBE_LVSUB;
4070 if (type == OP_LEAVESUBLV
4071 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4072 o->op_private |= OPpMAYBE_LVSUB;
4075 PL_hints |= HINT_BLOCK_SCOPE;
4076 if (type == OP_LEAVESUBLV)
4077 o->op_private |= OPpMAYBE_LVSUB;
4081 ref(cUNOPo->op_first, o->op_type);
4085 PL_hints |= HINT_BLOCK_SCOPE;
4095 case OP_AELEMFAST_LEX:
4102 PL_modcount = RETURN_UNLIMITED_NUMBER;
4103 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4104 return o; /* Treat \(@foo) like ordinary list. */
4105 if (scalar_mod_type(o, type))
4107 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4108 && type == OP_LEAVESUBLV)
4109 o->op_private |= OPpMAYBE_LVSUB;
4113 if (!type) /* local() */
4114 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4115 PNfARG(PAD_COMPNAME(o->op_targ)));
4116 if (!(o->op_private & OPpLVAL_INTRO)
4117 || ( type != OP_SASSIGN && type != OP_AASSIGN
4118 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4119 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4127 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4131 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4137 if (type == OP_LEAVESUBLV)
4138 o->op_private |= OPpMAYBE_LVSUB;
4139 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4140 /* substr and vec */
4141 /* If this op is in merely potential (non-fatal) modifiable
4142 context, then apply OP_ENTERSUB context to
4143 the kid op (to avoid croaking). Other-
4144 wise pass this op’s own type so the correct op is mentioned
4145 in error messages. */
4146 op_lvalue(OpSIBLING(cBINOPo->op_first),
4147 S_potential_mod_type(type)
4155 ref(cBINOPo->op_first, o->op_type);
4156 if (type == OP_ENTERSUB &&
4157 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4158 o->op_private |= OPpLVAL_DEFER;
4159 if (type == OP_LEAVESUBLV)
4160 o->op_private |= OPpMAYBE_LVSUB;
4167 o->op_private |= OPpLVALUE;
4173 if (o->op_flags & OPf_KIDS)
4174 op_lvalue(cLISTOPo->op_last, type);
4179 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4181 else if (!(o->op_flags & OPf_KIDS))
4184 if (o->op_targ != OP_LIST) {
4185 OP *sib = OpSIBLING(cLISTOPo->op_first);
4186 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4193 * compared with things like OP_MATCH which have the argument
4199 * so handle specially to correctly get "Can't modify" croaks etc
4202 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4204 /* this should trigger a "Can't modify transliteration" err */
4205 op_lvalue(sib, type);
4207 op_lvalue(cBINOPo->op_first, type);
4213 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4214 /* elements might be in void context because the list is
4215 in scalar context or because they are attribute sub calls */
4216 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4217 op_lvalue(kid, type);
4225 if (type == OP_LEAVESUBLV
4226 || !S_vivifies(cLOGOPo->op_first->op_type))
4227 op_lvalue(cLOGOPo->op_first, type);
4228 if (type == OP_LEAVESUBLV
4229 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4230 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4234 if (type == OP_NULL) { /* local */
4236 if (!FEATURE_MYREF_IS_ENABLED)
4237 Perl_croak(aTHX_ "The experimental declared_refs "
4238 "feature is not enabled");
4239 Perl_ck_warner_d(aTHX_
4240 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4241 "Declaring references is experimental");
4242 op_lvalue(cUNOPo->op_first, OP_NULL);
4245 if (type != OP_AASSIGN && type != OP_SASSIGN
4246 && type != OP_ENTERLOOP)
4248 /* Don’t bother applying lvalue context to the ex-list. */
4249 kid = cUNOPx(cUNOPo->op_first)->op_first;
4250 assert (!OpHAS_SIBLING(kid));
4253 if (type == OP_NULL) /* local */
4255 if (type != OP_AASSIGN) goto nomod;
4256 kid = cUNOPo->op_first;
4259 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4260 S_lvref(aTHX_ kid, type);
4261 if (!PL_parser || PL_parser->error_count == ec) {
4262 if (!FEATURE_REFALIASING_IS_ENABLED)
4264 "Experimental aliasing via reference not enabled");
4265 Perl_ck_warner_d(aTHX_
4266 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4267 "Aliasing via reference is experimental");
4270 if (o->op_type == OP_REFGEN)
4271 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4276 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4277 /* This is actually @array = split. */
4278 PL_modcount = RETURN_UNLIMITED_NUMBER;
4284 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4288 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4289 their argument is a filehandle; thus \stat(".") should not set
4291 if (type == OP_REFGEN &&
4292 PL_check[o->op_type] == Perl_ck_ftst)
4295 if (type != OP_LEAVESUBLV)
4296 o->op_flags |= OPf_MOD;
4298 if (type == OP_AASSIGN || type == OP_SASSIGN)
4299 o->op_flags |= OPf_SPECIAL
4300 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4301 else if (!type) { /* local() */
4304 o->op_private |= OPpLVAL_INTRO;
4305 o->op_flags &= ~OPf_SPECIAL;
4306 PL_hints |= HINT_BLOCK_SCOPE;
4311 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4312 "Useless localization of %s", OP_DESC(o));
4315 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4316 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4317 o->op_flags |= OPf_REF;
4322 S_scalar_mod_type(const OP *o, I32 type)
4327 if (o && o->op_type == OP_RV2GV)
4351 case OP_RIGHT_SHIFT:
4380 S_is_handle_constructor(const OP *o, I32 numargs)
4382 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4384 switch (o->op_type) {
4392 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4405 S_refkids(pTHX_ OP *o, I32 type)
4407 if (o && o->op_flags & OPf_KIDS) {
4409 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4416 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4421 PERL_ARGS_ASSERT_DOREF;
4423 if (PL_parser && PL_parser->error_count)
4426 switch (o->op_type) {
4428 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4429 !(o->op_flags & OPf_STACKED)) {
4430 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4431 assert(cUNOPo->op_first->op_type == OP_NULL);
4432 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
4433 o->op_flags |= OPf_SPECIAL;
4435 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4436 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4437 : type == OP_RV2HV ? OPpDEREF_HV
4439 o->op_flags |= OPf_MOD;
4445 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4446 doref(kid, type, set_op_ref);
4449 if (type == OP_DEFINED)
4450 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4451 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4454 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4455 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4456 : type == OP_RV2HV ? OPpDEREF_HV
4458 o->op_flags |= OPf_MOD;
4465 o->op_flags |= OPf_REF;
4468 if (type == OP_DEFINED)
4469 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4470 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4476 o->op_flags |= OPf_REF;
4481 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4483 doref(cBINOPo->op_first, type, set_op_ref);
4487 doref(cBINOPo->op_first, o->op_type, set_op_ref);
4488 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;
4502 if (!(o->op_flags & OPf_KIDS))
4504 doref(cLISTOPo->op_last, type, set_op_ref);
4514 S_dup_attrlist(pTHX_ OP *o)
4518 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4520 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4521 * where the first kid is OP_PUSHMARK and the remaining ones
4522 * are OP_CONST. We need to push the OP_CONST values.
4524 if (o->op_type == OP_CONST)
4525 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4527 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4529 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4530 if (o->op_type == OP_CONST)
4531 rop = op_append_elem(OP_LIST, rop,
4532 newSVOP(OP_CONST, o->op_flags,
4533 SvREFCNT_inc_NN(cSVOPo->op_sv)));
4540 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4542 PERL_ARGS_ASSERT_APPLY_ATTRS;
4544 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4546 /* fake up C<use attributes $pkg,$rv,@attrs> */
4548 #define ATTRSMODULE "attributes"
4549 #define ATTRSMODULE_PM "attributes.pm"
4552 aTHX_ PERL_LOADMOD_IMPORT_OPS,
4553 newSVpvs(ATTRSMODULE),
4555 op_prepend_elem(OP_LIST,
4556 newSVOP(OP_CONST, 0, stashsv),
4557 op_prepend_elem(OP_LIST,
4558 newSVOP(OP_CONST, 0,
4560 dup_attrlist(attrs))));
4565 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4567 OP *pack, *imop, *arg;
4568 SV *meth, *stashsv, **svp;
4570 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4575 assert(target->op_type == OP_PADSV ||
4576 target->op_type == OP_PADHV ||
4577 target->op_type == OP_PADAV);
4579 /* Ensure that attributes.pm is loaded. */
4580 /* Don't force the C<use> if we don't need it. */
4581 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4582 if (svp && *svp != &PL_sv_undef)
4583 NOOP; /* already in %INC */
4585 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4586 newSVpvs(ATTRSMODULE), NULL);
4588 /* Need package name for method call. */
4589 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4591 /* Build up the real arg-list. */
4592 stashsv = newSVhek(HvNAME_HEK(stash));
4594 arg = newOP(OP_PADSV, 0);
4595 arg->op_targ = target->op_targ;
4596 arg = op_prepend_elem(OP_LIST,
4597 newSVOP(OP_CONST, 0, stashsv),
4598 op_prepend_elem(OP_LIST,
4599 newUNOP(OP_REFGEN, 0,
4601 dup_attrlist(attrs)));
4603 /* Fake up a method call to import */
4604 meth = newSVpvs_share("import");
4605 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4606 op_append_elem(OP_LIST,
4607 op_prepend_elem(OP_LIST, pack, arg),
4608 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4610 /* Combine the ops. */
4611 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4615 =notfor apidoc apply_attrs_string
4617 Attempts to apply a list of attributes specified by the C<attrstr> and
4618 C<len> arguments to the subroutine identified by the C<cv> argument which
4619 is expected to be associated with the package identified by the C<stashpv>
4620 argument (see L<attributes>). It gets this wrong, though, in that it
4621 does not correctly identify the boundaries of the individual attribute
4622 specifications within C<attrstr>. This is not really intended for the
4623 public API, but has to be listed here for systems such as AIX which
4624 need an explicit export list for symbols. (It's called from XS code
4625 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
4626 to respect attribute syntax properly would be welcome.
4632 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4633 const char *attrstr, STRLEN len)
4637 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4640 len = strlen(attrstr);
4644 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4646 const char * const sstr = attrstr;
4647 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4648 attrs = op_append_elem(OP_LIST, attrs,
4649 newSVOP(OP_CONST, 0,
4650 newSVpvn(sstr, attrstr-sstr)));
4654 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4655 newSVpvs(ATTRSMODULE),
4656 NULL, op_prepend_elem(OP_LIST,
4657 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4658 op_prepend_elem(OP_LIST,
4659 newSVOP(OP_CONST, 0,
4660 newRV(MUTABLE_SV(cv))),
4665 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4668 OP *new_proto = NULL;
4673 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4679 if (o->op_type == OP_CONST) {
4680 pv = SvPV(cSVOPo_sv, pvlen);
4681 if (memBEGINs(pv, pvlen, "prototype(")) {
4682 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4683 SV ** const tmpo = cSVOPx_svp(o);
4684 SvREFCNT_dec(cSVOPo_sv);
4689 } else if (o->op_type == OP_LIST) {
4691 assert(o->op_flags & OPf_KIDS);
4692 lasto = cLISTOPo->op_first;
4693 assert(lasto->op_type == OP_PUSHMARK);
4694 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4695 if (o->op_type == OP_CONST) {
4696 pv = SvPV(cSVOPo_sv, pvlen);
4697 if (memBEGINs(pv, pvlen, "prototype(")) {
4698 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4699 SV ** const tmpo = cSVOPx_svp(o);
4700 SvREFCNT_dec(cSVOPo_sv);
4702 if (new_proto && ckWARN(WARN_MISC)) {
4704 const char * newp = SvPV(cSVOPo_sv, new_len);
4705 Perl_warner(aTHX_ packWARN(WARN_MISC),
4706 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4707 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4713 /* excise new_proto from the list */
4714 op_sibling_splice(*attrs, lasto, 1, NULL);
4721 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4722 would get pulled in with no real need */
4723 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4732 svname = sv_newmortal();
4733 gv_efullname3(svname, name, NULL);
4735 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4736 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4738 svname = (SV *)name;
4739 if (ckWARN(WARN_ILLEGALPROTO))
4740 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4742 if (*proto && ckWARN(WARN_PROTOTYPE)) {
4743 STRLEN old_len, new_len;
4744 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4745 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4747 if (curstash && svname == (SV *)name
4748 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4749 svname = sv_2mortal(newSVsv(PL_curstname));
4750 sv_catpvs(svname, "::");
4751 sv_catsv(svname, (SV *)name);
4754 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4755 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4757 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4758 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4768 S_cant_declare(pTHX_ OP *o)
4770 if (o->op_type == OP_NULL
4771 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4772 o = cUNOPo->op_first;
4773 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4774 o->op_type == OP_NULL
4775 && o->op_flags & OPf_SPECIAL
4778 PL_parser->in_my == KEY_our ? "our" :
4779 PL_parser->in_my == KEY_state ? "state" :
4784 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4787 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4789 PERL_ARGS_ASSERT_MY_KID;
4791 if (!o || (PL_parser && PL_parser->error_count))
4796 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4798 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4799 my_kid(kid, attrs, imopsp);
4801 } else if (type == OP_UNDEF || type == OP_STUB) {
4803 } else if (type == OP_RV2SV || /* "our" declaration */
4806 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4807 S_cant_declare(aTHX_ o);
4809 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4811 PL_parser->in_my = FALSE;
4812 PL_parser->in_my_stash = NULL;
4813 apply_attrs(GvSTASH(gv),
4814 (type == OP_RV2SV ? GvSVn(gv) :
4815 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4816 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4819 o->op_private |= OPpOUR_INTRO;
4822 else if (type == OP_REFGEN || type == OP_SREFGEN) {
4823 if (!FEATURE_MYREF_IS_ENABLED)
4824 Perl_croak(aTHX_ "The experimental declared_refs "
4825 "feature is not enabled");
4826 Perl_ck_warner_d(aTHX_
4827 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4828 "Declaring references is experimental");
4829 /* Kid is a nulled OP_LIST, handled above. */
4830 my_kid(cUNOPo->op_first, attrs, imopsp);
4833 else if (type != OP_PADSV &&
4836 type != OP_PUSHMARK)
4838 S_cant_declare(aTHX_ o);
4841 else if (attrs && type != OP_PUSHMARK) {
4845 PL_parser->in_my = FALSE;
4846 PL_parser->in_my_stash = NULL;
4848 /* check for C<my Dog $spot> when deciding package */
4849 stash = PAD_COMPNAME_TYPE(o->op_targ);
4851 stash = PL_curstash;
4852 apply_attrs_my(stash, o, attrs, imopsp);
4854 o->op_flags |= OPf_MOD;
4855 o->op_private |= OPpLVAL_INTRO;
4857 o->op_private |= OPpPAD_STATE;
4862 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4865 int maybe_scalar = 0;
4867 PERL_ARGS_ASSERT_MY_ATTRS;
4869 /* [perl #17376]: this appears to be premature, and results in code such as
4870 C< our(%x); > executing in list mode rather than void mode */
4872 if (o->op_flags & OPf_PARENS)
4882 o = my_kid(o, attrs, &rops);
4884 if (maybe_scalar && o->op_type == OP_PADSV) {
4885 o = scalar(op_append_list(OP_LIST, rops, o));
4886 o->op_private |= OPpLVAL_INTRO;
4889 /* The listop in rops might have a pushmark at the beginning,
4890 which will mess up list assignment. */
4891 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
4892 if (rops->op_type == OP_LIST &&
4893 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4895 OP * const pushmark = lrops->op_first;
4896 /* excise pushmark */
4897 op_sibling_splice(rops, NULL, 1, NULL);
4900 o = op_append_list(OP_LIST, o, rops);
4903 PL_parser->in_my = FALSE;
4904 PL_parser->in_my_stash = NULL;
4909 Perl_sawparens(pTHX_ OP *o)
4911 PERL_UNUSED_CONTEXT;
4913 o->op_flags |= OPf_PARENS;
4918 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4922 const OPCODE ltype = left->op_type;
4923 const OPCODE rtype = right->op_type;
4925 PERL_ARGS_ASSERT_BIND_MATCH;
4927 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4928 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4930 const char * const desc
4932 rtype == OP_SUBST || rtype == OP_TRANS
4933 || rtype == OP_TRANSR
4935 ? (int)rtype : OP_MATCH];
4936 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4938 S_op_varname(aTHX_ left);
4940 Perl_warner(aTHX_ packWARN(WARN_MISC),
4941 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4942 desc, SVfARG(name), SVfARG(name));
4944 const char * const sample = (isary
4945 ? "@array" : "%hash");
4946 Perl_warner(aTHX_ packWARN(WARN_MISC),
4947 "Applying %s to %s will act on scalar(%s)",
4948 desc, sample, sample);
4952 if (rtype == OP_CONST &&
4953 cSVOPx(right)->op_private & OPpCONST_BARE &&
4954 cSVOPx(right)->op_private & OPpCONST_STRICT)
4956 no_bareword_allowed(right);
4959 /* !~ doesn't make sense with /r, so error on it for now */
4960 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
4962 /* diag_listed_as: Using !~ with %s doesn't make sense */
4963 yyerror("Using !~ with s///r doesn't make sense");
4964 if (rtype == OP_TRANSR && type == OP_NOT)
4965 /* diag_listed_as: Using !~ with %s doesn't make sense */
4966 yyerror("Using !~ with tr///r doesn't make sense");
4968 ismatchop = (rtype == OP_MATCH ||
4969 rtype == OP_SUBST ||
4970 rtype == OP_TRANS || rtype == OP_TRANSR)
4971 && !(right->op_flags & OPf_SPECIAL);
4972 if (ismatchop && right->op_private & OPpTARGET_MY) {
4974 right->op_private &= ~OPpTARGET_MY;
4976 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
4977 if (left->op_type == OP_PADSV
4978 && !(left->op_private & OPpLVAL_INTRO))
4980 right->op_targ = left->op_targ;
4985 right->op_flags |= OPf_STACKED;
4986 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
4987 ! (rtype == OP_TRANS &&
4988 right->op_private & OPpTRANS_IDENTICAL) &&
4989 ! (rtype == OP_SUBST &&
4990 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
4991 left = op_lvalue(left, rtype);
4992 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
4993 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
4995 o = op_prepend_elem(rtype, scalar(left), right);
4998 return newUNOP(OP_NOT, 0, scalar(o));
5002 return bind_match(type, left,
5003 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5007 Perl_invert(pTHX_ OP *o)
5011 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5015 =for apidoc Amx|OP *|op_scope|OP *o
5017 Wraps up an op tree with some additional ops so that at runtime a dynamic
5018 scope will be created. The original ops run in the new dynamic scope,
5019 and then, provided that they exit normally, the scope will be unwound.
5020 The additional ops used to create and unwind the dynamic scope will
5021 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5022 instead if the ops are simple enough to not need the full dynamic scope
5029 Perl_op_scope(pTHX_ OP *o)
5033 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5034 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5035 OpTYPE_set(o, OP_LEAVE);
5037 else if (o->op_type == OP_LINESEQ) {
5039 OpTYPE_set(o, OP_SCOPE);
5040 kid = ((LISTOP*)o)->op_first;
5041 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5044 /* The following deals with things like 'do {1 for 1}' */
5045 kid = OpSIBLING(kid);
5047 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5052 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5058 Perl_op_unscope(pTHX_ OP *o)
5060 if (o && o->op_type == OP_LINESEQ) {
5061 OP *kid = cLISTOPo->op_first;
5062 for(; kid; kid = OpSIBLING(kid))
5063 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5070 =for apidoc Am|int|block_start|int full
5072 Handles compile-time scope entry.
5073 Arranges for hints to be restored on block
5074 exit and also handles pad sequence numbers to make lexical variables scope
5075 right. Returns a savestack index for use with C<block_end>.
5081 Perl_block_start(pTHX_ int full)
5083 const int retval = PL_savestack_ix;
5085 PL_compiling.cop_seq = PL_cop_seqmax;
5087 pad_block_start(full);
5089 PL_hints &= ~HINT_BLOCK_SCOPE;
5090 SAVECOMPILEWARNINGS();
5091 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5092 SAVEI32(PL_compiling.cop_seq);
5093 PL_compiling.cop_seq = 0;
5095 CALL_BLOCK_HOOKS(bhk_start, full);
5101 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5103 Handles compile-time scope exit. C<floor>
5104 is the savestack index returned by
5105 C<block_start>, and C<seq> is the body of the block. Returns the block,
5112 Perl_block_end(pTHX_ I32 floor, OP *seq)
5114 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5115 OP* retval = scalarseq(seq);
5118 /* XXX Is the null PL_parser check necessary here? */
5119 assert(PL_parser); /* Let’s find out under debugging builds. */
5120 if (PL_parser && PL_parser->parsed_sub) {
5121 o = newSTATEOP(0, NULL, NULL);
5123 retval = op_append_elem(OP_LINESEQ, retval, o);
5126 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5130 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5134 /* pad_leavemy has created a sequence of introcv ops for all my
5135 subs declared in the block. We have to replicate that list with
5136 clonecv ops, to deal with this situation:
5141 sub s1 { state sub foo { \&s2 } }
5144 Originally, I was going to have introcv clone the CV and turn
5145 off the stale flag. Since &s1 is declared before &s2, the
5146 introcv op for &s1 is executed (on sub entry) before the one for
5147 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5148 cloned, since it is a state sub) closes over &s2 and expects
5149 to see it in its outer CV’s pad. If the introcv op clones &s1,
5150 then &s2 is still marked stale. Since &s1 is not active, and
5151 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5152 ble will not stay shared’ warning. Because it is the same stub
5153 that will be used when the introcv op for &s2 is executed, clos-
5154 ing over it is safe. Hence, we have to turn off the stale flag
5155 on all lexical subs in the block before we clone any of them.
5156 Hence, having introcv clone the sub cannot work. So we create a
5157 list of ops like this:
5181 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5182 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5183 for (;; kid = OpSIBLING(kid)) {
5184 OP *newkid = newOP(OP_CLONECV, 0);
5185 newkid->op_targ = kid->op_targ;
5186 o = op_append_elem(OP_LINESEQ, o, newkid);
5187 if (kid == last) break;
5189 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5192 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5198 =head1 Compile-time scope hooks
5200 =for apidoc Aox||blockhook_register
5202 Register a set of hooks to be called when the Perl lexical scope changes
5203 at compile time. See L<perlguts/"Compile-time scope hooks">.
5209 Perl_blockhook_register(pTHX_ BHK *hk)
5211 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5213 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5217 Perl_newPROG(pTHX_ OP *o)
5221 PERL_ARGS_ASSERT_NEWPROG;
5228 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5229 ((PL_in_eval & EVAL_KEEPERR)
5230 ? OPf_SPECIAL : 0), o);
5233 assert(CxTYPE(cx) == CXt_EVAL);
5235 if ((cx->blk_gimme & G_WANT) == G_VOID)
5236 scalarvoid(PL_eval_root);
5237 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5240 scalar(PL_eval_root);
5242 start = op_linklist(PL_eval_root);
5243 PL_eval_root->op_next = 0;
5244 i = PL_savestack_ix;
5247 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5249 PL_savestack_ix = i;
5252 if (o->op_type == OP_STUB) {
5253 /* This block is entered if nothing is compiled for the main
5254 program. This will be the case for an genuinely empty main
5255 program, or one which only has BEGIN blocks etc, so already
5258 Historically (5.000) the guard above was !o. However, commit
5259 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5260 c71fccf11fde0068, changed perly.y so that newPROG() is now
5261 called with the output of block_end(), which returns a new
5262 OP_STUB for the case of an empty optree. ByteLoader (and
5263 maybe other things) also take this path, because they set up
5264 PL_main_start and PL_main_root directly, without generating an
5267 If the parsing the main program aborts (due to parse errors,
5268 or due to BEGIN or similar calling exit), then newPROG()
5269 isn't even called, and hence this code path and its cleanups
5270 are skipped. This shouldn't make a make a difference:
5271 * a non-zero return from perl_parse is a failure, and
5272 perl_destruct() should be called immediately.
5273 * however, if exit(0) is called during the parse, then
5274 perl_parse() returns 0, and perl_run() is called. As
5275 PL_main_start will be NULL, perl_run() will return
5276 promptly, and the exit code will remain 0.
5279 PL_comppad_name = 0;
5281 S_op_destroy(aTHX_ o);
5284 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5285 PL_curcop = &PL_compiling;
5286 start = LINKLIST(PL_main_root);
5287 PL_main_root->op_next = 0;
5288 S_process_optree(aTHX_ NULL, PL_main_root, start);
5289 cv_forget_slab(PL_compcv);
5292 /* Register with debugger */
5294 CV * const cv = get_cvs("DB::postponed", 0);
5298 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5300 call_sv(MUTABLE_SV(cv), G_DISCARD);
5307 Perl_localize(pTHX_ OP *o, I32 lex)
5309 PERL_ARGS_ASSERT_LOCALIZE;
5311 if (o->op_flags & OPf_PARENS)
5312 /* [perl #17376]: this appears to be premature, and results in code such as
5313 C< our(%x); > executing in list mode rather than void mode */
5320 if ( PL_parser->bufptr > PL_parser->oldbufptr
5321 && PL_parser->bufptr[-1] == ','
5322 && ckWARN(WARN_PARENTHESIS))
5324 char *s = PL_parser->bufptr;
5327 /* some heuristics to detect a potential error */
5328 while (*s && (strchr(", \t\n", *s)))
5332 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5334 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5337 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5339 while (*s && (strchr(", \t\n", *s)))
5345 if (sigil && (*s == ';' || *s == '=')) {
5346 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5347 "Parentheses missing around \"%s\" list",
5349 ? (PL_parser->in_my == KEY_our
5351 : PL_parser->in_my == KEY_state
5361 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5362 PL_parser->in_my = FALSE;
5363 PL_parser->in_my_stash = NULL;
5368 Perl_jmaybe(pTHX_ OP *o)
5370 PERL_ARGS_ASSERT_JMAYBE;
5372 if (o->op_type == OP_LIST) {
5374 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5375 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5380 PERL_STATIC_INLINE OP *
5381 S_op_std_init(pTHX_ OP *o)
5383 I32 type = o->op_type;
5385 PERL_ARGS_ASSERT_OP_STD_INIT;
5387 if (PL_opargs[type] & OA_RETSCALAR)
5389 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5390 o->op_targ = pad_alloc(type, SVs_PADTMP);
5395 PERL_STATIC_INLINE OP *
5396 S_op_integerize(pTHX_ OP *o)
5398 I32 type = o->op_type;
5400 PERL_ARGS_ASSERT_OP_INTEGERIZE;
5402 /* integerize op. */
5403 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5406 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5409 if (type == OP_NEGATE)
5410 /* XXX might want a ck_negate() for this */
5411 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5417 S_fold_constants(pTHX_ OP *const o)
5420 OP * volatile curop;
5422 volatile I32 type = o->op_type;
5424 SV * volatile sv = NULL;
5427 SV * const oldwarnhook = PL_warnhook;
5428 SV * const olddiehook = PL_diehook;
5430 U8 oldwarn = PL_dowarn;
5434 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5436 if (!(PL_opargs[type] & OA_FOLDCONST))
5445 #ifdef USE_LOCALE_CTYPE
5446 if (IN_LC_COMPILETIME(LC_CTYPE))
5455 #ifdef USE_LOCALE_COLLATE
5456 if (IN_LC_COMPILETIME(LC_COLLATE))
5461 /* XXX what about the numeric ops? */
5462 #ifdef USE_LOCALE_NUMERIC
5463 if (IN_LC_COMPILETIME(LC_NUMERIC))
5468 if (!OpHAS_SIBLING(cLISTOPo->op_first)
5469 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5472 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5473 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5475 const char *s = SvPVX_const(sv);
5476 while (s < SvEND(sv)) {
5477 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5484 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5487 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5488 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5492 if (PL_parser && PL_parser->error_count)
5493 goto nope; /* Don't try to run w/ errors */
5495 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5496 switch (curop->op_type) {
5498 if ( (curop->op_private & OPpCONST_BARE)
5499 && (curop->op_private & OPpCONST_STRICT)) {
5500 no_bareword_allowed(curop);
5508 /* Foldable; move to next op in list */
5512 /* No other op types are considered foldable */
5517 curop = LINKLIST(o);
5518 old_next = o->op_next;
5522 old_cxix = cxstack_ix;
5523 create_eval_scope(NULL, G_FAKINGEVAL);
5525 /* Verify that we don't need to save it: */
5526 assert(PL_curcop == &PL_compiling);
5527 StructCopy(&PL_compiling, ¬_compiling, COP);
5528 PL_curcop = ¬_compiling;
5529 /* The above ensures that we run with all the correct hints of the
5530 currently compiling COP, but that IN_PERL_RUNTIME is true. */
5531 assert(IN_PERL_RUNTIME);
5532 PL_warnhook = PERL_WARNHOOK_FATAL;
5536 /* Effective $^W=1. */
5537 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5538 PL_dowarn |= G_WARN_ON;
5543 sv = *(PL_stack_sp--);
5544 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
5545 pad_swipe(o->op_targ, FALSE);
5547 else if (SvTEMP(sv)) { /* grab mortal temp? */
5548 SvREFCNT_inc_simple_void(sv);
5551 else { assert(SvIMMORTAL(sv)); }
5554 /* Something tried to die. Abandon constant folding. */
5555 /* Pretend the error never happened. */
5557 o->op_next = old_next;
5561 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
5562 PL_warnhook = oldwarnhook;
5563 PL_diehook = olddiehook;
5564 /* XXX note that this croak may fail as we've already blown away
5565 * the stack - eg any nested evals */
5566 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5569 PL_dowarn = oldwarn;
5570 PL_warnhook = oldwarnhook;
5571 PL_diehook = olddiehook;
5572 PL_curcop = &PL_compiling;
5574 /* if we croaked, depending on how we croaked the eval scope
5575 * may or may not have already been popped */
5576 if (cxstack_ix > old_cxix) {
5577 assert(cxstack_ix == old_cxix + 1);
5578 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5579 delete_eval_scope();
5584 /* OP_STRINGIFY and constant folding are used to implement qq.
5585 Here the constant folding is an implementation detail that we
5586 want to hide. If the stringify op is itself already marked
5587 folded, however, then it is actually a folded join. */
5588 is_stringify = type == OP_STRINGIFY && !o->op_folded;
5593 else if (!SvIMMORTAL(sv)) {
5597 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5598 if (!is_stringify) newop->op_folded = 1;
5606 S_gen_constant_list(pTHX_ OP *o)
5609 OP *curop, *old_next;
5610 SV * const oldwarnhook = PL_warnhook;
5611 SV * const olddiehook = PL_diehook;
5613 U8 oldwarn = PL_dowarn;
5623 if (PL_parser && PL_parser->error_count)
5624 return o; /* Don't attempt to run with errors */
5626 curop = LINKLIST(o);
5627 old_next = o->op_next;
5629 op_was_null = o->op_type == OP_NULL;
5630 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5631 o->op_type = OP_CUSTOM;
5634 o->op_type = OP_NULL;
5635 S_prune_chain_head(&curop);
5638 old_cxix = cxstack_ix;
5639 create_eval_scope(NULL, G_FAKINGEVAL);
5641 old_curcop = PL_curcop;
5642 StructCopy(old_curcop, ¬_compiling, COP);
5643 PL_curcop = ¬_compiling;
5644 /* The above ensures that we run with all the correct hints of the
5645 current COP, but that IN_PERL_RUNTIME is true. */
5646 assert(IN_PERL_RUNTIME);
5647 PL_warnhook = PERL_WARNHOOK_FATAL;
5651 /* Effective $^W=1. */
5652 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5653 PL_dowarn |= G_WARN_ON;
5657 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5658 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5660 Perl_pp_pushmark(aTHX);
5663 assert (!(curop->op_flags & OPf_SPECIAL));
5664 assert(curop->op_type == OP_RANGE);
5665 Perl_pp_anonlist(aTHX);
5669 o->op_next = old_next;
5673 PL_warnhook = oldwarnhook;
5674 PL_diehook = olddiehook;
5675 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5680 PL_dowarn = oldwarn;
5681 PL_warnhook = oldwarnhook;
5682 PL_diehook = olddiehook;
5683 PL_curcop = old_curcop;
5685 if (cxstack_ix > old_cxix) {
5686 assert(cxstack_ix == old_cxix + 1);
5687 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5688 delete_eval_scope();
5693 OpTYPE_set(o, OP_RV2AV);
5694 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
5695 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
5696 o->op_opt = 0; /* needs to be revisited in rpeep() */
5697 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5699 /* replace subtree with an OP_CONST */
5700 curop = ((UNOP*)o)->op_first;
5701 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5704 if (AvFILLp(av) != -1)
5705 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5708 SvREADONLY_on(*svp);
5715 =head1 Optree Manipulation Functions
5718 /* List constructors */
5721 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5723 Append an item to the list of ops contained directly within a list-type
5724 op, returning the lengthened list. C<first> is the list-type op,
5725 and C<last> is the op to append to the list. C<optype> specifies the
5726 intended opcode for the list. If C<first> is not already a list of the
5727 right type, it will be upgraded into one. If either C<first> or C<last>
5728 is null, the other is returned unchanged.
5734 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5742 if (first->op_type != (unsigned)type
5743 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5745 return newLISTOP(type, 0, first, last);
5748 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5749 first->op_flags |= OPf_KIDS;
5754 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5756 Concatenate the lists of ops contained directly within two list-type ops,
5757 returning the combined list. C<first> and C<last> are the list-type ops
5758 to concatenate. C<optype> specifies the intended opcode for the list.
5759 If either C<first> or C<last> is not already a list of the right type,
5760 it will be upgraded into one. If either C<first> or C<last> is null,
5761 the other is returned unchanged.
5767 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5775 if (first->op_type != (unsigned)type)
5776 return op_prepend_elem(type, first, last);
5778 if (last->op_type != (unsigned)type)
5779 return op_append_elem(type, first, last);
5781 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5782 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5783 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5784 first->op_flags |= (last->op_flags & OPf_KIDS);
5786 S_op_destroy(aTHX_ last);
5792 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5794 Prepend an item to the list of ops contained directly within a list-type
5795 op, returning the lengthened list. C<first> is the op to prepend to the
5796 list, and C<last> is the list-type op. C<optype> specifies the intended
5797 opcode for the list. If C<last> is not already a list of the right type,
5798 it will be upgraded into one. If either C<first> or C<last> is null,
5799 the other is returned unchanged.
5805 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5813 if (last->op_type == (unsigned)type) {
5814 if (type == OP_LIST) { /* already a PUSHMARK there */
5815 /* insert 'first' after pushmark */
5816 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5817 if (!(first->op_flags & OPf_PARENS))
5818 last->op_flags &= ~OPf_PARENS;
5821 op_sibling_splice(last, NULL, 0, first);
5822 last->op_flags |= OPf_KIDS;
5826 return newLISTOP(type, 0, first, last);
5830 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5832 Converts C<o> into a list op if it is not one already, and then converts it
5833 into the specified C<type>, calling its check function, allocating a target if
5834 it needs one, and folding constants.
5836 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5837 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
5838 C<op_convert_list> to make it the right type.
5844 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5847 if (type < 0) type = -type, flags |= OPf_SPECIAL;
5848 if (!o || o->op_type != OP_LIST)
5849 o = force_list(o, 0);
5852 o->op_flags &= ~OPf_WANT;
5853 o->op_private &= ~OPpLVAL_INTRO;
5856 if (!(PL_opargs[type] & OA_MARK))
5857 op_null(cLISTOPo->op_first);
5859 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5860 if (kid2 && kid2->op_type == OP_COREARGS) {
5861 op_null(cLISTOPo->op_first);
5862 kid2->op_private |= OPpCOREARGS_PUSHMARK;
5866 if (type != OP_SPLIT)
5867 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5868 * ck_split() create a real PMOP and leave the op's type as listop
5869 * for now. Otherwise op_free() etc will crash.
5871 OpTYPE_set(o, type);
5873 o->op_flags |= flags;
5874 if (flags & OPf_FOLDED)
5877 o = CHECKOP(type, o);
5878 if (o->op_type != (unsigned)type)
5881 return fold_constants(op_integerize(op_std_init(o)));
5888 =head1 Optree construction
5890 =for apidoc Am|OP *|newNULLLIST
5892 Constructs, checks, and returns a new C<stub> op, which represents an
5893 empty list expression.
5899 Perl_newNULLLIST(pTHX)
5901 return newOP(OP_STUB, 0);
5904 /* promote o and any siblings to be a list if its not already; i.e.
5912 * pushmark - o - A - B
5914 * If nullit it true, the list op is nulled.
5918 S_force_list(pTHX_ OP *o, bool nullit)
5920 if (!o || o->op_type != OP_LIST) {
5923 /* manually detach any siblings then add them back later */
5924 rest = OpSIBLING(o);
5925 OpLASTSIB_set(o, NULL);
5927 o = newLISTOP(OP_LIST, 0, o, NULL);
5929 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5937 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
5939 Constructs, checks, and returns an op of any list type. C<type> is
5940 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
5941 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
5942 supply up to two ops to be direct children of the list op; they are
5943 consumed by this function and become part of the constructed op tree.
5945 For most list operators, the check function expects all the kid ops to be
5946 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
5947 appropriate. What you want to do in that case is create an op of type
5948 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
5949 See L</op_convert_list> for more information.
5956 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5961 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
5962 || type == OP_CUSTOM);
5964 NewOp(1101, listop, 1, LISTOP);
5966 OpTYPE_set(listop, type);
5969 listop->op_flags = (U8)flags;
5973 else if (!first && last)
5976 OpMORESIB_set(first, last);
5977 listop->op_first = first;
5978 listop->op_last = last;
5979 if (type == OP_LIST) {
5980 OP* const pushop = newOP(OP_PUSHMARK, 0);
5981 OpMORESIB_set(pushop, first);
5982 listop->op_first = pushop;
5983 listop->op_flags |= OPf_KIDS;
5985 listop->op_last = pushop;
5987 if (listop->op_last)
5988 OpLASTSIB_set(listop->op_last, (OP*)listop);
5990 return CHECKOP(type, listop);
5994 =for apidoc Am|OP *|newOP|I32 type|I32 flags
5996 Constructs, checks, and returns an op of any base type (any type that
5997 has no extra fields). C<type> is the opcode. C<flags> gives the
5998 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6005 Perl_newOP(pTHX_ I32 type, I32 flags)
6010 if (type == -OP_ENTEREVAL) {
6011 type = OP_ENTEREVAL;
6012 flags |= OPpEVAL_BYTES<<8;
6015 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6016 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6017 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6018 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6020 NewOp(1101, o, 1, OP);
6021 OpTYPE_set(o, type);
6022 o->op_flags = (U8)flags;
6025 o->op_private = (U8)(0 | (flags >> 8));
6026 if (PL_opargs[type] & OA_RETSCALAR)
6028 if (PL_opargs[type] & OA_TARGET)
6029 o->op_targ = pad_alloc(type, SVs_PADTMP);
6030 return CHECKOP(type, o);
6034 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6036 Constructs, checks, and returns an op of any unary type. C<type> is
6037 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6038 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6039 bits, the eight bits of C<op_private>, except that the bit with value 1
6040 is automatically set. C<first> supplies an optional op to be the direct
6041 child of the unary op; it is consumed by this function and become part
6042 of the constructed op tree.
6048 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6053 if (type == -OP_ENTEREVAL) {
6054 type = OP_ENTEREVAL;
6055 flags |= OPpEVAL_BYTES<<8;
6058 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6059 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6060 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6061 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6062 || type == OP_SASSIGN
6063 || type == OP_ENTERTRY
6064 || type == OP_CUSTOM
6065 || type == OP_NULL );
6068 first = newOP(OP_STUB, 0);
6069 if (PL_opargs[type] & OA_MARK)
6070 first = force_list(first, 1);
6072 NewOp(1101, unop, 1, UNOP);
6073 OpTYPE_set(unop, type);
6074 unop->op_first = first;
6075 unop->op_flags = (U8)(flags | OPf_KIDS);
6076 unop->op_private = (U8)(1 | (flags >> 8));
6078 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6079 OpLASTSIB_set(first, (OP*)unop);
6081 unop = (UNOP*) CHECKOP(type, unop);
6085 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6089 =for apidoc newUNOP_AUX
6091 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6092 initialised to C<aux>
6098 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6103 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6104 || type == OP_CUSTOM);
6106 NewOp(1101, unop, 1, UNOP_AUX);
6107 unop->op_type = (OPCODE)type;
6108 unop->op_ppaddr = PL_ppaddr[type];
6109 unop->op_first = first;
6110 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6111 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6114 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6115 OpLASTSIB_set(first, (OP*)unop);
6117 unop = (UNOP_AUX*) CHECKOP(type, unop);
6119 return op_std_init((OP *) unop);
6123 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6125 Constructs, checks, and returns an op of method type with a method name
6126 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6127 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6128 and, shifted up eight bits, the eight bits of C<op_private>, except that
6129 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6130 op which evaluates method name; it is consumed by this function and
6131 become part of the constructed op tree.
6132 Supported optypes: C<OP_METHOD>.
6138 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6142 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6143 || type == OP_CUSTOM);
6145 NewOp(1101, methop, 1, METHOP);
6147 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6148 methop->op_flags = (U8)(flags | OPf_KIDS);
6149 methop->op_u.op_first = dynamic_meth;
6150 methop->op_private = (U8)(1 | (flags >> 8));
6152 if (!OpHAS_SIBLING(dynamic_meth))
6153 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6157 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6158 methop->op_u.op_meth_sv = const_meth;
6159 methop->op_private = (U8)(0 | (flags >> 8));
6160 methop->op_next = (OP*)methop;
6164 methop->op_rclass_targ = 0;
6166 methop->op_rclass_sv = NULL;
6169 OpTYPE_set(methop, type);
6170 return CHECKOP(type, methop);
6174 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6175 PERL_ARGS_ASSERT_NEWMETHOP;
6176 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6180 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6182 Constructs, checks, and returns an op of method type with a constant
6183 method name. C<type> is the opcode. C<flags> gives the eight bits of
6184 C<op_flags>, and, shifted up eight bits, the eight bits of
6185 C<op_private>. C<const_meth> supplies a constant method name;
6186 it must be a shared COW string.
6187 Supported optypes: C<OP_METHOD_NAMED>.
6193 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6194 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6195 return newMETHOP_internal(type, flags, NULL, const_meth);
6199 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6201 Constructs, checks, and returns an op of any binary type. C<type>
6202 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6203 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6204 the eight bits of C<op_private>, except that the bit with value 1 or
6205 2 is automatically set as required. C<first> and C<last> supply up to
6206 two ops to be the direct children of the binary op; they are consumed
6207 by this function and become part of the constructed op tree.
6213 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6218 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6219 || type == OP_NULL || type == OP_CUSTOM);
6221 NewOp(1101, binop, 1, BINOP);
6224 first = newOP(OP_NULL, 0);
6226 OpTYPE_set(binop, type);
6227 binop->op_first = first;
6228 binop->op_flags = (U8)(flags | OPf_KIDS);
6231 binop->op_private = (U8)(1 | (flags >> 8));
6234 binop->op_private = (U8)(2 | (flags >> 8));
6235 OpMORESIB_set(first, last);
6238 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6239 OpLASTSIB_set(last, (OP*)binop);
6241 binop->op_last = OpSIBLING(binop->op_first);
6243 OpLASTSIB_set(binop->op_last, (OP*)binop);
6245 binop = (BINOP*)CHECKOP(type, binop);
6246 if (binop->op_next || binop->op_type != (OPCODE)type)
6249 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6252 static int uvcompare(const void *a, const void *b)
6253 __attribute__nonnull__(1)
6254 __attribute__nonnull__(2)
6255 __attribute__pure__;
6256 static int uvcompare(const void *a, const void *b)
6258 if (*((const UV *)a) < (*(const UV *)b))
6260 if (*((const UV *)a) > (*(const UV *)b))
6262 if (*((const UV *)a+1) < (*(const UV *)b+1))
6264 if (*((const UV *)a+1) > (*(const UV *)b+1))
6270 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6272 SV * const tstr = ((SVOP*)expr)->op_sv;
6274 ((SVOP*)repl)->op_sv;
6277 const U8 *t = (U8*)SvPV_const(tstr, tlen);
6278 const U8 *r = (U8*)SvPV_const(rstr, rlen);
6284 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
6285 const I32 squash = o->op_private & OPpTRANS_SQUASH;
6286 I32 del = o->op_private & OPpTRANS_DELETE;
6289 PERL_ARGS_ASSERT_PMTRANS;
6291 PL_hints |= HINT_BLOCK_SCOPE;
6294 o->op_private |= OPpTRANS_FROM_UTF;
6297 o->op_private |= OPpTRANS_TO_UTF;
6299 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6300 SV* const listsv = newSVpvs("# comment\n");
6302 const U8* tend = t + tlen;
6303 const U8* rend = r + rlen;
6319 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
6320 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
6323 const U32 flags = UTF8_ALLOW_DEFAULT;
6327 t = tsave = bytes_to_utf8(t, &len);
6330 if (!to_utf && rlen) {
6332 r = rsave = bytes_to_utf8(r, &len);
6336 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6337 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6341 U8 tmpbuf[UTF8_MAXBYTES+1];
6344 Newx(cp, 2*tlen, UV);
6346 transv = newSVpvs("");
6348 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6350 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6352 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6356 cp[2*i+1] = cp[2*i];
6360 qsort(cp, i, 2*sizeof(UV), uvcompare);
6361 for (j = 0; j < i; j++) {
6363 diff = val - nextmin;
6365 t = uvchr_to_utf8(tmpbuf,nextmin);
6366 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6368 U8 range_mark = ILLEGAL_UTF8_BYTE;
6369 t = uvchr_to_utf8(tmpbuf, val - 1);
6370 sv_catpvn(transv, (char *)&range_mark, 1);
6371 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6378 t = uvchr_to_utf8(tmpbuf,nextmin);
6379 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6381 U8 range_mark = ILLEGAL_UTF8_BYTE;
6382 sv_catpvn(transv, (char *)&range_mark, 1);
6384 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6385 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6386 t = (const U8*)SvPVX_const(transv);
6387 tlen = SvCUR(transv);
6391 else if (!rlen && !del) {
6392 r = t; rlen = tlen; rend = tend;
6395 if ((!rlen && !del) || t == r ||
6396 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6398 o->op_private |= OPpTRANS_IDENTICAL;
6402 while (t < tend || tfirst <= tlast) {
6403 /* see if we need more "t" chars */
6404 if (tfirst > tlast) {
6405 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6407 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6409 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6416 /* now see if we need more "r" chars */
6417 if (rfirst > rlast) {
6419 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6421 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6423 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6432 rfirst = rlast = 0xffffffff;
6436 /* now see which range will peter out first, if either. */
6437 tdiff = tlast - tfirst;
6438 rdiff = rlast - rfirst;
6439 tcount += tdiff + 1;
6440 rcount += rdiff + 1;
6447 if (rfirst == 0xffffffff) {
6448 diff = tdiff; /* oops, pretend rdiff is infinite */
6450 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6451 (long)tfirst, (long)tlast);
6453 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6457 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6458 (long)tfirst, (long)(tfirst + diff),
6461 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6462 (long)tfirst, (long)rfirst);
6464 if (rfirst + diff > max)
6465 max = rfirst + diff;
6467 grows = (tfirst < rfirst &&
6468 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6480 else if (max > 0xff)
6485 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6487 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6488 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6489 PAD_SETSV(cPADOPo->op_padix, swash);
6491 SvREADONLY_on(swash);
6493 cSVOPo->op_sv = swash;
6495 SvREFCNT_dec(listsv);
6496 SvREFCNT_dec(transv);
6498 if (!del && havefinal && rlen)
6499 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6500 newSVuv((UV)final), 0);
6509 else if (rlast == 0xffffffff)
6515 tbl = (short*)PerlMemShared_calloc(
6516 (o->op_private & OPpTRANS_COMPLEMENT) &&
6517 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
6519 cPVOPo->op_pv = (char*)tbl;
6521 for (i = 0; i < (I32)tlen; i++)
6523 for (i = 0, j = 0; i < 256; i++) {
6525 if (j >= (I32)rlen) {
6534 if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
6544 o->op_private |= OPpTRANS_IDENTICAL;
6546 else if (j >= (I32)rlen)
6551 PerlMemShared_realloc(tbl,
6552 (0x101+rlen-j) * sizeof(short));
6553 cPVOPo->op_pv = (char*)tbl;
6555 tbl[0x100] = (short)(rlen - j);
6556 for (i=0; i < (I32)rlen - j; i++)
6557 tbl[0x101+i] = r[j+i];
6561 if (!rlen && !del) {
6564 o->op_private |= OPpTRANS_IDENTICAL;
6566 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6567 o->op_private |= OPpTRANS_IDENTICAL;
6569 for (i = 0; i < 256; i++)
6571 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
6572 if (j >= (I32)rlen) {
6574 if (tbl[t[i]] == -1)
6580 if (tbl[t[i]] == -1) {
6581 if ( UVCHR_IS_INVARIANT(t[i])
6582 && ! UVCHR_IS_INVARIANT(r[j]))
6590 if(del && rlen == tlen) {
6591 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6592 } else if(rlen > tlen && !complement) {
6593 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6597 o->op_private |= OPpTRANS_GROWS;
6605 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6607 Constructs, checks, and returns an op of any pattern matching type.
6608 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
6609 and, shifted up eight bits, the eight bits of C<op_private>.
6615 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6620 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6621 || type == OP_CUSTOM);
6623 NewOp(1101, pmop, 1, PMOP);
6624 OpTYPE_set(pmop, type);
6625 pmop->op_flags = (U8)flags;
6626 pmop->op_private = (U8)(0 | (flags >> 8));
6627 if (PL_opargs[type] & OA_RETSCALAR)
6630 if (PL_hints & HINT_RE_TAINT)
6631 pmop->op_pmflags |= PMf_RETAINT;
6632 #ifdef USE_LOCALE_CTYPE
6633 if (IN_LC_COMPILETIME(LC_CTYPE)) {
6634 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6639 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6641 if (PL_hints & HINT_RE_FLAGS) {
6642 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6643 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6645 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6646 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6647 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6649 if (reflags && SvOK(reflags)) {
6650 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6656 assert(SvPOK(PL_regex_pad[0]));
6657 if (SvCUR(PL_regex_pad[0])) {
6658 /* Pop off the "packed" IV from the end. */
6659 SV *const repointer_list = PL_regex_pad[0];
6660 const char *p = SvEND(repointer_list) - sizeof(IV);
6661 const IV offset = *((IV*)p);
6663 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6665 SvEND_set(repointer_list, p);
6667 pmop->op_pmoffset = offset;
6668 /* This slot should be free, so assert this: */
6669 assert(PL_regex_pad[offset] == &PL_sv_undef);
6671 SV * const repointer = &PL_sv_undef;
6672 av_push(PL_regex_padav, repointer);
6673 pmop->op_pmoffset = av_tindex(PL_regex_padav);
6674 PL_regex_pad = AvARRAY(PL_regex_padav);
6678 return CHECKOP(type, pmop);
6686 /* Any pad names in scope are potentially lvalues. */
6687 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6688 PADNAME *pn = PAD_COMPNAME_SV(i);
6689 if (!pn || !PadnameLEN(pn))
6691 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6692 S_mark_padname_lvalue(aTHX_ pn);
6696 /* Given some sort of match op o, and an expression expr containing a
6697 * pattern, either compile expr into a regex and attach it to o (if it's
6698 * constant), or convert expr into a runtime regcomp op sequence (if it's
6701 * Flags currently has 2 bits of meaning:
6702 * 1: isreg indicates that the pattern is part of a regex construct, eg
6703 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6704 * split "pattern", which aren't. In the former case, expr will be a list
6705 * if the pattern contains more than one term (eg /a$b/).
6706 * 2: The pattern is for a split.
6708 * When the pattern has been compiled within a new anon CV (for
6709 * qr/(?{...})/ ), then floor indicates the savestack level just before
6710 * the new sub was created
6714 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6718 I32 repl_has_vars = 0;
6719 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6720 bool is_compiletime;
6722 bool isreg = cBOOL(flags & 1);
6723 bool is_split = cBOOL(flags & 2);
6725 PERL_ARGS_ASSERT_PMRUNTIME;
6728 return pmtrans(o, expr, repl);
6731 /* find whether we have any runtime or code elements;
6732 * at the same time, temporarily set the op_next of each DO block;
6733 * then when we LINKLIST, this will cause the DO blocks to be excluded
6734 * from the op_next chain (and from having LINKLIST recursively
6735 * applied to them). We fix up the DOs specially later */
6739 if (expr->op_type == OP_LIST) {
6741 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6742 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6744 assert(!o->op_next);
6745 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6746 assert(PL_parser && PL_parser->error_count);
6747 /* This can happen with qr/ (?{(^{})/. Just fake up
6748 the op we were expecting to see, to avoid crashing
6750 op_sibling_splice(expr, o, 0,
6751 newSVOP(OP_CONST, 0, &PL_sv_no));
6753 o->op_next = OpSIBLING(o);
6755 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
6759 else if (expr->op_type != OP_CONST)
6764 /* fix up DO blocks; treat each one as a separate little sub;
6765 * also, mark any arrays as LIST/REF */
6767 if (expr->op_type == OP_LIST) {
6769 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6771 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
6772 assert( !(o->op_flags & OPf_WANT));
6773 /* push the array rather than its contents. The regex
6774 * engine will retrieve and join the elements later */
6775 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
6779 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
6781 o->op_next = NULL; /* undo temporary hack from above */
6784 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
6785 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
6787 assert(leaveop->op_first->op_type == OP_ENTER);
6788 assert(OpHAS_SIBLING(leaveop->op_first));
6789 o->op_next = OpSIBLING(leaveop->op_first);
6791 assert(leaveop->op_flags & OPf_KIDS);
6792 assert(leaveop->op_last->op_next == (OP*)leaveop);
6793 leaveop->op_next = NULL; /* stop on last op */
6794 op_null((OP*)leaveop);
6798 OP *scope = cLISTOPo->op_first;
6799 assert(scope->op_type == OP_SCOPE);
6800 assert(scope->op_flags & OPf_KIDS);
6801 scope->op_next = NULL; /* stop on last op */
6806 /* runtime finalizes as part of finalizing whole tree */
6809 /* have to peep the DOs individually as we've removed it from
6810 * the op_next chain */
6812 S_prune_chain_head(&(o->op_next));
6814 /* runtime finalizes as part of finalizing whole tree */
6818 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
6819 assert( !(expr->op_flags & OPf_WANT));
6820 /* push the array rather than its contents. The regex
6821 * engine will retrieve and join the elements later */
6822 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
6825 PL_hints |= HINT_BLOCK_SCOPE;
6827 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
6829 if (is_compiletime) {
6830 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
6831 regexp_engine const *eng = current_re_engine();
6834 /* make engine handle split ' ' specially */
6835 pm->op_pmflags |= PMf_SPLIT;
6836 rx_flags |= RXf_SPLIT;
6839 /* Skip compiling if parser found an error for this pattern */
6840 if (pm->op_pmflags & PMf_HAS_ERROR) {
6844 if (!has_code || !eng->op_comp) {
6845 /* compile-time simple constant pattern */
6847 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
6848 /* whoops! we guessed that a qr// had a code block, but we
6849 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
6850 * that isn't required now. Note that we have to be pretty
6851 * confident that nothing used that CV's pad while the
6852 * regex was parsed, except maybe op targets for \Q etc.
6853 * If there were any op targets, though, they should have
6854 * been stolen by constant folding.
6858 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
6859 while (++i <= AvFILLp(PL_comppad)) {
6860 # ifdef USE_PAD_RESET
6861 /* under USE_PAD_RESET, pad swipe replaces a swiped
6862 * folded constant with a fresh padtmp */
6863 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
6865 assert(!PL_curpad[i]);
6869 /* But we know that one op is using this CV's slab. */
6870 cv_forget_slab(PL_compcv);
6872 pm->op_pmflags &= ~PMf_HAS_CV;
6877 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
6878 rx_flags, pm->op_pmflags)
6879 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
6880 rx_flags, pm->op_pmflags)
6885 /* compile-time pattern that includes literal code blocks */
6886 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
6889 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
6892 if (pm->op_pmflags & PMf_HAS_CV) {
6894 /* this QR op (and the anon sub we embed it in) is never
6895 * actually executed. It's just a placeholder where we can
6896 * squirrel away expr in op_code_list without the peephole
6897 * optimiser etc processing it for a second time */
6898 OP *qr = newPMOP(OP_QR, 0);
6899 ((PMOP*)qr)->op_code_list = expr;
6901 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
6902 SvREFCNT_inc_simple_void(PL_compcv);
6903 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
6904 ReANY(re)->qr_anoncv = cv;
6906 /* attach the anon CV to the pad so that
6907 * pad_fixup_inner_anons() can find it */
6908 (void)pad_add_anon(cv, o->op_type);
6909 SvREFCNT_inc_simple_void(cv);
6912 pm->op_code_list = expr;
6917 /* runtime pattern: build chain of regcomp etc ops */
6919 PADOFFSET cv_targ = 0;
6921 reglist = isreg && expr->op_type == OP_LIST;
6926 pm->op_code_list = expr;
6927 /* don't free op_code_list; its ops are embedded elsewhere too */
6928 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
6932 /* make engine handle split ' ' specially */
6933 pm->op_pmflags |= PMf_SPLIT;
6935 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
6936 * to allow its op_next to be pointed past the regcomp and
6937 * preceding stacking ops;
6938 * OP_REGCRESET is there to reset taint before executing the
6940 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
6941 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
6943 if (pm->op_pmflags & PMf_HAS_CV) {
6944 /* we have a runtime qr with literal code. This means
6945 * that the qr// has been wrapped in a new CV, which
6946 * means that runtime consts, vars etc will have been compiled
6947 * against a new pad. So... we need to execute those ops
6948 * within the environment of the new CV. So wrap them in a call
6949 * to a new anon sub. i.e. for
6953 * we build an anon sub that looks like
6955 * sub { "a", $b, '(?{...})' }
6957 * and call it, passing the returned list to regcomp.
6958 * Or to put it another way, the list of ops that get executed
6962 * ------ -------------------
6963 * pushmark (for regcomp)
6964 * pushmark (for entersub)
6968 * regcreset regcreset
6970 * const("a") const("a")
6972 * const("(?{...})") const("(?{...})")
6977 SvREFCNT_inc_simple_void(PL_compcv);
6978 CvLVALUE_on(PL_compcv);
6979 /* these lines are just an unrolled newANONATTRSUB */
6980 expr = newSVOP(OP_ANONCODE, 0,
6981 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
6982 cv_targ = expr->op_targ;
6983 expr = newUNOP(OP_REFGEN, 0, expr);
6985 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
6988 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
6989 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
6990 | (reglist ? OPf_STACKED : 0);
6991 rcop->op_targ = cv_targ;
6993 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
6994 if (PL_hints & HINT_RE_EVAL)
6995 S_set_haseval(aTHX);
6997 /* establish postfix order */
6998 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7000 rcop->op_next = expr;
7001 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7004 rcop->op_next = LINKLIST(expr);
7005 expr->op_next = (OP*)rcop;
7008 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7014 /* If we are looking at s//.../e with a single statement, get past
7015 the implicit do{}. */
7016 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7017 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7018 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7021 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7022 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7023 && !OpHAS_SIBLING(sib))
7026 if (curop->op_type == OP_CONST)
7028 else if (( (curop->op_type == OP_RV2SV ||
7029 curop->op_type == OP_RV2AV ||
7030 curop->op_type == OP_RV2HV ||
7031 curop->op_type == OP_RV2GV)
7032 && cUNOPx(curop)->op_first
7033 && cUNOPx(curop)->op_first->op_type == OP_GV )
7034 || curop->op_type == OP_PADSV
7035 || curop->op_type == OP_PADAV
7036 || curop->op_type == OP_PADHV
7037 || curop->op_type == OP_PADANY) {
7045 || !RX_PRELEN(PM_GETRE(pm))
7046 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7048 pm->op_pmflags |= PMf_CONST; /* const for long enough */
7049 op_prepend_elem(o->op_type, scalar(repl), o);
7052 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7053 rcop->op_private = 1;
7055 /* establish postfix order */
7056 rcop->op_next = LINKLIST(repl);
7057 repl->op_next = (OP*)rcop;
7059 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7060 assert(!(pm->op_pmflags & PMf_ONCE));
7061 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7070 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7072 Constructs, checks, and returns an op of any type that involves an
7073 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
7074 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
7075 takes ownership of one reference to it.
7081 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7086 PERL_ARGS_ASSERT_NEWSVOP;
7088 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7089 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7090 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7091 || type == OP_CUSTOM);
7093 NewOp(1101, svop, 1, SVOP);
7094 OpTYPE_set(svop, type);
7096 svop->op_next = (OP*)svop;
7097 svop->op_flags = (U8)flags;
7098 svop->op_private = (U8)(0 | (flags >> 8));
7099 if (PL_opargs[type] & OA_RETSCALAR)
7101 if (PL_opargs[type] & OA_TARGET)
7102 svop->op_targ = pad_alloc(type, SVs_PADTMP);
7103 return CHECKOP(type, svop);
7107 =for apidoc Am|OP *|newDEFSVOP|
7109 Constructs and returns an op to access C<$_>.
7115 Perl_newDEFSVOP(pTHX)
7117 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7123 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7125 Constructs, checks, and returns an op of any type that involves a
7126 reference to a pad element. C<type> is the opcode. C<flags> gives the
7127 eight bits of C<op_flags>. A pad slot is automatically allocated, and
7128 is populated with C<sv>; this function takes ownership of one reference
7131 This function only exists if Perl has been compiled to use ithreads.
7137 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7142 PERL_ARGS_ASSERT_NEWPADOP;
7144 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7145 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7146 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7147 || type == OP_CUSTOM);
7149 NewOp(1101, padop, 1, PADOP);
7150 OpTYPE_set(padop, type);
7152 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7153 SvREFCNT_dec(PAD_SVl(padop->op_padix));
7154 PAD_SETSV(padop->op_padix, sv);
7156 padop->op_next = (OP*)padop;
7157 padop->op_flags = (U8)flags;
7158 if (PL_opargs[type] & OA_RETSCALAR)
7160 if (PL_opargs[type] & OA_TARGET)
7161 padop->op_targ = pad_alloc(type, SVs_PADTMP);
7162 return CHECKOP(type, padop);
7165 #endif /* USE_ITHREADS */
7168 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7170 Constructs, checks, and returns an op of any type that involves an
7171 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
7172 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
7173 reference; calling this function does not transfer ownership of any
7180 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7182 PERL_ARGS_ASSERT_NEWGVOP;
7185 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7187 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7192 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7194 Constructs, checks, and returns an op of any type that involves an
7195 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
7196 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
7197 Depending on the op type, the memory referenced by C<pv> may be freed
7198 when the op is destroyed. If the op is of a freeing type, C<pv> must
7199 have been allocated using C<PerlMemShared_malloc>.
7205 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7208 const bool utf8 = cBOOL(flags & SVf_UTF8);
7213 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7214 || type == OP_RUNCV || type == OP_CUSTOM
7215 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7217 NewOp(1101, pvop, 1, PVOP);
7218 OpTYPE_set(pvop, type);
7220 pvop->op_next = (OP*)pvop;
7221 pvop->op_flags = (U8)flags;
7222 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7223 if (PL_opargs[type] & OA_RETSCALAR)
7225 if (PL_opargs[type] & OA_TARGET)
7226 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7227 return CHECKOP(type, pvop);
7231 Perl_package(pTHX_ OP *o)
7233 SV *const sv = cSVOPo->op_sv;
7235 PERL_ARGS_ASSERT_PACKAGE;
7237 SAVEGENERICSV(PL_curstash);
7238 save_item(PL_curstname);
7240 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7242 sv_setsv(PL_curstname, sv);
7244 PL_hints |= HINT_BLOCK_SCOPE;
7245 PL_parser->copline = NOLINE;
7251 Perl_package_version( pTHX_ OP *v )
7253 U32 savehints = PL_hints;
7254 PERL_ARGS_ASSERT_PACKAGE_VERSION;
7255 PL_hints &= ~HINT_STRICT_VARS;
7256 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7257 PL_hints = savehints;
7262 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7267 SV *use_version = NULL;
7269 PERL_ARGS_ASSERT_UTILIZE;
7271 if (idop->op_type != OP_CONST)
7272 Perl_croak(aTHX_ "Module name must be constant");
7277 SV * const vesv = ((SVOP*)version)->op_sv;
7279 if (!arg && !SvNIOKp(vesv)) {
7286 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7287 Perl_croak(aTHX_ "Version number must be a constant number");
7289 /* Make copy of idop so we don't free it twice */
7290 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7292 /* Fake up a method call to VERSION */
7293 meth = newSVpvs_share("VERSION");
7294 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7295 op_append_elem(OP_LIST,
7296 op_prepend_elem(OP_LIST, pack, version),
7297 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7301 /* Fake up an import/unimport */
7302 if (arg && arg->op_type == OP_STUB) {
7303 imop = arg; /* no import on explicit () */
7305 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7306 imop = NULL; /* use 5.0; */
7308 use_version = ((SVOP*)idop)->op_sv;
7310 idop->op_private |= OPpCONST_NOVER;
7315 /* Make copy of idop so we don't free it twice */
7316 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7318 /* Fake up a method call to import/unimport */
7320 ? newSVpvs_share("import") : newSVpvs_share("unimport");
7321 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7322 op_append_elem(OP_LIST,
7323 op_prepend_elem(OP_LIST, pack, arg),
7324 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7328 /* Fake up the BEGIN {}, which does its thing immediately. */
7330 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7333 op_append_elem(OP_LINESEQ,
7334 op_append_elem(OP_LINESEQ,
7335 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7336 newSTATEOP(0, NULL, veop)),
7337 newSTATEOP(0, NULL, imop) ));
7341 * feature bundle that corresponds to the required version. */
7342 use_version = sv_2mortal(new_version(use_version));
7343 S_enable_feature_bundle(aTHX_ use_version);
7345 /* If a version >= 5.11.0 is requested, strictures are on by default! */
7346 if (vcmp(use_version,
7347 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7348 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7349 PL_hints |= HINT_STRICT_REFS;
7350 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7351 PL_hints |= HINT_STRICT_SUBS;
7352 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7353 PL_hints |= HINT_STRICT_VARS;
7355 /* otherwise they are off */
7357 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7358 PL_hints &= ~HINT_STRICT_REFS;
7359 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7360 PL_hints &= ~HINT_STRICT_SUBS;
7361 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7362 PL_hints &= ~HINT_STRICT_VARS;
7366 /* The "did you use incorrect case?" warning used to be here.
7367 * The problem is that on case-insensitive filesystems one
7368 * might get false positives for "use" (and "require"):
7369 * "use Strict" or "require CARP" will work. This causes
7370 * portability problems for the script: in case-strict
7371 * filesystems the script will stop working.
7373 * The "incorrect case" warning checked whether "use Foo"
7374 * imported "Foo" to your namespace, but that is wrong, too:
7375 * there is no requirement nor promise in the language that
7376 * a Foo.pm should or would contain anything in package "Foo".
7378 * There is very little Configure-wise that can be done, either:
7379 * the case-sensitivity of the build filesystem of Perl does not
7380 * help in guessing the case-sensitivity of the runtime environment.
7383 PL_hints |= HINT_BLOCK_SCOPE;
7384 PL_parser->copline = NOLINE;
7385 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7389 =head1 Embedding Functions
7391 =for apidoc load_module
7393 Loads the module whose name is pointed to by the string part of C<name>.
7394 Note that the actual module name, not its filename, should be given.
7395 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7396 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7397 trailing arguments can be used to specify arguments to the module's C<import()>
7398 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7399 on the flags. The flags argument is a bitwise-ORed collection of any of
7400 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7401 (or 0 for no flags).
7403 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7404 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7405 the trailing optional arguments may be omitted entirely. Otherwise, if
7406 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7407 exactly one C<OP*>, containing the op tree that produces the relevant import
7408 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7409 will be used as import arguments; and the list must be terminated with C<(SV*)
7410 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7411 set, the trailing C<NULL> pointer is needed even if no import arguments are
7412 desired. The reference count for each specified C<SV*> argument is
7413 decremented. In addition, the C<name> argument is modified.
7415 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7421 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7425 PERL_ARGS_ASSERT_LOAD_MODULE;
7427 va_start(args, ver);
7428 vload_module(flags, name, ver, &args);
7432 #ifdef PERL_IMPLICIT_CONTEXT
7434 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7438 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7439 va_start(args, ver);
7440 vload_module(flags, name, ver, &args);
7446 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7449 OP * const modname = newSVOP(OP_CONST, 0, name);
7451 PERL_ARGS_ASSERT_VLOAD_MODULE;
7453 modname->op_private |= OPpCONST_BARE;
7455 veop = newSVOP(OP_CONST, 0, ver);
7459 if (flags & PERL_LOADMOD_NOIMPORT) {
7460 imop = sawparens(newNULLLIST());
7462 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7463 imop = va_arg(*args, OP*);
7468 sv = va_arg(*args, SV*);
7470 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7471 sv = va_arg(*args, SV*);
7475 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7476 * that it has a PL_parser to play with while doing that, and also
7477 * that it doesn't mess with any existing parser, by creating a tmp
7478 * new parser with lex_start(). This won't actually be used for much,
7479 * since pp_require() will create another parser for the real work.
7480 * The ENTER/LEAVE pair protect callers from any side effects of use. */
7483 SAVEVPTR(PL_curcop);
7484 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7485 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
7486 veop, modname, imop);
7490 PERL_STATIC_INLINE OP *
7491 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7493 return newUNOP(OP_ENTERSUB, OPf_STACKED,
7494 newLISTOP(OP_LIST, 0, arg,
7495 newUNOP(OP_RV2CV, 0,
7496 newGVOP(OP_GV, 0, gv))));
7500 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7505 PERL_ARGS_ASSERT_DOFILE;
7507 if (!force_builtin && (gv = gv_override("do", 2))) {
7508 doop = S_new_entersubop(aTHX_ gv, term);
7511 doop = newUNOP(OP_DOFILE, 0, scalar(term));
7517 =head1 Optree construction
7519 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7521 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
7522 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7523 be set automatically, and, shifted up eight bits, the eight bits of
7524 C<op_private>, except that the bit with value 1 or 2 is automatically
7525 set as required. C<listval> and C<subscript> supply the parameters of
7526 the slice; they are consumed by this function and become part of the
7527 constructed op tree.
7533 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7535 return newBINOP(OP_LSLICE, flags,
7536 list(force_list(subscript, 1)),
7537 list(force_list(listval, 1)) );
7540 #define ASSIGN_LIST 1
7541 #define ASSIGN_REF 2
7544 S_assignment_type(pTHX_ const OP *o)
7553 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7554 o = cUNOPo->op_first;
7556 flags = o->op_flags;
7558 if (type == OP_COND_EXPR) {
7559 OP * const sib = OpSIBLING(cLOGOPo->op_first);
7560 const I32 t = assignment_type(sib);
7561 const I32 f = assignment_type(OpSIBLING(sib));
7563 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7565 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7566 yyerror("Assignment to both a list and a scalar");
7570 if (type == OP_SREFGEN)
7572 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7573 type = kid->op_type;
7574 flags |= kid->op_flags;
7575 if (!(flags & OPf_PARENS)
7576 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7577 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7583 if (type == OP_LIST &&
7584 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7585 o->op_private & OPpLVAL_INTRO)
7588 if (type == OP_LIST || flags & OPf_PARENS ||
7589 type == OP_RV2AV || type == OP_RV2HV ||
7590 type == OP_ASLICE || type == OP_HSLICE ||
7591 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7594 if (type == OP_PADAV || type == OP_PADHV)
7597 if (type == OP_RV2SV)
7604 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7606 const PADOFFSET target = padop->op_targ;
7607 OP *const other = newOP(OP_PADSV,
7609 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7610 OP *const first = newOP(OP_NULL, 0);
7611 OP *const nullop = newCONDOP(0, first, initop, other);
7612 /* XXX targlex disabled for now; see ticket #124160
7613 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7615 OP *const condop = first->op_next;
7617 OpTYPE_set(condop, OP_ONCE);
7618 other->op_targ = target;
7619 nullop->op_flags |= OPf_WANT_SCALAR;
7621 /* Store the initializedness of state vars in a separate
7624 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7625 /* hijacking PADSTALE for uninitialized state variables */
7626 SvPADSTALE_on(PAD_SVl(condop->op_targ));
7632 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7634 Constructs, checks, and returns an assignment op. C<left> and C<right>
7635 supply the parameters of the assignment; they are consumed by this
7636 function and become part of the constructed op tree.
7638 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7639 a suitable conditional optree is constructed. If C<optype> is the opcode
7640 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7641 performs the binary operation and assigns the result to the left argument.
7642 Either way, if C<optype> is non-zero then C<flags> has no effect.
7644 If C<optype> is zero, then a plain scalar or list assignment is
7645 constructed. Which type of assignment it is is automatically determined.
7646 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7647 will be set automatically, and, shifted up eight bits, the eight bits
7648 of C<op_private>, except that the bit with value 1 or 2 is automatically
7655 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7661 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7662 right = scalar(right);
7663 return newLOGOP(optype, 0,
7664 op_lvalue(scalar(left), optype),
7665 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7668 return newBINOP(optype, OPf_STACKED,
7669 op_lvalue(scalar(left), optype), scalar(right));
7673 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7674 OP *state_var_op = NULL;
7675 static const char no_list_state[] = "Initialization of state variables"
7676 " in list currently forbidden";
7679 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7680 left->op_private &= ~ OPpSLICEWARNING;
7683 left = op_lvalue(left, OP_AASSIGN);
7684 curop = list(force_list(left, 1));
7685 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7686 o->op_private = (U8)(0 | (flags >> 8));
7688 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7690 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7691 if (!(left->op_flags & OPf_PARENS) &&
7692 lop->op_type == OP_PUSHMARK &&
7693 (vop = OpSIBLING(lop)) &&
7694 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7695 !(vop->op_flags & OPf_PARENS) &&
7696 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7697 (OPpLVAL_INTRO|OPpPAD_STATE) &&
7698 (eop = OpSIBLING(vop)) &&
7699 eop->op_type == OP_ENTERSUB &&
7700 !OpHAS_SIBLING(eop)) {
7704 if ((lop->op_type == OP_PADSV ||
7705 lop->op_type == OP_PADAV ||
7706 lop->op_type == OP_PADHV ||
7707 lop->op_type == OP_PADANY)
7708 && (lop->op_private & OPpPAD_STATE)
7710 yyerror(no_list_state);
7711 lop = OpSIBLING(lop);
7715 else if ( (left->op_private & OPpLVAL_INTRO)
7716 && (left->op_private & OPpPAD_STATE)
7717 && ( left->op_type == OP_PADSV
7718 || left->op_type == OP_PADAV
7719 || left->op_type == OP_PADHV
7720 || left->op_type == OP_PADANY)
7722 /* All single variable list context state assignments, hence
7732 if (left->op_flags & OPf_PARENS)
7733 yyerror(no_list_state);
7735 state_var_op = left;
7738 /* optimise @a = split(...) into:
7739 * @{expr}: split(..., @{expr}) (where @a is not flattened)
7740 * @a, my @a, local @a: split(...) (where @a is attached to
7741 * the split op itself)
7745 && right->op_type == OP_SPLIT
7746 /* don't do twice, e.g. @b = (@a = split) */
7747 && !(right->op_private & OPpSPLIT_ASSIGN))
7751 if ( ( left->op_type == OP_RV2AV
7752 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
7753 || left->op_type == OP_PADAV)
7755 /* @pkg or @lex or local @pkg' or 'my @lex' */
7759 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
7760 = cPADOPx(gvop)->op_padix;
7761 cPADOPx(gvop)->op_padix = 0; /* steal it */
7763 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
7764 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
7765 cSVOPx(gvop)->op_sv = NULL; /* steal it */
7767 right->op_private |=
7768 left->op_private & OPpOUR_INTRO;
7771 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
7772 left->op_targ = 0; /* steal it */
7773 right->op_private |= OPpSPLIT_LEX;
7775 right->op_private |= left->op_private & OPpLVAL_INTRO;
7778 tmpop = cUNOPo->op_first; /* to list (nulled) */
7779 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
7780 assert(OpSIBLING(tmpop) == right);
7781 assert(!OpHAS_SIBLING(right));
7782 /* detach the split subtreee from the o tree,
7783 * then free the residual o tree */
7784 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
7785 op_free(o); /* blow off assign */
7786 right->op_private |= OPpSPLIT_ASSIGN;
7787 right->op_flags &= ~OPf_WANT;
7788 /* "I don't know and I don't care." */
7791 else if (left->op_type == OP_RV2AV) {
7794 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
7795 assert(OpSIBLING(pushop) == left);
7796 /* Detach the array ... */
7797 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
7798 /* ... and attach it to the split. */
7799 op_sibling_splice(right, cLISTOPx(right)->op_last,
7801 right->op_flags |= OPf_STACKED;
7802 /* Detach split and expunge aassign as above. */
7805 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
7806 ((LISTOP*)right)->op_last->op_type == OP_CONST)
7808 /* convert split(...,0) to split(..., PL_modcount+1) */
7810 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
7811 SV * const sv = *svp;
7812 if (SvIOK(sv) && SvIVX(sv) == 0)
7814 if (right->op_private & OPpSPLIT_IMPLIM) {
7815 /* our own SV, created in ck_split */
7817 sv_setiv(sv, PL_modcount+1);
7820 /* SV may belong to someone else */
7822 *svp = newSViv(PL_modcount+1);
7829 o = S_newONCEOP(aTHX_ o, state_var_op);
7832 if (assign_type == ASSIGN_REF)
7833 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
7835 right = newOP(OP_UNDEF, 0);
7836 if (right->op_type == OP_READLINE) {
7837 right->op_flags |= OPf_STACKED;
7838 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
7842 o = newBINOP(OP_SASSIGN, flags,
7843 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
7849 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
7851 Constructs a state op (COP). The state op is normally a C<nextstate> op,
7852 but will be a C<dbstate> op if debugging is enabled for currently-compiled
7853 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
7854 If C<label> is non-null, it supplies the name of a label to attach to
7855 the state op; this function takes ownership of the memory pointed at by
7856 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
7859 If C<o> is null, the state op is returned. Otherwise the state op is
7860 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
7861 is consumed by this function and becomes part of the returned op tree.
7867 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
7870 const U32 seq = intro_my();
7871 const U32 utf8 = flags & SVf_UTF8;
7874 PL_parser->parsed_sub = 0;
7878 NewOp(1101, cop, 1, COP);
7879 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
7880 OpTYPE_set(cop, OP_DBSTATE);
7883 OpTYPE_set(cop, OP_NEXTSTATE);
7885 cop->op_flags = (U8)flags;
7886 CopHINTS_set(cop, PL_hints);
7888 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
7890 cop->op_next = (OP*)cop;
7893 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7894 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
7896 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
7898 PL_hints |= HINT_BLOCK_SCOPE;
7899 /* It seems that we need to defer freeing this pointer, as other parts
7900 of the grammar end up wanting to copy it after this op has been
7905 if (PL_parser->preambling != NOLINE) {
7906 CopLINE_set(cop, PL_parser->preambling);
7907 PL_parser->copline = NOLINE;
7909 else if (PL_parser->copline == NOLINE)
7910 CopLINE_set(cop, CopLINE(PL_curcop));
7912 CopLINE_set(cop, PL_parser->copline);
7913 PL_parser->copline = NOLINE;
7916 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
7918 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
7920 CopSTASH_set(cop, PL_curstash);
7922 if (cop->op_type == OP_DBSTATE) {
7923 /* this line can have a breakpoint - store the cop in IV */
7924 AV *av = CopFILEAVx(PL_curcop);
7926 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
7927 if (svp && *svp != &PL_sv_undef ) {
7928 (void)SvIOK_on(*svp);
7929 SvIV_set(*svp, PTR2IV(cop));
7934 if (flags & OPf_SPECIAL)
7936 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
7940 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
7942 Constructs, checks, and returns a logical (flow control) op. C<type>
7943 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
7944 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
7945 the eight bits of C<op_private>, except that the bit with value 1 is
7946 automatically set. C<first> supplies the expression controlling the
7947 flow, and C<other> supplies the side (alternate) chain of ops; they are
7948 consumed by this function and become part of the constructed op tree.
7954 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
7956 PERL_ARGS_ASSERT_NEWLOGOP;
7958 return new_logop(type, flags, &first, &other);
7962 S_search_const(pTHX_ OP *o)
7964 PERL_ARGS_ASSERT_SEARCH_CONST;
7966 switch (o->op_type) {
7970 if (o->op_flags & OPf_KIDS)
7971 return search_const(cUNOPo->op_first);
7978 if (!(o->op_flags & OPf_KIDS))
7980 kid = cLISTOPo->op_first;
7982 switch (kid->op_type) {
7986 kid = OpSIBLING(kid);
7989 if (kid != cLISTOPo->op_last)
7995 kid = cLISTOPo->op_last;
7997 return search_const(kid);
8005 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8013 int prepend_not = 0;
8015 PERL_ARGS_ASSERT_NEW_LOGOP;
8020 /* [perl #59802]: Warn about things like "return $a or $b", which
8021 is parsed as "(return $a) or $b" rather than "return ($a or
8022 $b)". NB: This also applies to xor, which is why we do it
8025 switch (first->op_type) {
8029 /* XXX: Perhaps we should emit a stronger warning for these.
8030 Even with the high-precedence operator they don't seem to do
8033 But until we do, fall through here.
8039 /* XXX: Currently we allow people to "shoot themselves in the
8040 foot" by explicitly writing "(return $a) or $b".
8042 Warn unless we are looking at the result from folding or if
8043 the programmer explicitly grouped the operators like this.
8044 The former can occur with e.g.
8046 use constant FEATURE => ( $] >= ... );
8047 sub { not FEATURE and return or do_stuff(); }
8049 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8050 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8051 "Possible precedence issue with control flow operator");
8052 /* XXX: Should we optimze this to "return $a;" (i.e. remove
8058 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8059 return newBINOP(type, flags, scalar(first), scalar(other));
8061 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8062 || type == OP_CUSTOM);
8064 scalarboolean(first);
8066 /* search for a constant op that could let us fold the test */
8067 if ((cstop = search_const(first))) {
8068 if (cstop->op_private & OPpCONST_STRICT)
8069 no_bareword_allowed(cstop);
8070 else if ((cstop->op_private & OPpCONST_BARE))
8071 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8072 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
8073 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8074 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8075 /* Elide the (constant) lhs, since it can't affect the outcome */
8077 if (other->op_type == OP_CONST)
8078 other->op_private |= OPpCONST_SHORTCIRCUIT;
8080 if (other->op_type == OP_LEAVE)
8081 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8082 else if (other->op_type == OP_MATCH
8083 || other->op_type == OP_SUBST
8084 || other->op_type == OP_TRANSR
8085 || other->op_type == OP_TRANS)
8086 /* Mark the op as being unbindable with =~ */
8087 other->op_flags |= OPf_SPECIAL;
8089 other->op_folded = 1;
8093 /* Elide the rhs, since the outcome is entirely determined by
8094 * the (constant) lhs */
8096 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8097 const OP *o2 = other;
8098 if ( ! (o2->op_type == OP_LIST
8099 && (( o2 = cUNOPx(o2)->op_first))
8100 && o2->op_type == OP_PUSHMARK
8101 && (( o2 = OpSIBLING(o2))) )
8104 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8105 || o2->op_type == OP_PADHV)
8106 && o2->op_private & OPpLVAL_INTRO
8107 && !(o2->op_private & OPpPAD_STATE))
8109 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8110 "Deprecated use of my() in false conditional. "
8111 "This will be a fatal error in Perl 5.30");
8115 if (cstop->op_type == OP_CONST)
8116 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8121 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8122 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8124 const OP * const k1 = ((UNOP*)first)->op_first;
8125 const OP * const k2 = OpSIBLING(k1);
8127 switch (first->op_type)
8130 if (k2 && k2->op_type == OP_READLINE
8131 && (k2->op_flags & OPf_STACKED)
8132 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8134 warnop = k2->op_type;
8139 if (k1->op_type == OP_READDIR
8140 || k1->op_type == OP_GLOB
8141 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8142 || k1->op_type == OP_EACH
8143 || k1->op_type == OP_AEACH)
8145 warnop = ((k1->op_type == OP_NULL)
8146 ? (OPCODE)k1->op_targ : k1->op_type);
8151 const line_t oldline = CopLINE(PL_curcop);
8152 /* This ensures that warnings are reported at the first line
8153 of the construction, not the last. */
8154 CopLINE_set(PL_curcop, PL_parser->copline);
8155 Perl_warner(aTHX_ packWARN(WARN_MISC),
8156 "Value of %s%s can be \"0\"; test with defined()",
8158 ((warnop == OP_READLINE || warnop == OP_GLOB)
8159 ? " construct" : "() operator"));
8160 CopLINE_set(PL_curcop, oldline);
8164 /* optimize AND and OR ops that have NOTs as children */
8165 if (first->op_type == OP_NOT
8166 && (first->op_flags & OPf_KIDS)
8167 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8168 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8170 if (type == OP_AND || type == OP_OR) {
8176 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8178 prepend_not = 1; /* prepend a NOT op later */
8183 logop = alloc_LOGOP(type, first, LINKLIST(other));
8184 logop->op_flags |= (U8)flags;
8185 logop->op_private = (U8)(1 | (flags >> 8));
8187 /* establish postfix order */
8188 logop->op_next = LINKLIST(first);
8189 first->op_next = (OP*)logop;
8190 assert(!OpHAS_SIBLING(first));
8191 op_sibling_splice((OP*)logop, first, 0, other);
8193 CHECKOP(type,logop);
8195 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8196 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8204 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8206 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8207 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8208 will be set automatically, and, shifted up eight bits, the eight bits of
8209 C<op_private>, except that the bit with value 1 is automatically set.
8210 C<first> supplies the expression selecting between the two branches,
8211 and C<trueop> and C<falseop> supply the branches; they are consumed by
8212 this function and become part of the constructed op tree.
8218 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8226 PERL_ARGS_ASSERT_NEWCONDOP;
8229 return newLOGOP(OP_AND, 0, first, trueop);
8231 return newLOGOP(OP_OR, 0, first, falseop);
8233 scalarboolean(first);
8234 if ((cstop = search_const(first))) {
8235 /* Left or right arm of the conditional? */
8236 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8237 OP *live = left ? trueop : falseop;
8238 OP *const dead = left ? falseop : trueop;
8239 if (cstop->op_private & OPpCONST_BARE &&
8240 cstop->op_private & OPpCONST_STRICT) {
8241 no_bareword_allowed(cstop);
8245 if (live->op_type == OP_LEAVE)
8246 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8247 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8248 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8249 /* Mark the op as being unbindable with =~ */
8250 live->op_flags |= OPf_SPECIAL;
8251 live->op_folded = 1;
8254 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8255 logop->op_flags |= (U8)flags;
8256 logop->op_private = (U8)(1 | (flags >> 8));
8257 logop->op_next = LINKLIST(falseop);
8259 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8262 /* establish postfix order */
8263 start = LINKLIST(first);
8264 first->op_next = (OP*)logop;
8266 /* make first, trueop, falseop siblings */
8267 op_sibling_splice((OP*)logop, first, 0, trueop);
8268 op_sibling_splice((OP*)logop, trueop, 0, falseop);
8270 o = newUNOP(OP_NULL, 0, (OP*)logop);
8272 trueop->op_next = falseop->op_next = o;
8279 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8281 Constructs and returns a C<range> op, with subordinate C<flip> and
8282 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
8283 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8284 for both the C<flip> and C<range> ops, except that the bit with value
8285 1 is automatically set. C<left> and C<right> supply the expressions
8286 controlling the endpoints of the range; they are consumed by this function
8287 and become part of the constructed op tree.
8293 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8301 PERL_ARGS_ASSERT_NEWRANGE;
8303 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8304 range->op_flags = OPf_KIDS;
8305 leftstart = LINKLIST(left);
8306 range->op_private = (U8)(1 | (flags >> 8));
8308 /* make left and right siblings */
8309 op_sibling_splice((OP*)range, left, 0, right);
8311 range->op_next = (OP*)range;
8312 flip = newUNOP(OP_FLIP, flags, (OP*)range);
8313 flop = newUNOP(OP_FLOP, 0, flip);
8314 o = newUNOP(OP_NULL, 0, flop);
8316 range->op_next = leftstart;
8318 left->op_next = flip;
8319 right->op_next = flop;
8322 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8323 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8325 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8326 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8327 SvPADTMP_on(PAD_SV(flip->op_targ));
8329 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8330 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8332 /* check barewords before they might be optimized aways */
8333 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8334 no_bareword_allowed(left);
8335 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8336 no_bareword_allowed(right);
8339 if (!flip->op_private || !flop->op_private)
8340 LINKLIST(o); /* blow off optimizer unless constant */
8346 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8348 Constructs, checks, and returns an op tree expressing a loop. This is
8349 only a loop in the control flow through the op tree; it does not have
8350 the heavyweight loop structure that allows exiting the loop by C<last>
8351 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
8352 top-level op, except that some bits will be set automatically as required.
8353 C<expr> supplies the expression controlling loop iteration, and C<block>
8354 supplies the body of the loop; they are consumed by this function and
8355 become part of the constructed op tree. C<debuggable> is currently
8356 unused and should always be 1.
8362 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8366 const bool once = block && block->op_flags & OPf_SPECIAL &&
8367 block->op_type == OP_NULL;
8369 PERL_UNUSED_ARG(debuggable);
8373 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8374 || ( expr->op_type == OP_NOT
8375 && cUNOPx(expr)->op_first->op_type == OP_CONST
8376 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8379 /* Return the block now, so that S_new_logop does not try to
8381 return block; /* do {} while 0 does once */
8382 if (expr->op_type == OP_READLINE
8383 || expr->op_type == OP_READDIR
8384 || expr->op_type == OP_GLOB
8385 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8386 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8387 expr = newUNOP(OP_DEFINED, 0,
8388 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8389 } else if (expr->op_flags & OPf_KIDS) {
8390 const OP * const k1 = ((UNOP*)expr)->op_first;
8391 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8392 switch (expr->op_type) {
8394 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8395 && (k2->op_flags & OPf_STACKED)
8396 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8397 expr = newUNOP(OP_DEFINED, 0, expr);
8401 if (k1 && (k1->op_type == OP_READDIR
8402 || k1->op_type == OP_GLOB
8403 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8404 || k1->op_type == OP_EACH
8405 || k1->op_type == OP_AEACH))
8406 expr = newUNOP(OP_DEFINED, 0, expr);
8412 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8413 * op, in listop. This is wrong. [perl #27024] */
8415 block = newOP(OP_NULL, 0);
8416 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8417 o = new_logop(OP_AND, 0, &expr, &listop);
8424 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8426 if (once && o != listop)
8428 assert(cUNOPo->op_first->op_type == OP_AND
8429 || cUNOPo->op_first->op_type == OP_OR);
8430 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8434 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
8436 o->op_flags |= flags;
8438 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8443 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8445 Constructs, checks, and returns an op tree expressing a C<while> loop.
8446 This is a heavyweight loop, with structure that allows exiting the loop
8447 by C<last> and suchlike.
8449 C<loop> is an optional preconstructed C<enterloop> op to use in the
8450 loop; if it is null then a suitable op will be constructed automatically.
8451 C<expr> supplies the loop's controlling expression. C<block> supplies the
8452 main body of the loop, and C<cont> optionally supplies a C<continue> block
8453 that operates as a second half of the body. All of these optree inputs
8454 are consumed by this function and become part of the constructed op tree.
8456 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8457 op and, shifted up eight bits, the eight bits of C<op_private> for
8458 the C<leaveloop> op, except that (in both cases) some bits will be set
8459 automatically. C<debuggable> is currently unused and should always be 1.
8460 C<has_my> can be supplied as true to force the
8461 loop body to be enclosed in its own scope.
8467 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8468 OP *expr, OP *block, OP *cont, I32 has_my)
8477 PERL_UNUSED_ARG(debuggable);
8480 if (expr->op_type == OP_READLINE
8481 || expr->op_type == OP_READDIR
8482 || expr->op_type == OP_GLOB
8483 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8484 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8485 expr = newUNOP(OP_DEFINED, 0,
8486 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8487 } else if (expr->op_flags & OPf_KIDS) {
8488 const OP * const k1 = ((UNOP*)expr)->op_first;
8489 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8490 switch (expr->op_type) {
8492 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8493 && (k2->op_flags & OPf_STACKED)
8494 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8495 expr = newUNOP(OP_DEFINED, 0, expr);
8499 if (k1 && (k1->op_type == OP_READDIR
8500 || k1->op_type == OP_GLOB
8501 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8502 || k1->op_type == OP_EACH
8503 || k1->op_type == OP_AEACH))
8504 expr = newUNOP(OP_DEFINED, 0, expr);
8511 block = newOP(OP_NULL, 0);
8512 else if (cont || has_my) {
8513 block = op_scope(block);
8517 next = LINKLIST(cont);
8520 OP * const unstack = newOP(OP_UNSTACK, 0);
8523 cont = op_append_elem(OP_LINESEQ, cont, unstack);
8527 listop = op_append_list(OP_LINESEQ, block, cont);
8529 redo = LINKLIST(listop);
8533 o = new_logop(OP_AND, 0, &expr, &listop);
8534 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8536 return expr; /* listop already freed by new_logop */
8539 ((LISTOP*)listop)->op_last->op_next =
8540 (o == listop ? redo : LINKLIST(o));
8546 NewOp(1101,loop,1,LOOP);
8547 OpTYPE_set(loop, OP_ENTERLOOP);
8548 loop->op_private = 0;
8549 loop->op_next = (OP*)loop;
8552 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8554 loop->op_redoop = redo;
8555 loop->op_lastop = o;
8556 o->op_private |= loopflags;
8559 loop->op_nextop = next;
8561 loop->op_nextop = o;
8563 o->op_flags |= flags;
8564 o->op_private |= (flags >> 8);
8569 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8571 Constructs, checks, and returns an op tree expressing a C<foreach>
8572 loop (iteration through a list of values). This is a heavyweight loop,
8573 with structure that allows exiting the loop by C<last> and suchlike.
8575 C<sv> optionally supplies the variable that will be aliased to each
8576 item in turn; if null, it defaults to C<$_>.
8577 C<expr> supplies the list of values to iterate over. C<block> supplies
8578 the main body of the loop, and C<cont> optionally supplies a C<continue>
8579 block that operates as a second half of the body. All of these optree
8580 inputs are consumed by this function and become part of the constructed
8583 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8584 op and, shifted up eight bits, the eight bits of C<op_private> for
8585 the C<leaveloop> op, except that (in both cases) some bits will be set
8592 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8597 PADOFFSET padoff = 0;
8601 PERL_ARGS_ASSERT_NEWFOROP;
8604 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
8605 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8606 OpTYPE_set(sv, OP_RV2GV);
8608 /* The op_type check is needed to prevent a possible segfault
8609 * if the loop variable is undeclared and 'strict vars' is in
8610 * effect. This is illegal but is nonetheless parsed, so we
8611 * may reach this point with an OP_CONST where we're expecting
8614 if (cUNOPx(sv)->op_first->op_type == OP_GV
8615 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8616 iterpflags |= OPpITER_DEF;
8618 else if (sv->op_type == OP_PADSV) { /* private variable */
8619 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8620 padoff = sv->op_targ;
8624 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8626 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8629 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8631 PADNAME * const pn = PAD_COMPNAME(padoff);
8632 const char * const name = PadnamePV(pn);
8634 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8635 iterpflags |= OPpITER_DEF;
8639 sv = newGVOP(OP_GV, 0, PL_defgv);
8640 iterpflags |= OPpITER_DEF;
8643 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8644 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8645 iterflags |= OPf_STACKED;
8647 else if (expr->op_type == OP_NULL &&
8648 (expr->op_flags & OPf_KIDS) &&
8649 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8651 /* Basically turn for($x..$y) into the same as for($x,$y), but we
8652 * set the STACKED flag to indicate that these values are to be
8653 * treated as min/max values by 'pp_enteriter'.
8655 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8656 LOGOP* const range = (LOGOP*) flip->op_first;
8657 OP* const left = range->op_first;
8658 OP* const right = OpSIBLING(left);
8661 range->op_flags &= ~OPf_KIDS;
8662 /* detach range's children */
8663 op_sibling_splice((OP*)range, NULL, -1, NULL);
8665 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8666 listop->op_first->op_next = range->op_next;
8667 left->op_next = range->op_other;
8668 right->op_next = (OP*)listop;
8669 listop->op_next = listop->op_first;
8672 expr = (OP*)(listop);
8674 iterflags |= OPf_STACKED;
8677 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8680 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8681 op_append_elem(OP_LIST, list(expr),
8683 assert(!loop->op_next);
8684 /* for my $x () sets OPpLVAL_INTRO;
8685 * for our $x () sets OPpOUR_INTRO */
8686 loop->op_private = (U8)iterpflags;
8687 if (loop->op_slabbed
8688 && DIFF(loop, OpSLOT(loop)->opslot_next)
8689 < SIZE_TO_PSIZE(sizeof(LOOP)))
8692 NewOp(1234,tmp,1,LOOP);
8693 Copy(loop,tmp,1,LISTOP);
8694 #ifdef PERL_OP_PARENT
8695 assert(loop->op_last->op_sibparent == (OP*)loop);
8696 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8698 S_op_destroy(aTHX_ (OP*)loop);
8701 else if (!loop->op_slabbed)
8703 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8704 #ifdef PERL_OP_PARENT
8705 OpLASTSIB_set(loop->op_last, (OP*)loop);
8708 loop->op_targ = padoff;
8709 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8714 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8716 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8717 or C<last>). C<type> is the opcode. C<label> supplies the parameter
8718 determining the target of the op; it is consumed by this function and
8719 becomes part of the constructed op tree.
8725 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8729 PERL_ARGS_ASSERT_NEWLOOPEX;
8731 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8732 || type == OP_CUSTOM);
8734 if (type != OP_GOTO) {
8735 /* "last()" means "last" */
8736 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8737 o = newOP(type, OPf_SPECIAL);
8741 /* Check whether it's going to be a goto &function */
8742 if (label->op_type == OP_ENTERSUB
8743 && !(label->op_flags & OPf_STACKED))
8744 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8747 /* Check for a constant argument */
8748 if (label->op_type == OP_CONST) {
8749 SV * const sv = ((SVOP *)label)->op_sv;
8751 const char *s = SvPV_const(sv,l);
8752 if (l == strlen(s)) {
8754 SvUTF8(((SVOP*)label)->op_sv),
8756 SvPV_nolen_const(((SVOP*)label)->op_sv)));
8760 /* If we have already created an op, we do not need the label. */
8763 else o = newUNOP(type, OPf_STACKED, label);
8765 PL_hints |= HINT_BLOCK_SCOPE;
8769 /* if the condition is a literal array or hash
8770 (or @{ ... } etc), make a reference to it.
8773 S_ref_array_or_hash(pTHX_ OP *cond)
8776 && (cond->op_type == OP_RV2AV
8777 || cond->op_type == OP_PADAV
8778 || cond->op_type == OP_RV2HV
8779 || cond->op_type == OP_PADHV))
8781 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
8784 && (cond->op_type == OP_ASLICE
8785 || cond->op_type == OP_KVASLICE
8786 || cond->op_type == OP_HSLICE
8787 || cond->op_type == OP_KVHSLICE)) {
8789 /* anonlist now needs a list from this op, was previously used in
8791 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
8792 cond->op_flags |= OPf_WANT_LIST;
8794 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
8801 /* These construct the optree fragments representing given()
8804 entergiven and enterwhen are LOGOPs; the op_other pointer
8805 points up to the associated leave op. We need this so we
8806 can put it in the context and make break/continue work.
8807 (Also, of course, pp_enterwhen will jump straight to
8808 op_other if the match fails.)
8812 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
8813 I32 enter_opcode, I32 leave_opcode,
8814 PADOFFSET entertarg)
8820 PERL_ARGS_ASSERT_NEWGIVWHENOP;
8821 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
8823 enterop = alloc_LOGOP(enter_opcode, block, NULL);
8824 enterop->op_targ = 0;
8825 enterop->op_private = 0;
8827 o = newUNOP(leave_opcode, 0, (OP *) enterop);
8830 /* prepend cond if we have one */
8831 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
8833 o->op_next = LINKLIST(cond);
8834 cond->op_next = (OP *) enterop;
8837 /* This is a default {} block */
8838 enterop->op_flags |= OPf_SPECIAL;
8839 o ->op_flags |= OPf_SPECIAL;
8841 o->op_next = (OP *) enterop;
8844 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
8845 entergiven and enterwhen both
8848 enterop->op_next = LINKLIST(block);
8849 block->op_next = enterop->op_other = o;
8854 /* Does this look like a boolean operation? For these purposes
8855 a boolean operation is:
8856 - a subroutine call [*]
8857 - a logical connective
8858 - a comparison operator
8859 - a filetest operator, with the exception of -s -M -A -C
8860 - defined(), exists() or eof()
8861 - /$re/ or $foo =~ /$re/
8863 [*] possibly surprising
8866 S_looks_like_bool(pTHX_ const OP *o)
8868 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
8870 switch(o->op_type) {
8873 return looks_like_bool(cLOGOPo->op_first);
8877 OP* sibl = OpSIBLING(cLOGOPo->op_first);
8880 looks_like_bool(cLOGOPo->op_first)
8881 && looks_like_bool(sibl));
8887 o->op_flags & OPf_KIDS
8888 && looks_like_bool(cUNOPo->op_first));
8892 case OP_NOT: case OP_XOR:
8894 case OP_EQ: case OP_NE: case OP_LT:
8895 case OP_GT: case OP_LE: case OP_GE:
8897 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
8898 case OP_I_GT: case OP_I_LE: case OP_I_GE:
8900 case OP_SEQ: case OP_SNE: case OP_SLT:
8901 case OP_SGT: case OP_SLE: case OP_SGE:
8905 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
8906 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
8907 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
8908 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
8909 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
8910 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
8911 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
8912 case OP_FTTEXT: case OP_FTBINARY:
8914 case OP_DEFINED: case OP_EXISTS:
8915 case OP_MATCH: case OP_EOF:
8922 /* Detect comparisons that have been optimized away */
8923 if (cSVOPo->op_sv == &PL_sv_yes
8924 || cSVOPo->op_sv == &PL_sv_no)
8937 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
8939 Constructs, checks, and returns an op tree expressing a C<given> block.
8940 C<cond> supplies the expression to whose value C<$_> will be locally
8941 aliased, and C<block> supplies the body of the C<given> construct; they
8942 are consumed by this function and become part of the constructed op tree.
8943 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
8949 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
8951 PERL_ARGS_ASSERT_NEWGIVENOP;
8952 PERL_UNUSED_ARG(defsv_off);
8955 return newGIVWHENOP(
8956 ref_array_or_hash(cond),
8958 OP_ENTERGIVEN, OP_LEAVEGIVEN,
8963 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
8965 Constructs, checks, and returns an op tree expressing a C<when> block.
8966 C<cond> supplies the test expression, and C<block> supplies the block
8967 that will be executed if the test evaluates to true; they are consumed
8968 by this function and become part of the constructed op tree. C<cond>
8969 will be interpreted DWIMically, often as a comparison against C<$_>,
8970 and may be null to generate a C<default> block.
8976 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
8978 const bool cond_llb = (!cond || looks_like_bool(cond));
8981 PERL_ARGS_ASSERT_NEWWHENOP;
8986 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
8988 scalar(ref_array_or_hash(cond)));
8991 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
8994 /* must not conflict with SVf_UTF8 */
8995 #define CV_CKPROTO_CURSTASH 0x1
8998 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
8999 const STRLEN len, const U32 flags)
9001 SV *name = NULL, *msg;
9002 const char * cvp = SvROK(cv)
9003 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9004 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9007 STRLEN clen = CvPROTOLEN(cv), plen = len;
9009 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9011 if (p == NULL && cvp == NULL)
9014 if (!ckWARN_d(WARN_PROTOTYPE))
9018 p = S_strip_spaces(aTHX_ p, &plen);
9019 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9020 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9021 if (plen == clen && memEQ(cvp, p, plen))
9024 if (flags & SVf_UTF8) {
9025 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9029 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9035 msg = sv_newmortal();
9040 gv_efullname3(name = sv_newmortal(), gv, NULL);
9041 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9042 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9043 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9044 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9045 sv_catpvs(name, "::");
9047 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9048 assert (CvNAMED(SvRV_const(gv)));
9049 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9051 else sv_catsv(name, (SV *)gv);
9053 else name = (SV *)gv;
9055 sv_setpvs(msg, "Prototype mismatch:");
9057 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9059 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9060 UTF8fARG(SvUTF8(cv),clen,cvp)
9063 sv_catpvs(msg, ": none");
9064 sv_catpvs(msg, " vs ");
9066 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9068 sv_catpvs(msg, "none");
9069 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9072 static void const_sv_xsub(pTHX_ CV* cv);
9073 static void const_av_xsub(pTHX_ CV* cv);
9077 =head1 Optree Manipulation Functions
9079 =for apidoc cv_const_sv
9081 If C<cv> is a constant sub eligible for inlining, returns the constant
9082 value returned by the sub. Otherwise, returns C<NULL>.
9084 Constant subs can be created with C<newCONSTSUB> or as described in
9085 L<perlsub/"Constant Functions">.
9090 Perl_cv_const_sv(const CV *const cv)
9095 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9097 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9098 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9103 Perl_cv_const_sv_or_av(const CV * const cv)
9107 if (SvROK(cv)) return SvRV((SV *)cv);
9108 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9109 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9112 /* op_const_sv: examine an optree to determine whether it's in-lineable.
9113 * Can be called in 2 ways:
9116 * look for a single OP_CONST with attached value: return the value
9118 * allow_lex && !CvCONST(cv);
9120 * examine the clone prototype, and if contains only a single
9121 * OP_CONST, return the value; or if it contains a single PADSV ref-
9122 * erencing an outer lexical, turn on CvCONST to indicate the CV is
9123 * a candidate for "constizing" at clone time, and return NULL.
9127 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9135 for (; o; o = o->op_next) {
9136 const OPCODE type = o->op_type;
9138 if (type == OP_NEXTSTATE || type == OP_LINESEQ
9140 || type == OP_PUSHMARK)
9142 if (type == OP_DBSTATE)
9144 if (type == OP_LEAVESUB)
9148 if (type == OP_CONST && cSVOPo->op_sv)
9150 else if (type == OP_UNDEF && !o->op_private) {
9154 else if (allow_lex && type == OP_PADSV) {
9155 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9157 sv = &PL_sv_undef; /* an arbitrary non-null value */
9175 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9176 PADNAME * const name, SV ** const const_svp)
9182 if (CvFLAGS(PL_compcv)) {
9183 /* might have had built-in attrs applied */
9184 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9185 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9186 && ckWARN(WARN_MISC))
9188 /* protect against fatal warnings leaking compcv */
9189 SAVEFREESV(PL_compcv);
9190 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9191 SvREFCNT_inc_simple_void_NN(PL_compcv);
9194 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9195 & ~(CVf_LVALUE * pureperl));
9200 /* redundant check for speed: */
9201 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9202 const line_t oldline = CopLINE(PL_curcop);
9205 : sv_2mortal(newSVpvn_utf8(
9206 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9208 if (PL_parser && PL_parser->copline != NOLINE)
9209 /* This ensures that warnings are reported at the first
9210 line of a redefinition, not the last. */
9211 CopLINE_set(PL_curcop, PL_parser->copline);
9212 /* protect against fatal warnings leaking compcv */
9213 SAVEFREESV(PL_compcv);
9214 report_redefined_cv(namesv, cv, const_svp);
9215 SvREFCNT_inc_simple_void_NN(PL_compcv);
9216 CopLINE_set(PL_curcop, oldline);
9223 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9228 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9231 CV *compcv = PL_compcv;
9234 PADOFFSET pax = o->op_targ;
9235 CV *outcv = CvOUTSIDE(PL_compcv);
9238 bool reusable = FALSE;
9240 #ifdef PERL_DEBUG_READONLY_OPS
9241 OPSLAB *slab = NULL;
9244 PERL_ARGS_ASSERT_NEWMYSUB;
9246 PL_hints |= HINT_BLOCK_SCOPE;
9248 /* Find the pad slot for storing the new sub.
9249 We cannot use PL_comppad, as it is the pad owned by the new sub. We
9250 need to look in CvOUTSIDE and find the pad belonging to the enclos-
9251 ing sub. And then we need to dig deeper if this is a lexical from
9253 my sub foo; sub { sub foo { } }
9256 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9257 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9258 pax = PARENT_PAD_INDEX(name);
9259 outcv = CvOUTSIDE(outcv);
9264 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9265 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9266 spot = (CV **)svspot;
9268 if (!(PL_parser && PL_parser->error_count))
9269 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9272 assert(proto->op_type == OP_CONST);
9273 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9274 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9284 if (PL_parser && PL_parser->error_count) {
9286 SvREFCNT_dec(PL_compcv);
9291 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9293 svspot = (SV **)(spot = &clonee);
9295 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9298 assert (SvTYPE(*spot) == SVt_PVCV);
9300 hek = CvNAME_HEK(*spot);
9304 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9305 CvNAME_HEK_set(*spot, hek =
9308 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9312 CvLEXICAL_on(*spot);
9314 cv = PadnamePROTOCV(name);
9315 svspot = (SV **)(spot = &PadnamePROTOCV(name));
9319 /* This makes sub {}; work as expected. */
9320 if (block->op_type == OP_STUB) {
9321 const line_t l = PL_parser->copline;
9323 block = newSTATEOP(0, NULL, 0);
9324 PL_parser->copline = l;
9326 block = CvLVALUE(compcv)
9327 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9328 ? newUNOP(OP_LEAVESUBLV, 0,
9329 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9330 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9331 start = LINKLIST(block);
9333 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9334 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9342 const bool exists = CvROOT(cv) || CvXSUB(cv);
9344 /* if the subroutine doesn't exist and wasn't pre-declared
9345 * with a prototype, assume it will be AUTOLOADed,
9346 * skipping the prototype check
9348 if (exists || SvPOK(cv))
9349 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9351 /* already defined? */
9353 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9359 /* just a "sub foo;" when &foo is already defined */
9364 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9371 SvREFCNT_inc_simple_void_NN(const_sv);
9372 SvFLAGS(const_sv) |= SVs_PADTMP;
9374 assert(!CvROOT(cv) && !CvCONST(cv));
9378 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9379 CvFILE_set_from_cop(cv, PL_curcop);
9380 CvSTASH_set(cv, PL_curstash);
9383 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
9384 CvXSUBANY(cv).any_ptr = const_sv;
9385 CvXSUB(cv) = const_sv_xsub;
9389 CvFLAGS(cv) |= CvMETHOD(compcv);
9391 SvREFCNT_dec(compcv);
9396 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9397 determine whether this sub definition is in the same scope as its
9398 declaration. If this sub definition is inside an inner named pack-
9399 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9400 the package sub. So check PadnameOUTER(name) too.
9402 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9403 assert(!CvWEAKOUTSIDE(compcv));
9404 SvREFCNT_dec(CvOUTSIDE(compcv));
9405 CvWEAKOUTSIDE_on(compcv);
9407 /* XXX else do we have a circular reference? */
9409 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
9410 /* transfer PL_compcv to cv */
9412 cv_flags_t preserved_flags =
9413 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9414 PADLIST *const temp_padl = CvPADLIST(cv);
9415 CV *const temp_cv = CvOUTSIDE(cv);
9416 const cv_flags_t other_flags =
9417 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9418 OP * const cvstart = CvSTART(cv);
9422 CvFLAGS(compcv) | preserved_flags;
9423 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9424 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9425 CvPADLIST_set(cv, CvPADLIST(compcv));
9426 CvOUTSIDE(compcv) = temp_cv;
9427 CvPADLIST_set(compcv, temp_padl);
9428 CvSTART(cv) = CvSTART(compcv);
9429 CvSTART(compcv) = cvstart;
9430 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9431 CvFLAGS(compcv) |= other_flags;
9433 if (CvFILE(cv) && CvDYNFILE(cv)) {
9434 Safefree(CvFILE(cv));
9437 /* inner references to compcv must be fixed up ... */
9438 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9439 if (PERLDB_INTER)/* Advice debugger on the new sub. */
9440 ++PL_sub_generation;
9443 /* Might have had built-in attributes applied -- propagate them. */
9444 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9446 /* ... before we throw it away */
9447 SvREFCNT_dec(compcv);
9448 PL_compcv = compcv = cv;
9457 if (!CvNAME_HEK(cv)) {
9458 if (hek) (void)share_hek_hek(hek);
9462 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9463 hek = share_hek(PadnamePV(name)+1,
9464 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9467 CvNAME_HEK_set(cv, hek);
9473 CvFILE_set_from_cop(cv, PL_curcop);
9474 CvSTASH_set(cv, PL_curstash);
9477 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9479 SvUTF8_on(MUTABLE_SV(cv));
9483 /* If we assign an optree to a PVCV, then we've defined a
9484 * subroutine that the debugger could be able to set a breakpoint
9485 * in, so signal to pp_entereval that it should not throw away any
9486 * saved lines at scope exit. */
9488 PL_breakable_sub_gen++;
9490 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9491 itself has a refcount. */
9493 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9494 #ifdef PERL_DEBUG_READONLY_OPS
9495 slab = (OPSLAB *)CvSTART(cv);
9497 S_process_optree(aTHX_ cv, block, start);
9502 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9503 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9507 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9508 SV * const tmpstr = sv_newmortal();
9509 GV * const db_postponed = gv_fetchpvs("DB::postponed",
9510 GV_ADDMULTI, SVt_PVHV);
9512 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9515 (long)CopLINE(PL_curcop));
9516 if (HvNAME_HEK(PL_curstash)) {
9517 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9518 sv_catpvs(tmpstr, "::");
9521 sv_setpvs(tmpstr, "__ANON__::");
9523 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9524 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9525 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9526 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9527 hv = GvHVn(db_postponed);
9528 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9529 CV * const pcv = GvCV(db_postponed);
9535 call_sv(MUTABLE_SV(pcv), G_DISCARD);
9543 assert(CvDEPTH(outcv));
9545 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9547 cv_clone_into(clonee, *spot);
9548 else *spot = cv_clone(clonee);
9549 SvREFCNT_dec_NN(clonee);
9553 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9554 PADOFFSET depth = CvDEPTH(outcv);
9557 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9559 *svspot = SvREFCNT_inc_simple_NN(cv);
9560 SvREFCNT_dec(oldcv);
9566 PL_parser->copline = NOLINE;
9568 #ifdef PERL_DEBUG_READONLY_OPS
9579 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9580 OP *block, bool o_is_gv)
9584 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9586 CV *cv = NULL; /* the previous CV with this name, if any */
9588 const bool ec = PL_parser && PL_parser->error_count;
9589 /* If the subroutine has no body, no attributes, and no builtin attributes
9590 then it's just a sub declaration, and we may be able to get away with
9591 storing with a placeholder scalar in the symbol table, rather than a
9592 full CV. If anything is present then it will take a full CV to
9594 const I32 gv_fetch_flags
9595 = ec ? GV_NOADD_NOINIT :
9596 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9597 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9599 const char * const name =
9600 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9602 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9603 bool evanescent = FALSE;
9605 #ifdef PERL_DEBUG_READONLY_OPS
9606 OPSLAB *slab = NULL;
9614 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
9615 hek and CvSTASH pointer together can imply the GV. If the name
9616 contains a package name, then GvSTASH(CvGV(cv)) may differ from
9617 CvSTASH, so forego the optimisation if we find any.
9618 Also, we may be called from load_module at run time, so
9619 PL_curstash (which sets CvSTASH) may not point to the stash the
9620 sub is stored in. */
9622 ec ? GV_NOADD_NOINIT
9623 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9624 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9626 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9627 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9629 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9630 SV * const sv = sv_newmortal();
9631 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9632 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9633 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9634 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9636 } else if (PL_curstash) {
9637 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9640 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9646 move_proto_attr(&proto, &attrs, gv, 0);
9649 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9654 assert(proto->op_type == OP_CONST);
9655 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9656 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9672 SvREFCNT_dec(PL_compcv);
9677 if (name && block) {
9678 const char *s = (char *) my_memrchr(name, ':', namlen);
9680 if (strEQ(s, "BEGIN")) {
9681 if (PL_in_eval & EVAL_KEEPERR)
9682 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
9684 SV * const errsv = ERRSV;
9685 /* force display of errors found but not reported */
9686 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
9687 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
9694 if (!block && SvTYPE(gv) != SVt_PVGV) {
9695 /* If we are not defining a new sub and the existing one is not a
9697 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
9698 /* We are applying attributes to an existing sub, so we need it
9699 upgraded if it is a constant. */
9700 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
9701 gv_init_pvn(gv, PL_curstash, name, namlen,
9702 SVf_UTF8 * name_is_utf8);
9704 else { /* Maybe prototype now, and had at maximum
9705 a prototype or const/sub ref before. */
9706 if (SvTYPE(gv) > SVt_NULL) {
9707 cv_ckproto_len_flags((const CV *)gv,
9708 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
9714 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
9716 SvUTF8_on(MUTABLE_SV(gv));
9719 sv_setiv(MUTABLE_SV(gv), -1);
9722 SvREFCNT_dec(PL_compcv);
9723 cv = PL_compcv = NULL;
9728 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
9732 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
9738 /* This makes sub {}; work as expected. */
9739 if (block->op_type == OP_STUB) {
9740 const line_t l = PL_parser->copline;
9742 block = newSTATEOP(0, NULL, 0);
9743 PL_parser->copline = l;
9745 block = CvLVALUE(PL_compcv)
9746 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
9747 && (!isGV(gv) || !GvASSUMECV(gv)))
9748 ? newUNOP(OP_LEAVESUBLV, 0,
9749 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9750 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9751 start = LINKLIST(block);
9753 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
9755 S_op_const_sv(aTHX_ start, PL_compcv,
9756 cBOOL(CvCLONE(PL_compcv)));
9763 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
9764 cv_ckproto_len_flags((const CV *)gv,
9765 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
9766 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
9768 /* All the other code for sub redefinition warnings expects the
9769 clobbered sub to be a CV. Instead of making all those code
9770 paths more complex, just inline the RV version here. */
9771 const line_t oldline = CopLINE(PL_curcop);
9772 assert(IN_PERL_COMPILETIME);
9773 if (PL_parser && PL_parser->copline != NOLINE)
9774 /* This ensures that warnings are reported at the first
9775 line of a redefinition, not the last. */
9776 CopLINE_set(PL_curcop, PL_parser->copline);
9777 /* protect against fatal warnings leaking compcv */
9778 SAVEFREESV(PL_compcv);
9780 if (ckWARN(WARN_REDEFINE)
9781 || ( ckWARN_d(WARN_REDEFINE)
9782 && ( !const_sv || SvRV(gv) == const_sv
9783 || sv_cmp(SvRV(gv), const_sv) ))) {
9785 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9786 "Constant subroutine %" SVf " redefined",
9787 SVfARG(cSVOPo->op_sv));
9790 SvREFCNT_inc_simple_void_NN(PL_compcv);
9791 CopLINE_set(PL_curcop, oldline);
9792 SvREFCNT_dec(SvRV(gv));
9797 const bool exists = CvROOT(cv) || CvXSUB(cv);
9799 /* if the subroutine doesn't exist and wasn't pre-declared
9800 * with a prototype, assume it will be AUTOLOADed,
9801 * skipping the prototype check
9803 if (exists || SvPOK(cv))
9804 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
9805 /* already defined (or promised)? */
9806 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
9807 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
9813 /* just a "sub foo;" when &foo is already defined */
9814 SAVEFREESV(PL_compcv);
9821 SvREFCNT_inc_simple_void_NN(const_sv);
9822 SvFLAGS(const_sv) |= SVs_PADTMP;
9824 assert(!CvROOT(cv) && !CvCONST(cv));
9826 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
9827 CvXSUBANY(cv).any_ptr = const_sv;
9828 CvXSUB(cv) = const_sv_xsub;
9832 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
9835 if (isGV(gv) || CvMETHOD(PL_compcv)) {
9836 if (name && isGV(gv))
9838 cv = newCONSTSUB_flags(
9839 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
9842 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
9846 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
9847 prepare_SV_for_RV((SV *)gv);
9851 SvRV_set(gv, const_sv);
9855 SvREFCNT_dec(PL_compcv);
9860 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
9861 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
9864 if (cv) { /* must reuse cv if autoloaded */
9865 /* transfer PL_compcv to cv */
9867 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
9868 PADLIST *const temp_av = CvPADLIST(cv);
9869 CV *const temp_cv = CvOUTSIDE(cv);
9870 const cv_flags_t other_flags =
9871 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9872 OP * const cvstart = CvSTART(cv);
9876 assert(!CvCVGV_RC(cv));
9877 assert(CvGV(cv) == gv);
9882 PERL_HASH(hash, name, namlen);
9892 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
9894 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
9895 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
9896 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
9897 CvOUTSIDE(PL_compcv) = temp_cv;
9898 CvPADLIST_set(PL_compcv, temp_av);
9899 CvSTART(cv) = CvSTART(PL_compcv);
9900 CvSTART(PL_compcv) = cvstart;
9901 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9902 CvFLAGS(PL_compcv) |= other_flags;
9904 if (CvFILE(cv) && CvDYNFILE(cv)) {
9905 Safefree(CvFILE(cv));
9907 CvFILE_set_from_cop(cv, PL_curcop);
9908 CvSTASH_set(cv, PL_curstash);
9910 /* inner references to PL_compcv must be fixed up ... */
9911 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
9912 if (PERLDB_INTER)/* Advice debugger on the new sub. */
9913 ++PL_sub_generation;
9916 /* Might have had built-in attributes applied -- propagate them. */
9917 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
9919 /* ... before we throw it away */
9920 SvREFCNT_dec(PL_compcv);
9925 if (name && isGV(gv)) {
9928 if (HvENAME_HEK(GvSTASH(gv)))
9929 /* sub Foo::bar { (shift)+1 } */
9930 gv_method_changed(gv);
9934 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
9935 prepare_SV_for_RV((SV *)gv);
9939 SvRV_set(gv, (SV *)cv);
9940 if (HvENAME_HEK(PL_curstash))
9941 mro_method_changed_in(PL_curstash);
9951 PERL_HASH(hash, name, namlen);
9952 CvNAME_HEK_set(cv, share_hek(name,
9958 CvFILE_set_from_cop(cv, PL_curcop);
9959 CvSTASH_set(cv, PL_curstash);
9963 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9965 SvUTF8_on(MUTABLE_SV(cv));
9969 /* If we assign an optree to a PVCV, then we've defined a
9970 * subroutine that the debugger could be able to set a breakpoint
9971 * in, so signal to pp_entereval that it should not throw away any
9972 * saved lines at scope exit. */
9974 PL_breakable_sub_gen++;
9976 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9977 itself has a refcount. */
9979 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9980 #ifdef PERL_DEBUG_READONLY_OPS
9981 slab = (OPSLAB *)CvSTART(cv);
9983 S_process_optree(aTHX_ cv, block, start);
9988 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9989 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
9994 apply_attrs(stash, MUTABLE_SV(cv), attrs);
9996 SvREFCNT_inc_simple_void_NN(cv);
9999 if (block && has_name) {
10000 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10001 SV * const tmpstr = cv_name(cv,NULL,0);
10002 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10003 GV_ADDMULTI, SVt_PVHV);
10005 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10006 CopFILE(PL_curcop),
10008 (long)CopLINE(PL_curcop));
10009 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10010 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10011 hv = GvHVn(db_postponed);
10012 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10013 CV * const pcv = GvCV(db_postponed);
10019 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10025 if (PL_parser && PL_parser->error_count)
10026 clear_special_blocks(name, gv, cv);
10029 process_special_blocks(floor, name, gv, cv);
10035 PL_parser->copline = NOLINE;
10036 LEAVE_SCOPE(floor);
10039 #ifdef PERL_DEBUG_READONLY_OPS
10043 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10044 pad_add_weakref(cv);
10050 S_clear_special_blocks(pTHX_ const char *const fullname,
10051 GV *const gv, CV *const cv) {
10055 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10057 colon = strrchr(fullname,':');
10058 name = colon ? colon + 1 : fullname;
10060 if ((*name == 'B' && strEQ(name, "BEGIN"))
10061 || (*name == 'E' && strEQ(name, "END"))
10062 || (*name == 'U' && strEQ(name, "UNITCHECK"))
10063 || (*name == 'C' && strEQ(name, "CHECK"))
10064 || (*name == 'I' && strEQ(name, "INIT"))) {
10069 GvCV_set(gv, NULL);
10070 SvREFCNT_dec_NN(MUTABLE_SV(cv));
10074 /* Returns true if the sub has been freed. */
10076 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10080 const char *const colon = strrchr(fullname,':');
10081 const char *const name = colon ? colon + 1 : fullname;
10083 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10085 if (*name == 'B') {
10086 if (strEQ(name, "BEGIN")) {
10087 const I32 oldscope = PL_scopestack_ix;
10090 if (floor) LEAVE_SCOPE(floor);
10092 PUSHSTACKi(PERLSI_REQUIRE);
10093 SAVECOPFILE(&PL_compiling);
10094 SAVECOPLINE(&PL_compiling);
10095 SAVEVPTR(PL_curcop);
10097 DEBUG_x( dump_sub(gv) );
10098 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10099 GvCV_set(gv,0); /* cv has been hijacked */
10100 call_list(oldscope, PL_beginav);
10104 return !PL_savebegin;
10109 if (*name == 'E') {
10110 if strEQ(name, "END") {
10111 DEBUG_x( dump_sub(gv) );
10112 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10115 } else if (*name == 'U') {
10116 if (strEQ(name, "UNITCHECK")) {
10117 /* It's never too late to run a unitcheck block */
10118 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10122 } else if (*name == 'C') {
10123 if (strEQ(name, "CHECK")) {
10125 /* diag_listed_as: Too late to run %s block */
10126 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10127 "Too late to run CHECK block");
10128 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10132 } else if (*name == 'I') {
10133 if (strEQ(name, "INIT")) {
10135 /* diag_listed_as: Too late to run %s block */
10136 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10137 "Too late to run INIT block");
10138 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10144 DEBUG_x( dump_sub(gv) );
10146 GvCV_set(gv,0); /* cv has been hijacked */
10152 =for apidoc newCONSTSUB
10154 See L</newCONSTSUB_flags>.
10160 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10162 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10166 =for apidoc newCONSTSUB_flags
10168 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
10169 eligible for inlining at compile-time.
10171 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
10173 The newly created subroutine takes ownership of a reference to the passed in
10176 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
10177 which won't be called if used as a destructor, but will suppress the overhead
10178 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
10185 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10189 const char *const file = CopFILE(PL_curcop);
10193 if (IN_PERL_RUNTIME) {
10194 /* at runtime, it's not safe to manipulate PL_curcop: it may be
10195 * an op shared between threads. Use a non-shared COP for our
10197 SAVEVPTR(PL_curcop);
10198 SAVECOMPILEWARNINGS();
10199 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10200 PL_curcop = &PL_compiling;
10202 SAVECOPLINE(PL_curcop);
10203 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10206 PL_hints &= ~HINT_BLOCK_SCOPE;
10209 SAVEGENERICSV(PL_curstash);
10210 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10213 /* Protect sv against leakage caused by fatal warnings. */
10214 if (sv) SAVEFREESV(sv);
10216 /* file becomes the CvFILE. For an XS, it's usually static storage,
10217 and so doesn't get free()d. (It's expected to be from the C pre-
10218 processor __FILE__ directive). But we need a dynamically allocated one,
10219 and we need it to get freed. */
10220 cv = newXS_len_flags(name, len,
10221 sv && SvTYPE(sv) == SVt_PVAV
10224 file ? file : "", "",
10225 &sv, XS_DYNAMIC_FILENAME | flags);
10226 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10235 =for apidoc U||newXS
10237 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
10238 static storage, as it is used directly as CvFILE(), without a copy being made.
10244 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10246 PERL_ARGS_ASSERT_NEWXS;
10247 return newXS_len_flags(
10248 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10253 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10254 const char *const filename, const char *const proto,
10257 PERL_ARGS_ASSERT_NEWXS_FLAGS;
10258 return newXS_len_flags(
10259 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10264 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10266 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10267 return newXS_len_flags(
10268 name, strlen(name), subaddr, NULL, NULL, NULL, 0
10273 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10274 XSUBADDR_t subaddr, const char *const filename,
10275 const char *const proto, SV **const_svp,
10279 bool interleave = FALSE;
10281 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10284 GV * const gv = gv_fetchpvn(
10285 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10286 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10287 sizeof("__ANON__::__ANON__") - 1,
10288 GV_ADDMULTI | flags, SVt_PVCV);
10290 if ((cv = (name ? GvCV(gv) : NULL))) {
10292 /* just a cached method */
10296 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10297 /* already defined (or promised) */
10298 /* Redundant check that allows us to avoid creating an SV
10299 most of the time: */
10300 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10301 report_redefined_cv(newSVpvn_flags(
10302 name,len,(flags&SVf_UTF8)|SVs_TEMP
10313 if (cv) /* must reuse cv if autoloaded */
10316 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10320 if (HvENAME_HEK(GvSTASH(gv)))
10321 gv_method_changed(gv); /* newXS */
10327 /* XSUBs can't be perl lang/perl5db.pl debugged
10328 if (PERLDB_LINE_OR_SAVESRC)
10329 (void)gv_fetchfile(filename); */
10330 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10331 if (flags & XS_DYNAMIC_FILENAME) {
10333 CvFILE(cv) = savepv(filename);
10335 /* NOTE: not copied, as it is expected to be an external constant string */
10336 CvFILE(cv) = (char *)filename;
10339 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10340 CvFILE(cv) = (char*)PL_xsubfilename;
10343 CvXSUB(cv) = subaddr;
10344 #ifndef PERL_IMPLICIT_CONTEXT
10345 CvHSCXT(cv) = &PL_stack_sp;
10351 process_special_blocks(0, name, gv, cv);
10354 } /* <- not a conditional branch */
10357 sv_setpv(MUTABLE_SV(cv), proto);
10358 if (interleave) LEAVE;
10363 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10365 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10367 PERL_ARGS_ASSERT_NEWSTUB;
10368 assert(!GvCVu(gv));
10371 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10372 gv_method_changed(gv);
10374 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10378 CvGV_set(cv, cvgv);
10379 CvFILE_set_from_cop(cv, PL_curcop);
10380 CvSTASH_set(cv, PL_curstash);
10386 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10393 if (PL_parser && PL_parser->error_count) {
10399 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10400 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10403 if ((cv = GvFORM(gv))) {
10404 if (ckWARN(WARN_REDEFINE)) {
10405 const line_t oldline = CopLINE(PL_curcop);
10406 if (PL_parser && PL_parser->copline != NOLINE)
10407 CopLINE_set(PL_curcop, PL_parser->copline);
10409 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10410 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10412 /* diag_listed_as: Format %s redefined */
10413 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10414 "Format STDOUT redefined");
10416 CopLINE_set(PL_curcop, oldline);
10421 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10423 CvFILE_set_from_cop(cv, PL_curcop);
10426 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10428 start = LINKLIST(root);
10430 S_process_optree(aTHX_ cv, root, start);
10431 cv_forget_slab(cv);
10436 PL_parser->copline = NOLINE;
10437 LEAVE_SCOPE(floor);
10438 PL_compiling.cop_seq = 0;
10442 Perl_newANONLIST(pTHX_ OP *o)
10444 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10448 Perl_newANONHASH(pTHX_ OP *o)
10450 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10454 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10456 return newANONATTRSUB(floor, proto, NULL, block);
10460 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10462 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10464 newSVOP(OP_ANONCODE, 0,
10466 if (CvANONCONST(cv))
10467 anoncode = newUNOP(OP_ANONCONST, 0,
10468 op_convert_list(OP_ENTERSUB,
10469 OPf_STACKED|OPf_WANT_SCALAR,
10471 return newUNOP(OP_REFGEN, 0, anoncode);
10475 Perl_oopsAV(pTHX_ OP *o)
10479 PERL_ARGS_ASSERT_OOPSAV;
10481 switch (o->op_type) {
10484 OpTYPE_set(o, OP_PADAV);
10485 return ref(o, OP_RV2AV);
10489 OpTYPE_set(o, OP_RV2AV);
10494 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10501 Perl_oopsHV(pTHX_ OP *o)
10505 PERL_ARGS_ASSERT_OOPSHV;
10507 switch (o->op_type) {
10510 OpTYPE_set(o, OP_PADHV);
10511 return ref(o, OP_RV2HV);
10515 OpTYPE_set(o, OP_RV2HV);
10516 /* rv2hv steals the bottom bit for its own uses */
10517 o->op_private &= ~OPpARG1_MASK;
10522 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
10529 Perl_newAVREF(pTHX_ OP *o)
10533 PERL_ARGS_ASSERT_NEWAVREF;
10535 if (o->op_type == OP_PADANY) {
10536 OpTYPE_set(o, OP_PADAV);
10539 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
10540 Perl_croak(aTHX_ "Can't use an array as a reference");
10542 return newUNOP(OP_RV2AV, 0, scalar(o));
10546 Perl_newGVREF(pTHX_ I32 type, OP *o)
10548 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
10549 return newUNOP(OP_NULL, 0, o);
10550 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
10554 Perl_newHVREF(pTHX_ OP *o)
10558 PERL_ARGS_ASSERT_NEWHVREF;
10560 if (o->op_type == OP_PADANY) {
10561 OpTYPE_set(o, OP_PADHV);
10564 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
10565 Perl_croak(aTHX_ "Can't use a hash as a reference");
10567 return newUNOP(OP_RV2HV, 0, scalar(o));
10571 Perl_newCVREF(pTHX_ I32 flags, OP *o)
10573 if (o->op_type == OP_PADANY) {
10575 OpTYPE_set(o, OP_PADCV);
10577 return newUNOP(OP_RV2CV, flags, scalar(o));
10581 Perl_newSVREF(pTHX_ OP *o)
10585 PERL_ARGS_ASSERT_NEWSVREF;
10587 if (o->op_type == OP_PADANY) {
10588 OpTYPE_set(o, OP_PADSV);
10592 return newUNOP(OP_RV2SV, 0, scalar(o));
10595 /* Check routines. See the comments at the top of this file for details
10596 * on when these are called */
10599 Perl_ck_anoncode(pTHX_ OP *o)
10601 PERL_ARGS_ASSERT_CK_ANONCODE;
10603 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
10604 cSVOPo->op_sv = NULL;
10609 S_io_hints(pTHX_ OP *o)
10611 #if O_BINARY != 0 || O_TEXT != 0
10613 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
10615 SV **svp = hv_fetchs(table, "open_IN", FALSE);
10618 const char *d = SvPV_const(*svp, len);
10619 const I32 mode = mode_from_discipline(d, len);
10620 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
10622 if (mode & O_BINARY)
10623 o->op_private |= OPpOPEN_IN_RAW;
10627 o->op_private |= OPpOPEN_IN_CRLF;
10631 svp = hv_fetchs(table, "open_OUT", FALSE);
10634 const char *d = SvPV_const(*svp, len);
10635 const I32 mode = mode_from_discipline(d, len);
10636 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
10638 if (mode & O_BINARY)
10639 o->op_private |= OPpOPEN_OUT_RAW;
10643 o->op_private |= OPpOPEN_OUT_CRLF;
10648 PERL_UNUSED_CONTEXT;
10649 PERL_UNUSED_ARG(o);
10654 Perl_ck_backtick(pTHX_ OP *o)
10659 PERL_ARGS_ASSERT_CK_BACKTICK;
10660 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
10661 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
10662 && (gv = gv_override("readpipe",8)))
10664 /* detach rest of siblings from o and its first child */
10665 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10666 newop = S_new_entersubop(aTHX_ gv, sibl);
10668 else if (!(o->op_flags & OPf_KIDS))
10669 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
10674 S_io_hints(aTHX_ o);
10679 Perl_ck_bitop(pTHX_ OP *o)
10681 PERL_ARGS_ASSERT_CK_BITOP;
10683 o->op_private = (U8)(PL_hints & HINT_INTEGER);
10685 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
10686 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
10687 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
10688 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
10689 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
10690 "The bitwise feature is experimental");
10691 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
10692 && OP_IS_INFIX_BIT(o->op_type))
10694 const OP * const left = cBINOPo->op_first;
10695 const OP * const right = OpSIBLING(left);
10696 if ((OP_IS_NUMCOMPARE(left->op_type) &&
10697 (left->op_flags & OPf_PARENS) == 0) ||
10698 (OP_IS_NUMCOMPARE(right->op_type) &&
10699 (right->op_flags & OPf_PARENS) == 0))
10700 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
10701 "Possible precedence problem on bitwise %s operator",
10702 o->op_type == OP_BIT_OR
10703 ||o->op_type == OP_NBIT_OR ? "|"
10704 : o->op_type == OP_BIT_AND
10705 ||o->op_type == OP_NBIT_AND ? "&"
10706 : o->op_type == OP_BIT_XOR
10707 ||o->op_type == OP_NBIT_XOR ? "^"
10708 : o->op_type == OP_SBIT_OR ? "|."
10709 : o->op_type == OP_SBIT_AND ? "&." : "^."
10715 PERL_STATIC_INLINE bool
10716 is_dollar_bracket(pTHX_ const OP * const o)
10719 PERL_UNUSED_CONTEXT;
10720 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
10721 && (kid = cUNOPx(o)->op_first)
10722 && kid->op_type == OP_GV
10723 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
10726 /* for lt, gt, le, ge, eq, ne and their i_ variants */
10729 Perl_ck_cmp(pTHX_ OP *o)
10735 OP *indexop, *constop, *start;
10739 PERL_ARGS_ASSERT_CK_CMP;
10741 is_eq = ( o->op_type == OP_EQ
10742 || o->op_type == OP_NE
10743 || o->op_type == OP_I_EQ
10744 || o->op_type == OP_I_NE);
10746 if (!is_eq && ckWARN(WARN_SYNTAX)) {
10747 const OP *kid = cUNOPo->op_first;
10750 ( is_dollar_bracket(aTHX_ kid)
10751 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
10753 || ( kid->op_type == OP_CONST
10754 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
10758 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10759 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
10762 /* convert (index(...) == -1) and variations into
10763 * (r)index/BOOL(,NEG)
10768 indexop = cUNOPo->op_first;
10769 constop = OpSIBLING(indexop);
10771 if (indexop->op_type == OP_CONST) {
10773 indexop = OpSIBLING(constop);
10778 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
10781 /* ($lex = index(....)) == -1 */
10782 if (indexop->op_private & OPpTARGET_MY)
10785 if (constop->op_type != OP_CONST)
10788 sv = cSVOPx_sv(constop);
10789 if (!(sv && SvIOK_notUV(sv)))
10793 if (iv != -1 && iv != 0)
10797 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
10798 if (!(iv0 ^ reverse))
10802 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
10807 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
10808 if (!(iv0 ^ reverse))
10812 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
10817 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
10823 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
10829 indexop->op_flags &= ~OPf_PARENS;
10830 indexop->op_flags |= (o->op_flags & OPf_PARENS);
10831 indexop->op_private |= OPpTRUEBOOL;
10833 indexop->op_private |= OPpINDEX_BOOLNEG;
10834 /* cut out the index op and free the eq,const ops */
10835 (void)op_sibling_splice(o, start, 1, NULL);
10843 Perl_ck_concat(pTHX_ OP *o)
10845 const OP * const kid = cUNOPo->op_first;
10847 PERL_ARGS_ASSERT_CK_CONCAT;
10848 PERL_UNUSED_CONTEXT;
10850 /* reuse the padtmp returned by the concat child */
10851 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
10852 !(kUNOP->op_first->op_flags & OPf_MOD))
10854 o->op_flags |= OPf_STACKED;
10855 o->op_private |= OPpCONCAT_NESTED;
10861 Perl_ck_spair(pTHX_ OP *o)
10865 PERL_ARGS_ASSERT_CK_SPAIR;
10867 if (o->op_flags & OPf_KIDS) {
10871 const OPCODE type = o->op_type;
10872 o = modkids(ck_fun(o), type);
10873 kid = cUNOPo->op_first;
10874 kidkid = kUNOP->op_first;
10875 newop = OpSIBLING(kidkid);
10877 const OPCODE type = newop->op_type;
10878 if (OpHAS_SIBLING(newop))
10880 if (o->op_type == OP_REFGEN
10881 && ( type == OP_RV2CV
10882 || ( !(newop->op_flags & OPf_PARENS)
10883 && ( type == OP_RV2AV || type == OP_PADAV
10884 || type == OP_RV2HV || type == OP_PADHV))))
10885 NOOP; /* OK (allow srefgen for \@a and \%h) */
10886 else if (OP_GIMME(newop,0) != G_SCALAR)
10889 /* excise first sibling */
10890 op_sibling_splice(kid, NULL, 1, NULL);
10893 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
10894 * and OP_CHOMP into OP_SCHOMP */
10895 o->op_ppaddr = PL_ppaddr[++o->op_type];
10900 Perl_ck_delete(pTHX_ OP *o)
10902 PERL_ARGS_ASSERT_CK_DELETE;
10906 if (o->op_flags & OPf_KIDS) {
10907 OP * const kid = cUNOPo->op_first;
10908 switch (kid->op_type) {
10910 o->op_flags |= OPf_SPECIAL;
10913 o->op_private |= OPpSLICE;
10916 o->op_flags |= OPf_SPECIAL;
10921 o->op_flags |= OPf_SPECIAL;
10924 o->op_private |= OPpKVSLICE;
10927 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
10928 "element or slice");
10930 if (kid->op_private & OPpLVAL_INTRO)
10931 o->op_private |= OPpLVAL_INTRO;
10938 Perl_ck_eof(pTHX_ OP *o)
10940 PERL_ARGS_ASSERT_CK_EOF;
10942 if (o->op_flags & OPf_KIDS) {
10944 if (cLISTOPo->op_first->op_type == OP_STUB) {
10946 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
10951 kid = cLISTOPo->op_first;
10952 if (kid->op_type == OP_RV2GV)
10953 kid->op_private |= OPpALLOW_FAKE;
10960 Perl_ck_eval(pTHX_ OP *o)
10964 PERL_ARGS_ASSERT_CK_EVAL;
10966 PL_hints |= HINT_BLOCK_SCOPE;
10967 if (o->op_flags & OPf_KIDS) {
10968 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10971 if (o->op_type == OP_ENTERTRY) {
10974 /* cut whole sibling chain free from o */
10975 op_sibling_splice(o, NULL, -1, NULL);
10978 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
10980 /* establish postfix order */
10981 enter->op_next = (OP*)enter;
10983 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
10984 OpTYPE_set(o, OP_LEAVETRY);
10985 enter->op_other = o;
10990 S_set_haseval(aTHX);
10994 const U8 priv = o->op_private;
10996 /* the newUNOP will recursively call ck_eval(), which will handle
10997 * all the stuff at the end of this function, like adding
11000 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11002 o->op_targ = (PADOFFSET)PL_hints;
11003 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11004 if ((PL_hints & HINT_LOCALIZE_HH) != 0
11005 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11006 /* Store a copy of %^H that pp_entereval can pick up. */
11007 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11008 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11009 /* append hhop to only child */
11010 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11012 o->op_private |= OPpEVAL_HAS_HH;
11014 if (!(o->op_private & OPpEVAL_BYTES)
11015 && FEATURE_UNIEVAL_IS_ENABLED)
11016 o->op_private |= OPpEVAL_UNICODE;
11021 Perl_ck_exec(pTHX_ OP *o)
11023 PERL_ARGS_ASSERT_CK_EXEC;
11025 if (o->op_flags & OPf_STACKED) {
11028 kid = OpSIBLING(cUNOPo->op_first);
11029 if (kid->op_type == OP_RV2GV)
11038 Perl_ck_exists(pTHX_ OP *o)
11040 PERL_ARGS_ASSERT_CK_EXISTS;
11043 if (o->op_flags & OPf_KIDS) {
11044 OP * const kid = cUNOPo->op_first;
11045 if (kid->op_type == OP_ENTERSUB) {
11046 (void) ref(kid, o->op_type);
11047 if (kid->op_type != OP_RV2CV
11048 && !(PL_parser && PL_parser->error_count))
11050 "exists argument is not a subroutine name");
11051 o->op_private |= OPpEXISTS_SUB;
11053 else if (kid->op_type == OP_AELEM)
11054 o->op_flags |= OPf_SPECIAL;
11055 else if (kid->op_type != OP_HELEM)
11056 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11057 "element or a subroutine");
11064 Perl_ck_rvconst(pTHX_ OP *o)
11067 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11069 PERL_ARGS_ASSERT_CK_RVCONST;
11071 if (o->op_type == OP_RV2HV)
11072 /* rv2hv steals the bottom bit for its own uses */
11073 o->op_private &= ~OPpARG1_MASK;
11075 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11077 if (kid->op_type == OP_CONST) {
11080 SV * const kidsv = kid->op_sv;
11082 /* Is it a constant from cv_const_sv()? */
11083 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11086 if (SvTYPE(kidsv) == SVt_PVAV) return o;
11087 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11088 const char *badthing;
11089 switch (o->op_type) {
11091 badthing = "a SCALAR";
11094 badthing = "an ARRAY";
11097 badthing = "a HASH";
11105 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11106 SVfARG(kidsv), badthing);
11109 * This is a little tricky. We only want to add the symbol if we
11110 * didn't add it in the lexer. Otherwise we get duplicate strict
11111 * warnings. But if we didn't add it in the lexer, we must at
11112 * least pretend like we wanted to add it even if it existed before,
11113 * or we get possible typo warnings. OPpCONST_ENTERED says
11114 * whether the lexer already added THIS instance of this symbol.
11116 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11117 gv = gv_fetchsv(kidsv,
11118 o->op_type == OP_RV2CV
11119 && o->op_private & OPpMAY_RETURN_CONSTANT
11121 : iscv | !(kid->op_private & OPpCONST_ENTERED),
11124 : o->op_type == OP_RV2SV
11126 : o->op_type == OP_RV2AV
11128 : o->op_type == OP_RV2HV
11135 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11136 && SvTYPE(SvRV(gv)) != SVt_PVCV)
11137 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11139 OpTYPE_set(kid, OP_GV);
11140 SvREFCNT_dec(kid->op_sv);
11141 #ifdef USE_ITHREADS
11142 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11143 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11144 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11145 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11146 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11148 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11150 kid->op_private = 0;
11151 /* FAKE globs in the symbol table cause weird bugs (#77810) */
11159 Perl_ck_ftst(pTHX_ OP *o)
11162 const I32 type = o->op_type;
11164 PERL_ARGS_ASSERT_CK_FTST;
11166 if (o->op_flags & OPf_REF) {
11169 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11170 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11171 const OPCODE kidtype = kid->op_type;
11173 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11174 && !kid->op_folded) {
11175 OP * const newop = newGVOP(type, OPf_REF,
11176 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11181 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11182 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11184 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11185 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11186 array_passed_to_stat, name);
11189 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11190 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11193 scalar((OP *) kid);
11194 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11195 o->op_private |= OPpFT_ACCESS;
11196 if (type != OP_STAT && type != OP_LSTAT
11197 && PL_check[kidtype] == Perl_ck_ftst
11198 && kidtype != OP_STAT && kidtype != OP_LSTAT
11200 o->op_private |= OPpFT_STACKED;
11201 kid->op_private |= OPpFT_STACKING;
11202 if (kidtype == OP_FTTTY && (
11203 !(kid->op_private & OPpFT_STACKED)
11204 || kid->op_private & OPpFT_AFTER_t
11206 o->op_private |= OPpFT_AFTER_t;
11211 if (type == OP_FTTTY)
11212 o = newGVOP(type, OPf_REF, PL_stdingv);
11214 o = newUNOP(type, 0, newDEFSVOP());
11220 Perl_ck_fun(pTHX_ OP *o)
11222 const int type = o->op_type;
11223 I32 oa = PL_opargs[type] >> OASHIFT;
11225 PERL_ARGS_ASSERT_CK_FUN;
11227 if (o->op_flags & OPf_STACKED) {
11228 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11229 oa &= ~OA_OPTIONAL;
11231 return no_fh_allowed(o);
11234 if (o->op_flags & OPf_KIDS) {
11235 OP *prev_kid = NULL;
11236 OP *kid = cLISTOPo->op_first;
11238 bool seen_optional = FALSE;
11240 if (kid->op_type == OP_PUSHMARK ||
11241 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11244 kid = OpSIBLING(kid);
11246 if (kid && kid->op_type == OP_COREARGS) {
11247 bool optional = FALSE;
11250 if (oa & OA_OPTIONAL) optional = TRUE;
11253 if (optional) o->op_private |= numargs;
11258 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11259 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11260 kid = newDEFSVOP();
11261 /* append kid to chain */
11262 op_sibling_splice(o, prev_kid, 0, kid);
11264 seen_optional = TRUE;
11271 /* list seen where single (scalar) arg expected? */
11272 if (numargs == 1 && !(oa >> 4)
11273 && kid->op_type == OP_LIST && type != OP_SCALAR)
11275 return too_many_arguments_pv(o,PL_op_desc[type], 0);
11277 if (type != OP_DELETE) scalar(kid);
11288 if ((type == OP_PUSH || type == OP_UNSHIFT)
11289 && !OpHAS_SIBLING(kid))
11290 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11291 "Useless use of %s with no values",
11294 if (kid->op_type == OP_CONST
11295 && ( !SvROK(cSVOPx_sv(kid))
11296 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
11298 bad_type_pv(numargs, "array", o, kid);
11299 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11300 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11301 PL_op_desc[type]), 0);
11304 op_lvalue(kid, type);
11308 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11309 bad_type_pv(numargs, "hash", o, kid);
11310 op_lvalue(kid, type);
11314 /* replace kid with newop in chain */
11316 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11317 newop->op_next = newop;
11322 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11323 if (kid->op_type == OP_CONST &&
11324 (kid->op_private & OPpCONST_BARE))
11326 OP * const newop = newGVOP(OP_GV, 0,
11327 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11328 /* replace kid with newop in chain */
11329 op_sibling_splice(o, prev_kid, 1, newop);
11333 else if (kid->op_type == OP_READLINE) {
11334 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11335 bad_type_pv(numargs, "HANDLE", o, kid);
11338 I32 flags = OPf_SPECIAL;
11340 PADOFFSET targ = 0;
11342 /* is this op a FH constructor? */
11343 if (is_handle_constructor(o,numargs)) {
11344 const char *name = NULL;
11347 bool want_dollar = TRUE;
11350 /* Set a flag to tell rv2gv to vivify
11351 * need to "prove" flag does not mean something
11352 * else already - NI-S 1999/05/07
11355 if (kid->op_type == OP_PADSV) {
11357 = PAD_COMPNAME_SV(kid->op_targ);
11358 name = PadnamePV (pn);
11359 len = PadnameLEN(pn);
11360 name_utf8 = PadnameUTF8(pn);
11362 else if (kid->op_type == OP_RV2SV
11363 && kUNOP->op_first->op_type == OP_GV)
11365 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11367 len = GvNAMELEN(gv);
11368 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11370 else if (kid->op_type == OP_AELEM
11371 || kid->op_type == OP_HELEM)
11374 OP *op = ((BINOP*)kid)->op_first;
11378 const char * const a =
11379 kid->op_type == OP_AELEM ?
11381 if (((op->op_type == OP_RV2AV) ||
11382 (op->op_type == OP_RV2HV)) &&
11383 (firstop = ((UNOP*)op)->op_first) &&
11384 (firstop->op_type == OP_GV)) {
11385 /* packagevar $a[] or $h{} */
11386 GV * const gv = cGVOPx_gv(firstop);
11389 Perl_newSVpvf(aTHX_
11394 else if (op->op_type == OP_PADAV
11395 || op->op_type == OP_PADHV) {
11396 /* lexicalvar $a[] or $h{} */
11397 const char * const padname =
11398 PAD_COMPNAME_PV(op->op_targ);
11401 Perl_newSVpvf(aTHX_
11407 name = SvPV_const(tmpstr, len);
11408 name_utf8 = SvUTF8(tmpstr);
11409 sv_2mortal(tmpstr);
11413 name = "__ANONIO__";
11415 want_dollar = FALSE;
11417 op_lvalue(kid, type);
11421 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11422 namesv = PAD_SVl(targ);
11423 if (want_dollar && *name != '$')
11424 sv_setpvs(namesv, "$");
11427 sv_catpvn(namesv, name, len);
11428 if ( name_utf8 ) SvUTF8_on(namesv);
11432 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11434 kid->op_targ = targ;
11435 kid->op_private |= priv;
11441 if ((type == OP_UNDEF || type == OP_POS)
11442 && numargs == 1 && !(oa >> 4)
11443 && kid->op_type == OP_LIST)
11444 return too_many_arguments_pv(o,PL_op_desc[type], 0);
11445 op_lvalue(scalar(kid), type);
11450 kid = OpSIBLING(kid);
11452 /* FIXME - should the numargs or-ing move after the too many
11453 * arguments check? */
11454 o->op_private |= numargs;
11456 return too_many_arguments_pv(o,OP_DESC(o), 0);
11459 else if (PL_opargs[type] & OA_DEFGV) {
11460 /* Ordering of these two is important to keep f_map.t passing. */
11462 return newUNOP(type, 0, newDEFSVOP());
11466 while (oa & OA_OPTIONAL)
11468 if (oa && oa != OA_LIST)
11469 return too_few_arguments_pv(o,OP_DESC(o), 0);
11475 Perl_ck_glob(pTHX_ OP *o)
11479 PERL_ARGS_ASSERT_CK_GLOB;
11482 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11483 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11485 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11489 * \ null - const(wildcard)
11494 * \ mark - glob - rv2cv
11495 * | \ gv(CORE::GLOBAL::glob)
11497 * \ null - const(wildcard)
11499 o->op_flags |= OPf_SPECIAL;
11500 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11501 o = S_new_entersubop(aTHX_ gv, o);
11502 o = newUNOP(OP_NULL, 0, o);
11503 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11506 else o->op_flags &= ~OPf_SPECIAL;
11507 #if !defined(PERL_EXTERNAL_GLOB)
11508 if (!PL_globhook) {
11510 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11511 newSVpvs("File::Glob"), NULL, NULL, NULL);
11514 #endif /* !PERL_EXTERNAL_GLOB */
11515 gv = (GV *)newSV(0);
11516 gv_init(gv, 0, "", 0, 0);
11518 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11519 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11525 Perl_ck_grep(pTHX_ OP *o)
11529 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
11531 PERL_ARGS_ASSERT_CK_GREP;
11533 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
11535 if (o->op_flags & OPf_STACKED) {
11536 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
11537 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
11538 return no_fh_allowed(o);
11539 o->op_flags &= ~OPf_STACKED;
11541 kid = OpSIBLING(cLISTOPo->op_first);
11542 if (type == OP_MAPWHILE)
11547 if (PL_parser && PL_parser->error_count)
11549 kid = OpSIBLING(cLISTOPo->op_first);
11550 if (kid->op_type != OP_NULL)
11551 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
11552 kid = kUNOP->op_first;
11554 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
11555 kid->op_next = (OP*)gwop;
11556 o->op_private = gwop->op_private = 0;
11557 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
11559 kid = OpSIBLING(cLISTOPo->op_first);
11560 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
11561 op_lvalue(kid, OP_GREPSTART);
11567 Perl_ck_index(pTHX_ OP *o)
11569 PERL_ARGS_ASSERT_CK_INDEX;
11571 if (o->op_flags & OPf_KIDS) {
11572 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
11574 kid = OpSIBLING(kid); /* get past "big" */
11575 if (kid && kid->op_type == OP_CONST) {
11576 const bool save_taint = TAINT_get;
11577 SV *sv = kSVOP->op_sv;
11578 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
11579 && SvOK(sv) && !SvROK(sv))
11582 sv_copypv(sv, kSVOP->op_sv);
11583 SvREFCNT_dec_NN(kSVOP->op_sv);
11586 if (SvOK(sv)) fbm_compile(sv, 0);
11587 TAINT_set(save_taint);
11588 #ifdef NO_TAINT_SUPPORT
11589 PERL_UNUSED_VAR(save_taint);
11597 Perl_ck_lfun(pTHX_ OP *o)
11599 const OPCODE type = o->op_type;
11601 PERL_ARGS_ASSERT_CK_LFUN;
11603 return modkids(ck_fun(o), type);
11607 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
11609 PERL_ARGS_ASSERT_CK_DEFINED;
11611 if ((o->op_flags & OPf_KIDS)) {
11612 switch (cUNOPo->op_first->op_type) {
11615 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
11616 " (Maybe you should just omit the defined()?)");
11617 NOT_REACHED; /* NOTREACHED */
11621 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
11622 " (Maybe you should just omit the defined()?)");
11623 NOT_REACHED; /* NOTREACHED */
11634 Perl_ck_readline(pTHX_ OP *o)
11636 PERL_ARGS_ASSERT_CK_READLINE;
11638 if (o->op_flags & OPf_KIDS) {
11639 OP *kid = cLISTOPo->op_first;
11640 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11644 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
11652 Perl_ck_rfun(pTHX_ OP *o)
11654 const OPCODE type = o->op_type;
11656 PERL_ARGS_ASSERT_CK_RFUN;
11658 return refkids(ck_fun(o), type);
11662 Perl_ck_listiob(pTHX_ OP *o)
11666 PERL_ARGS_ASSERT_CK_LISTIOB;
11668 kid = cLISTOPo->op_first;
11670 o = force_list(o, 1);
11671 kid = cLISTOPo->op_first;
11673 if (kid->op_type == OP_PUSHMARK)
11674 kid = OpSIBLING(kid);
11675 if (kid && o->op_flags & OPf_STACKED)
11676 kid = OpSIBLING(kid);
11677 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
11678 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
11679 && !kid->op_folded) {
11680 o->op_flags |= OPf_STACKED; /* make it a filehandle */
11682 /* replace old const op with new OP_RV2GV parent */
11683 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
11684 OP_RV2GV, OPf_REF);
11685 kid = OpSIBLING(kid);
11690 op_append_elem(o->op_type, o, newDEFSVOP());
11692 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
11693 return listkids(o);
11697 Perl_ck_smartmatch(pTHX_ OP *o)
11700 PERL_ARGS_ASSERT_CK_SMARTMATCH;
11701 if (0 == (o->op_flags & OPf_SPECIAL)) {
11702 OP *first = cBINOPo->op_first;
11703 OP *second = OpSIBLING(first);
11705 /* Implicitly take a reference to an array or hash */
11707 /* remove the original two siblings, then add back the
11708 * (possibly different) first and second sibs.
11710 op_sibling_splice(o, NULL, 1, NULL);
11711 op_sibling_splice(o, NULL, 1, NULL);
11712 first = ref_array_or_hash(first);
11713 second = ref_array_or_hash(second);
11714 op_sibling_splice(o, NULL, 0, second);
11715 op_sibling_splice(o, NULL, 0, first);
11717 /* Implicitly take a reference to a regular expression */
11718 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
11719 OpTYPE_set(first, OP_QR);
11721 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
11722 OpTYPE_set(second, OP_QR);
11731 S_maybe_targlex(pTHX_ OP *o)
11733 OP * const kid = cLISTOPo->op_first;
11734 /* has a disposable target? */
11735 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
11736 && !(kid->op_flags & OPf_STACKED)
11737 /* Cannot steal the second time! */
11738 && !(kid->op_private & OPpTARGET_MY)
11741 OP * const kkid = OpSIBLING(kid);
11743 /* Can just relocate the target. */
11744 if (kkid && kkid->op_type == OP_PADSV
11745 && (!(kkid->op_private & OPpLVAL_INTRO)
11746 || kkid->op_private & OPpPAD_STATE))
11748 kid->op_targ = kkid->op_targ;
11750 /* Now we do not need PADSV and SASSIGN.
11751 * Detach kid and free the rest. */
11752 op_sibling_splice(o, NULL, 1, NULL);
11754 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
11762 Perl_ck_sassign(pTHX_ OP *o)
11765 OP * const kid = cBINOPo->op_first;
11767 PERL_ARGS_ASSERT_CK_SASSIGN;
11769 if (OpHAS_SIBLING(kid)) {
11770 OP *kkid = OpSIBLING(kid);
11771 /* For state variable assignment with attributes, kkid is a list op
11772 whose op_last is a padsv. */
11773 if ((kkid->op_type == OP_PADSV ||
11774 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
11775 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
11778 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
11779 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
11780 return S_newONCEOP(aTHX_ o, kkid);
11783 return S_maybe_targlex(aTHX_ o);
11788 Perl_ck_match(pTHX_ OP *o)
11790 PERL_UNUSED_CONTEXT;
11791 PERL_ARGS_ASSERT_CK_MATCH;
11797 Perl_ck_method(pTHX_ OP *o)
11799 SV *sv, *methsv, *rclass;
11800 const char* method;
11803 STRLEN len, nsplit = 0, i;
11805 OP * const kid = cUNOPo->op_first;
11807 PERL_ARGS_ASSERT_CK_METHOD;
11808 if (kid->op_type != OP_CONST) return o;
11812 /* replace ' with :: */
11813 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
11814 SvEND(sv) - SvPVX(sv) )))
11817 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
11820 method = SvPVX_const(sv);
11822 utf8 = SvUTF8(sv) ? -1 : 1;
11824 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
11829 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
11831 if (!nsplit) { /* $proto->method() */
11833 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
11836 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
11838 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
11841 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
11842 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
11843 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
11844 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
11846 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
11847 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
11849 #ifdef USE_ITHREADS
11850 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
11852 cMETHOPx(new_op)->op_rclass_sv = rclass;
11859 Perl_ck_null(pTHX_ OP *o)
11861 PERL_ARGS_ASSERT_CK_NULL;
11862 PERL_UNUSED_CONTEXT;
11867 Perl_ck_open(pTHX_ OP *o)
11869 PERL_ARGS_ASSERT_CK_OPEN;
11871 S_io_hints(aTHX_ o);
11873 /* In case of three-arg dup open remove strictness
11874 * from the last arg if it is a bareword. */
11875 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
11876 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
11880 if ((last->op_type == OP_CONST) && /* The bareword. */
11881 (last->op_private & OPpCONST_BARE) &&
11882 (last->op_private & OPpCONST_STRICT) &&
11883 (oa = OpSIBLING(first)) && /* The fh. */
11884 (oa = OpSIBLING(oa)) && /* The mode. */
11885 (oa->op_type == OP_CONST) &&
11886 SvPOK(((SVOP*)oa)->op_sv) &&
11887 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
11888 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
11889 (last == OpSIBLING(oa))) /* The bareword. */
11890 last->op_private &= ~OPpCONST_STRICT;
11896 Perl_ck_prototype(pTHX_ OP *o)
11898 PERL_ARGS_ASSERT_CK_PROTOTYPE;
11899 if (!(o->op_flags & OPf_KIDS)) {
11901 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
11907 Perl_ck_refassign(pTHX_ OP *o)
11909 OP * const right = cLISTOPo->op_first;
11910 OP * const left = OpSIBLING(right);
11911 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
11914 PERL_ARGS_ASSERT_CK_REFASSIGN;
11916 assert (left->op_type == OP_SREFGEN);
11919 /* we use OPpPAD_STATE in refassign to mean either of those things,
11920 * and the code assumes the two flags occupy the same bit position
11921 * in the various ops below */
11922 assert(OPpPAD_STATE == OPpOUR_INTRO);
11924 switch (varop->op_type) {
11926 o->op_private |= OPpLVREF_AV;
11929 o->op_private |= OPpLVREF_HV;
11933 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
11934 o->op_targ = varop->op_targ;
11935 varop->op_targ = 0;
11936 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
11940 o->op_private |= OPpLVREF_AV;
11942 NOT_REACHED; /* NOTREACHED */
11944 o->op_private |= OPpLVREF_HV;
11948 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
11949 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
11951 /* Point varop to its GV kid, detached. */
11952 varop = op_sibling_splice(varop, NULL, -1, NULL);
11956 OP * const kidparent =
11957 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
11958 OP * const kid = cUNOPx(kidparent)->op_first;
11959 o->op_private |= OPpLVREF_CV;
11960 if (kid->op_type == OP_GV) {
11962 goto detach_and_stack;
11964 if (kid->op_type != OP_PADCV) goto bad;
11965 o->op_targ = kid->op_targ;
11971 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
11972 o->op_private |= OPpLVREF_ELEM;
11975 /* Detach varop. */
11976 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
11980 /* diag_listed_as: Can't modify reference to %s in %s assignment */
11981 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
11986 if (!FEATURE_REFALIASING_IS_ENABLED)
11988 "Experimental aliasing via reference not enabled");
11989 Perl_ck_warner_d(aTHX_
11990 packWARN(WARN_EXPERIMENTAL__REFALIASING),
11991 "Aliasing via reference is experimental");
11993 o->op_flags |= OPf_STACKED;
11994 op_sibling_splice(o, right, 1, varop);
11997 o->op_flags &=~ OPf_STACKED;
11998 op_sibling_splice(o, right, 1, NULL);
12005 Perl_ck_repeat(pTHX_ OP *o)
12007 PERL_ARGS_ASSERT_CK_REPEAT;
12009 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12011 o->op_private |= OPpREPEAT_DOLIST;
12012 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12013 kids = force_list(kids, 1); /* promote it to a list */
12014 op_sibling_splice(o, NULL, 0, kids); /* and add back */
12022 Perl_ck_require(pTHX_ OP *o)
12026 PERL_ARGS_ASSERT_CK_REQUIRE;
12028 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
12029 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12033 if (kid->op_type == OP_CONST) {
12034 SV * const sv = kid->op_sv;
12035 U32 const was_readonly = SvREADONLY(sv);
12036 if (kid->op_private & OPpCONST_BARE) {
12041 if (was_readonly) {
12042 SvREADONLY_off(sv);
12044 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12049 /* treat ::foo::bar as foo::bar */
12050 if (len >= 2 && s[0] == ':' && s[1] == ':')
12051 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12053 DIE(aTHX_ "Bareword in require maps to empty filename");
12055 for (; s < end; s++) {
12056 if (*s == ':' && s[1] == ':') {
12058 Move(s+2, s+1, end - s - 1, char);
12062 SvEND_set(sv, end);
12063 sv_catpvs(sv, ".pm");
12064 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12065 hek = share_hek(SvPVX(sv),
12066 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12068 sv_sethek(sv, hek);
12070 SvFLAGS(sv) |= was_readonly;
12072 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12075 if (SvREFCNT(sv) > 1) {
12076 kid->op_sv = newSVpvn_share(
12077 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12078 SvREFCNT_dec_NN(sv);
12083 if (was_readonly) SvREADONLY_off(sv);
12084 PERL_HASH(hash, s, len);
12086 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12088 sv_sethek(sv, hek);
12090 SvFLAGS(sv) |= was_readonly;
12096 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12097 /* handle override, if any */
12098 && (gv = gv_override("require", 7))) {
12100 if (o->op_flags & OPf_KIDS) {
12101 kid = cUNOPo->op_first;
12102 op_sibling_splice(o, NULL, -1, NULL);
12105 kid = newDEFSVOP();
12108 newop = S_new_entersubop(aTHX_ gv, kid);
12116 Perl_ck_return(pTHX_ OP *o)
12120 PERL_ARGS_ASSERT_CK_RETURN;
12122 kid = OpSIBLING(cLISTOPo->op_first);
12123 if (PL_compcv && CvLVALUE(PL_compcv)) {
12124 for (; kid; kid = OpSIBLING(kid))
12125 op_lvalue(kid, OP_LEAVESUBLV);
12132 Perl_ck_select(pTHX_ OP *o)
12137 PERL_ARGS_ASSERT_CK_SELECT;
12139 if (o->op_flags & OPf_KIDS) {
12140 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12141 if (kid && OpHAS_SIBLING(kid)) {
12142 OpTYPE_set(o, OP_SSELECT);
12144 return fold_constants(op_integerize(op_std_init(o)));
12148 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12149 if (kid && kid->op_type == OP_RV2GV)
12150 kid->op_private &= ~HINT_STRICT_REFS;
12155 Perl_ck_shift(pTHX_ OP *o)
12157 const I32 type = o->op_type;
12159 PERL_ARGS_ASSERT_CK_SHIFT;
12161 if (!(o->op_flags & OPf_KIDS)) {
12164 if (!CvUNIQUE(PL_compcv)) {
12165 o->op_flags |= OPf_SPECIAL;
12169 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12171 return newUNOP(type, 0, scalar(argop));
12173 return scalar(ck_fun(o));
12177 Perl_ck_sort(pTHX_ OP *o)
12181 HV * const hinthv =
12182 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12185 PERL_ARGS_ASSERT_CK_SORT;
12188 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12190 const I32 sorthints = (I32)SvIV(*svp);
12191 if ((sorthints & HINT_SORT_STABLE) != 0)
12192 o->op_private |= OPpSORT_STABLE;
12193 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12194 o->op_private |= OPpSORT_UNSTABLE;
12198 if (o->op_flags & OPf_STACKED)
12200 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12202 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
12203 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
12205 /* if the first arg is a code block, process it and mark sort as
12207 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12209 if (kid->op_type == OP_LEAVE)
12210 op_null(kid); /* wipe out leave */
12211 /* Prevent execution from escaping out of the sort block. */
12214 /* provide scalar context for comparison function/block */
12215 kid = scalar(firstkid);
12216 kid->op_next = kid;
12217 o->op_flags |= OPf_SPECIAL;
12219 else if (kid->op_type == OP_CONST
12220 && kid->op_private & OPpCONST_BARE) {
12224 const char * const name = SvPV(kSVOP_sv, len);
12226 assert (len < 256);
12227 Copy(name, tmpbuf+1, len, char);
12228 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12229 if (off != NOT_IN_PAD) {
12230 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12232 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12233 sv_catpvs(fq, "::");
12234 sv_catsv(fq, kSVOP_sv);
12235 SvREFCNT_dec_NN(kSVOP_sv);
12239 OP * const padop = newOP(OP_PADCV, 0);
12240 padop->op_targ = off;
12241 /* replace the const op with the pad op */
12242 op_sibling_splice(firstkid, NULL, 1, padop);
12248 firstkid = OpSIBLING(firstkid);
12251 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12252 /* provide list context for arguments */
12255 op_lvalue(kid, OP_GREPSTART);
12261 /* for sort { X } ..., where X is one of
12262 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12263 * elide the second child of the sort (the one containing X),
12264 * and set these flags as appropriate
12268 * Also, check and warn on lexical $a, $b.
12272 S_simplify_sort(pTHX_ OP *o)
12274 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12278 const char *gvname;
12281 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12283 kid = kUNOP->op_first; /* get past null */
12284 if (!(have_scopeop = kid->op_type == OP_SCOPE)
12285 && kid->op_type != OP_LEAVE)
12287 kid = kLISTOP->op_last; /* get past scope */
12288 switch(kid->op_type) {
12292 if (!have_scopeop) goto padkids;
12297 k = kid; /* remember this node*/
12298 if (kBINOP->op_first->op_type != OP_RV2SV
12299 || kBINOP->op_last ->op_type != OP_RV2SV)
12302 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12303 then used in a comparison. This catches most, but not
12304 all cases. For instance, it catches
12305 sort { my($a); $a <=> $b }
12307 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12308 (although why you'd do that is anyone's guess).
12312 if (!ckWARN(WARN_SYNTAX)) return;
12313 kid = kBINOP->op_first;
12315 if (kid->op_type == OP_PADSV) {
12316 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12317 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12318 && ( PadnamePV(name)[1] == 'a'
12319 || PadnamePV(name)[1] == 'b' ))
12320 /* diag_listed_as: "my %s" used in sort comparison */
12321 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12322 "\"%s %s\" used in sort comparison",
12323 PadnameIsSTATE(name)
12328 } while ((kid = OpSIBLING(kid)));
12331 kid = kBINOP->op_first; /* get past cmp */
12332 if (kUNOP->op_first->op_type != OP_GV)
12334 kid = kUNOP->op_first; /* get past rv2sv */
12336 if (GvSTASH(gv) != PL_curstash)
12338 gvname = GvNAME(gv);
12339 if (*gvname == 'a' && gvname[1] == '\0')
12341 else if (*gvname == 'b' && gvname[1] == '\0')
12346 kid = k; /* back to cmp */
12347 /* already checked above that it is rv2sv */
12348 kid = kBINOP->op_last; /* down to 2nd arg */
12349 if (kUNOP->op_first->op_type != OP_GV)
12351 kid = kUNOP->op_first; /* get past rv2sv */
12353 if (GvSTASH(gv) != PL_curstash)
12355 gvname = GvNAME(gv);
12357 ? !(*gvname == 'a' && gvname[1] == '\0')
12358 : !(*gvname == 'b' && gvname[1] == '\0'))
12360 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12362 o->op_private |= OPpSORT_DESCEND;
12363 if (k->op_type == OP_NCMP)
12364 o->op_private |= OPpSORT_NUMERIC;
12365 if (k->op_type == OP_I_NCMP)
12366 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12367 kid = OpSIBLING(cLISTOPo->op_first);
12368 /* cut out and delete old block (second sibling) */
12369 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12374 Perl_ck_split(pTHX_ OP *o)
12380 PERL_ARGS_ASSERT_CK_SPLIT;
12382 assert(o->op_type == OP_LIST);
12384 if (o->op_flags & OPf_STACKED)
12385 return no_fh_allowed(o);
12387 kid = cLISTOPo->op_first;
12388 /* delete leading NULL node, then add a CONST if no other nodes */
12389 assert(kid->op_type == OP_NULL);
12390 op_sibling_splice(o, NULL, 1,
12391 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12393 kid = cLISTOPo->op_first;
12395 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12396 /* remove match expression, and replace with new optree with
12397 * a match op at its head */
12398 op_sibling_splice(o, NULL, 1, NULL);
12399 /* pmruntime will handle split " " behavior with flag==2 */
12400 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12401 op_sibling_splice(o, NULL, 0, kid);
12404 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12406 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12407 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12408 "Use of /g modifier is meaningless in split");
12411 /* eliminate the split op, and move the match op (plus any children)
12412 * into its place, then convert the match op into a split op. i.e.
12414 * SPLIT MATCH SPLIT(ex-MATCH)
12416 * MATCH - A - B - C => R - A - B - C => R - A - B - C
12422 * (R, if it exists, will be a regcomp op)
12425 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12426 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12427 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12428 OpTYPE_set(kid, OP_SPLIT);
12429 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
12430 kid->op_private = o->op_private;
12433 kid = sibs; /* kid is now the string arg of the split */
12436 kid = newDEFSVOP();
12437 op_append_elem(OP_SPLIT, o, kid);
12441 kid = OpSIBLING(kid);
12443 kid = newSVOP(OP_CONST, 0, newSViv(0));
12444 op_append_elem(OP_SPLIT, o, kid);
12445 o->op_private |= OPpSPLIT_IMPLIM;
12449 if (OpHAS_SIBLING(kid))
12450 return too_many_arguments_pv(o,OP_DESC(o), 0);
12456 Perl_ck_stringify(pTHX_ OP *o)
12458 OP * const kid = OpSIBLING(cUNOPo->op_first);
12459 PERL_ARGS_ASSERT_CK_STRINGIFY;
12460 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12461 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
12462 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
12463 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12465 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12473 Perl_ck_join(pTHX_ OP *o)
12475 OP * const kid = OpSIBLING(cLISTOPo->op_first);
12477 PERL_ARGS_ASSERT_CK_JOIN;
12479 if (kid && kid->op_type == OP_MATCH) {
12480 if (ckWARN(WARN_SYNTAX)) {
12481 const REGEXP *re = PM_GETRE(kPMOP);
12483 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12484 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12485 : newSVpvs_flags( "STRING", SVs_TEMP );
12486 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12487 "/%" SVf "/ should probably be written as \"%" SVf "\"",
12488 SVfARG(msg), SVfARG(msg));
12492 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12493 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12494 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12495 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12497 const OP * const bairn = OpSIBLING(kid); /* the list */
12498 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12499 && OP_GIMME(bairn,0) == G_SCALAR)
12501 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12502 op_sibling_splice(o, kid, 1, NULL));
12512 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12514 Examines an op, which is expected to identify a subroutine at runtime,
12515 and attempts to determine at compile time which subroutine it identifies.
12516 This is normally used during Perl compilation to determine whether
12517 a prototype can be applied to a function call. C<cvop> is the op
12518 being considered, normally an C<rv2cv> op. A pointer to the identified
12519 subroutine is returned, if it could be determined statically, and a null
12520 pointer is returned if it was not possible to determine statically.
12522 Currently, the subroutine can be identified statically if the RV that the
12523 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
12524 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
12525 suitable if the constant value must be an RV pointing to a CV. Details of
12526 this process may change in future versions of Perl. If the C<rv2cv> op
12527 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
12528 the subroutine statically: this flag is used to suppress compile-time
12529 magic on a subroutine call, forcing it to use default runtime behaviour.
12531 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
12532 of a GV reference is modified. If a GV was examined and its CV slot was
12533 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
12534 If the op is not optimised away, and the CV slot is later populated with
12535 a subroutine having a prototype, that flag eventually triggers the warning
12536 "called too early to check prototype".
12538 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
12539 of returning a pointer to the subroutine it returns a pointer to the
12540 GV giving the most appropriate name for the subroutine in this context.
12541 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
12542 (C<CvANON>) subroutine that is referenced through a GV it will be the
12543 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
12544 A null pointer is returned as usual if there is no statically-determinable
12550 /* shared by toke.c:yylex */
12552 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
12554 PADNAME *name = PAD_COMPNAME(off);
12555 CV *compcv = PL_compcv;
12556 while (PadnameOUTER(name)) {
12557 assert(PARENT_PAD_INDEX(name));
12558 compcv = CvOUTSIDE(compcv);
12559 name = PadlistNAMESARRAY(CvPADLIST(compcv))
12560 [off = PARENT_PAD_INDEX(name)];
12562 assert(!PadnameIsOUR(name));
12563 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
12564 return PadnamePROTOCV(name);
12566 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
12570 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
12575 PERL_ARGS_ASSERT_RV2CV_OP_CV;
12576 if (flags & ~RV2CVOPCV_FLAG_MASK)
12577 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
12578 if (cvop->op_type != OP_RV2CV)
12580 if (cvop->op_private & OPpENTERSUB_AMPER)
12582 if (!(cvop->op_flags & OPf_KIDS))
12584 rvop = cUNOPx(cvop)->op_first;
12585 switch (rvop->op_type) {
12587 gv = cGVOPx_gv(rvop);
12589 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
12590 cv = MUTABLE_CV(SvRV(gv));
12594 if (flags & RV2CVOPCV_RETURN_STUB)
12600 if (flags & RV2CVOPCV_MARK_EARLY)
12601 rvop->op_private |= OPpEARLY_CV;
12606 SV *rv = cSVOPx_sv(rvop);
12609 cv = (CV*)SvRV(rv);
12613 cv = find_lexical_cv(rvop->op_targ);
12618 } NOT_REACHED; /* NOTREACHED */
12620 if (SvTYPE((SV*)cv) != SVt_PVCV)
12622 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
12623 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
12627 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
12628 if (CvLEXICAL(cv) || CvNAMED(cv))
12630 if (!CvANON(cv) || !gv)
12640 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
12642 Performs the default fixup of the arguments part of an C<entersub>
12643 op tree. This consists of applying list context to each of the
12644 argument ops. This is the standard treatment used on a call marked
12645 with C<&>, or a method call, or a call through a subroutine reference,
12646 or any other call where the callee can't be identified at compile time,
12647 or a call where the callee has no prototype.
12653 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
12657 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
12659 aop = cUNOPx(entersubop)->op_first;
12660 if (!OpHAS_SIBLING(aop))
12661 aop = cUNOPx(aop)->op_first;
12662 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
12663 /* skip the extra attributes->import() call implicitly added in
12664 * something like foo(my $x : bar)
12666 if ( aop->op_type == OP_ENTERSUB
12667 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
12671 op_lvalue(aop, OP_ENTERSUB);
12677 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
12679 Performs the fixup of the arguments part of an C<entersub> op tree
12680 based on a subroutine prototype. This makes various modifications to
12681 the argument ops, from applying context up to inserting C<refgen> ops,
12682 and checking the number and syntactic types of arguments, as directed by
12683 the prototype. This is the standard treatment used on a subroutine call,
12684 not marked with C<&>, where the callee can be identified at compile time
12685 and has a prototype.
12687 C<protosv> supplies the subroutine prototype to be applied to the call.
12688 It may be a normal defined scalar, of which the string value will be used.
12689 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
12690 that has been cast to C<SV*>) which has a prototype. The prototype
12691 supplied, in whichever form, does not need to match the actual callee
12692 referenced by the op tree.
12694 If the argument ops disagree with the prototype, for example by having
12695 an unacceptable number of arguments, a valid op tree is returned anyway.
12696 The error is reflected in the parser state, normally resulting in a single
12697 exception at the top level of parsing which covers all the compilation
12698 errors that occurred. In the error message, the callee is referred to
12699 by the name defined by the C<namegv> parameter.
12705 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
12708 const char *proto, *proto_end;
12709 OP *aop, *prev, *cvop, *parent;
12712 I32 contextclass = 0;
12713 const char *e = NULL;
12714 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
12715 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
12716 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
12717 "flags=%lx", (unsigned long) SvFLAGS(protosv));
12718 if (SvTYPE(protosv) == SVt_PVCV)
12719 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
12720 else proto = SvPV(protosv, proto_len);
12721 proto = S_strip_spaces(aTHX_ proto, &proto_len);
12722 proto_end = proto + proto_len;
12723 parent = entersubop;
12724 aop = cUNOPx(entersubop)->op_first;
12725 if (!OpHAS_SIBLING(aop)) {
12727 aop = cUNOPx(aop)->op_first;
12730 aop = OpSIBLING(aop);
12731 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
12732 while (aop != cvop) {
12735 if (proto >= proto_end)
12737 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
12738 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
12739 SVfARG(namesv)), SvUTF8(namesv));
12749 /* _ must be at the end */
12750 if (proto[1] && !strchr(";@%", proto[1]))
12766 if ( o3->op_type != OP_UNDEF
12767 && (o3->op_type != OP_SREFGEN
12768 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
12770 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
12772 bad_type_gv(arg, namegv, o3,
12773 arg == 1 ? "block or sub {}" : "sub {}");
12776 /* '*' allows any scalar type, including bareword */
12779 if (o3->op_type == OP_RV2GV)
12780 goto wrapref; /* autoconvert GLOB -> GLOBref */
12781 else if (o3->op_type == OP_CONST)
12782 o3->op_private &= ~OPpCONST_STRICT;
12788 if (o3->op_type == OP_RV2AV ||
12789 o3->op_type == OP_PADAV ||
12790 o3->op_type == OP_RV2HV ||
12791 o3->op_type == OP_PADHV
12797 case '[': case ']':
12804 switch (*proto++) {
12806 if (contextclass++ == 0) {
12807 e = (char *) memchr(proto, ']', proto_end - proto);
12808 if (!e || e == proto)
12816 if (contextclass) {
12817 const char *p = proto;
12818 const char *const end = proto;
12820 while (*--p != '[')
12821 /* \[$] accepts any scalar lvalue */
12823 && Perl_op_lvalue_flags(aTHX_
12825 OP_READ, /* not entersub */
12828 bad_type_gv(arg, namegv, o3,
12829 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
12834 if (o3->op_type == OP_RV2GV)
12837 bad_type_gv(arg, namegv, o3, "symbol");
12840 if (o3->op_type == OP_ENTERSUB
12841 && !(o3->op_flags & OPf_STACKED))
12844 bad_type_gv(arg, namegv, o3, "subroutine");
12847 if (o3->op_type == OP_RV2SV ||
12848 o3->op_type == OP_PADSV ||
12849 o3->op_type == OP_HELEM ||
12850 o3->op_type == OP_AELEM)
12852 if (!contextclass) {
12853 /* \$ accepts any scalar lvalue */
12854 if (Perl_op_lvalue_flags(aTHX_
12856 OP_READ, /* not entersub */
12859 bad_type_gv(arg, namegv, o3, "scalar");
12863 if (o3->op_type == OP_RV2AV ||
12864 o3->op_type == OP_PADAV)
12866 o3->op_flags &=~ OPf_PARENS;
12870 bad_type_gv(arg, namegv, o3, "array");
12873 if (o3->op_type == OP_RV2HV ||
12874 o3->op_type == OP_PADHV)
12876 o3->op_flags &=~ OPf_PARENS;
12880 bad_type_gv(arg, namegv, o3, "hash");
12883 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
12885 if (contextclass && e) {
12890 default: goto oops;
12900 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
12901 SVfARG(cv_name((CV *)namegv, NULL, 0)),
12906 op_lvalue(aop, OP_ENTERSUB);
12908 aop = OpSIBLING(aop);
12910 if (aop == cvop && *proto == '_') {
12911 /* generate an access to $_ */
12912 op_sibling_splice(parent, prev, 0, newDEFSVOP());
12914 if (!optional && proto_end > proto &&
12915 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
12917 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
12918 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
12919 SVfARG(namesv)), SvUTF8(namesv));
12925 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
12927 Performs the fixup of the arguments part of an C<entersub> op tree either
12928 based on a subroutine prototype or using default list-context processing.
12929 This is the standard treatment used on a subroutine call, not marked
12930 with C<&>, where the callee can be identified at compile time.
12932 C<protosv> supplies the subroutine prototype to be applied to the call,
12933 or indicates that there is no prototype. It may be a normal scalar,
12934 in which case if it is defined then the string value will be used
12935 as a prototype, and if it is undefined then there is no prototype.
12936 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
12937 that has been cast to C<SV*>), of which the prototype will be used if it
12938 has one. The prototype (or lack thereof) supplied, in whichever form,
12939 does not need to match the actual callee referenced by the op tree.
12941 If the argument ops disagree with the prototype, for example by having
12942 an unacceptable number of arguments, a valid op tree is returned anyway.
12943 The error is reflected in the parser state, normally resulting in a single
12944 exception at the top level of parsing which covers all the compilation
12945 errors that occurred. In the error message, the callee is referred to
12946 by the name defined by the C<namegv> parameter.
12952 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
12953 GV *namegv, SV *protosv)
12955 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
12956 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
12957 return ck_entersub_args_proto(entersubop, namegv, protosv);
12959 return ck_entersub_args_list(entersubop);
12963 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
12965 IV cvflags = SvIVX(protosv);
12966 int opnum = cvflags & 0xffff;
12967 OP *aop = cUNOPx(entersubop)->op_first;
12969 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
12973 if (!OpHAS_SIBLING(aop))
12974 aop = cUNOPx(aop)->op_first;
12975 aop = OpSIBLING(aop);
12976 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
12978 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
12979 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
12980 SVfARG(namesv)), SvUTF8(namesv));
12983 op_free(entersubop);
12984 switch(cvflags >> 16) {
12985 case 'F': return newSVOP(OP_CONST, 0,
12986 newSVpv(CopFILE(PL_curcop),0));
12987 case 'L': return newSVOP(
12989 Perl_newSVpvf(aTHX_
12990 "%" IVdf, (IV)CopLINE(PL_curcop)
12993 case 'P': return newSVOP(OP_CONST, 0,
12995 ? newSVhek(HvNAME_HEK(PL_curstash))
13000 NOT_REACHED; /* NOTREACHED */
13003 OP *prev, *cvop, *first, *parent;
13006 parent = entersubop;
13007 if (!OpHAS_SIBLING(aop)) {
13009 aop = cUNOPx(aop)->op_first;
13012 first = prev = aop;
13013 aop = OpSIBLING(aop);
13014 /* find last sibling */
13016 OpHAS_SIBLING(cvop);
13017 prev = cvop, cvop = OpSIBLING(cvop))
13019 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13020 /* Usually, OPf_SPECIAL on an op with no args means that it had
13021 * parens, but these have their own meaning for that flag: */
13022 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13023 && opnum != OP_DELETE && opnum != OP_EXISTS)
13024 flags |= OPf_SPECIAL;
13025 /* excise cvop from end of sibling chain */
13026 op_sibling_splice(parent, prev, 1, NULL);
13028 if (aop == cvop) aop = NULL;
13030 /* detach remaining siblings from the first sibling, then
13031 * dispose of original optree */
13034 op_sibling_splice(parent, first, -1, NULL);
13035 op_free(entersubop);
13037 if (cvflags == (OP_ENTEREVAL | (1<<16)))
13038 flags |= OPpEVAL_BYTES <<8;
13040 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13042 case OA_BASEOP_OR_UNOP:
13043 case OA_FILESTATOP:
13044 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13047 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13048 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13049 SVfARG(namesv)), SvUTF8(namesv));
13052 return opnum == OP_RUNCV
13053 ? newPVOP(OP_RUNCV,0,NULL)
13056 return op_convert_list(opnum,0,aop);
13059 NOT_REACHED; /* NOTREACHED */
13064 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13066 Retrieves the function that will be used to fix up a call to C<cv>.
13067 Specifically, the function is applied to an C<entersub> op tree for a
13068 subroutine call, not marked with C<&>, where the callee can be identified
13069 at compile time as C<cv>.
13071 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13072 for it is returned in C<*ckobj_p>, and control flags are returned in
13073 C<*ckflags_p>. The function is intended to be called in this manner:
13075 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13077 In this call, C<entersubop> is a pointer to the C<entersub> op,
13078 which may be replaced by the check function, and C<namegv> supplies
13079 the name that should be used by the check function to refer
13080 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13081 It is permitted to apply the check function in non-standard situations,
13082 such as to a call to a different subroutine or to a method call.
13084 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
13085 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13086 instead, anything that can be used as the first argument to L</cv_name>.
13087 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13088 check function requires C<namegv> to be a genuine GV.
13090 By default, the check function is
13091 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13092 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13093 flag is clear. This implements standard prototype processing. It can
13094 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13096 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13097 indicates that the caller only knows about the genuine GV version of
13098 C<namegv>, and accordingly the corresponding bit will always be set in
13099 C<*ckflags_p>, regardless of the check function's recorded requirements.
13100 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13101 indicates the caller knows about the possibility of passing something
13102 other than a GV as C<namegv>, and accordingly the corresponding bit may
13103 be either set or clear in C<*ckflags_p>, indicating the check function's
13104 recorded requirements.
13106 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13107 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13108 (for which see above). All other bits should be clear.
13110 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13112 The original form of L</cv_get_call_checker_flags>, which does not return
13113 checker flags. When using a checker function returned by this function,
13114 it is only safe to call it with a genuine GV as its C<namegv> argument.
13120 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13121 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13124 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13125 PERL_UNUSED_CONTEXT;
13126 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13128 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13129 *ckobj_p = callmg->mg_obj;
13130 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13132 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13133 *ckobj_p = (SV*)cv;
13134 *ckflags_p = gflags & MGf_REQUIRE_GV;
13139 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13142 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13143 PERL_UNUSED_CONTEXT;
13144 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13149 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13151 Sets the function that will be used to fix up a call to C<cv>.
13152 Specifically, the function is applied to an C<entersub> op tree for a
13153 subroutine call, not marked with C<&>, where the callee can be identified
13154 at compile time as C<cv>.
13156 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13157 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13158 The function should be defined like this:
13160 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13162 It is intended to be called in this manner:
13164 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13166 In this call, C<entersubop> is a pointer to the C<entersub> op,
13167 which may be replaced by the check function, and C<namegv> supplies
13168 the name that should be used by the check function to refer
13169 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13170 It is permitted to apply the check function in non-standard situations,
13171 such as to a call to a different subroutine or to a method call.
13173 C<namegv> may not actually be a GV. For efficiency, perl may pass a
13174 CV or other SV instead. Whatever is passed can be used as the first
13175 argument to L</cv_name>. You can force perl to pass a GV by including
13176 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13178 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13179 bit currently has a defined meaning (for which see above). All other
13180 bits should be clear.
13182 The current setting for a particular CV can be retrieved by
13183 L</cv_get_call_checker_flags>.
13185 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13187 The original form of L</cv_set_call_checker_flags>, which passes it the
13188 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
13189 of that flag setting is that the check function is guaranteed to get a
13190 genuine GV as its C<namegv> argument.
13196 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13198 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13199 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13203 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13204 SV *ckobj, U32 ckflags)
13206 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13207 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13208 if (SvMAGICAL((SV*)cv))
13209 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13212 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13213 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13215 if (callmg->mg_flags & MGf_REFCOUNTED) {
13216 SvREFCNT_dec(callmg->mg_obj);
13217 callmg->mg_flags &= ~MGf_REFCOUNTED;
13219 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13220 callmg->mg_obj = ckobj;
13221 if (ckobj != (SV*)cv) {
13222 SvREFCNT_inc_simple_void_NN(ckobj);
13223 callmg->mg_flags |= MGf_REFCOUNTED;
13225 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13226 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13231 S_entersub_alloc_targ(pTHX_ OP * const o)
13233 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13234 o->op_private |= OPpENTERSUB_HASTARG;
13238 Perl_ck_subr(pTHX_ OP *o)
13243 SV **const_class = NULL;
13245 PERL_ARGS_ASSERT_CK_SUBR;
13247 aop = cUNOPx(o)->op_first;
13248 if (!OpHAS_SIBLING(aop))
13249 aop = cUNOPx(aop)->op_first;
13250 aop = OpSIBLING(aop);
13251 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13252 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13253 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13255 o->op_private &= ~1;
13256 o->op_private |= (PL_hints & HINT_STRICT_REFS);
13257 if (PERLDB_SUB && PL_curstash != PL_debstash)
13258 o->op_private |= OPpENTERSUB_DB;
13259 switch (cvop->op_type) {
13261 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13265 case OP_METHOD_NAMED:
13266 case OP_METHOD_SUPER:
13267 case OP_METHOD_REDIR:
13268 case OP_METHOD_REDIR_SUPER:
13269 o->op_flags |= OPf_REF;
13270 if (aop->op_type == OP_CONST) {
13271 aop->op_private &= ~OPpCONST_STRICT;
13272 const_class = &cSVOPx(aop)->op_sv;
13274 else if (aop->op_type == OP_LIST) {
13275 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13276 if (sib && sib->op_type == OP_CONST) {
13277 sib->op_private &= ~OPpCONST_STRICT;
13278 const_class = &cSVOPx(sib)->op_sv;
13281 /* make class name a shared cow string to speedup method calls */
13282 /* constant string might be replaced with object, f.e. bigint */
13283 if (const_class && SvPOK(*const_class)) {
13285 const char* str = SvPV(*const_class, len);
13287 SV* const shared = newSVpvn_share(
13288 str, SvUTF8(*const_class)
13289 ? -(SSize_t)len : (SSize_t)len,
13292 if (SvREADONLY(*const_class))
13293 SvREADONLY_on(shared);
13294 SvREFCNT_dec(*const_class);
13295 *const_class = shared;
13302 S_entersub_alloc_targ(aTHX_ o);
13303 return ck_entersub_args_list(o);
13305 Perl_call_checker ckfun;
13308 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13309 if (CvISXSUB(cv) || !CvROOT(cv))
13310 S_entersub_alloc_targ(aTHX_ o);
13312 /* The original call checker API guarantees that a GV will be
13313 be provided with the right name. So, if the old API was
13314 used (or the REQUIRE_GV flag was passed), we have to reify
13315 the CV’s GV, unless this is an anonymous sub. This is not
13316 ideal for lexical subs, as its stringification will include
13317 the package. But it is the best we can do. */
13318 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13319 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13322 else namegv = MUTABLE_GV(cv);
13323 /* After a syntax error in a lexical sub, the cv that
13324 rv2cv_op_cv returns may be a nameless stub. */
13325 if (!namegv) return ck_entersub_args_list(o);
13328 return ckfun(aTHX_ o, namegv, ckobj);
13333 Perl_ck_svconst(pTHX_ OP *o)
13335 SV * const sv = cSVOPo->op_sv;
13336 PERL_ARGS_ASSERT_CK_SVCONST;
13337 PERL_UNUSED_CONTEXT;
13338 #ifdef PERL_COPY_ON_WRITE
13339 /* Since the read-only flag may be used to protect a string buffer, we
13340 cannot do copy-on-write with existing read-only scalars that are not
13341 already copy-on-write scalars. To allow $_ = "hello" to do COW with
13342 that constant, mark the constant as COWable here, if it is not
13343 already read-only. */
13344 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13347 # ifdef PERL_DEBUG_READONLY_COW
13357 Perl_ck_trunc(pTHX_ OP *o)
13359 PERL_ARGS_ASSERT_CK_TRUNC;
13361 if (o->op_flags & OPf_KIDS) {
13362 SVOP *kid = (SVOP*)cUNOPo->op_first;
13364 if (kid->op_type == OP_NULL)
13365 kid = (SVOP*)OpSIBLING(kid);
13366 if (kid && kid->op_type == OP_CONST &&
13367 (kid->op_private & OPpCONST_BARE) &&
13370 o->op_flags |= OPf_SPECIAL;
13371 kid->op_private &= ~OPpCONST_STRICT;
13378 Perl_ck_substr(pTHX_ OP *o)
13380 PERL_ARGS_ASSERT_CK_SUBSTR;
13383 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13384 OP *kid = cLISTOPo->op_first;
13386 if (kid->op_type == OP_NULL)
13387 kid = OpSIBLING(kid);
13389 op_lvalue(kid, o->op_type);
13396 Perl_ck_tell(pTHX_ OP *o)
13398 PERL_ARGS_ASSERT_CK_TELL;
13400 if (o->op_flags & OPf_KIDS) {
13401 OP *kid = cLISTOPo->op_first;
13402 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13403 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13409 Perl_ck_each(pTHX_ OP *o)
13412 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13413 const unsigned orig_type = o->op_type;
13415 PERL_ARGS_ASSERT_CK_EACH;
13418 switch (kid->op_type) {
13424 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13425 : orig_type == OP_KEYS ? OP_AKEYS
13429 if (kid->op_private == OPpCONST_BARE
13430 || !SvROK(cSVOPx_sv(kid))
13431 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13432 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
13437 qerror(Perl_mess(aTHX_
13438 "Experimental %s on scalar is now forbidden",
13439 PL_op_desc[orig_type]));
13441 bad_type_pv(1, "hash or array", o, kid);
13449 Perl_ck_length(pTHX_ OP *o)
13451 PERL_ARGS_ASSERT_CK_LENGTH;
13455 if (ckWARN(WARN_SYNTAX)) {
13456 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13460 const bool hash = kid->op_type == OP_PADHV
13461 || kid->op_type == OP_RV2HV;
13462 switch (kid->op_type) {
13467 name = S_op_varname(aTHX_ kid);
13473 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13474 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13476 SVfARG(name), hash ? "keys " : "", SVfARG(name)
13479 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13480 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13481 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13483 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13484 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13485 "length() used on @array (did you mean \"scalar(@array)\"?)");
13495 ---------------------------------------------------------
13497 Common vars in list assignment
13499 There now follows some enums and static functions for detecting
13500 common variables in list assignments. Here is a little essay I wrote
13501 for myself when trying to get my head around this. DAPM.
13505 First some random observations:
13507 * If a lexical var is an alias of something else, e.g.
13508 for my $x ($lex, $pkg, $a[0]) {...}
13509 then the act of aliasing will increase the reference count of the SV
13511 * If a package var is an alias of something else, it may still have a
13512 reference count of 1, depending on how the alias was created, e.g.
13513 in *a = *b, $a may have a refcount of 1 since the GP is shared
13514 with a single GvSV pointer to the SV. So If it's an alias of another
13515 package var, then RC may be 1; if it's an alias of another scalar, e.g.
13516 a lexical var or an array element, then it will have RC > 1.
13518 * There are many ways to create a package alias; ultimately, XS code
13519 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
13520 run-time tracing mechanisms are unlikely to be able to catch all cases.
13522 * When the LHS is all my declarations, the same vars can't appear directly
13523 on the RHS, but they can indirectly via closures, aliasing and lvalue
13524 subs. But those techniques all involve an increase in the lexical
13525 scalar's ref count.
13527 * When the LHS is all lexical vars (but not necessarily my declarations),
13528 it is possible for the same lexicals to appear directly on the RHS, and
13529 without an increased ref count, since the stack isn't refcounted.
13530 This case can be detected at compile time by scanning for common lex
13531 vars with PL_generation.
13533 * lvalue subs defeat common var detection, but they do at least
13534 return vars with a temporary ref count increment. Also, you can't
13535 tell at compile time whether a sub call is lvalue.
13540 A: There are a few circumstances where there definitely can't be any
13543 LHS empty: () = (...);
13544 RHS empty: (....) = ();
13545 RHS contains only constants or other 'can't possibly be shared'
13546 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
13547 i.e. they only contain ops not marked as dangerous, whose children
13548 are also not dangerous;
13550 LHS contains a single scalar element: e.g. ($x) = (....); because
13551 after $x has been modified, it won't be used again on the RHS;
13552 RHS contains a single element with no aggregate on LHS: e.g.
13553 ($a,$b,$c) = ($x); again, once $a has been modified, its value
13554 won't be used again.
13556 B: If LHS are all 'my' lexical var declarations (or safe ops, which
13559 my ($a, $b, @c) = ...;
13561 Due to closure and goto tricks, these vars may already have content.
13562 For the same reason, an element on the RHS may be a lexical or package
13563 alias of one of the vars on the left, or share common elements, for
13566 my ($x,$y) = f(); # $x and $y on both sides
13567 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
13572 my @a = @$ra; # elements of @a on both sides
13573 sub f { @a = 1..4; \@a }
13576 First, just consider scalar vars on LHS:
13578 RHS is safe only if (A), or in addition,
13579 * contains only lexical *scalar* vars, where neither side's
13580 lexicals have been flagged as aliases
13582 If RHS is not safe, then it's always legal to check LHS vars for
13583 RC==1, since the only RHS aliases will always be associated
13586 Note that in particular, RHS is not safe if:
13588 * it contains package scalar vars; e.g.:
13591 my ($x, $y) = (2, $x_alias);
13592 sub f { $x = 1; *x_alias = \$x; }
13594 * It contains other general elements, such as flattened or
13595 * spliced or single array or hash elements, e.g.
13598 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
13602 use feature 'refaliasing';
13603 \($a[0], $a[1]) = \($y,$x);
13606 It doesn't matter if the array/hash is lexical or package.
13608 * it contains a function call that happens to be an lvalue
13609 sub which returns one or more of the above, e.g.
13620 (so a sub call on the RHS should be treated the same
13621 as having a package var on the RHS).
13623 * any other "dangerous" thing, such an op or built-in that
13624 returns one of the above, e.g. pp_preinc
13627 If RHS is not safe, what we can do however is at compile time flag
13628 that the LHS are all my declarations, and at run time check whether
13629 all the LHS have RC == 1, and if so skip the full scan.
13631 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
13633 Here the issue is whether there can be elements of @a on the RHS
13634 which will get prematurely freed when @a is cleared prior to
13635 assignment. This is only a problem if the aliasing mechanism
13636 is one which doesn't increase the refcount - only if RC == 1
13637 will the RHS element be prematurely freed.
13639 Because the array/hash is being INTROed, it or its elements
13640 can't directly appear on the RHS:
13642 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
13644 but can indirectly, e.g.:
13648 sub f { @a = 1..3; \@a }
13650 So if the RHS isn't safe as defined by (A), we must always
13651 mortalise and bump the ref count of any remaining RHS elements
13652 when assigning to a non-empty LHS aggregate.
13654 Lexical scalars on the RHS aren't safe if they've been involved in
13657 use feature 'refaliasing';
13660 \(my $lex) = \$pkg;
13661 my @a = ($lex,3); # equivalent to ($a[0],3)
13668 Similarly with lexical arrays and hashes on the RHS:
13682 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
13683 my $a; ($a, my $b) = (....);
13685 The difference between (B) and (C) is that it is now physically
13686 possible for the LHS vars to appear on the RHS too, where they
13687 are not reference counted; but in this case, the compile-time
13688 PL_generation sweep will detect such common vars.
13690 So the rules for (C) differ from (B) in that if common vars are
13691 detected, the runtime "test RC==1" optimisation can no longer be used,
13692 and a full mark and sweep is required
13694 D: As (C), but in addition the LHS may contain package vars.
13696 Since package vars can be aliased without a corresponding refcount
13697 increase, all bets are off. It's only safe if (A). E.g.
13699 my ($x, $y) = (1,2);
13701 for $x_alias ($x) {
13702 ($x_alias, $y) = (3, $x); # whoops
13705 Ditto for LHS aggregate package vars.
13707 E: Any other dangerous ops on LHS, e.g.
13708 (f(), $a[0], @$r) = (...);
13710 this is similar to (E) in that all bets are off. In addition, it's
13711 impossible to determine at compile time whether the LHS
13712 contains a scalar or an aggregate, e.g.
13714 sub f : lvalue { @a }
13717 * ---------------------------------------------------------
13721 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
13722 * that at least one of the things flagged was seen.
13726 AAS_MY_SCALAR = 0x001, /* my $scalar */
13727 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
13728 AAS_LEX_SCALAR = 0x004, /* $lexical */
13729 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
13730 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
13731 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
13732 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
13733 AAS_DANGEROUS = 0x080, /* an op (other than the above)
13734 that's flagged OA_DANGEROUS */
13735 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
13736 not in any of the categories above */
13737 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
13742 /* helper function for S_aassign_scan().
13743 * check a PAD-related op for commonality and/or set its generation number.
13744 * Returns a boolean indicating whether its shared */
13747 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
13749 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
13750 /* lexical used in aliasing */
13754 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
13756 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
13763 Helper function for OPpASSIGN_COMMON* detection in rpeep().
13764 It scans the left or right hand subtree of the aassign op, and returns a
13765 set of flags indicating what sorts of things it found there.
13766 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
13767 set PL_generation on lexical vars; if the latter, we see if
13768 PL_generation matches.
13769 'top' indicates whether we're recursing or at the top level.
13770 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
13771 This fn will increment it by the number seen. It's not intended to
13772 be an accurate count (especially as many ops can push a variable
13773 number of SVs onto the stack); rather it's used as to test whether there
13774 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
13778 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
13781 bool kid_top = FALSE;
13783 /* first, look for a solitary @_ on the RHS */
13786 && (o->op_flags & OPf_KIDS)
13787 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
13789 OP *kid = cUNOPo->op_first;
13790 if ( ( kid->op_type == OP_PUSHMARK
13791 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
13792 && ((kid = OpSIBLING(kid)))
13793 && !OpHAS_SIBLING(kid)
13794 && kid->op_type == OP_RV2AV
13795 && !(kid->op_flags & OPf_REF)
13796 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13797 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
13798 && ((kid = cUNOPx(kid)->op_first))
13799 && kid->op_type == OP_GV
13800 && cGVOPx_gv(kid) == PL_defgv
13802 flags |= AAS_DEFAV;
13805 switch (o->op_type) {
13808 return AAS_PKG_SCALAR;
13813 /* if !top, could be e.g. @a[0,1] */
13814 if (top && (o->op_flags & OPf_REF))
13815 return (o->op_private & OPpLVAL_INTRO)
13816 ? AAS_MY_AGG : AAS_LEX_AGG;
13817 return AAS_DANGEROUS;
13821 int comm = S_aassign_padcheck(aTHX_ o, rhs)
13822 ? AAS_LEX_SCALAR_COMM : 0;
13824 return (o->op_private & OPpLVAL_INTRO)
13825 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
13831 if (cUNOPx(o)->op_first->op_type != OP_GV)
13832 return AAS_DANGEROUS; /* @{expr}, %{expr} */
13834 /* if !top, could be e.g. @a[0,1] */
13835 if (top && (o->op_flags & OPf_REF))
13836 return AAS_PKG_AGG;
13837 return AAS_DANGEROUS;
13841 if (cUNOPx(o)->op_first->op_type != OP_GV) {
13843 return AAS_DANGEROUS; /* ${expr} */
13845 return AAS_PKG_SCALAR; /* $pkg */
13848 if (o->op_private & OPpSPLIT_ASSIGN) {
13849 /* the assign in @a = split() has been optimised away
13850 * and the @a attached directly to the split op
13851 * Treat the array as appearing on the RHS, i.e.
13852 * ... = (@a = split)
13857 if (o->op_flags & OPf_STACKED)
13858 /* @{expr} = split() - the array expression is tacked
13859 * on as an extra child to split - process kid */
13860 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
13863 /* ... else array is directly attached to split op */
13865 if (PL_op->op_private & OPpSPLIT_LEX)
13866 return (o->op_private & OPpLVAL_INTRO)
13867 ? AAS_MY_AGG : AAS_LEX_AGG;
13869 return AAS_PKG_AGG;
13872 /* other args of split can't be returned */
13873 return AAS_SAFE_SCALAR;
13876 /* undef counts as a scalar on the RHS:
13877 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
13878 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
13882 flags = AAS_SAFE_SCALAR;
13887 /* these are all no-ops; they don't push a potentially common SV
13888 * onto the stack, so they are neither AAS_DANGEROUS nor
13889 * AAS_SAFE_SCALAR */
13892 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
13897 /* these do nothing but may have children; but their children
13898 * should also be treated as top-level */
13903 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
13905 flags = AAS_DANGEROUS;
13909 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
13910 && (o->op_private & OPpTARGET_MY))
13913 return S_aassign_padcheck(aTHX_ o, rhs)
13914 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
13917 /* if its an unrecognised, non-dangerous op, assume that it
13918 * it the cause of at least one safe scalar */
13920 flags = AAS_SAFE_SCALAR;
13924 /* XXX this assumes that all other ops are "transparent" - i.e. that
13925 * they can return some of their children. While this true for e.g.
13926 * sort and grep, it's not true for e.g. map. We really need a
13927 * 'transparent' flag added to regen/opcodes
13929 if (o->op_flags & OPf_KIDS) {
13931 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
13932 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
13938 /* Check for in place reverse and sort assignments like "@a = reverse @a"
13939 and modify the optree to make them work inplace */
13942 S_inplace_aassign(pTHX_ OP *o) {
13944 OP *modop, *modop_pushmark;
13946 OP *oleft, *oleft_pushmark;
13948 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
13950 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
13952 assert(cUNOPo->op_first->op_type == OP_NULL);
13953 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
13954 assert(modop_pushmark->op_type == OP_PUSHMARK);
13955 modop = OpSIBLING(modop_pushmark);
13957 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
13960 /* no other operation except sort/reverse */
13961 if (OpHAS_SIBLING(modop))
13964 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
13965 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
13967 if (modop->op_flags & OPf_STACKED) {
13968 /* skip sort subroutine/block */
13969 assert(oright->op_type == OP_NULL);
13970 oright = OpSIBLING(oright);
13973 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
13974 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
13975 assert(oleft_pushmark->op_type == OP_PUSHMARK);
13976 oleft = OpSIBLING(oleft_pushmark);
13978 /* Check the lhs is an array */
13980 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
13981 || OpHAS_SIBLING(oleft)
13982 || (oleft->op_private & OPpLVAL_INTRO)
13986 /* Only one thing on the rhs */
13987 if (OpHAS_SIBLING(oright))
13990 /* check the array is the same on both sides */
13991 if (oleft->op_type == OP_RV2AV) {
13992 if (oright->op_type != OP_RV2AV
13993 || !cUNOPx(oright)->op_first
13994 || cUNOPx(oright)->op_first->op_type != OP_GV
13995 || cUNOPx(oleft )->op_first->op_type != OP_GV
13996 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
13997 cGVOPx_gv(cUNOPx(oright)->op_first)
14001 else if (oright->op_type != OP_PADAV
14002 || oright->op_targ != oleft->op_targ
14006 /* This actually is an inplace assignment */
14008 modop->op_private |= OPpSORT_INPLACE;
14010 /* transfer MODishness etc from LHS arg to RHS arg */
14011 oright->op_flags = oleft->op_flags;
14013 /* remove the aassign op and the lhs */
14015 op_null(oleft_pushmark);
14016 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14017 op_null(cUNOPx(oleft)->op_first);
14023 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14024 * that potentially represent a series of one or more aggregate derefs
14025 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14026 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14027 * additional ops left in too).
14029 * The caller will have already verified that the first few ops in the
14030 * chain following 'start' indicate a multideref candidate, and will have
14031 * set 'orig_o' to the point further on in the chain where the first index
14032 * expression (if any) begins. 'orig_action' specifies what type of
14033 * beginning has already been determined by the ops between start..orig_o
14034 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
14036 * 'hints' contains any hints flags that need adding (currently just
14037 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14041 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14045 UNOP_AUX_item *arg_buf = NULL;
14046 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
14047 int index_skip = -1; /* don't output index arg on this action */
14049 /* similar to regex compiling, do two passes; the first pass
14050 * determines whether the op chain is convertible and calculates the
14051 * buffer size; the second pass populates the buffer and makes any
14052 * changes necessary to ops (such as moving consts to the pad on
14053 * threaded builds).
14055 * NB: for things like Coverity, note that both passes take the same
14056 * path through the logic tree (except for 'if (pass)' bits), since
14057 * both passes are following the same op_next chain; and in
14058 * particular, if it would return early on the second pass, it would
14059 * already have returned early on the first pass.
14061 for (pass = 0; pass < 2; pass++) {
14063 UV action = orig_action;
14064 OP *first_elem_op = NULL; /* first seen aelem/helem */
14065 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
14066 int action_count = 0; /* number of actions seen so far */
14067 int action_ix = 0; /* action_count % (actions per IV) */
14068 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
14069 bool is_last = FALSE; /* no more derefs to follow */
14070 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14071 UNOP_AUX_item *arg = arg_buf;
14072 UNOP_AUX_item *action_ptr = arg_buf;
14075 action_ptr->uv = 0;
14079 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14080 case MDEREF_HV_gvhv_helem:
14081 next_is_hash = TRUE;
14083 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14084 case MDEREF_AV_gvav_aelem:
14086 #ifdef USE_ITHREADS
14087 arg->pad_offset = cPADOPx(start)->op_padix;
14088 /* stop it being swiped when nulled */
14089 cPADOPx(start)->op_padix = 0;
14091 arg->sv = cSVOPx(start)->op_sv;
14092 cSVOPx(start)->op_sv = NULL;
14098 case MDEREF_HV_padhv_helem:
14099 case MDEREF_HV_padsv_vivify_rv2hv_helem:
14100 next_is_hash = TRUE;
14102 case MDEREF_AV_padav_aelem:
14103 case MDEREF_AV_padsv_vivify_rv2av_aelem:
14105 arg->pad_offset = start->op_targ;
14106 /* we skip setting op_targ = 0 for now, since the intact
14107 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14108 reset_start_targ = TRUE;
14113 case MDEREF_HV_pop_rv2hv_helem:
14114 next_is_hash = TRUE;
14116 case MDEREF_AV_pop_rv2av_aelem:
14120 NOT_REACHED; /* NOTREACHED */
14125 /* look for another (rv2av/hv; get index;
14126 * aelem/helem/exists/delele) sequence */
14131 UV index_type = MDEREF_INDEX_none;
14133 if (action_count) {
14134 /* if this is not the first lookup, consume the rv2av/hv */
14136 /* for N levels of aggregate lookup, we normally expect
14137 * that the first N-1 [ah]elem ops will be flagged as
14138 * /DEREF (so they autovivifiy if necessary), and the last
14139 * lookup op not to be.
14140 * For other things (like @{$h{k1}{k2}}) extra scope or
14141 * leave ops can appear, so abandon the effort in that
14143 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14146 /* rv2av or rv2hv sKR/1 */
14148 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14149 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14150 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14153 /* at this point, we wouldn't expect any of these
14154 * possible private flags:
14155 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14156 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14158 ASSUME(!(o->op_private &
14159 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14161 hints = (o->op_private & OPpHINT_STRICT_REFS);
14163 /* make sure the type of the previous /DEREF matches the
14164 * type of the next lookup */
14165 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14168 action = next_is_hash
14169 ? MDEREF_HV_vivify_rv2hv_helem
14170 : MDEREF_AV_vivify_rv2av_aelem;
14174 /* if this is the second pass, and we're at the depth where
14175 * previously we encountered a non-simple index expression,
14176 * stop processing the index at this point */
14177 if (action_count != index_skip) {
14179 /* look for one or more simple ops that return an array
14180 * index or hash key */
14182 switch (o->op_type) {
14184 /* it may be a lexical var index */
14185 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14186 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14187 ASSUME(!(o->op_private &
14188 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14190 if ( OP_GIMME(o,0) == G_SCALAR
14191 && !(o->op_flags & (OPf_REF|OPf_MOD))
14192 && o->op_private == 0)
14195 arg->pad_offset = o->op_targ;
14197 index_type = MDEREF_INDEX_padsv;
14203 if (next_is_hash) {
14204 /* it's a constant hash index */
14205 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14206 /* "use constant foo => FOO; $h{+foo}" for
14207 * some weird FOO, can leave you with constants
14208 * that aren't simple strings. It's not worth
14209 * the extra hassle for those edge cases */
14214 OP * helem_op = o->op_next;
14216 ASSUME( helem_op->op_type == OP_HELEM
14217 || helem_op->op_type == OP_NULL);
14218 if (helem_op->op_type == OP_HELEM) {
14219 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14220 if ( helem_op->op_private & OPpLVAL_INTRO
14221 || rop->op_type != OP_RV2HV
14225 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
14227 #ifdef USE_ITHREADS
14228 /* Relocate sv to the pad for thread safety */
14229 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14230 arg->pad_offset = o->op_targ;
14233 arg->sv = cSVOPx_sv(o);
14238 /* it's a constant array index */
14240 SV *ix_sv = cSVOPo->op_sv;
14245 if ( action_count == 0
14248 && ( action == MDEREF_AV_padav_aelem
14249 || action == MDEREF_AV_gvav_aelem)
14251 maybe_aelemfast = TRUE;
14255 SvREFCNT_dec_NN(cSVOPo->op_sv);
14259 /* we've taken ownership of the SV */
14260 cSVOPo->op_sv = NULL;
14262 index_type = MDEREF_INDEX_const;
14267 /* it may be a package var index */
14269 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14270 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14271 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14272 || o->op_private != 0
14277 if (kid->op_type != OP_RV2SV)
14280 ASSUME(!(kid->op_flags &
14281 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14282 |OPf_SPECIAL|OPf_PARENS)));
14283 ASSUME(!(kid->op_private &
14285 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14286 |OPpDEREF|OPpLVAL_INTRO)));
14287 if( (kid->op_flags &~ OPf_PARENS)
14288 != (OPf_WANT_SCALAR|OPf_KIDS)
14289 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14294 #ifdef USE_ITHREADS
14295 arg->pad_offset = cPADOPx(o)->op_padix;
14296 /* stop it being swiped when nulled */
14297 cPADOPx(o)->op_padix = 0;
14299 arg->sv = cSVOPx(o)->op_sv;
14300 cSVOPo->op_sv = NULL;
14304 index_type = MDEREF_INDEX_gvsv;
14309 } /* action_count != index_skip */
14311 action |= index_type;
14314 /* at this point we have either:
14315 * * detected what looks like a simple index expression,
14316 * and expect the next op to be an [ah]elem, or
14317 * an nulled [ah]elem followed by a delete or exists;
14318 * * found a more complex expression, so something other
14319 * than the above follows.
14322 /* possibly an optimised away [ah]elem (where op_next is
14323 * exists or delete) */
14324 if (o->op_type == OP_NULL)
14327 /* at this point we're looking for an OP_AELEM, OP_HELEM,
14328 * OP_EXISTS or OP_DELETE */
14330 /* if something like arybase (a.k.a $[ ) is in scope,
14331 * abandon optimisation attempt */
14332 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14333 && PL_check[o->op_type] != Perl_ck_null)
14335 /* similarly for customised exists and delete */
14336 if ( (o->op_type == OP_EXISTS)
14337 && PL_check[o->op_type] != Perl_ck_exists)
14339 if ( (o->op_type == OP_DELETE)
14340 && PL_check[o->op_type] != Perl_ck_delete)
14343 if ( o->op_type != OP_AELEM
14344 || (o->op_private &
14345 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14347 maybe_aelemfast = FALSE;
14349 /* look for aelem/helem/exists/delete. If it's not the last elem
14350 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14351 * flags; if it's the last, then it mustn't have
14352 * OPpDEREF_AV/HV, but may have lots of other flags, like
14353 * OPpLVAL_INTRO etc
14356 if ( index_type == MDEREF_INDEX_none
14357 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
14358 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14362 /* we have aelem/helem/exists/delete with valid simple index */
14364 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14365 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
14366 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14368 /* This doesn't make much sense but is legal:
14369 * @{ local $x[0][0] } = 1
14370 * Since scope exit will undo the autovivification,
14371 * don't bother in the first place. The OP_LEAVE
14372 * assertion is in case there are other cases of both
14373 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14374 * exit that would undo the local - in which case this
14375 * block of code would need rethinking.
14377 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14379 OP *n = o->op_next;
14380 while (n && ( n->op_type == OP_NULL
14381 || n->op_type == OP_LIST))
14383 assert(n && n->op_type == OP_LEAVE);
14385 o->op_private &= ~OPpDEREF;
14390 ASSUME(!(o->op_flags &
14391 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14392 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14394 ok = (o->op_flags &~ OPf_PARENS)
14395 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14396 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14398 else if (o->op_type == OP_EXISTS) {
14399 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14400 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14401 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14402 ok = !(o->op_private & ~OPpARG1_MASK);
14404 else if (o->op_type == OP_DELETE) {
14405 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14406 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14407 ASSUME(!(o->op_private &
14408 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14409 /* don't handle slices or 'local delete'; the latter
14410 * is fairly rare, and has a complex runtime */
14411 ok = !(o->op_private & ~OPpARG1_MASK);
14412 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14413 /* skip handling run-tome error */
14414 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14417 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14418 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14419 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14420 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14421 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14422 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14427 if (!first_elem_op)
14431 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14436 action |= MDEREF_FLAG_last;
14440 /* at this point we have something that started
14441 * promisingly enough (with rv2av or whatever), but failed
14442 * to find a simple index followed by an
14443 * aelem/helem/exists/delete. If this is the first action,
14444 * give up; but if we've already seen at least one
14445 * aelem/helem, then keep them and add a new action with
14446 * MDEREF_INDEX_none, which causes it to do the vivify
14447 * from the end of the previous lookup, and do the deref,
14448 * but stop at that point. So $a[0][expr] will do one
14449 * av_fetch, vivify and deref, then continue executing at
14454 index_skip = action_count;
14455 action |= MDEREF_FLAG_last;
14456 if (index_type != MDEREF_INDEX_none)
14461 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14464 /* if there's no space for the next action, create a new slot
14465 * for it *before* we start adding args for that action */
14466 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14473 } /* while !is_last */
14481 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14482 if (index_skip == -1) {
14483 mderef->op_flags = o->op_flags
14484 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14485 if (o->op_type == OP_EXISTS)
14486 mderef->op_private = OPpMULTIDEREF_EXISTS;
14487 else if (o->op_type == OP_DELETE)
14488 mderef->op_private = OPpMULTIDEREF_DELETE;
14490 mderef->op_private = o->op_private
14491 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14493 /* accumulate strictness from every level (although I don't think
14494 * they can actually vary) */
14495 mderef->op_private |= hints;
14497 /* integrate the new multideref op into the optree and the
14500 * In general an op like aelem or helem has two child
14501 * sub-trees: the aggregate expression (a_expr) and the
14502 * index expression (i_expr):
14508 * The a_expr returns an AV or HV, while the i-expr returns an
14509 * index. In general a multideref replaces most or all of a
14510 * multi-level tree, e.g.
14526 * With multideref, all the i_exprs will be simple vars or
14527 * constants, except that i_expr1 may be arbitrary in the case
14528 * of MDEREF_INDEX_none.
14530 * The bottom-most a_expr will be either:
14531 * 1) a simple var (so padXv or gv+rv2Xv);
14532 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
14533 * so a simple var with an extra rv2Xv;
14534 * 3) or an arbitrary expression.
14536 * 'start', the first op in the execution chain, will point to
14537 * 1),2): the padXv or gv op;
14538 * 3): the rv2Xv which forms the last op in the a_expr
14539 * execution chain, and the top-most op in the a_expr
14542 * For all cases, the 'start' node is no longer required,
14543 * but we can't free it since one or more external nodes
14544 * may point to it. E.g. consider
14545 * $h{foo} = $a ? $b : $c
14546 * Here, both the op_next and op_other branches of the
14547 * cond_expr point to the gv[*h] of the hash expression, so
14548 * we can't free the 'start' op.
14550 * For expr->[...], we need to save the subtree containing the
14551 * expression; for the other cases, we just need to save the
14553 * So in all cases, we null the start op and keep it around by
14554 * making it the child of the multideref op; for the expr->
14555 * case, the expr will be a subtree of the start node.
14557 * So in the simple 1,2 case the optree above changes to
14563 * ex-gv (or ex-padxv)
14565 * with the op_next chain being
14567 * -> ex-gv -> multideref -> op-following-ex-exists ->
14569 * In the 3 case, we have
14582 * -> rest-of-a_expr subtree ->
14583 * ex-rv2xv -> multideref -> op-following-ex-exists ->
14586 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
14587 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
14588 * multideref attached as the child, e.g.
14594 * ex-rv2av - i_expr1
14602 /* if we free this op, don't free the pad entry */
14603 if (reset_start_targ)
14604 start->op_targ = 0;
14607 /* Cut the bit we need to save out of the tree and attach to
14608 * the multideref op, then free the rest of the tree */
14610 /* find parent of node to be detached (for use by splice) */
14612 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
14613 || orig_action == MDEREF_HV_pop_rv2hv_helem)
14615 /* there is an arbitrary expression preceding us, e.g.
14616 * expr->[..]? so we need to save the 'expr' subtree */
14617 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
14618 p = cUNOPx(p)->op_first;
14619 ASSUME( start->op_type == OP_RV2AV
14620 || start->op_type == OP_RV2HV);
14623 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
14624 * above for exists/delete. */
14625 while ( (p->op_flags & OPf_KIDS)
14626 && cUNOPx(p)->op_first != start
14628 p = cUNOPx(p)->op_first;
14630 ASSUME(cUNOPx(p)->op_first == start);
14632 /* detach from main tree, and re-attach under the multideref */
14633 op_sibling_splice(mderef, NULL, 0,
14634 op_sibling_splice(p, NULL, 1, NULL));
14637 start->op_next = mderef;
14639 mderef->op_next = index_skip == -1 ? o->op_next : o;
14641 /* excise and free the original tree, and replace with
14642 * the multideref op */
14643 p = op_sibling_splice(top_op, NULL, -1, mderef);
14652 Size_t size = arg - arg_buf;
14654 if (maybe_aelemfast && action_count == 1)
14657 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
14658 sizeof(UNOP_AUX_item) * (size + 1));
14659 /* for dumping etc: store the length in a hidden first slot;
14660 * we set the op_aux pointer to the second slot */
14661 arg_buf->uv = size;
14664 } /* for (pass = ...) */
14667 /* See if the ops following o are such that o will always be executed in
14668 * boolean context: that is, the SV which o pushes onto the stack will
14669 * only ever be consumed by later ops via SvTRUE(sv) or similar.
14670 * If so, set a suitable private flag on o. Normally this will be
14671 * bool_flag; but see below why maybe_flag is needed too.
14673 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
14674 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
14675 * already be taken, so you'll have to give that op two different flags.
14677 * More explanation of 'maybe_flag' and 'safe_and' parameters.
14678 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
14679 * those underlying ops) short-circuit, which means that rather than
14680 * necessarily returning a truth value, they may return the LH argument,
14681 * which may not be boolean. For example in $x = (keys %h || -1), keys
14682 * should return a key count rather than a boolean, even though its
14683 * sort-of being used in boolean context.
14685 * So we only consider such logical ops to provide boolean context to
14686 * their LH argument if they themselves are in void or boolean context.
14687 * However, sometimes the context isn't known until run-time. In this
14688 * case the op is marked with the maybe_flag flag it.
14690 * Consider the following.
14692 * sub f { ....; if (%h) { .... } }
14694 * This is actually compiled as
14696 * sub f { ....; %h && do { .... } }
14698 * Here we won't know until runtime whether the final statement (and hence
14699 * the &&) is in void context and so is safe to return a boolean value.
14700 * So mark o with maybe_flag rather than the bool_flag.
14701 * Note that there is cost associated with determining context at runtime
14702 * (e.g. a call to block_gimme()), so it may not be worth setting (at
14703 * compile time) and testing (at runtime) maybe_flag if the scalar verses
14704 * boolean costs savings are marginal.
14706 * However, we can do slightly better with && (compared to || and //):
14707 * this op only returns its LH argument when that argument is false. In
14708 * this case, as long as the op promises to return a false value which is
14709 * valid in both boolean and scalar contexts, we can mark an op consumed
14710 * by && with bool_flag rather than maybe_flag.
14711 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
14712 * than &PL_sv_no for a false result in boolean context, then it's safe. An
14713 * op which promises to handle this case is indicated by setting safe_and
14718 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
14723 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
14725 /* OPpTARGET_MY and boolean context probably don't mix well.
14726 * If someone finds a valid use case, maybe add an extra flag to this
14727 * function which indicates its safe to do so for this op? */
14728 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
14729 && (o->op_private & OPpTARGET_MY)));
14734 switch (lop->op_type) {
14739 /* these two consume the stack argument in the scalar case,
14740 * and treat it as a boolean in the non linenumber case */
14743 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
14744 || (lop->op_private & OPpFLIP_LINENUM))
14750 /* these never leave the original value on the stack */
14759 /* OR DOR and AND evaluate their arg as a boolean, but then may
14760 * leave the original scalar value on the stack when following the
14761 * op_next route. If not in void context, we need to ensure
14762 * that whatever follows consumes the arg only in boolean context
14774 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
14778 else if (!(lop->op_flags & OPf_WANT)) {
14779 /* unknown context - decide at runtime */
14791 lop = lop->op_next;
14794 o->op_private |= flag;
14799 /* mechanism for deferring recursion in rpeep() */
14801 #define MAX_DEFERRED 4
14805 if (defer_ix == (MAX_DEFERRED-1)) { \
14806 OP **defer = defer_queue[defer_base]; \
14807 CALL_RPEEP(*defer); \
14808 S_prune_chain_head(defer); \
14809 defer_base = (defer_base + 1) % MAX_DEFERRED; \
14812 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
14815 #define IS_AND_OP(o) (o->op_type == OP_AND)
14816 #define IS_OR_OP(o) (o->op_type == OP_OR)
14819 /* A peephole optimizer. We visit the ops in the order they're to execute.
14820 * See the comments at the top of this file for more details about when
14821 * peep() is called */
14824 Perl_rpeep(pTHX_ OP *o)
14828 OP* oldoldop = NULL;
14829 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
14830 int defer_base = 0;
14833 if (!o || o->op_opt)
14836 assert(o->op_type != OP_FREED);
14840 SAVEVPTR(PL_curcop);
14841 for (;; o = o->op_next) {
14842 if (o && o->op_opt)
14845 while (defer_ix >= 0) {
14847 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
14848 CALL_RPEEP(*defer);
14849 S_prune_chain_head(defer);
14856 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
14857 assert(!oldoldop || oldoldop->op_next == oldop);
14858 assert(!oldop || oldop->op_next == o);
14860 /* By default, this op has now been optimised. A couple of cases below
14861 clear this again. */
14865 /* look for a series of 1 or more aggregate derefs, e.g.
14866 * $a[1]{foo}[$i]{$k}
14867 * and replace with a single OP_MULTIDEREF op.
14868 * Each index must be either a const, or a simple variable,
14870 * First, look for likely combinations of starting ops,
14871 * corresponding to (global and lexical variants of)
14873 * $r->[...] $r->{...}
14874 * (preceding expression)->[...]
14875 * (preceding expression)->{...}
14876 * and if so, call maybe_multideref() to do a full inspection
14877 * of the op chain and if appropriate, replace with an
14885 switch (o2->op_type) {
14887 /* $pkg[..] : gv[*pkg]
14888 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
14890 /* Fail if there are new op flag combinations that we're
14891 * not aware of, rather than:
14892 * * silently failing to optimise, or
14893 * * silently optimising the flag away.
14894 * If this ASSUME starts failing, examine what new flag
14895 * has been added to the op, and decide whether the
14896 * optimisation should still occur with that flag, then
14897 * update the code accordingly. This applies to all the
14898 * other ASSUMEs in the block of code too.
14900 ASSUME(!(o2->op_flags &
14901 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
14902 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
14906 if (o2->op_type == OP_RV2AV) {
14907 action = MDEREF_AV_gvav_aelem;
14911 if (o2->op_type == OP_RV2HV) {
14912 action = MDEREF_HV_gvhv_helem;
14916 if (o2->op_type != OP_RV2SV)
14919 /* at this point we've seen gv,rv2sv, so the only valid
14920 * construct left is $pkg->[] or $pkg->{} */
14922 ASSUME(!(o2->op_flags & OPf_STACKED));
14923 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
14924 != (OPf_WANT_SCALAR|OPf_MOD))
14927 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
14928 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
14929 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
14931 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
14932 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
14936 if (o2->op_type == OP_RV2AV) {
14937 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
14940 if (o2->op_type == OP_RV2HV) {
14941 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
14947 /* $lex->[...]: padsv[$lex] sM/DREFAV */
14949 ASSUME(!(o2->op_flags &
14950 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
14951 if ((o2->op_flags &
14952 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
14953 != (OPf_WANT_SCALAR|OPf_MOD))
14956 ASSUME(!(o2->op_private &
14957 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14958 /* skip if state or intro, or not a deref */
14959 if ( o2->op_private != OPpDEREF_AV
14960 && o2->op_private != OPpDEREF_HV)
14964 if (o2->op_type == OP_RV2AV) {
14965 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
14968 if (o2->op_type == OP_RV2HV) {
14969 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
14976 /* $lex[..]: padav[@lex:1,2] sR *
14977 * or $lex{..}: padhv[%lex:1,2] sR */
14978 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
14979 OPf_REF|OPf_SPECIAL)));
14980 if ((o2->op_flags &
14981 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
14982 != (OPf_WANT_SCALAR|OPf_REF))
14984 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
14986 /* OPf_PARENS isn't currently used in this case;
14987 * if that changes, let us know! */
14988 ASSUME(!(o2->op_flags & OPf_PARENS));
14990 /* at this point, we wouldn't expect any of the remaining
14991 * possible private flags:
14992 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
14993 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
14995 * OPpSLICEWARNING shouldn't affect runtime
14997 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
14999 action = o2->op_type == OP_PADAV
15000 ? MDEREF_AV_padav_aelem
15001 : MDEREF_HV_padhv_helem;
15003 S_maybe_multideref(aTHX_ o, o2, action, 0);
15009 action = o2->op_type == OP_RV2AV
15010 ? MDEREF_AV_pop_rv2av_aelem
15011 : MDEREF_HV_pop_rv2hv_helem;
15014 /* (expr)->[...]: rv2av sKR/1;
15015 * (expr)->{...}: rv2hv sKR/1; */
15017 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15019 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15020 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15021 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15024 /* at this point, we wouldn't expect any of these
15025 * possible private flags:
15026 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15027 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15029 ASSUME(!(o2->op_private &
15030 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15032 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15036 S_maybe_multideref(aTHX_ o, o2, action, hints);
15045 switch (o->op_type) {
15047 PL_curcop = ((COP*)o); /* for warnings */
15050 PL_curcop = ((COP*)o); /* for warnings */
15052 /* Optimise a "return ..." at the end of a sub to just be "...".
15053 * This saves 2 ops. Before:
15054 * 1 <;> nextstate(main 1 -e:1) v ->2
15055 * 4 <@> return K ->5
15056 * 2 <0> pushmark s ->3
15057 * - <1> ex-rv2sv sK/1 ->4
15058 * 3 <#> gvsv[*cat] s ->4
15061 * - <@> return K ->-
15062 * - <0> pushmark s ->2
15063 * - <1> ex-rv2sv sK/1 ->-
15064 * 2 <$> gvsv(*cat) s ->3
15067 OP *next = o->op_next;
15068 OP *sibling = OpSIBLING(o);
15069 if ( OP_TYPE_IS(next, OP_PUSHMARK)
15070 && OP_TYPE_IS(sibling, OP_RETURN)
15071 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15072 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15073 ||OP_TYPE_IS(sibling->op_next->op_next,
15075 && cUNOPx(sibling)->op_first == next
15076 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15079 /* Look through the PUSHMARK's siblings for one that
15080 * points to the RETURN */
15081 OP *top = OpSIBLING(next);
15082 while (top && top->op_next) {
15083 if (top->op_next == sibling) {
15084 top->op_next = sibling->op_next;
15085 o->op_next = next->op_next;
15088 top = OpSIBLING(top);
15093 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15095 * This latter form is then suitable for conversion into padrange
15096 * later on. Convert:
15098 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15102 * nextstate1 -> listop -> nextstate3
15104 * pushmark -> padop1 -> padop2
15106 if (o->op_next && (
15107 o->op_next->op_type == OP_PADSV
15108 || o->op_next->op_type == OP_PADAV
15109 || o->op_next->op_type == OP_PADHV
15111 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15112 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15113 && o->op_next->op_next->op_next && (
15114 o->op_next->op_next->op_next->op_type == OP_PADSV
15115 || o->op_next->op_next->op_next->op_type == OP_PADAV
15116 || o->op_next->op_next->op_next->op_type == OP_PADHV
15118 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15119 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15120 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15121 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15123 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15126 ns2 = pad1->op_next;
15127 pad2 = ns2->op_next;
15128 ns3 = pad2->op_next;
15130 /* we assume here that the op_next chain is the same as
15131 * the op_sibling chain */
15132 assert(OpSIBLING(o) == pad1);
15133 assert(OpSIBLING(pad1) == ns2);
15134 assert(OpSIBLING(ns2) == pad2);
15135 assert(OpSIBLING(pad2) == ns3);
15137 /* excise and delete ns2 */
15138 op_sibling_splice(NULL, pad1, 1, NULL);
15141 /* excise pad1 and pad2 */
15142 op_sibling_splice(NULL, o, 2, NULL);
15144 /* create new listop, with children consisting of:
15145 * a new pushmark, pad1, pad2. */
15146 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15147 newop->op_flags |= OPf_PARENS;
15148 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15150 /* insert newop between o and ns3 */
15151 op_sibling_splice(NULL, o, 0, newop);
15153 /*fixup op_next chain */
15154 newpm = cUNOPx(newop)->op_first; /* pushmark */
15155 o ->op_next = newpm;
15156 newpm->op_next = pad1;
15157 pad1 ->op_next = pad2;
15158 pad2 ->op_next = newop; /* listop */
15159 newop->op_next = ns3;
15161 /* Ensure pushmark has this flag if padops do */
15162 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15163 newpm->op_flags |= OPf_MOD;
15169 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15170 to carry two labels. For now, take the easier option, and skip
15171 this optimisation if the first NEXTSTATE has a label. */
15172 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15173 OP *nextop = o->op_next;
15174 while (nextop && nextop->op_type == OP_NULL)
15175 nextop = nextop->op_next;
15177 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15180 oldop->op_next = nextop;
15182 /* Skip (old)oldop assignment since the current oldop's
15183 op_next already points to the next op. */
15190 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15191 if (o->op_next->op_private & OPpTARGET_MY) {
15192 if (o->op_flags & OPf_STACKED) /* chained concats */
15193 break; /* ignore_optimization */
15195 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15196 o->op_targ = o->op_next->op_targ;
15197 o->op_next->op_targ = 0;
15198 o->op_private |= OPpTARGET_MY;
15201 op_null(o->op_next);
15205 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15206 break; /* Scalar stub must produce undef. List stub is noop */
15210 if (o->op_targ == OP_NEXTSTATE
15211 || o->op_targ == OP_DBSTATE)
15213 PL_curcop = ((COP*)o);
15215 /* XXX: We avoid setting op_seq here to prevent later calls
15216 to rpeep() from mistakenly concluding that optimisation
15217 has already occurred. This doesn't fix the real problem,
15218 though (See 20010220.007 (#5874)). AMS 20010719 */
15219 /* op_seq functionality is now replaced by op_opt */
15227 oldop->op_next = o->op_next;
15241 convert repeat into a stub with no kids.
15243 if (o->op_next->op_type == OP_CONST
15244 || ( o->op_next->op_type == OP_PADSV
15245 && !(o->op_next->op_private & OPpLVAL_INTRO))
15246 || ( o->op_next->op_type == OP_GV
15247 && o->op_next->op_next->op_type == OP_RV2SV
15248 && !(o->op_next->op_next->op_private
15249 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15251 const OP *kid = o->op_next->op_next;
15252 if (o->op_next->op_type == OP_GV)
15253 kid = kid->op_next;
15254 /* kid is now the ex-list. */
15255 if (kid->op_type == OP_NULL
15256 && (kid = kid->op_next)->op_type == OP_CONST
15257 /* kid is now the repeat count. */
15258 && kid->op_next->op_type == OP_REPEAT
15259 && kid->op_next->op_private & OPpREPEAT_DOLIST
15260 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15261 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15264 o = kid->op_next; /* repeat */
15265 oldop->op_next = o;
15266 op_free(cBINOPo->op_first);
15267 op_free(cBINOPo->op_last );
15268 o->op_flags &=~ OPf_KIDS;
15269 /* stub is a baseop; repeat is a binop */
15270 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15271 OpTYPE_set(o, OP_STUB);
15277 /* Convert a series of PAD ops for my vars plus support into a
15278 * single padrange op. Basically
15280 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15282 * becomes, depending on circumstances, one of
15284 * padrange ----------------------------------> (list) -> rest
15285 * padrange --------------------------------------------> rest
15287 * where all the pad indexes are sequential and of the same type
15289 * We convert the pushmark into a padrange op, then skip
15290 * any other pad ops, and possibly some trailing ops.
15291 * Note that we don't null() the skipped ops, to make it
15292 * easier for Deparse to undo this optimisation (and none of
15293 * the skipped ops are holding any resourses). It also makes
15294 * it easier for find_uninit_var(), as it can just ignore
15295 * padrange, and examine the original pad ops.
15299 OP *followop = NULL; /* the op that will follow the padrange op */
15302 PADOFFSET base = 0; /* init only to stop compiler whining */
15303 bool gvoid = 0; /* init only to stop compiler whining */
15304 bool defav = 0; /* seen (...) = @_ */
15305 bool reuse = 0; /* reuse an existing padrange op */
15307 /* look for a pushmark -> gv[_] -> rv2av */
15312 if ( p->op_type == OP_GV
15313 && cGVOPx_gv(p) == PL_defgv
15314 && (rv2av = p->op_next)
15315 && rv2av->op_type == OP_RV2AV
15316 && !(rv2av->op_flags & OPf_REF)
15317 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15318 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15320 q = rv2av->op_next;
15321 if (q->op_type == OP_NULL)
15323 if (q->op_type == OP_PUSHMARK) {
15333 /* scan for PAD ops */
15335 for (p = p->op_next; p; p = p->op_next) {
15336 if (p->op_type == OP_NULL)
15339 if (( p->op_type != OP_PADSV
15340 && p->op_type != OP_PADAV
15341 && p->op_type != OP_PADHV
15343 /* any private flag other than INTRO? e.g. STATE */
15344 || (p->op_private & ~OPpLVAL_INTRO)
15348 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15350 if ( p->op_type == OP_PADAV
15352 && p->op_next->op_type == OP_CONST
15353 && p->op_next->op_next
15354 && p->op_next->op_next->op_type == OP_AELEM
15358 /* for 1st padop, note what type it is and the range
15359 * start; for the others, check that it's the same type
15360 * and that the targs are contiguous */
15362 intro = (p->op_private & OPpLVAL_INTRO);
15364 gvoid = OP_GIMME(p,0) == G_VOID;
15367 if ((p->op_private & OPpLVAL_INTRO) != intro)
15369 /* Note that you'd normally expect targs to be
15370 * contiguous in my($a,$b,$c), but that's not the case
15371 * when external modules start doing things, e.g.
15372 * Function::Parameters */
15373 if (p->op_targ != base + count)
15375 assert(p->op_targ == base + count);
15376 /* Either all the padops or none of the padops should
15377 be in void context. Since we only do the optimisa-
15378 tion for av/hv when the aggregate itself is pushed
15379 on to the stack (one item), there is no need to dis-
15380 tinguish list from scalar context. */
15381 if (gvoid != (OP_GIMME(p,0) == G_VOID))
15385 /* for AV, HV, only when we're not flattening */
15386 if ( p->op_type != OP_PADSV
15388 && !(p->op_flags & OPf_REF)
15392 if (count >= OPpPADRANGE_COUNTMASK)
15395 /* there's a biggest base we can fit into a
15396 * SAVEt_CLEARPADRANGE in pp_padrange.
15397 * (The sizeof() stuff will be constant-folded, and is
15398 * intended to avoid getting "comparison is always false"
15399 * compiler warnings. See the comments above
15400 * MEM_WRAP_CHECK for more explanation on why we do this
15401 * in a weird way to avoid compiler warnings.)
15404 && (8*sizeof(base) >
15405 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15407 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15409 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15413 /* Success! We've got another valid pad op to optimise away */
15415 followop = p->op_next;
15418 if (count < 1 || (count == 1 && !defav))
15421 /* pp_padrange in specifically compile-time void context
15422 * skips pushing a mark and lexicals; in all other contexts
15423 * (including unknown till runtime) it pushes a mark and the
15424 * lexicals. We must be very careful then, that the ops we
15425 * optimise away would have exactly the same effect as the
15427 * In particular in void context, we can only optimise to
15428 * a padrange if we see the complete sequence
15429 * pushmark, pad*v, ...., list
15430 * which has the net effect of leaving the markstack as it
15431 * was. Not pushing onto the stack (whereas padsv does touch
15432 * the stack) makes no difference in void context.
15436 if (followop->op_type == OP_LIST
15437 && OP_GIMME(followop,0) == G_VOID
15440 followop = followop->op_next; /* skip OP_LIST */
15442 /* consolidate two successive my(...);'s */
15445 && oldoldop->op_type == OP_PADRANGE
15446 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15447 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15448 && !(oldoldop->op_flags & OPf_SPECIAL)
15451 assert(oldoldop->op_next == oldop);
15452 assert( oldop->op_type == OP_NEXTSTATE
15453 || oldop->op_type == OP_DBSTATE);
15454 assert(oldop->op_next == o);
15457 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15459 /* Do not assume pad offsets for $c and $d are con-
15464 if ( oldoldop->op_targ + old_count == base
15465 && old_count < OPpPADRANGE_COUNTMASK - count) {
15466 base = oldoldop->op_targ;
15467 count += old_count;
15472 /* if there's any immediately following singleton
15473 * my var's; then swallow them and the associated
15475 * my ($a,$b); my $c; my $d;
15477 * my ($a,$b,$c,$d);
15480 while ( ((p = followop->op_next))
15481 && ( p->op_type == OP_PADSV
15482 || p->op_type == OP_PADAV
15483 || p->op_type == OP_PADHV)
15484 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15485 && (p->op_private & OPpLVAL_INTRO) == intro
15486 && !(p->op_private & ~OPpLVAL_INTRO)
15488 && ( p->op_next->op_type == OP_NEXTSTATE
15489 || p->op_next->op_type == OP_DBSTATE)
15490 && count < OPpPADRANGE_COUNTMASK
15491 && base + count == p->op_targ
15494 followop = p->op_next;
15502 assert(oldoldop->op_type == OP_PADRANGE);
15503 oldoldop->op_next = followop;
15504 oldoldop->op_private = (intro | count);
15510 /* Convert the pushmark into a padrange.
15511 * To make Deparse easier, we guarantee that a padrange was
15512 * *always* formerly a pushmark */
15513 assert(o->op_type == OP_PUSHMARK);
15514 o->op_next = followop;
15515 OpTYPE_set(o, OP_PADRANGE);
15517 /* bit 7: INTRO; bit 6..0: count */
15518 o->op_private = (intro | count);
15519 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
15520 | gvoid * OPf_WANT_VOID
15521 | (defav ? OPf_SPECIAL : 0));
15527 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15528 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15533 /*'keys %h' in void or scalar context: skip the OP_KEYS
15534 * and perform the functionality directly in the RV2HV/PADHV
15537 if (o->op_flags & OPf_REF) {
15538 OP *k = o->op_next;
15539 U8 want = (k->op_flags & OPf_WANT);
15541 && k->op_type == OP_KEYS
15542 && ( want == OPf_WANT_VOID
15543 || want == OPf_WANT_SCALAR)
15544 && !(k->op_private & OPpMAYBE_LVSUB)
15545 && !(k->op_flags & OPf_MOD)
15547 o->op_next = k->op_next;
15548 o->op_flags &= ~(OPf_REF|OPf_WANT);
15549 o->op_flags |= want;
15550 o->op_private |= (o->op_type == OP_PADHV ?
15551 OPpRV2HV_ISKEYS : OPpRV2HV_ISKEYS);
15552 /* for keys(%lex), hold onto the OP_KEYS's targ
15553 * since padhv doesn't have its own targ to return
15555 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
15560 /* see if %h is used in boolean context */
15561 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15562 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
15565 if (o->op_type != OP_PADHV)
15569 if ( o->op_type == OP_PADAV
15570 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
15572 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15575 /* Skip over state($x) in void context. */
15576 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
15577 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
15579 oldop->op_next = o->op_next;
15580 goto redo_nextstate;
15582 if (o->op_type != OP_PADAV)
15586 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
15587 OP* const pop = (o->op_type == OP_PADAV) ?
15588 o->op_next : o->op_next->op_next;
15590 if (pop && pop->op_type == OP_CONST &&
15591 ((PL_op = pop->op_next)) &&
15592 pop->op_next->op_type == OP_AELEM &&
15593 !(pop->op_next->op_private &
15594 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
15595 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
15598 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
15599 no_bareword_allowed(pop);
15600 if (o->op_type == OP_GV)
15601 op_null(o->op_next);
15602 op_null(pop->op_next);
15604 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
15605 o->op_next = pop->op_next->op_next;
15606 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
15607 o->op_private = (U8)i;
15608 if (o->op_type == OP_GV) {
15611 o->op_type = OP_AELEMFAST;
15614 o->op_type = OP_AELEMFAST_LEX;
15616 if (o->op_type != OP_GV)
15620 /* Remove $foo from the op_next chain in void context. */
15622 && ( o->op_next->op_type == OP_RV2SV
15623 || o->op_next->op_type == OP_RV2AV
15624 || o->op_next->op_type == OP_RV2HV )
15625 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
15626 && !(o->op_next->op_private & OPpLVAL_INTRO))
15628 oldop->op_next = o->op_next->op_next;
15629 /* Reprocess the previous op if it is a nextstate, to
15630 allow double-nextstate optimisation. */
15632 if (oldop->op_type == OP_NEXTSTATE) {
15639 o = oldop->op_next;
15642 else if (o->op_next->op_type == OP_RV2SV) {
15643 if (!(o->op_next->op_private & OPpDEREF)) {
15644 op_null(o->op_next);
15645 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
15647 o->op_next = o->op_next->op_next;
15648 OpTYPE_set(o, OP_GVSV);
15651 else if (o->op_next->op_type == OP_READLINE
15652 && o->op_next->op_next->op_type == OP_CONCAT
15653 && (o->op_next->op_next->op_flags & OPf_STACKED))
15655 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
15656 OpTYPE_set(o, OP_RCATLINE);
15657 o->op_flags |= OPf_STACKED;
15658 op_null(o->op_next->op_next);
15659 op_null(o->op_next);
15670 while (cLOGOP->op_other->op_type == OP_NULL)
15671 cLOGOP->op_other = cLOGOP->op_other->op_next;
15672 while (o->op_next && ( o->op_type == o->op_next->op_type
15673 || o->op_next->op_type == OP_NULL))
15674 o->op_next = o->op_next->op_next;
15676 /* If we're an OR and our next is an AND in void context, we'll
15677 follow its op_other on short circuit, same for reverse.
15678 We can't do this with OP_DOR since if it's true, its return
15679 value is the underlying value which must be evaluated
15683 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
15684 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
15686 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
15688 o->op_next = ((LOGOP*)o->op_next)->op_other;
15690 DEFER(cLOGOP->op_other);
15695 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15696 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15705 case OP_ARGDEFELEM:
15706 while (cLOGOP->op_other->op_type == OP_NULL)
15707 cLOGOP->op_other = cLOGOP->op_other->op_next;
15708 DEFER(cLOGOP->op_other);
15713 while (cLOOP->op_redoop->op_type == OP_NULL)
15714 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
15715 while (cLOOP->op_nextop->op_type == OP_NULL)
15716 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
15717 while (cLOOP->op_lastop->op_type == OP_NULL)
15718 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
15719 /* a while(1) loop doesn't have an op_next that escapes the
15720 * loop, so we have to explicitly follow the op_lastop to
15721 * process the rest of the code */
15722 DEFER(cLOOP->op_lastop);
15726 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
15727 DEFER(cLOGOPo->op_other);
15731 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15732 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15733 assert(!(cPMOP->op_pmflags & PMf_ONCE));
15734 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
15735 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
15736 cPMOP->op_pmstashstartu.op_pmreplstart
15737 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
15738 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
15744 if (o->op_flags & OPf_SPECIAL) {
15745 /* first arg is a code block */
15746 OP * const nullop = OpSIBLING(cLISTOP->op_first);
15747 OP * kid = cUNOPx(nullop)->op_first;
15749 assert(nullop->op_type == OP_NULL);
15750 assert(kid->op_type == OP_SCOPE
15751 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
15752 /* since OP_SORT doesn't have a handy op_other-style
15753 * field that can point directly to the start of the code
15754 * block, store it in the otherwise-unused op_next field
15755 * of the top-level OP_NULL. This will be quicker at
15756 * run-time, and it will also allow us to remove leading
15757 * OP_NULLs by just messing with op_nexts without
15758 * altering the basic op_first/op_sibling layout. */
15759 kid = kLISTOP->op_first;
15761 (kid->op_type == OP_NULL
15762 && ( kid->op_targ == OP_NEXTSTATE
15763 || kid->op_targ == OP_DBSTATE ))
15764 || kid->op_type == OP_STUB
15765 || kid->op_type == OP_ENTER
15766 || (PL_parser && PL_parser->error_count));
15767 nullop->op_next = kid->op_next;
15768 DEFER(nullop->op_next);
15771 /* check that RHS of sort is a single plain array */
15772 oright = cUNOPo->op_first;
15773 if (!oright || oright->op_type != OP_PUSHMARK)
15776 if (o->op_private & OPpSORT_INPLACE)
15779 /* reverse sort ... can be optimised. */
15780 if (!OpHAS_SIBLING(cUNOPo)) {
15781 /* Nothing follows us on the list. */
15782 OP * const reverse = o->op_next;
15784 if (reverse->op_type == OP_REVERSE &&
15785 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
15786 OP * const pushmark = cUNOPx(reverse)->op_first;
15787 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
15788 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
15789 /* reverse -> pushmark -> sort */
15790 o->op_private |= OPpSORT_REVERSE;
15792 pushmark->op_next = oright->op_next;
15802 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
15804 LISTOP *enter, *exlist;
15806 if (o->op_private & OPpSORT_INPLACE)
15809 enter = (LISTOP *) o->op_next;
15812 if (enter->op_type == OP_NULL) {
15813 enter = (LISTOP *) enter->op_next;
15817 /* for $a (...) will have OP_GV then OP_RV2GV here.
15818 for (...) just has an OP_GV. */
15819 if (enter->op_type == OP_GV) {
15820 gvop = (OP *) enter;
15821 enter = (LISTOP *) enter->op_next;
15824 if (enter->op_type == OP_RV2GV) {
15825 enter = (LISTOP *) enter->op_next;
15831 if (enter->op_type != OP_ENTERITER)
15834 iter = enter->op_next;
15835 if (!iter || iter->op_type != OP_ITER)
15838 expushmark = enter->op_first;
15839 if (!expushmark || expushmark->op_type != OP_NULL
15840 || expushmark->op_targ != OP_PUSHMARK)
15843 exlist = (LISTOP *) OpSIBLING(expushmark);
15844 if (!exlist || exlist->op_type != OP_NULL
15845 || exlist->op_targ != OP_LIST)
15848 if (exlist->op_last != o) {
15849 /* Mmm. Was expecting to point back to this op. */
15852 theirmark = exlist->op_first;
15853 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
15856 if (OpSIBLING(theirmark) != o) {
15857 /* There's something between the mark and the reverse, eg
15858 for (1, reverse (...))
15863 ourmark = ((LISTOP *)o)->op_first;
15864 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
15867 ourlast = ((LISTOP *)o)->op_last;
15868 if (!ourlast || ourlast->op_next != o)
15871 rv2av = OpSIBLING(ourmark);
15872 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
15873 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
15874 /* We're just reversing a single array. */
15875 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
15876 enter->op_flags |= OPf_STACKED;
15879 /* We don't have control over who points to theirmark, so sacrifice
15881 theirmark->op_next = ourmark->op_next;
15882 theirmark->op_flags = ourmark->op_flags;
15883 ourlast->op_next = gvop ? gvop : (OP *) enter;
15886 enter->op_private |= OPpITER_REVERSED;
15887 iter->op_private |= OPpITER_REVERSED;
15891 o = oldop->op_next;
15893 NOT_REACHED; /* NOTREACHED */
15899 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
15900 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
15905 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
15906 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
15909 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
15911 sv = newRV((SV *)PL_compcv);
15915 OpTYPE_set(o, OP_CONST);
15916 o->op_flags |= OPf_SPECIAL;
15917 cSVOPo->op_sv = sv;
15922 if (OP_GIMME(o,0) == G_VOID
15923 || ( o->op_next->op_type == OP_LINESEQ
15924 && ( o->op_next->op_next->op_type == OP_LEAVESUB
15925 || ( o->op_next->op_next->op_type == OP_RETURN
15926 && !CvLVALUE(PL_compcv)))))
15928 OP *right = cBINOP->op_first;
15947 OP *left = OpSIBLING(right);
15948 if (left->op_type == OP_SUBSTR
15949 && (left->op_private & 7) < 4) {
15951 /* cut out right */
15952 op_sibling_splice(o, NULL, 1, NULL);
15953 /* and insert it as second child of OP_SUBSTR */
15954 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
15956 left->op_private |= OPpSUBSTR_REPL_FIRST;
15958 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15965 int l, r, lr, lscalars, rscalars;
15967 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
15968 Note that we do this now rather than in newASSIGNOP(),
15969 since only by now are aliased lexicals flagged as such
15971 See the essay "Common vars in list assignment" above for
15972 the full details of the rationale behind all the conditions
15975 PL_generation sorcery:
15976 To detect whether there are common vars, the global var
15977 PL_generation is incremented for each assign op we scan.
15978 Then we run through all the lexical variables on the LHS,
15979 of the assignment, setting a spare slot in each of them to
15980 PL_generation. Then we scan the RHS, and if any lexicals
15981 already have that value, we know we've got commonality.
15982 Also, if the generation number is already set to
15983 PERL_INT_MAX, then the variable is involved in aliasing, so
15984 we also have potential commonality in that case.
15990 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
15993 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
15997 /* After looking for things which are *always* safe, this main
15998 * if/else chain selects primarily based on the type of the
15999 * LHS, gradually working its way down from the more dangerous
16000 * to the more restrictive and thus safer cases */
16002 if ( !l /* () = ....; */
16003 || !r /* .... = (); */
16004 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16005 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16006 || (lscalars < 2) /* ($x, undef) = ... */
16008 NOOP; /* always safe */
16010 else if (l & AAS_DANGEROUS) {
16011 /* always dangerous */
16012 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16013 o->op_private |= OPpASSIGN_COMMON_AGG;
16015 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16016 /* package vars are always dangerous - too many
16017 * aliasing possibilities */
16018 if (l & AAS_PKG_SCALAR)
16019 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16020 if (l & AAS_PKG_AGG)
16021 o->op_private |= OPpASSIGN_COMMON_AGG;
16023 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16024 |AAS_LEX_SCALAR|AAS_LEX_AGG))
16026 /* LHS contains only lexicals and safe ops */
16028 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16029 o->op_private |= OPpASSIGN_COMMON_AGG;
16031 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16032 if (lr & AAS_LEX_SCALAR_COMM)
16033 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16034 else if ( !(l & AAS_LEX_SCALAR)
16035 && (r & AAS_DEFAV))
16039 * as scalar-safe for performance reasons.
16040 * (it will still have been marked _AGG if necessary */
16043 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16044 /* if there are only lexicals on the LHS and no
16045 * common ones on the RHS, then we assume that the
16046 * only way those lexicals could also get
16047 * on the RHS is via some sort of dereffing or
16050 * ($lex, $x) = (1, $$r)
16051 * and in this case we assume the var must have
16052 * a bumped ref count. So if its ref count is 1,
16053 * it must only be on the LHS.
16055 o->op_private |= OPpASSIGN_COMMON_RC1;
16060 * may have to handle aggregate on LHS, but we can't
16061 * have common scalars. */
16064 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16066 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16067 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16072 /* see if ref() is used in boolean context */
16073 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16074 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16078 /* see if the op is used in known boolean context,
16079 * but not if OA_TARGLEX optimisation is enabled */
16080 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16081 && !(o->op_private & OPpTARGET_MY)
16083 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16087 /* see if the op is used in known boolean context */
16088 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16089 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16093 Perl_cpeep_t cpeep =
16094 XopENTRYCUSTOM(o, xop_peep);
16096 cpeep(aTHX_ o, oldop);
16101 /* did we just null the current op? If so, re-process it to handle
16102 * eliding "empty" ops from the chain */
16103 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16116 Perl_peep(pTHX_ OP *o)
16122 =head1 Custom Operators
16124 =for apidoc Ao||custom_op_xop
16125 Return the XOP structure for a given custom op. This macro should be
16126 considered internal to C<OP_NAME> and the other access macros: use them instead.
16127 This macro does call a function. Prior
16128 to 5.19.6, this was implemented as a
16135 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16141 static const XOP xop_null = { 0, 0, 0, 0, 0 };
16143 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16144 assert(o->op_type == OP_CUSTOM);
16146 /* This is wrong. It assumes a function pointer can be cast to IV,
16147 * which isn't guaranteed, but this is what the old custom OP code
16148 * did. In principle it should be safer to Copy the bytes of the
16149 * pointer into a PV: since the new interface is hidden behind
16150 * functions, this can be changed later if necessary. */
16151 /* Change custom_op_xop if this ever happens */
16152 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16155 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16157 /* assume noone will have just registered a desc */
16158 if (!he && PL_custom_op_names &&
16159 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16164 /* XXX does all this need to be shared mem? */
16165 Newxz(xop, 1, XOP);
16166 pv = SvPV(HeVAL(he), l);
16167 XopENTRY_set(xop, xop_name, savepvn(pv, l));
16168 if (PL_custom_op_descs &&
16169 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16171 pv = SvPV(HeVAL(he), l);
16172 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16174 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16178 xop = (XOP *)&xop_null;
16180 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16184 if(field == XOPe_xop_ptr) {
16187 const U32 flags = XopFLAGS(xop);
16188 if(flags & field) {
16190 case XOPe_xop_name:
16191 any.xop_name = xop->xop_name;
16193 case XOPe_xop_desc:
16194 any.xop_desc = xop->xop_desc;
16196 case XOPe_xop_class:
16197 any.xop_class = xop->xop_class;
16199 case XOPe_xop_peep:
16200 any.xop_peep = xop->xop_peep;
16203 NOT_REACHED; /* NOTREACHED */
16208 case XOPe_xop_name:
16209 any.xop_name = XOPd_xop_name;
16211 case XOPe_xop_desc:
16212 any.xop_desc = XOPd_xop_desc;
16214 case XOPe_xop_class:
16215 any.xop_class = XOPd_xop_class;
16217 case XOPe_xop_peep:
16218 any.xop_peep = XOPd_xop_peep;
16221 NOT_REACHED; /* NOTREACHED */
16226 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16227 * op.c: In function 'Perl_custom_op_get_field':
16228 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16229 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16230 * expands to assert(0), which expands to ((0) ? (void)0 :
16231 * __assert(...)), and gcc doesn't know that __assert can never return. */
16237 =for apidoc Ao||custom_op_register
16238 Register a custom op. See L<perlguts/"Custom Operators">.
16244 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16248 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16250 /* see the comment in custom_op_xop */
16251 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16253 if (!PL_custom_ops)
16254 PL_custom_ops = newHV();
16256 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16257 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16262 =for apidoc core_prototype
16264 This function assigns the prototype of the named core function to C<sv>, or
16265 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
16266 C<NULL> if the core function has no prototype. C<code> is a code as returned
16267 by C<keyword()>. It must not be equal to 0.
16273 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16276 int i = 0, n = 0, seen_question = 0, defgv = 0;
16278 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16279 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16280 bool nullret = FALSE;
16282 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16286 if (!sv) sv = sv_newmortal();
16288 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16290 switch (code < 0 ? -code : code) {
16291 case KEY_and : case KEY_chop: case KEY_chomp:
16292 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
16293 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
16294 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
16295 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
16296 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
16297 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
16298 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
16299 case KEY_x : case KEY_xor :
16300 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16301 case KEY_glob: retsetpvs("_;", OP_GLOB);
16302 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
16303 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
16304 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
16305 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
16306 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16308 case KEY_evalbytes:
16309 name = "entereval"; break;
16317 while (i < MAXO) { /* The slow way. */
16318 if (strEQ(name, PL_op_name[i])
16319 || strEQ(name, PL_op_desc[i]))
16321 if (nullret) { assert(opnum); *opnum = i; return NULL; }
16328 defgv = PL_opargs[i] & OA_DEFGV;
16329 oa = PL_opargs[i] >> OASHIFT;
16331 if (oa & OA_OPTIONAL && !seen_question && (
16332 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16337 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16338 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16339 /* But globs are already references (kinda) */
16340 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16344 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16345 && !scalar_mod_type(NULL, i)) {
16350 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16354 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16355 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16356 str[n-1] = '_'; defgv = 0;
16360 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16362 sv_setpvn(sv, str, n - 1);
16363 if (opnum) *opnum = i;
16368 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16371 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16374 PERL_ARGS_ASSERT_CORESUB_OP;
16378 return op_append_elem(OP_LINESEQ,
16381 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16388 o = newUNOP(OP_AVHVSWITCH,0,argop);
16389 o->op_private = opnum-OP_EACH;
16391 case OP_SELECT: /* which represents OP_SSELECT as well */
16396 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16397 newSVOP(OP_CONST, 0, newSVuv(1))
16399 coresub_op(newSVuv((UV)OP_SSELECT), 0,
16401 coresub_op(coreargssv, 0, OP_SELECT)
16405 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16407 return op_append_elem(
16410 opnum == OP_WANTARRAY || opnum == OP_RUNCV
16411 ? OPpOFFBYONE << 8 : 0)
16413 case OA_BASEOP_OR_UNOP:
16414 if (opnum == OP_ENTEREVAL) {
16415 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16416 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16418 else o = newUNOP(opnum,0,argop);
16419 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16422 if (is_handle_constructor(o, 1))
16423 argop->op_private |= OPpCOREARGS_DEREF1;
16424 if (scalar_mod_type(NULL, opnum))
16425 argop->op_private |= OPpCOREARGS_SCALARMOD;
16429 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16430 if (is_handle_constructor(o, 2))
16431 argop->op_private |= OPpCOREARGS_DEREF2;
16432 if (opnum == OP_SUBSTR) {
16433 o->op_private |= OPpMAYBE_LVSUB;
16442 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16443 SV * const *new_const_svp)
16445 const char *hvname;
16446 bool is_const = !!CvCONST(old_cv);
16447 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16449 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16451 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16453 /* They are 2 constant subroutines generated from
16454 the same constant. This probably means that
16455 they are really the "same" proxy subroutine
16456 instantiated in 2 places. Most likely this is
16457 when a constant is exported twice. Don't warn.
16460 (ckWARN(WARN_REDEFINE)
16462 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16463 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16464 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16465 strEQ(hvname, "autouse"))
16469 && ckWARN_d(WARN_REDEFINE)
16470 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16473 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16475 ? "Constant subroutine %" SVf " redefined"
16476 : "Subroutine %" SVf " redefined",
16481 =head1 Hook manipulation
16483 These functions provide convenient and thread-safe means of manipulating
16490 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16492 Puts a C function into the chain of check functions for a specified op
16493 type. This is the preferred way to manipulate the L</PL_check> array.
16494 C<opcode> specifies which type of op is to be affected. C<new_checker>
16495 is a pointer to the C function that is to be added to that opcode's
16496 check chain, and C<old_checker_p> points to the storage location where a
16497 pointer to the next function in the chain will be stored. The value of
16498 C<new_checker> is written into the L</PL_check> array, while the value
16499 previously stored there is written to C<*old_checker_p>.
16501 L</PL_check> is global to an entire process, and a module wishing to
16502 hook op checking may find itself invoked more than once per process,
16503 typically in different threads. To handle that situation, this function
16504 is idempotent. The location C<*old_checker_p> must initially (once
16505 per process) contain a null pointer. A C variable of static duration
16506 (declared at file scope, typically also marked C<static> to give
16507 it internal linkage) will be implicitly initialised appropriately,
16508 if it does not have an explicit initialiser. This function will only
16509 actually modify the check chain if it finds C<*old_checker_p> to be null.
16510 This function is also thread safe on the small scale. It uses appropriate
16511 locking to avoid race conditions in accessing L</PL_check>.
16513 When this function is called, the function referenced by C<new_checker>
16514 must be ready to be called, except for C<*old_checker_p> being unfilled.
16515 In a threading situation, C<new_checker> may be called immediately,
16516 even before this function has returned. C<*old_checker_p> will always
16517 be appropriately set before C<new_checker> is called. If C<new_checker>
16518 decides not to do anything special with an op that it is given (which
16519 is the usual case for most uses of op check hooking), it must chain the
16520 check function referenced by C<*old_checker_p>.
16522 Taken all together, XS code to hook an op checker should typically look
16523 something like this:
16525 static Perl_check_t nxck_frob;
16526 static OP *myck_frob(pTHX_ OP *op) {
16528 op = nxck_frob(aTHX_ op);
16533 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
16535 If you want to influence compilation of calls to a specific subroutine,
16536 then use L</cv_set_call_checker_flags> rather than hooking checking of
16537 all C<entersub> ops.
16543 Perl_wrap_op_checker(pTHX_ Optype opcode,
16544 Perl_check_t new_checker, Perl_check_t *old_checker_p)
16548 PERL_UNUSED_CONTEXT;
16549 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
16550 if (*old_checker_p) return;
16551 OP_CHECK_MUTEX_LOCK;
16552 if (!*old_checker_p) {
16553 *old_checker_p = PL_check[opcode];
16554 PL_check[opcode] = new_checker;
16556 OP_CHECK_MUTEX_UNLOCK;
16561 /* Efficient sub that returns a constant scalar value. */
16563 const_sv_xsub(pTHX_ CV* cv)
16566 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
16567 PERL_UNUSED_ARG(items);
16577 const_av_xsub(pTHX_ CV* cv)
16580 AV * const av = MUTABLE_AV(XSANY.any_ptr);
16588 if (SvRMAGICAL(av))
16589 Perl_croak(aTHX_ "Magical list constants are not supported");
16590 if (GIMME_V != G_ARRAY) {
16592 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
16595 EXTEND(SP, AvFILLp(av)+1);
16596 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
16597 XSRETURN(AvFILLp(av)+1);
16602 * ex: set ts=8 sts=4 sw=4 et: