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
423 Perl_Slab_Free(pTHX_ void *op)
425 OP * const o = (OP *)op;
428 PERL_ARGS_ASSERT_SLAB_FREE;
430 if (!o->op_slabbed) {
432 PerlMemShared_free(op);
437 /* If this op is already freed, our refcount will get screwy. */
438 assert(o->op_type != OP_FREED);
439 o->op_type = OP_FREED;
440 o->op_next = slab->opslab_freed;
441 slab->opslab_freed = o;
442 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
443 OpslabREFCNT_dec_padok(slab);
447 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
449 const bool havepad = !!PL_comppad;
450 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
453 PAD_SAVE_SETNULLPAD();
460 Perl_opslab_free(pTHX_ OPSLAB *slab)
463 PERL_ARGS_ASSERT_OPSLAB_FREE;
465 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
466 assert(slab->opslab_refcnt == 1);
468 slab2 = slab->opslab_next;
470 slab->opslab_refcnt = ~(size_t)0;
472 #ifdef PERL_DEBUG_READONLY_OPS
473 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
475 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
476 perror("munmap failed");
480 PerlMemShared_free(slab);
487 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
492 size_t savestack_count = 0;
494 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
497 for (slot = slab2->opslab_first;
499 slot = slot->opslot_next) {
500 if (slot->opslot_op.op_type != OP_FREED
501 && !(slot->opslot_op.op_savefree
507 assert(slot->opslot_op.op_slabbed);
508 op_free(&slot->opslot_op);
509 if (slab->opslab_refcnt == 1) goto free;
512 } while ((slab2 = slab2->opslab_next));
513 /* > 1 because the CV still holds a reference count. */
514 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
516 assert(savestack_count == slab->opslab_refcnt-1);
518 /* Remove the CV’s reference count. */
519 slab->opslab_refcnt--;
526 #ifdef PERL_DEBUG_READONLY_OPS
528 Perl_op_refcnt_inc(pTHX_ OP *o)
531 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
532 if (slab && slab->opslab_readonly) {
545 Perl_op_refcnt_dec(pTHX_ OP *o)
548 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
550 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
552 if (slab && slab->opslab_readonly) {
554 result = --o->op_targ;
557 result = --o->op_targ;
563 * In the following definition, the ", (OP*)0" is just to make the compiler
564 * think the expression is of the right type: croak actually does a Siglongjmp.
566 #define CHECKOP(type,o) \
567 ((PL_op_mask && PL_op_mask[type]) \
568 ? ( op_free((OP*)o), \
569 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
571 : PL_check[type](aTHX_ (OP*)o))
573 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
575 #define OpTYPE_set(o,type) \
577 o->op_type = (OPCODE)type; \
578 o->op_ppaddr = PL_ppaddr[type]; \
582 S_no_fh_allowed(pTHX_ OP *o)
584 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
586 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
592 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
594 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
595 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
600 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
602 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
604 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
609 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
611 PERL_ARGS_ASSERT_BAD_TYPE_PV;
613 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
614 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
617 /* remove flags var, its unused in all callers, move to to right end since gv
618 and kid are always the same */
620 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
622 SV * const namesv = cv_name((CV *)gv, NULL, 0);
623 PERL_ARGS_ASSERT_BAD_TYPE_GV;
625 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
626 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
630 S_no_bareword_allowed(pTHX_ OP *o)
632 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
634 qerror(Perl_mess(aTHX_
635 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
637 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
640 /* "register" allocation */
643 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
646 const bool is_our = (PL_parser->in_my == KEY_our);
648 PERL_ARGS_ASSERT_ALLOCMY;
650 if (flags & ~SVf_UTF8)
651 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
654 /* complain about "my $<special_var>" etc etc */
658 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
659 (name[1] == '_' && len > 2)))
661 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
663 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
664 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
665 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
666 PL_parser->in_my == KEY_state ? "state" : "my"));
668 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
669 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
673 /* allocate a spare slot and store the name in that slot */
675 off = pad_add_name_pvn(name, len,
676 (is_our ? padadd_OUR :
677 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
678 PL_parser->in_my_stash,
680 /* $_ is always in main::, even with our */
681 ? (PL_curstash && !memEQs(name,len,"$_")
687 /* anon sub prototypes contains state vars should always be cloned,
688 * otherwise the state var would be shared between anon subs */
690 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
691 CvCLONE_on(PL_compcv);
697 =head1 Optree Manipulation Functions
699 =for apidoc alloccopstash
701 Available only under threaded builds, this function allocates an entry in
702 C<PL_stashpad> for the stash passed to it.
709 Perl_alloccopstash(pTHX_ HV *hv)
711 PADOFFSET off = 0, o = 1;
712 bool found_slot = FALSE;
714 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
716 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
718 for (; o < PL_stashpadmax; ++o) {
719 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
720 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
721 found_slot = TRUE, off = o;
724 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
725 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
726 off = PL_stashpadmax;
727 PL_stashpadmax += 10;
730 PL_stashpad[PL_stashpadix = off] = hv;
735 /* free the body of an op without examining its contents.
736 * Always use this rather than FreeOp directly */
739 S_op_destroy(pTHX_ OP *o)
747 =for apidoc Am|void|op_free|OP *o
749 Free an op. Only use this when an op is no longer linked to from any
756 Perl_op_free(pTHX_ OP *o)
760 SSize_t defer_ix = -1;
761 SSize_t defer_stack_alloc = 0;
762 OP **defer_stack = NULL;
766 /* Though ops may be freed twice, freeing the op after its slab is a
768 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
769 /* During the forced freeing of ops after compilation failure, kidops
770 may be freed before their parents. */
771 if (!o || o->op_type == OP_FREED)
776 /* an op should only ever acquire op_private flags that we know about.
777 * If this fails, you may need to fix something in regen/op_private.
778 * Don't bother testing if:
779 * * the op_ppaddr doesn't match the op; someone may have
780 * overridden the op and be doing strange things with it;
781 * * we've errored, as op flags are often left in an
782 * inconsistent state then. Note that an error when
783 * compiling the main program leaves PL_parser NULL, so
784 * we can't spot faults in the main code, only
785 * evaled/required code */
787 if ( o->op_ppaddr == PL_ppaddr[o->op_type]
789 && !PL_parser->error_count)
791 assert(!(o->op_private & ~PL_op_private_valid[type]));
795 if (o->op_private & OPpREFCOUNTED) {
806 refcnt = OpREFCNT_dec(o);
809 /* Need to find and remove any pattern match ops from the list
810 we maintain for reset(). */
811 find_and_forget_pmops(o);
821 /* Call the op_free hook if it has been set. Do it now so that it's called
822 * at the right time for refcounted ops, but still before all of the kids
826 if (o->op_flags & OPf_KIDS) {
828 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
829 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
830 if (!kid || kid->op_type == OP_FREED)
831 /* During the forced freeing of ops after
832 compilation failure, kidops may be freed before
835 if (!(kid->op_flags & OPf_KIDS))
836 /* If it has no kids, just free it now */
843 type = (OPCODE)o->op_targ;
846 Slab_to_rw(OpSLAB(o));
848 /* COP* is not cleared by op_clear() so that we may track line
849 * numbers etc even after null() */
850 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
858 } while ( (o = POP_DEFERRED_OP()) );
860 Safefree(defer_stack);
863 /* S_op_clear_gv(): free a GV attached to an OP */
867 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
869 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
873 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
874 || o->op_type == OP_MULTIDEREF)
877 ? ((GV*)PAD_SVl(*ixp)) : NULL;
879 ? (GV*)(*svp) : NULL;
881 /* It's possible during global destruction that the GV is freed
882 before the optree. Whilst the SvREFCNT_inc is happy to bump from
883 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
884 will trigger an assertion failure, because the entry to sv_clear
885 checks that the scalar is not already freed. A check of for
886 !SvIS_FREED(gv) turns out to be invalid, because during global
887 destruction the reference count can be forced down to zero
888 (with SVf_BREAK set). In which case raising to 1 and then
889 dropping to 0 triggers cleanup before it should happen. I
890 *think* that this might actually be a general, systematic,
891 weakness of the whole idea of SVf_BREAK, in that code *is*
892 allowed to raise and lower references during global destruction,
893 so any *valid* code that happens to do this during global
894 destruction might well trigger premature cleanup. */
895 bool still_valid = gv && SvREFCNT(gv);
898 SvREFCNT_inc_simple_void(gv);
901 pad_swipe(*ixp, TRUE);
909 int try_downgrade = SvREFCNT(gv) == 2;
912 gv_try_downgrade(gv);
918 Perl_op_clear(pTHX_ OP *o)
923 PERL_ARGS_ASSERT_OP_CLEAR;
925 switch (o->op_type) {
926 case OP_NULL: /* Was holding old type, if any. */
929 case OP_ENTEREVAL: /* Was holding hints. */
930 case OP_ARGDEFELEM: /* Was holding signature index. */
934 if (!(o->op_flags & OPf_REF)
935 || (PL_check[o->op_type] != Perl_ck_ftst))
942 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
944 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
947 case OP_METHOD_REDIR:
948 case OP_METHOD_REDIR_SUPER:
950 if (cMETHOPx(o)->op_rclass_targ) {
951 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
952 cMETHOPx(o)->op_rclass_targ = 0;
955 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
956 cMETHOPx(o)->op_rclass_sv = NULL;
958 case OP_METHOD_NAMED:
959 case OP_METHOD_SUPER:
960 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
961 cMETHOPx(o)->op_u.op_meth_sv = NULL;
964 pad_swipe(o->op_targ, 1);
971 SvREFCNT_dec(cSVOPo->op_sv);
972 cSVOPo->op_sv = NULL;
975 Even if op_clear does a pad_free for the target of the op,
976 pad_free doesn't actually remove the sv that exists in the pad;
977 instead it lives on. This results in that it could be reused as
978 a target later on when the pad was reallocated.
981 pad_swipe(o->op_targ,1);
991 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
996 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
997 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
999 if (cPADOPo->op_padix > 0) {
1000 pad_swipe(cPADOPo->op_padix, TRUE);
1001 cPADOPo->op_padix = 0;
1004 SvREFCNT_dec(cSVOPo->op_sv);
1005 cSVOPo->op_sv = NULL;
1009 PerlMemShared_free(cPVOPo->op_pv);
1010 cPVOPo->op_pv = NULL;
1014 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1018 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1019 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1021 if (o->op_private & OPpSPLIT_LEX)
1022 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1025 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1027 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1034 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1035 op_free(cPMOPo->op_code_list);
1036 cPMOPo->op_code_list = NULL;
1037 forget_pmop(cPMOPo);
1038 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1039 /* we use the same protection as the "SAFE" version of the PM_ macros
1040 * here since sv_clean_all might release some PMOPs
1041 * after PL_regex_padav has been cleared
1042 * and the clearing of PL_regex_padav needs to
1043 * happen before sv_clean_all
1046 if(PL_regex_pad) { /* We could be in destruction */
1047 const IV offset = (cPMOPo)->op_pmoffset;
1048 ReREFCNT_dec(PM_GETRE(cPMOPo));
1049 PL_regex_pad[offset] = &PL_sv_undef;
1050 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1054 ReREFCNT_dec(PM_GETRE(cPMOPo));
1055 PM_SETRE(cPMOPo, NULL);
1061 PerlMemShared_free(cUNOP_AUXo->op_aux);
1066 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1067 UV actions = items->uv;
1069 bool is_hash = FALSE;
1072 switch (actions & MDEREF_ACTION_MASK) {
1075 actions = (++items)->uv;
1078 case MDEREF_HV_padhv_helem:
1080 case MDEREF_AV_padav_aelem:
1081 pad_free((++items)->pad_offset);
1084 case MDEREF_HV_gvhv_helem:
1086 case MDEREF_AV_gvav_aelem:
1088 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1090 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1094 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1096 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1098 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1100 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1102 goto do_vivify_rv2xv_elem;
1104 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1106 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1107 pad_free((++items)->pad_offset);
1108 goto do_vivify_rv2xv_elem;
1110 case MDEREF_HV_pop_rv2hv_helem:
1111 case MDEREF_HV_vivify_rv2hv_helem:
1113 do_vivify_rv2xv_elem:
1114 case MDEREF_AV_pop_rv2av_aelem:
1115 case MDEREF_AV_vivify_rv2av_aelem:
1117 switch (actions & MDEREF_INDEX_MASK) {
1118 case MDEREF_INDEX_none:
1121 case MDEREF_INDEX_const:
1125 pad_swipe((++items)->pad_offset, 1);
1127 SvREFCNT_dec((++items)->sv);
1133 case MDEREF_INDEX_padsv:
1134 pad_free((++items)->pad_offset);
1136 case MDEREF_INDEX_gvsv:
1138 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1140 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1145 if (actions & MDEREF_FLAG_last)
1158 actions >>= MDEREF_SHIFT;
1161 /* start of malloc is at op_aux[-1], where the length is
1163 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1168 if (o->op_targ > 0) {
1169 pad_free(o->op_targ);
1175 S_cop_free(pTHX_ COP* cop)
1177 PERL_ARGS_ASSERT_COP_FREE;
1180 if (! specialWARN(cop->cop_warnings))
1181 PerlMemShared_free(cop->cop_warnings);
1182 cophh_free(CopHINTHASH_get(cop));
1183 if (PL_curcop == cop)
1188 S_forget_pmop(pTHX_ PMOP *const o
1191 HV * const pmstash = PmopSTASH(o);
1193 PERL_ARGS_ASSERT_FORGET_PMOP;
1195 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1196 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1198 PMOP **const array = (PMOP**) mg->mg_ptr;
1199 U32 count = mg->mg_len / sizeof(PMOP**);
1203 if (array[i] == o) {
1204 /* Found it. Move the entry at the end to overwrite it. */
1205 array[i] = array[--count];
1206 mg->mg_len = count * sizeof(PMOP**);
1207 /* Could realloc smaller at this point always, but probably
1208 not worth it. Probably worth free()ing if we're the
1211 Safefree(mg->mg_ptr);
1224 S_find_and_forget_pmops(pTHX_ OP *o)
1226 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1228 if (o->op_flags & OPf_KIDS) {
1229 OP *kid = cUNOPo->op_first;
1231 switch (kid->op_type) {
1236 forget_pmop((PMOP*)kid);
1238 find_and_forget_pmops(kid);
1239 kid = OpSIBLING(kid);
1245 =for apidoc Am|void|op_null|OP *o
1247 Neutralizes an op when it is no longer needed, but is still linked to from
1254 Perl_op_null(pTHX_ OP *o)
1258 PERL_ARGS_ASSERT_OP_NULL;
1260 if (o->op_type == OP_NULL)
1263 o->op_targ = o->op_type;
1264 OpTYPE_set(o, OP_NULL);
1268 Perl_op_refcnt_lock(pTHX)
1269 PERL_TSA_ACQUIRE(PL_op_mutex)
1274 PERL_UNUSED_CONTEXT;
1279 Perl_op_refcnt_unlock(pTHX)
1280 PERL_TSA_RELEASE(PL_op_mutex)
1285 PERL_UNUSED_CONTEXT;
1291 =for apidoc op_sibling_splice
1293 A general function for editing the structure of an existing chain of
1294 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1295 you to delete zero or more sequential nodes, replacing them with zero or
1296 more different nodes. Performs the necessary op_first/op_last
1297 housekeeping on the parent node and op_sibling manipulation on the
1298 children. The last deleted node will be marked as as the last node by
1299 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1301 Note that op_next is not manipulated, and nodes are not freed; that is the
1302 responsibility of the caller. It also won't create a new list op for an
1303 empty list etc; use higher-level functions like op_append_elem() for that.
1305 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1306 the splicing doesn't affect the first or last op in the chain.
1308 C<start> is the node preceding the first node to be spliced. Node(s)
1309 following it will be deleted, and ops will be inserted after it. If it is
1310 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1313 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1314 If -1 or greater than or equal to the number of remaining kids, all
1315 remaining kids are deleted.
1317 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1318 If C<NULL>, no nodes are inserted.
1320 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1325 action before after returns
1326 ------ ----- ----- -------
1329 splice(P, A, 2, X-Y-Z) | | B-C
1333 splice(P, NULL, 1, X-Y) | | A
1337 splice(P, NULL, 3, NULL) | | A-B-C
1341 splice(P, B, 0, X-Y) | | NULL
1345 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1346 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1352 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1356 OP *last_del = NULL;
1357 OP *last_ins = NULL;
1360 first = OpSIBLING(start);
1364 first = cLISTOPx(parent)->op_first;
1366 assert(del_count >= -1);
1368 if (del_count && first) {
1370 while (--del_count && OpHAS_SIBLING(last_del))
1371 last_del = OpSIBLING(last_del);
1372 rest = OpSIBLING(last_del);
1373 OpLASTSIB_set(last_del, NULL);
1380 while (OpHAS_SIBLING(last_ins))
1381 last_ins = OpSIBLING(last_ins);
1382 OpMAYBESIB_set(last_ins, rest, NULL);
1388 OpMAYBESIB_set(start, insert, NULL);
1393 cLISTOPx(parent)->op_first = insert;
1395 parent->op_flags |= OPf_KIDS;
1397 parent->op_flags &= ~OPf_KIDS;
1401 /* update op_last etc */
1408 /* ought to use OP_CLASS(parent) here, but that can't handle
1409 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1411 type = parent->op_type;
1412 if (type == OP_CUSTOM) {
1414 type = XopENTRYCUSTOM(parent, xop_class);
1417 if (type == OP_NULL)
1418 type = parent->op_targ;
1419 type = PL_opargs[type] & OA_CLASS_MASK;
1422 lastop = last_ins ? last_ins : start ? start : NULL;
1423 if ( type == OA_BINOP
1424 || type == OA_LISTOP
1428 cLISTOPx(parent)->op_last = lastop;
1431 OpLASTSIB_set(lastop, parent);
1433 return last_del ? first : NULL;
1436 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1440 #ifdef PERL_OP_PARENT
1443 =for apidoc op_parent
1445 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1446 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1452 Perl_op_parent(OP *o)
1454 PERL_ARGS_ASSERT_OP_PARENT;
1455 while (OpHAS_SIBLING(o))
1457 return o->op_sibparent;
1463 /* replace the sibling following start with a new UNOP, which becomes
1464 * the parent of the original sibling; e.g.
1466 * op_sibling_newUNOP(P, A, unop-args...)
1474 * where U is the new UNOP.
1476 * parent and start args are the same as for op_sibling_splice();
1477 * type and flags args are as newUNOP().
1479 * Returns the new UNOP.
1483 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1487 kid = op_sibling_splice(parent, start, 1, NULL);
1488 newop = newUNOP(type, flags, kid);
1489 op_sibling_splice(parent, start, 0, newop);
1494 /* lowest-level newLOGOP-style function - just allocates and populates
1495 * the struct. Higher-level stuff should be done by S_new_logop() /
1496 * newLOGOP(). This function exists mainly to avoid op_first assignment
1497 * being spread throughout this file.
1501 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1506 NewOp(1101, logop, 1, LOGOP);
1507 OpTYPE_set(logop, type);
1508 logop->op_first = first;
1509 logop->op_other = other;
1510 logop->op_flags = OPf_KIDS;
1511 while (kid && OpHAS_SIBLING(kid))
1512 kid = OpSIBLING(kid);
1514 OpLASTSIB_set(kid, (OP*)logop);
1519 /* Contextualizers */
1522 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1524 Applies a syntactic context to an op tree representing an expression.
1525 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1526 or C<G_VOID> to specify the context to apply. The modified op tree
1533 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1535 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1537 case G_SCALAR: return scalar(o);
1538 case G_ARRAY: return list(o);
1539 case G_VOID: return scalarvoid(o);
1541 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1548 =for apidoc Am|OP*|op_linklist|OP *o
1549 This function is the implementation of the L</LINKLIST> macro. It should
1550 not be called directly.
1556 Perl_op_linklist(pTHX_ OP *o)
1560 PERL_ARGS_ASSERT_OP_LINKLIST;
1565 /* establish postfix order */
1566 first = cUNOPo->op_first;
1569 o->op_next = LINKLIST(first);
1572 OP *sibl = OpSIBLING(kid);
1574 kid->op_next = LINKLIST(sibl);
1589 S_scalarkids(pTHX_ OP *o)
1591 if (o && o->op_flags & OPf_KIDS) {
1593 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1600 S_scalarboolean(pTHX_ OP *o)
1602 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1604 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1605 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1606 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1607 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1608 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1609 if (ckWARN(WARN_SYNTAX)) {
1610 const line_t oldline = CopLINE(PL_curcop);
1612 if (PL_parser && PL_parser->copline != NOLINE) {
1613 /* This ensures that warnings are reported at the first line
1614 of the conditional, not the last. */
1615 CopLINE_set(PL_curcop, PL_parser->copline);
1617 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1618 CopLINE_set(PL_curcop, oldline);
1625 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1628 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1629 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1631 const char funny = o->op_type == OP_PADAV
1632 || o->op_type == OP_RV2AV ? '@' : '%';
1633 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1635 if (cUNOPo->op_first->op_type != OP_GV
1636 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1638 return varname(gv, funny, 0, NULL, 0, subscript_type);
1641 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1646 S_op_varname(pTHX_ const OP *o)
1648 return S_op_varname_subscript(aTHX_ o, 1);
1652 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1653 { /* or not so pretty :-) */
1654 if (o->op_type == OP_CONST) {
1656 if (SvPOK(*retsv)) {
1658 *retsv = sv_newmortal();
1659 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1660 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1662 else if (!SvOK(*retsv))
1665 else *retpv = "...";
1669 S_scalar_slice_warning(pTHX_ const OP *o)
1673 o->op_type == OP_HSLICE ? '{' : '[';
1675 o->op_type == OP_HSLICE ? '}' : ']';
1677 SV *keysv = NULL; /* just to silence compiler warnings */
1678 const char *key = NULL;
1680 if (!(o->op_private & OPpSLICEWARNING))
1682 if (PL_parser && PL_parser->error_count)
1683 /* This warning can be nonsensical when there is a syntax error. */
1686 kid = cLISTOPo->op_first;
1687 kid = OpSIBLING(kid); /* get past pushmark */
1688 /* weed out false positives: any ops that can return lists */
1689 switch (kid->op_type) {
1715 /* Don't warn if we have a nulled list either. */
1716 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1719 assert(OpSIBLING(kid));
1720 name = S_op_varname(aTHX_ OpSIBLING(kid));
1721 if (!name) /* XS module fiddling with the op tree */
1723 S_op_pretty(aTHX_ kid, &keysv, &key);
1724 assert(SvPOK(name));
1725 sv_chop(name,SvPVX(name)+1);
1727 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1728 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1729 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1731 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1732 lbrack, key, rbrack);
1734 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1735 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1736 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1738 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1739 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1743 Perl_scalar(pTHX_ OP *o)
1747 /* assumes no premature commitment */
1748 if (!o || (PL_parser && PL_parser->error_count)
1749 || (o->op_flags & OPf_WANT)
1750 || o->op_type == OP_RETURN)
1755 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1757 switch (o->op_type) {
1759 scalar(cBINOPo->op_first);
1760 if (o->op_private & OPpREPEAT_DOLIST) {
1761 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1762 assert(kid->op_type == OP_PUSHMARK);
1763 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1764 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1765 o->op_private &=~ OPpREPEAT_DOLIST;
1772 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1782 if (o->op_flags & OPf_KIDS) {
1783 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1789 kid = cLISTOPo->op_first;
1791 kid = OpSIBLING(kid);
1794 OP *sib = OpSIBLING(kid);
1795 if (sib && kid->op_type != OP_LEAVEWHEN
1796 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1797 || ( sib->op_targ != OP_NEXTSTATE
1798 && sib->op_targ != OP_DBSTATE )))
1804 PL_curcop = &PL_compiling;
1809 kid = cLISTOPo->op_first;
1812 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1817 /* Warn about scalar context */
1818 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1819 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1822 const char *key = NULL;
1824 /* This warning can be nonsensical when there is a syntax error. */
1825 if (PL_parser && PL_parser->error_count)
1828 if (!ckWARN(WARN_SYNTAX)) break;
1830 kid = cLISTOPo->op_first;
1831 kid = OpSIBLING(kid); /* get past pushmark */
1832 assert(OpSIBLING(kid));
1833 name = S_op_varname(aTHX_ OpSIBLING(kid));
1834 if (!name) /* XS module fiddling with the op tree */
1836 S_op_pretty(aTHX_ kid, &keysv, &key);
1837 assert(SvPOK(name));
1838 sv_chop(name,SvPVX(name)+1);
1840 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1841 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1842 "%%%" SVf "%c%s%c in scalar context better written "
1843 "as $%" SVf "%c%s%c",
1844 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1845 lbrack, key, rbrack);
1847 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1848 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1849 "%%%" SVf "%c%" SVf "%c in scalar context better "
1850 "written as $%" SVf "%c%" SVf "%c",
1851 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1852 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1859 Perl_scalarvoid(pTHX_ OP *arg)
1865 SSize_t defer_stack_alloc = 0;
1866 SSize_t defer_ix = -1;
1867 OP **defer_stack = NULL;
1870 PERL_ARGS_ASSERT_SCALARVOID;
1873 SV *useless_sv = NULL;
1874 const char* useless = NULL;
1876 if (o->op_type == OP_NEXTSTATE
1877 || o->op_type == OP_DBSTATE
1878 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1879 || o->op_targ == OP_DBSTATE)))
1880 PL_curcop = (COP*)o; /* for warning below */
1882 /* assumes no premature commitment */
1883 want = o->op_flags & OPf_WANT;
1884 if ((want && want != OPf_WANT_SCALAR)
1885 || (PL_parser && PL_parser->error_count)
1886 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1891 if ((o->op_private & OPpTARGET_MY)
1892 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1894 /* newASSIGNOP has already applied scalar context, which we
1895 leave, as if this op is inside SASSIGN. */
1899 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1901 switch (o->op_type) {
1903 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1907 if (o->op_flags & OPf_STACKED)
1909 if (o->op_type == OP_REPEAT)
1910 scalar(cBINOPo->op_first);
1913 if (o->op_private == 4)
1948 case OP_GETSOCKNAME:
1949 case OP_GETPEERNAME:
1954 case OP_GETPRIORITY:
1979 useless = OP_DESC(o);
1989 case OP_AELEMFAST_LEX:
1993 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1994 /* Otherwise it's "Useless use of grep iterator" */
1995 useless = OP_DESC(o);
1999 if (!(o->op_private & OPpSPLIT_ASSIGN))
2000 useless = OP_DESC(o);
2004 kid = cUNOPo->op_first;
2005 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2006 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2009 useless = "negative pattern binding (!~)";
2013 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2014 useless = "non-destructive substitution (s///r)";
2018 useless = "non-destructive transliteration (tr///r)";
2025 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2026 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2027 useless = "a variable";
2032 if (cSVOPo->op_private & OPpCONST_STRICT)
2033 no_bareword_allowed(o);
2035 if (ckWARN(WARN_VOID)) {
2037 /* don't warn on optimised away booleans, eg
2038 * use constant Foo, 5; Foo || print; */
2039 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2041 /* the constants 0 and 1 are permitted as they are
2042 conventionally used as dummies in constructs like
2043 1 while some_condition_with_side_effects; */
2044 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2046 else if (SvPOK(sv)) {
2047 SV * const dsv = newSVpvs("");
2049 = Perl_newSVpvf(aTHX_
2051 pv_pretty(dsv, SvPVX_const(sv),
2052 SvCUR(sv), 32, NULL, NULL,
2054 | PERL_PV_ESCAPE_NOCLEAR
2055 | PERL_PV_ESCAPE_UNI_DETECT));
2056 SvREFCNT_dec_NN(dsv);
2058 else if (SvOK(sv)) {
2059 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2062 useless = "a constant (undef)";
2065 op_null(o); /* don't execute or even remember it */
2069 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2073 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2077 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2081 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2086 UNOP *refgen, *rv2cv;
2089 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2092 rv2gv = ((BINOP *)o)->op_last;
2093 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2096 refgen = (UNOP *)((BINOP *)o)->op_first;
2098 if (!refgen || (refgen->op_type != OP_REFGEN
2099 && refgen->op_type != OP_SREFGEN))
2102 exlist = (LISTOP *)refgen->op_first;
2103 if (!exlist || exlist->op_type != OP_NULL
2104 || exlist->op_targ != OP_LIST)
2107 if (exlist->op_first->op_type != OP_PUSHMARK
2108 && exlist->op_first != exlist->op_last)
2111 rv2cv = (UNOP*)exlist->op_last;
2113 if (rv2cv->op_type != OP_RV2CV)
2116 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2117 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2118 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2120 o->op_private |= OPpASSIGN_CV_TO_GV;
2121 rv2gv->op_private |= OPpDONT_INIT_GV;
2122 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2134 kid = cLOGOPo->op_first;
2135 if (kid->op_type == OP_NOT
2136 && (kid->op_flags & OPf_KIDS)) {
2137 if (o->op_type == OP_AND) {
2138 OpTYPE_set(o, OP_OR);
2140 OpTYPE_set(o, OP_AND);
2150 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2151 if (!(kid->op_flags & OPf_KIDS))
2158 if (o->op_flags & OPf_STACKED)
2165 if (!(o->op_flags & OPf_KIDS))
2176 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2177 if (!(kid->op_flags & OPf_KIDS))
2183 /* If the first kid after pushmark is something that the padrange
2184 optimisation would reject, then null the list and the pushmark.
2186 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2187 && ( !(kid = OpSIBLING(kid))
2188 || ( kid->op_type != OP_PADSV
2189 && kid->op_type != OP_PADAV
2190 && kid->op_type != OP_PADHV)
2191 || kid->op_private & ~OPpLVAL_INTRO
2192 || !(kid = OpSIBLING(kid))
2193 || ( kid->op_type != OP_PADSV
2194 && kid->op_type != OP_PADAV
2195 && kid->op_type != OP_PADHV)
2196 || kid->op_private & ~OPpLVAL_INTRO)
2198 op_null(cUNOPo->op_first); /* NULL the pushmark */
2199 op_null(o); /* NULL the list */
2211 /* mortalise it, in case warnings are fatal. */
2212 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2213 "Useless use of %" SVf " in void context",
2214 SVfARG(sv_2mortal(useless_sv)));
2217 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2218 "Useless use of %s in void context",
2221 } while ( (o = POP_DEFERRED_OP()) );
2223 Safefree(defer_stack);
2229 S_listkids(pTHX_ OP *o)
2231 if (o && o->op_flags & OPf_KIDS) {
2233 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2240 Perl_list(pTHX_ OP *o)
2244 /* assumes no premature commitment */
2245 if (!o || (o->op_flags & OPf_WANT)
2246 || (PL_parser && PL_parser->error_count)
2247 || o->op_type == OP_RETURN)
2252 if ((o->op_private & OPpTARGET_MY)
2253 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2255 return o; /* As if inside SASSIGN */
2258 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2260 switch (o->op_type) {
2262 list(cBINOPo->op_first);
2265 if (o->op_private & OPpREPEAT_DOLIST
2266 && !(o->op_flags & OPf_STACKED))
2268 list(cBINOPo->op_first);
2269 kid = cBINOPo->op_last;
2270 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2271 && SvIVX(kSVOP_sv) == 1)
2273 op_null(o); /* repeat */
2274 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2276 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2283 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2291 if (!(o->op_flags & OPf_KIDS))
2293 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2294 list(cBINOPo->op_first);
2295 return gen_constant_list(o);
2301 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2302 op_null(cUNOPo->op_first); /* NULL the pushmark */
2303 op_null(o); /* NULL the list */
2308 kid = cLISTOPo->op_first;
2310 kid = OpSIBLING(kid);
2313 OP *sib = OpSIBLING(kid);
2314 if (sib && kid->op_type != OP_LEAVEWHEN)
2320 PL_curcop = &PL_compiling;
2324 kid = cLISTOPo->op_first;
2331 S_scalarseq(pTHX_ OP *o)
2334 const OPCODE type = o->op_type;
2336 if (type == OP_LINESEQ || type == OP_SCOPE ||
2337 type == OP_LEAVE || type == OP_LEAVETRY)
2340 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2341 if ((sib = OpSIBLING(kid))
2342 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2343 || ( sib->op_targ != OP_NEXTSTATE
2344 && sib->op_targ != OP_DBSTATE )))
2349 PL_curcop = &PL_compiling;
2351 o->op_flags &= ~OPf_PARENS;
2352 if (PL_hints & HINT_BLOCK_SCOPE)
2353 o->op_flags |= OPf_PARENS;
2356 o = newOP(OP_STUB, 0);
2361 S_modkids(pTHX_ OP *o, I32 type)
2363 if (o && o->op_flags & OPf_KIDS) {
2365 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2366 op_lvalue(kid, type);
2372 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2373 * const fields. Also, convert CONST keys to HEK-in-SVs.
2374 * rop is the op that retrieves the hash;
2375 * key_op is the first key
2379 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2385 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2387 if (rop->op_first->op_type == OP_PADSV)
2388 /* @$hash{qw(keys here)} */
2389 rop = (UNOP*)rop->op_first;
2391 /* @{$hash}{qw(keys here)} */
2392 if (rop->op_first->op_type == OP_SCOPE
2393 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2395 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2402 lexname = NULL; /* just to silence compiler warnings */
2403 fields = NULL; /* just to silence compiler warnings */
2407 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2408 SvPAD_TYPED(lexname))
2409 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2410 && isGV(*fields) && GvHV(*fields);
2412 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2414 if (key_op->op_type != OP_CONST)
2416 svp = cSVOPx_svp(key_op);
2418 /* make sure it's not a bareword under strict subs */
2419 if (key_op->op_private & OPpCONST_BARE &&
2420 key_op->op_private & OPpCONST_STRICT)
2422 no_bareword_allowed((OP*)key_op);
2425 /* Make the CONST have a shared SV */
2426 if ( !SvIsCOW_shared_hash(sv = *svp)
2427 && SvTYPE(sv) < SVt_PVMG
2432 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2433 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2434 SvREFCNT_dec_NN(sv);
2439 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2441 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2442 "in variable %" PNf " of type %" HEKf,
2443 SVfARG(*svp), PNfARG(lexname),
2444 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2451 =for apidoc finalize_optree
2453 This function finalizes the optree. Should be called directly after
2454 the complete optree is built. It does some additional
2455 checking which can't be done in the normal C<ck_>xxx functions and makes
2456 the tree thread-safe.
2461 Perl_finalize_optree(pTHX_ OP* o)
2463 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2466 SAVEVPTR(PL_curcop);
2474 /* Relocate sv to the pad for thread safety.
2475 * Despite being a "constant", the SV is written to,
2476 * for reference counts, sv_upgrade() etc. */
2477 PERL_STATIC_INLINE void
2478 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2481 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2483 ix = pad_alloc(OP_CONST, SVf_READONLY);
2484 SvREFCNT_dec(PAD_SVl(ix));
2485 PAD_SETSV(ix, *svp);
2486 /* XXX I don't know how this isn't readonly already. */
2487 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2495 S_finalize_op(pTHX_ OP* o)
2497 PERL_ARGS_ASSERT_FINALIZE_OP;
2499 assert(o->op_type != OP_FREED);
2501 switch (o->op_type) {
2504 PL_curcop = ((COP*)o); /* for warnings */
2507 if (OpHAS_SIBLING(o)) {
2508 OP *sib = OpSIBLING(o);
2509 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2510 && ckWARN(WARN_EXEC)
2511 && OpHAS_SIBLING(sib))
2513 const OPCODE type = OpSIBLING(sib)->op_type;
2514 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2515 const line_t oldline = CopLINE(PL_curcop);
2516 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2517 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2518 "Statement unlikely to be reached");
2519 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2520 "\t(Maybe you meant system() when you said exec()?)\n");
2521 CopLINE_set(PL_curcop, oldline);
2528 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2529 GV * const gv = cGVOPo_gv;
2530 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2531 /* XXX could check prototype here instead of just carping */
2532 SV * const sv = sv_newmortal();
2533 gv_efullname3(sv, gv, NULL);
2534 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2535 "%" SVf "() called too early to check prototype",
2542 if (cSVOPo->op_private & OPpCONST_STRICT)
2543 no_bareword_allowed(o);
2547 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2552 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2553 case OP_METHOD_NAMED:
2554 case OP_METHOD_SUPER:
2555 case OP_METHOD_REDIR:
2556 case OP_METHOD_REDIR_SUPER:
2557 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2566 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2569 rop = (UNOP*)((BINOP*)o)->op_first;
2574 S_scalar_slice_warning(aTHX_ o);
2578 kid = OpSIBLING(cLISTOPo->op_first);
2579 if (/* I bet there's always a pushmark... */
2580 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2581 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2586 key_op = (SVOP*)(kid->op_type == OP_CONST
2588 : OpSIBLING(kLISTOP->op_first));
2590 rop = (UNOP*)((LISTOP*)o)->op_last;
2593 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2595 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2599 S_scalar_slice_warning(aTHX_ o);
2603 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2604 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2611 if (o->op_flags & OPf_KIDS) {
2615 /* check that op_last points to the last sibling, and that
2616 * the last op_sibling/op_sibparent field points back to the
2617 * parent, and that the only ops with KIDS are those which are
2618 * entitled to them */
2619 U32 type = o->op_type;
2623 if (type == OP_NULL) {
2625 /* ck_glob creates a null UNOP with ex-type GLOB
2626 * (which is a list op. So pretend it wasn't a listop */
2627 if (type == OP_GLOB)
2630 family = PL_opargs[type] & OA_CLASS_MASK;
2632 has_last = ( family == OA_BINOP
2633 || family == OA_LISTOP
2634 || family == OA_PMOP
2635 || family == OA_LOOP
2637 assert( has_last /* has op_first and op_last, or ...
2638 ... has (or may have) op_first: */
2639 || family == OA_UNOP
2640 || family == OA_UNOP_AUX
2641 || family == OA_LOGOP
2642 || family == OA_BASEOP_OR_UNOP
2643 || family == OA_FILESTATOP
2644 || family == OA_LOOPEXOP
2645 || family == OA_METHOP
2646 || type == OP_CUSTOM
2647 || type == OP_NULL /* new_logop does this */
2650 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2651 # ifdef PERL_OP_PARENT
2652 if (!OpHAS_SIBLING(kid)) {
2654 assert(kid == cLISTOPo->op_last);
2655 assert(kid->op_sibparent == o);
2658 if (has_last && !OpHAS_SIBLING(kid))
2659 assert(kid == cLISTOPo->op_last);
2664 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2670 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2672 Propagate lvalue ("modifiable") context to an op and its children.
2673 C<type> represents the context type, roughly based on the type of op that
2674 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2675 because it has no op type of its own (it is signalled by a flag on
2678 This function detects things that can't be modified, such as C<$x+1>, and
2679 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2680 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2682 It also flags things that need to behave specially in an lvalue context,
2683 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2689 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2692 PadnameLVALUE_on(pn);
2693 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2695 /* RT #127786: cv can be NULL due to an eval within the DB package
2696 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2697 * unless they contain an eval, but calling eval within DB
2698 * pretends the eval was done in the caller's scope.
2702 assert(CvPADLIST(cv));
2704 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2705 assert(PadnameLEN(pn));
2706 PadnameLVALUE_on(pn);
2711 S_vivifies(const OPCODE type)
2714 case OP_RV2AV: case OP_ASLICE:
2715 case OP_RV2HV: case OP_KVASLICE:
2716 case OP_RV2SV: case OP_HSLICE:
2717 case OP_AELEMFAST: case OP_KVHSLICE:
2726 S_lvref(pTHX_ OP *o, I32 type)
2730 switch (o->op_type) {
2732 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2733 kid = OpSIBLING(kid))
2734 S_lvref(aTHX_ kid, type);
2739 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2740 o->op_flags |= OPf_STACKED;
2741 if (o->op_flags & OPf_PARENS) {
2742 if (o->op_private & OPpLVAL_INTRO) {
2743 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2744 "localized parenthesized array in list assignment"));
2748 OpTYPE_set(o, OP_LVAVREF);
2749 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2750 o->op_flags |= OPf_MOD|OPf_REF;
2753 o->op_private |= OPpLVREF_AV;
2756 kid = cUNOPo->op_first;
2757 if (kid->op_type == OP_NULL)
2758 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2760 o->op_private = OPpLVREF_CV;
2761 if (kid->op_type == OP_GV)
2762 o->op_flags |= OPf_STACKED;
2763 else if (kid->op_type == OP_PADCV) {
2764 o->op_targ = kid->op_targ;
2766 op_free(cUNOPo->op_first);
2767 cUNOPo->op_first = NULL;
2768 o->op_flags &=~ OPf_KIDS;
2773 if (o->op_flags & OPf_PARENS) {
2775 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2776 "parenthesized hash in list assignment"));
2779 o->op_private |= OPpLVREF_HV;
2783 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2784 o->op_flags |= OPf_STACKED;
2787 if (o->op_flags & OPf_PARENS) goto parenhash;
2788 o->op_private |= OPpLVREF_HV;
2791 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2794 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2795 if (o->op_flags & OPf_PARENS) goto slurpy;
2796 o->op_private |= OPpLVREF_AV;
2800 o->op_private |= OPpLVREF_ELEM;
2801 o->op_flags |= OPf_STACKED;
2805 OpTYPE_set(o, OP_LVREFSLICE);
2806 o->op_private &= OPpLVAL_INTRO;
2809 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2811 else if (!(o->op_flags & OPf_KIDS))
2813 if (o->op_targ != OP_LIST) {
2814 S_lvref(aTHX_ cBINOPo->op_first, type);
2819 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2820 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2821 S_lvref(aTHX_ kid, type);
2825 if (o->op_flags & OPf_PARENS)
2830 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2831 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2832 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2838 OpTYPE_set(o, OP_LVREF);
2840 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2841 if (type == OP_ENTERLOOP)
2842 o->op_private |= OPpLVREF_ITER;
2845 PERL_STATIC_INLINE bool
2846 S_potential_mod_type(I32 type)
2848 /* Types that only potentially result in modification. */
2849 return type == OP_GREPSTART || type == OP_ENTERSUB
2850 || type == OP_REFGEN || type == OP_LEAVESUBLV;
2854 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2858 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2861 if (!o || (PL_parser && PL_parser->error_count))
2864 if ((o->op_private & OPpTARGET_MY)
2865 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2870 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2872 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2874 switch (o->op_type) {
2879 if ((o->op_flags & OPf_PARENS))
2883 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2884 !(o->op_flags & OPf_STACKED)) {
2885 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
2886 assert(cUNOPo->op_first->op_type == OP_NULL);
2887 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2890 else { /* lvalue subroutine call */
2891 o->op_private |= OPpLVAL_INTRO;
2892 PL_modcount = RETURN_UNLIMITED_NUMBER;
2893 if (S_potential_mod_type(type)) {
2894 o->op_private |= OPpENTERSUB_INARGS;
2897 else { /* Compile-time error message: */
2898 OP *kid = cUNOPo->op_first;
2903 if (kid->op_type != OP_PUSHMARK) {
2904 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2906 "panic: unexpected lvalue entersub "
2907 "args: type/targ %ld:%" UVuf,
2908 (long)kid->op_type, (UV)kid->op_targ);
2909 kid = kLISTOP->op_first;
2911 while (OpHAS_SIBLING(kid))
2912 kid = OpSIBLING(kid);
2913 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2914 break; /* Postpone until runtime */
2917 kid = kUNOP->op_first;
2918 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2919 kid = kUNOP->op_first;
2920 if (kid->op_type == OP_NULL)
2922 "Unexpected constant lvalue entersub "
2923 "entry via type/targ %ld:%" UVuf,
2924 (long)kid->op_type, (UV)kid->op_targ);
2925 if (kid->op_type != OP_GV) {
2932 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2933 ? MUTABLE_CV(SvRV(gv))
2939 if (flags & OP_LVALUE_NO_CROAK)
2942 namesv = cv_name(cv, NULL, 0);
2943 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2944 "subroutine call of &%" SVf " in %s",
2945 SVfARG(namesv), PL_op_desc[type]),
2953 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2954 /* grep, foreach, subcalls, refgen */
2955 if (S_potential_mod_type(type))
2957 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2958 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2961 type ? PL_op_desc[type] : "local"));
2974 case OP_RIGHT_SHIFT:
2983 if (!(o->op_flags & OPf_STACKED))
2989 if (o->op_flags & OPf_STACKED) {
2993 if (!(o->op_private & OPpREPEAT_DOLIST))
2996 const I32 mods = PL_modcount;
2997 modkids(cBINOPo->op_first, type);
2998 if (type != OP_AASSIGN)
3000 kid = cBINOPo->op_last;
3001 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3002 const IV iv = SvIV(kSVOP_sv);
3003 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3005 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3008 PL_modcount = RETURN_UNLIMITED_NUMBER;
3014 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3015 op_lvalue(kid, type);
3020 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3021 PL_modcount = RETURN_UNLIMITED_NUMBER;
3022 return o; /* Treat \(@foo) like ordinary list. */
3026 if (scalar_mod_type(o, type))
3028 ref(cUNOPo->op_first, o->op_type);
3035 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
3036 if (type == OP_LEAVESUBLV && (
3037 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3038 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3040 o->op_private |= OPpMAYBE_LVSUB;
3044 PL_modcount = RETURN_UNLIMITED_NUMBER;
3049 if (type == OP_LEAVESUBLV)
3050 o->op_private |= OPpMAYBE_LVSUB;
3053 if (type == OP_LEAVESUBLV
3054 && (o->op_private & 3) + OP_EACH == OP_KEYS)
3055 o->op_private |= OPpMAYBE_LVSUB;
3058 PL_hints |= HINT_BLOCK_SCOPE;
3059 if (type == OP_LEAVESUBLV)
3060 o->op_private |= OPpMAYBE_LVSUB;
3064 ref(cUNOPo->op_first, o->op_type);
3068 PL_hints |= HINT_BLOCK_SCOPE;
3078 case OP_AELEMFAST_LEX:
3085 PL_modcount = RETURN_UNLIMITED_NUMBER;
3086 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3087 return o; /* Treat \(@foo) like ordinary list. */
3088 if (scalar_mod_type(o, type))
3090 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3091 && type == OP_LEAVESUBLV)
3092 o->op_private |= OPpMAYBE_LVSUB;
3096 if (!type) /* local() */
3097 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3098 PNfARG(PAD_COMPNAME(o->op_targ)));
3099 if (!(o->op_private & OPpLVAL_INTRO)
3100 || ( type != OP_SASSIGN && type != OP_AASSIGN
3101 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3102 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3110 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3114 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3120 if (type == OP_LEAVESUBLV)
3121 o->op_private |= OPpMAYBE_LVSUB;
3122 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3123 /* substr and vec */
3124 /* If this op is in merely potential (non-fatal) modifiable
3125 context, then apply OP_ENTERSUB context to
3126 the kid op (to avoid croaking). Other-
3127 wise pass this op’s own type so the correct op is mentioned
3128 in error messages. */
3129 op_lvalue(OpSIBLING(cBINOPo->op_first),
3130 S_potential_mod_type(type)
3138 ref(cBINOPo->op_first, o->op_type);
3139 if (type == OP_ENTERSUB &&
3140 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3141 o->op_private |= OPpLVAL_DEFER;
3142 if (type == OP_LEAVESUBLV)
3143 o->op_private |= OPpMAYBE_LVSUB;
3150 o->op_private |= OPpLVALUE;
3156 if (o->op_flags & OPf_KIDS)
3157 op_lvalue(cLISTOPo->op_last, type);
3162 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3164 else if (!(o->op_flags & OPf_KIDS))
3166 if (o->op_targ != OP_LIST) {
3167 op_lvalue(cBINOPo->op_first, type);
3173 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3174 /* elements might be in void context because the list is
3175 in scalar context or because they are attribute sub calls */
3176 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3177 op_lvalue(kid, type);
3185 if (type == OP_LEAVESUBLV
3186 || !S_vivifies(cLOGOPo->op_first->op_type))
3187 op_lvalue(cLOGOPo->op_first, type);
3188 if (type == OP_LEAVESUBLV
3189 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3190 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3194 if (type == OP_NULL) { /* local */
3196 if (!FEATURE_MYREF_IS_ENABLED)
3197 Perl_croak(aTHX_ "The experimental declared_refs "
3198 "feature is not enabled");
3199 Perl_ck_warner_d(aTHX_
3200 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3201 "Declaring references is experimental");
3202 op_lvalue(cUNOPo->op_first, OP_NULL);
3205 if (type != OP_AASSIGN && type != OP_SASSIGN
3206 && type != OP_ENTERLOOP)
3208 /* Don’t bother applying lvalue context to the ex-list. */
3209 kid = cUNOPx(cUNOPo->op_first)->op_first;
3210 assert (!OpHAS_SIBLING(kid));
3213 if (type == OP_NULL) /* local */
3215 if (type != OP_AASSIGN) goto nomod;
3216 kid = cUNOPo->op_first;
3219 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3220 S_lvref(aTHX_ kid, type);
3221 if (!PL_parser || PL_parser->error_count == ec) {
3222 if (!FEATURE_REFALIASING_IS_ENABLED)
3224 "Experimental aliasing via reference not enabled");
3225 Perl_ck_warner_d(aTHX_
3226 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3227 "Aliasing via reference is experimental");
3230 if (o->op_type == OP_REFGEN)
3231 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3236 if ((o->op_private & OPpSPLIT_ASSIGN)) {
3237 /* This is actually @array = split. */
3238 PL_modcount = RETURN_UNLIMITED_NUMBER;
3244 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3248 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3249 their argument is a filehandle; thus \stat(".") should not set
3251 if (type == OP_REFGEN &&
3252 PL_check[o->op_type] == Perl_ck_ftst)
3255 if (type != OP_LEAVESUBLV)
3256 o->op_flags |= OPf_MOD;
3258 if (type == OP_AASSIGN || type == OP_SASSIGN)
3259 o->op_flags |= OPf_SPECIAL
3260 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
3261 else if (!type) { /* local() */
3264 o->op_private |= OPpLVAL_INTRO;
3265 o->op_flags &= ~OPf_SPECIAL;
3266 PL_hints |= HINT_BLOCK_SCOPE;
3271 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3272 "Useless localization of %s", OP_DESC(o));
3275 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3276 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3277 o->op_flags |= OPf_REF;
3282 S_scalar_mod_type(const OP *o, I32 type)
3287 if (o && o->op_type == OP_RV2GV)
3311 case OP_RIGHT_SHIFT:
3340 S_is_handle_constructor(const OP *o, I32 numargs)
3342 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3344 switch (o->op_type) {
3352 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3365 S_refkids(pTHX_ OP *o, I32 type)
3367 if (o && o->op_flags & OPf_KIDS) {
3369 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3376 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3381 PERL_ARGS_ASSERT_DOREF;
3383 if (PL_parser && PL_parser->error_count)
3386 switch (o->op_type) {
3388 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3389 !(o->op_flags & OPf_STACKED)) {
3390 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3391 assert(cUNOPo->op_first->op_type == OP_NULL);
3392 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3393 o->op_flags |= OPf_SPECIAL;
3395 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3396 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3397 : type == OP_RV2HV ? OPpDEREF_HV
3399 o->op_flags |= OPf_MOD;
3405 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3406 doref(kid, type, set_op_ref);
3409 if (type == OP_DEFINED)
3410 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3411 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3414 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3415 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3416 : type == OP_RV2HV ? OPpDEREF_HV
3418 o->op_flags |= OPf_MOD;
3425 o->op_flags |= OPf_REF;
3428 if (type == OP_DEFINED)
3429 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3430 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3436 o->op_flags |= OPf_REF;
3441 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3443 doref(cBINOPo->op_first, type, set_op_ref);
3447 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3448 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3449 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3450 : type == OP_RV2HV ? OPpDEREF_HV
3452 o->op_flags |= OPf_MOD;
3462 if (!(o->op_flags & OPf_KIDS))
3464 doref(cLISTOPo->op_last, type, set_op_ref);
3474 S_dup_attrlist(pTHX_ OP *o)
3478 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3480 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3481 * where the first kid is OP_PUSHMARK and the remaining ones
3482 * are OP_CONST. We need to push the OP_CONST values.
3484 if (o->op_type == OP_CONST)
3485 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3487 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3489 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3490 if (o->op_type == OP_CONST)
3491 rop = op_append_elem(OP_LIST, rop,
3492 newSVOP(OP_CONST, o->op_flags,
3493 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3500 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3502 PERL_ARGS_ASSERT_APPLY_ATTRS;
3504 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3506 /* fake up C<use attributes $pkg,$rv,@attrs> */
3508 #define ATTRSMODULE "attributes"
3509 #define ATTRSMODULE_PM "attributes.pm"
3512 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3513 newSVpvs(ATTRSMODULE),
3515 op_prepend_elem(OP_LIST,
3516 newSVOP(OP_CONST, 0, stashsv),
3517 op_prepend_elem(OP_LIST,
3518 newSVOP(OP_CONST, 0,
3520 dup_attrlist(attrs))));
3525 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3527 OP *pack, *imop, *arg;
3528 SV *meth, *stashsv, **svp;
3530 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3535 assert(target->op_type == OP_PADSV ||
3536 target->op_type == OP_PADHV ||
3537 target->op_type == OP_PADAV);
3539 /* Ensure that attributes.pm is loaded. */
3540 /* Don't force the C<use> if we don't need it. */
3541 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3542 if (svp && *svp != &PL_sv_undef)
3543 NOOP; /* already in %INC */
3545 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3546 newSVpvs(ATTRSMODULE), NULL);
3548 /* Need package name for method call. */
3549 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3551 /* Build up the real arg-list. */
3552 stashsv = newSVhek(HvNAME_HEK(stash));
3554 arg = newOP(OP_PADSV, 0);
3555 arg->op_targ = target->op_targ;
3556 arg = op_prepend_elem(OP_LIST,
3557 newSVOP(OP_CONST, 0, stashsv),
3558 op_prepend_elem(OP_LIST,
3559 newUNOP(OP_REFGEN, 0,
3561 dup_attrlist(attrs)));
3563 /* Fake up a method call to import */
3564 meth = newSVpvs_share("import");
3565 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3566 op_append_elem(OP_LIST,
3567 op_prepend_elem(OP_LIST, pack, arg),
3568 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3570 /* Combine the ops. */
3571 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3575 =notfor apidoc apply_attrs_string
3577 Attempts to apply a list of attributes specified by the C<attrstr> and
3578 C<len> arguments to the subroutine identified by the C<cv> argument which
3579 is expected to be associated with the package identified by the C<stashpv>
3580 argument (see L<attributes>). It gets this wrong, though, in that it
3581 does not correctly identify the boundaries of the individual attribute
3582 specifications within C<attrstr>. This is not really intended for the
3583 public API, but has to be listed here for systems such as AIX which
3584 need an explicit export list for symbols. (It's called from XS code
3585 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3586 to respect attribute syntax properly would be welcome.
3592 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3593 const char *attrstr, STRLEN len)
3597 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3600 len = strlen(attrstr);
3604 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3606 const char * const sstr = attrstr;
3607 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3608 attrs = op_append_elem(OP_LIST, attrs,
3609 newSVOP(OP_CONST, 0,
3610 newSVpvn(sstr, attrstr-sstr)));
3614 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3615 newSVpvs(ATTRSMODULE),
3616 NULL, op_prepend_elem(OP_LIST,
3617 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3618 op_prepend_elem(OP_LIST,
3619 newSVOP(OP_CONST, 0,
3620 newRV(MUTABLE_SV(cv))),
3625 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3627 OP *new_proto = NULL;
3632 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3638 if (o->op_type == OP_CONST) {
3639 pv = SvPV(cSVOPo_sv, pvlen);
3640 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3641 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3642 SV ** const tmpo = cSVOPx_svp(o);
3643 SvREFCNT_dec(cSVOPo_sv);
3648 } else if (o->op_type == OP_LIST) {
3650 assert(o->op_flags & OPf_KIDS);
3651 lasto = cLISTOPo->op_first;
3652 assert(lasto->op_type == OP_PUSHMARK);
3653 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3654 if (o->op_type == OP_CONST) {
3655 pv = SvPV(cSVOPo_sv, pvlen);
3656 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3657 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3658 SV ** const tmpo = cSVOPx_svp(o);
3659 SvREFCNT_dec(cSVOPo_sv);
3661 if (new_proto && ckWARN(WARN_MISC)) {
3663 const char * newp = SvPV(cSVOPo_sv, new_len);
3664 Perl_warner(aTHX_ packWARN(WARN_MISC),
3665 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3666 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3672 /* excise new_proto from the list */
3673 op_sibling_splice(*attrs, lasto, 1, NULL);
3680 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3681 would get pulled in with no real need */
3682 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3691 svname = sv_newmortal();
3692 gv_efullname3(svname, name, NULL);
3694 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3695 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3697 svname = (SV *)name;
3698 if (ckWARN(WARN_ILLEGALPROTO))
3699 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3700 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3701 STRLEN old_len, new_len;
3702 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3703 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3705 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3706 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
3708 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3709 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3719 S_cant_declare(pTHX_ OP *o)
3721 if (o->op_type == OP_NULL
3722 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3723 o = cUNOPo->op_first;
3724 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3725 o->op_type == OP_NULL
3726 && o->op_flags & OPf_SPECIAL
3729 PL_parser->in_my == KEY_our ? "our" :
3730 PL_parser->in_my == KEY_state ? "state" :
3735 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3738 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3740 PERL_ARGS_ASSERT_MY_KID;
3742 if (!o || (PL_parser && PL_parser->error_count))
3747 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3749 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3750 my_kid(kid, attrs, imopsp);
3752 } else if (type == OP_UNDEF || type == OP_STUB) {
3754 } else if (type == OP_RV2SV || /* "our" declaration */
3757 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3758 S_cant_declare(aTHX_ o);
3760 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3762 PL_parser->in_my = FALSE;
3763 PL_parser->in_my_stash = NULL;
3764 apply_attrs(GvSTASH(gv),
3765 (type == OP_RV2SV ? GvSV(gv) :
3766 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3767 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3770 o->op_private |= OPpOUR_INTRO;
3773 else if (type == OP_REFGEN || type == OP_SREFGEN) {
3774 if (!FEATURE_MYREF_IS_ENABLED)
3775 Perl_croak(aTHX_ "The experimental declared_refs "
3776 "feature is not enabled");
3777 Perl_ck_warner_d(aTHX_
3778 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3779 "Declaring references is experimental");
3780 /* Kid is a nulled OP_LIST, handled above. */
3781 my_kid(cUNOPo->op_first, attrs, imopsp);
3784 else if (type != OP_PADSV &&
3787 type != OP_PUSHMARK)
3789 S_cant_declare(aTHX_ o);
3792 else if (attrs && type != OP_PUSHMARK) {
3796 PL_parser->in_my = FALSE;
3797 PL_parser->in_my_stash = NULL;
3799 /* check for C<my Dog $spot> when deciding package */
3800 stash = PAD_COMPNAME_TYPE(o->op_targ);
3802 stash = PL_curstash;
3803 apply_attrs_my(stash, o, attrs, imopsp);
3805 o->op_flags |= OPf_MOD;
3806 o->op_private |= OPpLVAL_INTRO;
3808 o->op_private |= OPpPAD_STATE;
3813 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3816 int maybe_scalar = 0;
3818 PERL_ARGS_ASSERT_MY_ATTRS;
3820 /* [perl #17376]: this appears to be premature, and results in code such as
3821 C< our(%x); > executing in list mode rather than void mode */
3823 if (o->op_flags & OPf_PARENS)
3833 o = my_kid(o, attrs, &rops);
3835 if (maybe_scalar && o->op_type == OP_PADSV) {
3836 o = scalar(op_append_list(OP_LIST, rops, o));
3837 o->op_private |= OPpLVAL_INTRO;
3840 /* The listop in rops might have a pushmark at the beginning,
3841 which will mess up list assignment. */
3842 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3843 if (rops->op_type == OP_LIST &&
3844 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3846 OP * const pushmark = lrops->op_first;
3847 /* excise pushmark */
3848 op_sibling_splice(rops, NULL, 1, NULL);
3851 o = op_append_list(OP_LIST, o, rops);
3854 PL_parser->in_my = FALSE;
3855 PL_parser->in_my_stash = NULL;
3860 Perl_sawparens(pTHX_ OP *o)
3862 PERL_UNUSED_CONTEXT;
3864 o->op_flags |= OPf_PARENS;
3869 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3873 const OPCODE ltype = left->op_type;
3874 const OPCODE rtype = right->op_type;
3876 PERL_ARGS_ASSERT_BIND_MATCH;
3878 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3879 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3881 const char * const desc
3883 rtype == OP_SUBST || rtype == OP_TRANS
3884 || rtype == OP_TRANSR
3886 ? (int)rtype : OP_MATCH];
3887 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3889 S_op_varname(aTHX_ left);
3891 Perl_warner(aTHX_ packWARN(WARN_MISC),
3892 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
3893 desc, SVfARG(name), SVfARG(name));
3895 const char * const sample = (isary
3896 ? "@array" : "%hash");
3897 Perl_warner(aTHX_ packWARN(WARN_MISC),
3898 "Applying %s to %s will act on scalar(%s)",
3899 desc, sample, sample);
3903 if (rtype == OP_CONST &&
3904 cSVOPx(right)->op_private & OPpCONST_BARE &&
3905 cSVOPx(right)->op_private & OPpCONST_STRICT)
3907 no_bareword_allowed(right);
3910 /* !~ doesn't make sense with /r, so error on it for now */
3911 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3913 /* diag_listed_as: Using !~ with %s doesn't make sense */
3914 yyerror("Using !~ with s///r doesn't make sense");
3915 if (rtype == OP_TRANSR && type == OP_NOT)
3916 /* diag_listed_as: Using !~ with %s doesn't make sense */
3917 yyerror("Using !~ with tr///r doesn't make sense");
3919 ismatchop = (rtype == OP_MATCH ||
3920 rtype == OP_SUBST ||
3921 rtype == OP_TRANS || rtype == OP_TRANSR)
3922 && !(right->op_flags & OPf_SPECIAL);
3923 if (ismatchop && right->op_private & OPpTARGET_MY) {
3925 right->op_private &= ~OPpTARGET_MY;
3927 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3928 if (left->op_type == OP_PADSV
3929 && !(left->op_private & OPpLVAL_INTRO))
3931 right->op_targ = left->op_targ;
3936 right->op_flags |= OPf_STACKED;
3937 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3938 ! (rtype == OP_TRANS &&
3939 right->op_private & OPpTRANS_IDENTICAL) &&
3940 ! (rtype == OP_SUBST &&
3941 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3942 left = op_lvalue(left, rtype);
3943 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3944 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3946 o = op_prepend_elem(rtype, scalar(left), right);
3949 return newUNOP(OP_NOT, 0, scalar(o));
3953 return bind_match(type, left,
3954 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3958 Perl_invert(pTHX_ OP *o)
3962 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3966 =for apidoc Amx|OP *|op_scope|OP *o
3968 Wraps up an op tree with some additional ops so that at runtime a dynamic
3969 scope will be created. The original ops run in the new dynamic scope,
3970 and then, provided that they exit normally, the scope will be unwound.
3971 The additional ops used to create and unwind the dynamic scope will
3972 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3973 instead if the ops are simple enough to not need the full dynamic scope
3980 Perl_op_scope(pTHX_ OP *o)
3984 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3985 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3986 OpTYPE_set(o, OP_LEAVE);
3988 else if (o->op_type == OP_LINESEQ) {
3990 OpTYPE_set(o, OP_SCOPE);
3991 kid = ((LISTOP*)o)->op_first;
3992 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3995 /* The following deals with things like 'do {1 for 1}' */
3996 kid = OpSIBLING(kid);
3998 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4003 o = newLISTOP(OP_SCOPE, 0, o, NULL);
4009 Perl_op_unscope(pTHX_ OP *o)
4011 if (o && o->op_type == OP_LINESEQ) {
4012 OP *kid = cLISTOPo->op_first;
4013 for(; kid; kid = OpSIBLING(kid))
4014 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4021 =for apidoc Am|int|block_start|int full
4023 Handles compile-time scope entry.
4024 Arranges for hints to be restored on block
4025 exit and also handles pad sequence numbers to make lexical variables scope
4026 right. Returns a savestack index for use with C<block_end>.
4032 Perl_block_start(pTHX_ int full)
4034 const int retval = PL_savestack_ix;
4036 PL_compiling.cop_seq = PL_cop_seqmax;
4038 pad_block_start(full);
4040 PL_hints &= ~HINT_BLOCK_SCOPE;
4041 SAVECOMPILEWARNINGS();
4042 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4043 SAVEI32(PL_compiling.cop_seq);
4044 PL_compiling.cop_seq = 0;
4046 CALL_BLOCK_HOOKS(bhk_start, full);
4052 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4054 Handles compile-time scope exit. C<floor>
4055 is the savestack index returned by
4056 C<block_start>, and C<seq> is the body of the block. Returns the block,
4063 Perl_block_end(pTHX_ I32 floor, OP *seq)
4065 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4066 OP* retval = scalarseq(seq);
4069 /* XXX Is the null PL_parser check necessary here? */
4070 assert(PL_parser); /* Let’s find out under debugging builds. */
4071 if (PL_parser && PL_parser->parsed_sub) {
4072 o = newSTATEOP(0, NULL, NULL);
4074 retval = op_append_elem(OP_LINESEQ, retval, o);
4077 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4081 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4085 /* pad_leavemy has created a sequence of introcv ops for all my
4086 subs declared in the block. We have to replicate that list with
4087 clonecv ops, to deal with this situation:
4092 sub s1 { state sub foo { \&s2 } }
4095 Originally, I was going to have introcv clone the CV and turn
4096 off the stale flag. Since &s1 is declared before &s2, the
4097 introcv op for &s1 is executed (on sub entry) before the one for
4098 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
4099 cloned, since it is a state sub) closes over &s2 and expects
4100 to see it in its outer CV’s pad. If the introcv op clones &s1,
4101 then &s2 is still marked stale. Since &s1 is not active, and
4102 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4103 ble will not stay shared’ warning. Because it is the same stub
4104 that will be used when the introcv op for &s2 is executed, clos-
4105 ing over it is safe. Hence, we have to turn off the stale flag
4106 on all lexical subs in the block before we clone any of them.
4107 Hence, having introcv clone the sub cannot work. So we create a
4108 list of ops like this:
4132 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4133 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4134 for (;; kid = OpSIBLING(kid)) {
4135 OP *newkid = newOP(OP_CLONECV, 0);
4136 newkid->op_targ = kid->op_targ;
4137 o = op_append_elem(OP_LINESEQ, o, newkid);
4138 if (kid == last) break;
4140 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4143 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4149 =head1 Compile-time scope hooks
4151 =for apidoc Aox||blockhook_register
4153 Register a set of hooks to be called when the Perl lexical scope changes
4154 at compile time. See L<perlguts/"Compile-time scope hooks">.
4160 Perl_blockhook_register(pTHX_ BHK *hk)
4162 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4164 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4168 Perl_newPROG(pTHX_ OP *o)
4170 PERL_ARGS_ASSERT_NEWPROG;
4177 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4178 ((PL_in_eval & EVAL_KEEPERR)
4179 ? OPf_SPECIAL : 0), o);
4182 assert(CxTYPE(cx) == CXt_EVAL);
4184 if ((cx->blk_gimme & G_WANT) == G_VOID)
4185 scalarvoid(PL_eval_root);
4186 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4189 scalar(PL_eval_root);
4191 PL_eval_start = op_linklist(PL_eval_root);
4192 PL_eval_root->op_private |= OPpREFCOUNTED;
4193 OpREFCNT_set(PL_eval_root, 1);
4194 PL_eval_root->op_next = 0;
4195 i = PL_savestack_ix;
4198 CALL_PEEP(PL_eval_start);
4199 finalize_optree(PL_eval_root);
4200 S_prune_chain_head(&PL_eval_start);
4202 PL_savestack_ix = i;
4205 if (o->op_type == OP_STUB) {
4206 /* This block is entered if nothing is compiled for the main
4207 program. This will be the case for an genuinely empty main
4208 program, or one which only has BEGIN blocks etc, so already
4211 Historically (5.000) the guard above was !o. However, commit
4212 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4213 c71fccf11fde0068, changed perly.y so that newPROG() is now
4214 called with the output of block_end(), which returns a new
4215 OP_STUB for the case of an empty optree. ByteLoader (and
4216 maybe other things) also take this path, because they set up
4217 PL_main_start and PL_main_root directly, without generating an
4220 If the parsing the main program aborts (due to parse errors,
4221 or due to BEGIN or similar calling exit), then newPROG()
4222 isn't even called, and hence this code path and its cleanups
4223 are skipped. This shouldn't make a make a difference:
4224 * a non-zero return from perl_parse is a failure, and
4225 perl_destruct() should be called immediately.
4226 * however, if exit(0) is called during the parse, then
4227 perl_parse() returns 0, and perl_run() is called. As
4228 PL_main_start will be NULL, perl_run() will return
4229 promptly, and the exit code will remain 0.
4232 PL_comppad_name = 0;
4234 S_op_destroy(aTHX_ o);
4237 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4238 PL_curcop = &PL_compiling;
4239 PL_main_start = LINKLIST(PL_main_root);
4240 PL_main_root->op_private |= OPpREFCOUNTED;
4241 OpREFCNT_set(PL_main_root, 1);
4242 PL_main_root->op_next = 0;
4243 CALL_PEEP(PL_main_start);
4244 finalize_optree(PL_main_root);
4245 S_prune_chain_head(&PL_main_start);
4246 cv_forget_slab(PL_compcv);
4249 /* Register with debugger */
4251 CV * const cv = get_cvs("DB::postponed", 0);
4255 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4257 call_sv(MUTABLE_SV(cv), G_DISCARD);
4264 Perl_localize(pTHX_ OP *o, I32 lex)
4266 PERL_ARGS_ASSERT_LOCALIZE;
4268 if (o->op_flags & OPf_PARENS)
4269 /* [perl #17376]: this appears to be premature, and results in code such as
4270 C< our(%x); > executing in list mode rather than void mode */
4277 if ( PL_parser->bufptr > PL_parser->oldbufptr
4278 && PL_parser->bufptr[-1] == ','
4279 && ckWARN(WARN_PARENTHESIS))
4281 char *s = PL_parser->bufptr;
4284 /* some heuristics to detect a potential error */
4285 while (*s && (strchr(", \t\n", *s)))
4289 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4291 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4294 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4296 while (*s && (strchr(", \t\n", *s)))
4302 if (sigil && (*s == ';' || *s == '=')) {
4303 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4304 "Parentheses missing around \"%s\" list",
4306 ? (PL_parser->in_my == KEY_our
4308 : PL_parser->in_my == KEY_state
4318 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4319 PL_parser->in_my = FALSE;
4320 PL_parser->in_my_stash = NULL;
4325 Perl_jmaybe(pTHX_ OP *o)
4327 PERL_ARGS_ASSERT_JMAYBE;
4329 if (o->op_type == OP_LIST) {
4331 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4332 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4337 PERL_STATIC_INLINE OP *
4338 S_op_std_init(pTHX_ OP *o)
4340 I32 type = o->op_type;
4342 PERL_ARGS_ASSERT_OP_STD_INIT;
4344 if (PL_opargs[type] & OA_RETSCALAR)
4346 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4347 o->op_targ = pad_alloc(type, SVs_PADTMP);
4352 PERL_STATIC_INLINE OP *
4353 S_op_integerize(pTHX_ OP *o)
4355 I32 type = o->op_type;
4357 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4359 /* integerize op. */
4360 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4363 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4366 if (type == OP_NEGATE)
4367 /* XXX might want a ck_negate() for this */
4368 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4374 S_fold_constants(pTHX_ OP *const o)
4379 VOL I32 type = o->op_type;
4384 SV * const oldwarnhook = PL_warnhook;
4385 SV * const olddiehook = PL_diehook;
4387 U8 oldwarn = PL_dowarn;
4391 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4393 if (!(PL_opargs[type] & OA_FOLDCONST))
4402 #ifdef USE_LOCALE_CTYPE
4403 if (IN_LC_COMPILETIME(LC_CTYPE))
4412 #ifdef USE_LOCALE_COLLATE
4413 if (IN_LC_COMPILETIME(LC_COLLATE))
4418 /* XXX what about the numeric ops? */
4419 #ifdef USE_LOCALE_NUMERIC
4420 if (IN_LC_COMPILETIME(LC_NUMERIC))
4425 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4426 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4429 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4430 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4432 const char *s = SvPVX_const(sv);
4433 while (s < SvEND(sv)) {
4434 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4441 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4444 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4445 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4449 if (PL_parser && PL_parser->error_count)
4450 goto nope; /* Don't try to run w/ errors */
4452 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4453 switch (curop->op_type) {
4455 if ( (curop->op_private & OPpCONST_BARE)
4456 && (curop->op_private & OPpCONST_STRICT)) {
4457 no_bareword_allowed(curop);
4465 /* Foldable; move to next op in list */
4469 /* No other op types are considered foldable */
4474 curop = LINKLIST(o);
4475 old_next = o->op_next;
4479 old_cxix = cxstack_ix;
4480 create_eval_scope(NULL, G_FAKINGEVAL);
4482 /* Verify that we don't need to save it: */
4483 assert(PL_curcop == &PL_compiling);
4484 StructCopy(&PL_compiling, ¬_compiling, COP);
4485 PL_curcop = ¬_compiling;
4486 /* The above ensures that we run with all the correct hints of the
4487 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4488 assert(IN_PERL_RUNTIME);
4489 PL_warnhook = PERL_WARNHOOK_FATAL;
4493 /* Effective $^W=1. */
4494 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4495 PL_dowarn |= G_WARN_ON;
4500 sv = *(PL_stack_sp--);
4501 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4502 pad_swipe(o->op_targ, FALSE);
4504 else if (SvTEMP(sv)) { /* grab mortal temp? */
4505 SvREFCNT_inc_simple_void(sv);
4508 else { assert(SvIMMORTAL(sv)); }
4511 /* Something tried to die. Abandon constant folding. */
4512 /* Pretend the error never happened. */
4514 o->op_next = old_next;
4518 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4519 PL_warnhook = oldwarnhook;
4520 PL_diehook = olddiehook;
4521 /* XXX note that this croak may fail as we've already blown away
4522 * the stack - eg any nested evals */
4523 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4526 PL_dowarn = oldwarn;
4527 PL_warnhook = oldwarnhook;
4528 PL_diehook = olddiehook;
4529 PL_curcop = &PL_compiling;
4531 /* if we croaked, depending on how we croaked the eval scope
4532 * may or may not have already been popped */
4533 if (cxstack_ix > old_cxix) {
4534 assert(cxstack_ix == old_cxix + 1);
4535 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4536 delete_eval_scope();
4541 /* OP_STRINGIFY and constant folding are used to implement qq.
4542 Here the constant folding is an implementation detail that we
4543 want to hide. If the stringify op is itself already marked
4544 folded, however, then it is actually a folded join. */
4545 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4550 else if (!SvIMMORTAL(sv)) {
4554 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4555 if (!is_stringify) newop->op_folded = 1;
4563 S_gen_constant_list(pTHX_ OP *o)
4567 const SSize_t oldtmps_floor = PL_tmps_floor;
4572 if (PL_parser && PL_parser->error_count)
4573 return o; /* Don't attempt to run with errors */
4575 curop = LINKLIST(o);
4578 S_prune_chain_head(&curop);
4580 Perl_pp_pushmark(aTHX);
4583 assert (!(curop->op_flags & OPf_SPECIAL));
4584 assert(curop->op_type == OP_RANGE);
4585 Perl_pp_anonlist(aTHX);
4586 PL_tmps_floor = oldtmps_floor;
4588 OpTYPE_set(o, OP_RV2AV);
4589 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4590 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4591 o->op_opt = 0; /* needs to be revisited in rpeep() */
4592 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4594 /* replace subtree with an OP_CONST */
4595 curop = ((UNOP*)o)->op_first;
4596 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4599 if (AvFILLp(av) != -1)
4600 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4603 SvREADONLY_on(*svp);
4610 =head1 Optree Manipulation Functions
4613 /* List constructors */
4616 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4618 Append an item to the list of ops contained directly within a list-type
4619 op, returning the lengthened list. C<first> is the list-type op,
4620 and C<last> is the op to append to the list. C<optype> specifies the
4621 intended opcode for the list. If C<first> is not already a list of the
4622 right type, it will be upgraded into one. If either C<first> or C<last>
4623 is null, the other is returned unchanged.
4629 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4637 if (first->op_type != (unsigned)type
4638 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4640 return newLISTOP(type, 0, first, last);
4643 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4644 first->op_flags |= OPf_KIDS;
4649 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4651 Concatenate the lists of ops contained directly within two list-type ops,
4652 returning the combined list. C<first> and C<last> are the list-type ops
4653 to concatenate. C<optype> specifies the intended opcode for the list.
4654 If either C<first> or C<last> is not already a list of the right type,
4655 it will be upgraded into one. If either C<first> or C<last> is null,
4656 the other is returned unchanged.
4662 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4670 if (first->op_type != (unsigned)type)
4671 return op_prepend_elem(type, first, last);
4673 if (last->op_type != (unsigned)type)
4674 return op_append_elem(type, first, last);
4676 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4677 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4678 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4679 first->op_flags |= (last->op_flags & OPf_KIDS);
4681 S_op_destroy(aTHX_ last);
4687 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4689 Prepend an item to the list of ops contained directly within a list-type
4690 op, returning the lengthened list. C<first> is the op to prepend to the
4691 list, and C<last> is the list-type op. C<optype> specifies the intended
4692 opcode for the list. If C<last> is not already a list of the right type,
4693 it will be upgraded into one. If either C<first> or C<last> is null,
4694 the other is returned unchanged.
4700 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4708 if (last->op_type == (unsigned)type) {
4709 if (type == OP_LIST) { /* already a PUSHMARK there */
4710 /* insert 'first' after pushmark */
4711 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4712 if (!(first->op_flags & OPf_PARENS))
4713 last->op_flags &= ~OPf_PARENS;
4716 op_sibling_splice(last, NULL, 0, first);
4717 last->op_flags |= OPf_KIDS;
4721 return newLISTOP(type, 0, first, last);
4725 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4727 Converts C<o> into a list op if it is not one already, and then converts it
4728 into the specified C<type>, calling its check function, allocating a target if
4729 it needs one, and folding constants.
4731 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4732 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4733 C<op_convert_list> to make it the right type.
4739 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4742 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4743 if (!o || o->op_type != OP_LIST)
4744 o = force_list(o, 0);
4747 o->op_flags &= ~OPf_WANT;
4748 o->op_private &= ~OPpLVAL_INTRO;
4751 if (!(PL_opargs[type] & OA_MARK))
4752 op_null(cLISTOPo->op_first);
4754 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4755 if (kid2 && kid2->op_type == OP_COREARGS) {
4756 op_null(cLISTOPo->op_first);
4757 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4761 if (type != OP_SPLIT)
4762 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
4763 * ck_split() create a real PMOP and leave the op's type as listop
4764 * for now. Otherwise op_free() etc will crash.
4766 OpTYPE_set(o, type);
4768 o->op_flags |= flags;
4769 if (flags & OPf_FOLDED)
4772 o = CHECKOP(type, o);
4773 if (o->op_type != (unsigned)type)
4776 return fold_constants(op_integerize(op_std_init(o)));
4783 =head1 Optree construction
4785 =for apidoc Am|OP *|newNULLLIST
4787 Constructs, checks, and returns a new C<stub> op, which represents an
4788 empty list expression.
4794 Perl_newNULLLIST(pTHX)
4796 return newOP(OP_STUB, 0);
4799 /* promote o and any siblings to be a list if its not already; i.e.
4807 * pushmark - o - A - B
4809 * If nullit it true, the list op is nulled.
4813 S_force_list(pTHX_ OP *o, bool nullit)
4815 if (!o || o->op_type != OP_LIST) {
4818 /* manually detach any siblings then add them back later */
4819 rest = OpSIBLING(o);
4820 OpLASTSIB_set(o, NULL);
4822 o = newLISTOP(OP_LIST, 0, o, NULL);
4824 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4832 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4834 Constructs, checks, and returns an op of any list type. C<type> is
4835 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4836 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
4837 supply up to two ops to be direct children of the list op; they are
4838 consumed by this function and become part of the constructed op tree.
4840 For most list operators, the check function expects all the kid ops to be
4841 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4842 appropriate. What you want to do in that case is create an op of type
4843 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4844 See L</op_convert_list> for more information.
4851 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4856 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4857 || type == OP_CUSTOM);
4859 NewOp(1101, listop, 1, LISTOP);
4861 OpTYPE_set(listop, type);
4864 listop->op_flags = (U8)flags;
4868 else if (!first && last)
4871 OpMORESIB_set(first, last);
4872 listop->op_first = first;
4873 listop->op_last = last;
4874 if (type == OP_LIST) {
4875 OP* const pushop = newOP(OP_PUSHMARK, 0);
4876 OpMORESIB_set(pushop, first);
4877 listop->op_first = pushop;
4878 listop->op_flags |= OPf_KIDS;
4880 listop->op_last = pushop;
4882 if (listop->op_last)
4883 OpLASTSIB_set(listop->op_last, (OP*)listop);
4885 return CHECKOP(type, listop);
4889 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4891 Constructs, checks, and returns an op of any base type (any type that
4892 has no extra fields). C<type> is the opcode. C<flags> gives the
4893 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4900 Perl_newOP(pTHX_ I32 type, I32 flags)
4905 if (type == -OP_ENTEREVAL) {
4906 type = OP_ENTEREVAL;
4907 flags |= OPpEVAL_BYTES<<8;
4910 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4911 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4912 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4913 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4915 NewOp(1101, o, 1, OP);
4916 OpTYPE_set(o, type);
4917 o->op_flags = (U8)flags;
4920 o->op_private = (U8)(0 | (flags >> 8));
4921 if (PL_opargs[type] & OA_RETSCALAR)
4923 if (PL_opargs[type] & OA_TARGET)
4924 o->op_targ = pad_alloc(type, SVs_PADTMP);
4925 return CHECKOP(type, o);
4929 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4931 Constructs, checks, and returns an op of any unary type. C<type> is
4932 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4933 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4934 bits, the eight bits of C<op_private>, except that the bit with value 1
4935 is automatically set. C<first> supplies an optional op to be the direct
4936 child of the unary op; it is consumed by this function and become part
4937 of the constructed op tree.
4943 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4948 if (type == -OP_ENTEREVAL) {
4949 type = OP_ENTEREVAL;
4950 flags |= OPpEVAL_BYTES<<8;
4953 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4954 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4955 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4956 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4957 || type == OP_SASSIGN
4958 || type == OP_ENTERTRY
4959 || type == OP_CUSTOM
4960 || type == OP_NULL );
4963 first = newOP(OP_STUB, 0);
4964 if (PL_opargs[type] & OA_MARK)
4965 first = force_list(first, 1);
4967 NewOp(1101, unop, 1, UNOP);
4968 OpTYPE_set(unop, type);
4969 unop->op_first = first;
4970 unop->op_flags = (U8)(flags | OPf_KIDS);
4971 unop->op_private = (U8)(1 | (flags >> 8));
4973 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4974 OpLASTSIB_set(first, (OP*)unop);
4976 unop = (UNOP*) CHECKOP(type, unop);
4980 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4984 =for apidoc newUNOP_AUX
4986 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4987 initialised to C<aux>
4993 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4998 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4999 || type == OP_CUSTOM);
5001 NewOp(1101, unop, 1, UNOP_AUX);
5002 unop->op_type = (OPCODE)type;
5003 unop->op_ppaddr = PL_ppaddr[type];
5004 unop->op_first = first;
5005 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5006 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5009 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5010 OpLASTSIB_set(first, (OP*)unop);
5012 unop = (UNOP_AUX*) CHECKOP(type, unop);
5014 return op_std_init((OP *) unop);
5018 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
5020 Constructs, checks, and returns an op of method type with a method name
5021 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
5022 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5023 and, shifted up eight bits, the eight bits of C<op_private>, except that
5024 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
5025 op which evaluates method name; it is consumed by this function and
5026 become part of the constructed op tree.
5027 Supported optypes: C<OP_METHOD>.
5033 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5037 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5038 || type == OP_CUSTOM);
5040 NewOp(1101, methop, 1, METHOP);
5042 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
5043 methop->op_flags = (U8)(flags | OPf_KIDS);
5044 methop->op_u.op_first = dynamic_meth;
5045 methop->op_private = (U8)(1 | (flags >> 8));
5047 if (!OpHAS_SIBLING(dynamic_meth))
5048 OpLASTSIB_set(dynamic_meth, (OP*)methop);
5052 methop->op_flags = (U8)(flags & ~OPf_KIDS);
5053 methop->op_u.op_meth_sv = const_meth;
5054 methop->op_private = (U8)(0 | (flags >> 8));
5055 methop->op_next = (OP*)methop;
5059 methop->op_rclass_targ = 0;
5061 methop->op_rclass_sv = NULL;
5064 OpTYPE_set(methop, type);
5065 return CHECKOP(type, methop);
5069 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5070 PERL_ARGS_ASSERT_NEWMETHOP;
5071 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5075 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
5077 Constructs, checks, and returns an op of method type with a constant
5078 method name. C<type> is the opcode. C<flags> gives the eight bits of
5079 C<op_flags>, and, shifted up eight bits, the eight bits of
5080 C<op_private>. C<const_meth> supplies a constant method name;
5081 it must be a shared COW string.
5082 Supported optypes: C<OP_METHOD_NAMED>.
5088 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5089 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5090 return newMETHOP_internal(type, flags, NULL, const_meth);
5094 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
5096 Constructs, checks, and returns an op of any binary type. C<type>
5097 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
5098 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5099 the eight bits of C<op_private>, except that the bit with value 1 or
5100 2 is automatically set as required. C<first> and C<last> supply up to
5101 two ops to be the direct children of the binary op; they are consumed
5102 by this function and become part of the constructed op tree.
5108 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5113 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5114 || type == OP_NULL || type == OP_CUSTOM);
5116 NewOp(1101, binop, 1, BINOP);
5119 first = newOP(OP_NULL, 0);
5121 OpTYPE_set(binop, type);
5122 binop->op_first = first;
5123 binop->op_flags = (U8)(flags | OPf_KIDS);
5126 binop->op_private = (U8)(1 | (flags >> 8));
5129 binop->op_private = (U8)(2 | (flags >> 8));
5130 OpMORESIB_set(first, last);
5133 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5134 OpLASTSIB_set(last, (OP*)binop);
5136 binop->op_last = OpSIBLING(binop->op_first);
5138 OpLASTSIB_set(binop->op_last, (OP*)binop);
5140 binop = (BINOP*)CHECKOP(type, binop);
5141 if (binop->op_next || binop->op_type != (OPCODE)type)
5144 return fold_constants(op_integerize(op_std_init((OP *)binop)));
5147 static int uvcompare(const void *a, const void *b)
5148 __attribute__nonnull__(1)
5149 __attribute__nonnull__(2)
5150 __attribute__pure__;
5151 static int uvcompare(const void *a, const void *b)
5153 if (*((const UV *)a) < (*(const UV *)b))
5155 if (*((const UV *)a) > (*(const UV *)b))
5157 if (*((const UV *)a+1) < (*(const UV *)b+1))
5159 if (*((const UV *)a+1) > (*(const UV *)b+1))
5165 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5167 SV * const tstr = ((SVOP*)expr)->op_sv;
5169 ((SVOP*)repl)->op_sv;
5172 const U8 *t = (U8*)SvPV_const(tstr, tlen);
5173 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5179 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5180 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5181 I32 del = o->op_private & OPpTRANS_DELETE;
5184 PERL_ARGS_ASSERT_PMTRANS;
5186 PL_hints |= HINT_BLOCK_SCOPE;
5189 o->op_private |= OPpTRANS_FROM_UTF;
5192 o->op_private |= OPpTRANS_TO_UTF;
5194 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5195 SV* const listsv = newSVpvs("# comment\n");
5197 const U8* tend = t + tlen;
5198 const U8* rend = r + rlen;
5214 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5215 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5218 const U32 flags = UTF8_ALLOW_DEFAULT;
5222 t = tsave = bytes_to_utf8(t, &len);
5225 if (!to_utf && rlen) {
5227 r = rsave = bytes_to_utf8(r, &len);
5231 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5232 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5236 U8 tmpbuf[UTF8_MAXBYTES+1];
5239 Newx(cp, 2*tlen, UV);
5241 transv = newSVpvs("");
5243 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5245 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5247 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5251 cp[2*i+1] = cp[2*i];
5255 qsort(cp, i, 2*sizeof(UV), uvcompare);
5256 for (j = 0; j < i; j++) {
5258 diff = val - nextmin;
5260 t = uvchr_to_utf8(tmpbuf,nextmin);
5261 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5263 U8 range_mark = ILLEGAL_UTF8_BYTE;
5264 t = uvchr_to_utf8(tmpbuf, val - 1);
5265 sv_catpvn(transv, (char *)&range_mark, 1);
5266 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5273 t = uvchr_to_utf8(tmpbuf,nextmin);
5274 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5276 U8 range_mark = ILLEGAL_UTF8_BYTE;
5277 sv_catpvn(transv, (char *)&range_mark, 1);
5279 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5280 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5281 t = (const U8*)SvPVX_const(transv);
5282 tlen = SvCUR(transv);
5286 else if (!rlen && !del) {
5287 r = t; rlen = tlen; rend = tend;
5290 if ((!rlen && !del) || t == r ||
5291 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5293 o->op_private |= OPpTRANS_IDENTICAL;
5297 while (t < tend || tfirst <= tlast) {
5298 /* see if we need more "t" chars */
5299 if (tfirst > tlast) {
5300 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5302 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5304 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5311 /* now see if we need more "r" chars */
5312 if (rfirst > rlast) {
5314 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5316 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5318 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5327 rfirst = rlast = 0xffffffff;
5331 /* now see which range will peter out first, if either. */
5332 tdiff = tlast - tfirst;
5333 rdiff = rlast - rfirst;
5334 tcount += tdiff + 1;
5335 rcount += rdiff + 1;
5342 if (rfirst == 0xffffffff) {
5343 diff = tdiff; /* oops, pretend rdiff is infinite */
5345 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5346 (long)tfirst, (long)tlast);
5348 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5352 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5353 (long)tfirst, (long)(tfirst + diff),
5356 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5357 (long)tfirst, (long)rfirst);
5359 if (rfirst + diff > max)
5360 max = rfirst + diff;
5362 grows = (tfirst < rfirst &&
5363 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5375 else if (max > 0xff)
5380 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5382 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5383 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5384 PAD_SETSV(cPADOPo->op_padix, swash);
5386 SvREADONLY_on(swash);
5388 cSVOPo->op_sv = swash;
5390 SvREFCNT_dec(listsv);
5391 SvREFCNT_dec(transv);
5393 if (!del && havefinal && rlen)
5394 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5395 newSVuv((UV)final), 0);
5404 else if (rlast == 0xffffffff)
5410 tbl = (short*)PerlMemShared_calloc(
5411 (o->op_private & OPpTRANS_COMPLEMENT) &&
5412 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5414 cPVOPo->op_pv = (char*)tbl;
5416 for (i = 0; i < (I32)tlen; i++)
5418 for (i = 0, j = 0; i < 256; i++) {
5420 if (j >= (I32)rlen) {
5429 if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
5439 o->op_private |= OPpTRANS_IDENTICAL;
5441 else if (j >= (I32)rlen)
5446 PerlMemShared_realloc(tbl,
5447 (0x101+rlen-j) * sizeof(short));
5448 cPVOPo->op_pv = (char*)tbl;
5450 tbl[0x100] = (short)(rlen - j);
5451 for (i=0; i < (I32)rlen - j; i++)
5452 tbl[0x101+i] = r[j+i];
5456 if (!rlen && !del) {
5459 o->op_private |= OPpTRANS_IDENTICAL;
5461 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5462 o->op_private |= OPpTRANS_IDENTICAL;
5464 for (i = 0; i < 256; i++)
5466 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5467 if (j >= (I32)rlen) {
5469 if (tbl[t[i]] == -1)
5475 if (tbl[t[i]] == -1) {
5476 if ( UVCHR_IS_INVARIANT(t[i])
5477 && ! UVCHR_IS_INVARIANT(r[j]))
5485 if(del && rlen == tlen) {
5486 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5487 } else if(rlen > tlen && !complement) {
5488 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5492 o->op_private |= OPpTRANS_GROWS;
5500 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5502 Constructs, checks, and returns an op of any pattern matching type.
5503 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
5504 and, shifted up eight bits, the eight bits of C<op_private>.
5510 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5515 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5516 || type == OP_CUSTOM);
5518 NewOp(1101, pmop, 1, PMOP);
5519 OpTYPE_set(pmop, type);
5520 pmop->op_flags = (U8)flags;
5521 pmop->op_private = (U8)(0 | (flags >> 8));
5522 if (PL_opargs[type] & OA_RETSCALAR)
5525 if (PL_hints & HINT_RE_TAINT)
5526 pmop->op_pmflags |= PMf_RETAINT;
5527 #ifdef USE_LOCALE_CTYPE
5528 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5529 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5534 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5536 if (PL_hints & HINT_RE_FLAGS) {
5537 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5538 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5540 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5541 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5542 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5544 if (reflags && SvOK(reflags)) {
5545 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5551 assert(SvPOK(PL_regex_pad[0]));
5552 if (SvCUR(PL_regex_pad[0])) {
5553 /* Pop off the "packed" IV from the end. */
5554 SV *const repointer_list = PL_regex_pad[0];
5555 const char *p = SvEND(repointer_list) - sizeof(IV);
5556 const IV offset = *((IV*)p);
5558 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5560 SvEND_set(repointer_list, p);
5562 pmop->op_pmoffset = offset;
5563 /* This slot should be free, so assert this: */
5564 assert(PL_regex_pad[offset] == &PL_sv_undef);
5566 SV * const repointer = &PL_sv_undef;
5567 av_push(PL_regex_padav, repointer);
5568 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5569 PL_regex_pad = AvARRAY(PL_regex_padav);
5573 return CHECKOP(type, pmop);
5581 /* Any pad names in scope are potentially lvalues. */
5582 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5583 PADNAME *pn = PAD_COMPNAME_SV(i);
5584 if (!pn || !PadnameLEN(pn))
5586 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5587 S_mark_padname_lvalue(aTHX_ pn);
5591 /* Given some sort of match op o, and an expression expr containing a
5592 * pattern, either compile expr into a regex and attach it to o (if it's
5593 * constant), or convert expr into a runtime regcomp op sequence (if it's
5596 * Flags currently has 2 bits of meaning:
5597 * 1: isreg indicates that the pattern is part of a regex construct, eg
5598 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5599 * split "pattern", which aren't. In the former case, expr will be a list
5600 * if the pattern contains more than one term (eg /a$b/).
5601 * 2: The pattern is for a split.
5603 * When the pattern has been compiled within a new anon CV (for
5604 * qr/(?{...})/ ), then floor indicates the savestack level just before
5605 * the new sub was created
5609 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
5613 I32 repl_has_vars = 0;
5614 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5615 bool is_compiletime;
5617 bool isreg = cBOOL(flags & 1);
5618 bool is_split = cBOOL(flags & 2);
5620 PERL_ARGS_ASSERT_PMRUNTIME;
5623 return pmtrans(o, expr, repl);
5626 /* find whether we have any runtime or code elements;
5627 * at the same time, temporarily set the op_next of each DO block;
5628 * then when we LINKLIST, this will cause the DO blocks to be excluded
5629 * from the op_next chain (and from having LINKLIST recursively
5630 * applied to them). We fix up the DOs specially later */
5634 if (expr->op_type == OP_LIST) {
5636 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5637 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5639 assert(!o->op_next);
5640 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5641 assert(PL_parser && PL_parser->error_count);
5642 /* This can happen with qr/ (?{(^{})/. Just fake up
5643 the op we were expecting to see, to avoid crashing
5645 op_sibling_splice(expr, o, 0,
5646 newSVOP(OP_CONST, 0, &PL_sv_no));
5648 o->op_next = OpSIBLING(o);
5650 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5654 else if (expr->op_type != OP_CONST)
5659 /* fix up DO blocks; treat each one as a separate little sub;
5660 * also, mark any arrays as LIST/REF */
5662 if (expr->op_type == OP_LIST) {
5664 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5666 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5667 assert( !(o->op_flags & OPf_WANT));
5668 /* push the array rather than its contents. The regex
5669 * engine will retrieve and join the elements later */
5670 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5674 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5676 o->op_next = NULL; /* undo temporary hack from above */
5679 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5680 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5682 assert(leaveop->op_first->op_type == OP_ENTER);
5683 assert(OpHAS_SIBLING(leaveop->op_first));
5684 o->op_next = OpSIBLING(leaveop->op_first);
5686 assert(leaveop->op_flags & OPf_KIDS);
5687 assert(leaveop->op_last->op_next == (OP*)leaveop);
5688 leaveop->op_next = NULL; /* stop on last op */
5689 op_null((OP*)leaveop);
5693 OP *scope = cLISTOPo->op_first;
5694 assert(scope->op_type == OP_SCOPE);
5695 assert(scope->op_flags & OPf_KIDS);
5696 scope->op_next = NULL; /* stop on last op */
5699 /* have to peep the DOs individually as we've removed it from
5700 * the op_next chain */
5702 S_prune_chain_head(&(o->op_next));
5704 /* runtime finalizes as part of finalizing whole tree */
5708 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5709 assert( !(expr->op_flags & OPf_WANT));
5710 /* push the array rather than its contents. The regex
5711 * engine will retrieve and join the elements later */
5712 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5715 PL_hints |= HINT_BLOCK_SCOPE;
5717 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5719 if (is_compiletime) {
5720 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5721 regexp_engine const *eng = current_re_engine();
5724 /* make engine handle split ' ' specially */
5725 pm->op_pmflags |= PMf_SPLIT;
5726 rx_flags |= RXf_SPLIT;
5729 if (!has_code || !eng->op_comp) {
5730 /* compile-time simple constant pattern */
5732 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5733 /* whoops! we guessed that a qr// had a code block, but we
5734 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5735 * that isn't required now. Note that we have to be pretty
5736 * confident that nothing used that CV's pad while the
5737 * regex was parsed, except maybe op targets for \Q etc.
5738 * If there were any op targets, though, they should have
5739 * been stolen by constant folding.
5743 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5744 while (++i <= AvFILLp(PL_comppad)) {
5745 # ifdef USE_PAD_RESET
5746 /* under USE_PAD_RESET, pad swipe replaces a swiped
5747 * folded constant with a fresh padtmp */
5748 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
5750 assert(!PL_curpad[i]);
5754 /* But we know that one op is using this CV's slab. */
5755 cv_forget_slab(PL_compcv);
5757 pm->op_pmflags &= ~PMf_HAS_CV;
5762 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5763 rx_flags, pm->op_pmflags)
5764 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5765 rx_flags, pm->op_pmflags)
5770 /* compile-time pattern that includes literal code blocks */
5771 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5774 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5777 if (pm->op_pmflags & PMf_HAS_CV) {
5779 /* this QR op (and the anon sub we embed it in) is never
5780 * actually executed. It's just a placeholder where we can
5781 * squirrel away expr in op_code_list without the peephole
5782 * optimiser etc processing it for a second time */
5783 OP *qr = newPMOP(OP_QR, 0);
5784 ((PMOP*)qr)->op_code_list = expr;
5786 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5787 SvREFCNT_inc_simple_void(PL_compcv);
5788 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5789 ReANY(re)->qr_anoncv = cv;
5791 /* attach the anon CV to the pad so that
5792 * pad_fixup_inner_anons() can find it */
5793 (void)pad_add_anon(cv, o->op_type);
5794 SvREFCNT_inc_simple_void(cv);
5797 pm->op_code_list = expr;
5802 /* runtime pattern: build chain of regcomp etc ops */
5804 PADOFFSET cv_targ = 0;
5806 reglist = isreg && expr->op_type == OP_LIST;
5811 pm->op_code_list = expr;
5812 /* don't free op_code_list; its ops are embedded elsewhere too */
5813 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5817 /* make engine handle split ' ' specially */
5818 pm->op_pmflags |= PMf_SPLIT;
5820 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5821 * to allow its op_next to be pointed past the regcomp and
5822 * preceding stacking ops;
5823 * OP_REGCRESET is there to reset taint before executing the
5825 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5826 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5828 if (pm->op_pmflags & PMf_HAS_CV) {
5829 /* we have a runtime qr with literal code. This means
5830 * that the qr// has been wrapped in a new CV, which
5831 * means that runtime consts, vars etc will have been compiled
5832 * against a new pad. So... we need to execute those ops
5833 * within the environment of the new CV. So wrap them in a call
5834 * to a new anon sub. i.e. for
5838 * we build an anon sub that looks like
5840 * sub { "a", $b, '(?{...})' }
5842 * and call it, passing the returned list to regcomp.
5843 * Or to put it another way, the list of ops that get executed
5847 * ------ -------------------
5848 * pushmark (for regcomp)
5849 * pushmark (for entersub)
5853 * regcreset regcreset
5855 * const("a") const("a")
5857 * const("(?{...})") const("(?{...})")
5862 SvREFCNT_inc_simple_void(PL_compcv);
5863 CvLVALUE_on(PL_compcv);
5864 /* these lines are just an unrolled newANONATTRSUB */
5865 expr = newSVOP(OP_ANONCODE, 0,
5866 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5867 cv_targ = expr->op_targ;
5868 expr = newUNOP(OP_REFGEN, 0, expr);
5870 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5873 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
5874 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5875 | (reglist ? OPf_STACKED : 0);
5876 rcop->op_targ = cv_targ;
5878 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5879 if (PL_hints & HINT_RE_EVAL)
5880 S_set_haseval(aTHX);
5882 /* establish postfix order */
5883 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5885 rcop->op_next = expr;
5886 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5889 rcop->op_next = LINKLIST(expr);
5890 expr->op_next = (OP*)rcop;
5893 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5899 /* If we are looking at s//.../e with a single statement, get past
5900 the implicit do{}. */
5901 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5902 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5903 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5906 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5907 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5908 && !OpHAS_SIBLING(sib))
5911 if (curop->op_type == OP_CONST)
5913 else if (( (curop->op_type == OP_RV2SV ||
5914 curop->op_type == OP_RV2AV ||
5915 curop->op_type == OP_RV2HV ||
5916 curop->op_type == OP_RV2GV)
5917 && cUNOPx(curop)->op_first
5918 && cUNOPx(curop)->op_first->op_type == OP_GV )
5919 || curop->op_type == OP_PADSV
5920 || curop->op_type == OP_PADAV
5921 || curop->op_type == OP_PADHV
5922 || curop->op_type == OP_PADANY) {
5930 || !RX_PRELEN(PM_GETRE(pm))
5931 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5933 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5934 op_prepend_elem(o->op_type, scalar(repl), o);
5937 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
5938 rcop->op_private = 1;
5940 /* establish postfix order */
5941 rcop->op_next = LINKLIST(repl);
5942 repl->op_next = (OP*)rcop;
5944 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5945 assert(!(pm->op_pmflags & PMf_ONCE));
5946 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5955 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5957 Constructs, checks, and returns an op of any type that involves an
5958 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
5959 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
5960 takes ownership of one reference to it.
5966 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5971 PERL_ARGS_ASSERT_NEWSVOP;
5973 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5974 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5975 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5976 || type == OP_CUSTOM);
5978 NewOp(1101, svop, 1, SVOP);
5979 OpTYPE_set(svop, type);
5981 svop->op_next = (OP*)svop;
5982 svop->op_flags = (U8)flags;
5983 svop->op_private = (U8)(0 | (flags >> 8));
5984 if (PL_opargs[type] & OA_RETSCALAR)
5986 if (PL_opargs[type] & OA_TARGET)
5987 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5988 return CHECKOP(type, svop);
5992 =for apidoc Am|OP *|newDEFSVOP|
5994 Constructs and returns an op to access C<$_>.
6000 Perl_newDEFSVOP(pTHX)
6002 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
6008 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
6010 Constructs, checks, and returns an op of any type that involves a
6011 reference to a pad element. C<type> is the opcode. C<flags> gives the
6012 eight bits of C<op_flags>. A pad slot is automatically allocated, and
6013 is populated with C<sv>; this function takes ownership of one reference
6016 This function only exists if Perl has been compiled to use ithreads.
6022 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
6027 PERL_ARGS_ASSERT_NEWPADOP;
6029 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
6030 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6031 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6032 || type == OP_CUSTOM);
6034 NewOp(1101, padop, 1, PADOP);
6035 OpTYPE_set(padop, type);
6037 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
6038 SvREFCNT_dec(PAD_SVl(padop->op_padix));
6039 PAD_SETSV(padop->op_padix, sv);
6041 padop->op_next = (OP*)padop;
6042 padop->op_flags = (U8)flags;
6043 if (PL_opargs[type] & OA_RETSCALAR)
6045 if (PL_opargs[type] & OA_TARGET)
6046 padop->op_targ = pad_alloc(type, SVs_PADTMP);
6047 return CHECKOP(type, padop);
6050 #endif /* USE_ITHREADS */
6053 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
6055 Constructs, checks, and returns an op of any type that involves an
6056 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
6057 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
6058 reference; calling this function does not transfer ownership of any
6065 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
6067 PERL_ARGS_ASSERT_NEWGVOP;
6070 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6072 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6077 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
6079 Constructs, checks, and returns an op of any type that involves an
6080 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
6081 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
6082 must have been allocated using C<PerlMemShared_malloc>; the memory will
6083 be freed when the op is destroyed.
6089 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
6092 const bool utf8 = cBOOL(flags & SVf_UTF8);
6097 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6098 || type == OP_RUNCV || type == OP_CUSTOM
6099 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6101 NewOp(1101, pvop, 1, PVOP);
6102 OpTYPE_set(pvop, type);
6104 pvop->op_next = (OP*)pvop;
6105 pvop->op_flags = (U8)flags;
6106 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
6107 if (PL_opargs[type] & OA_RETSCALAR)
6109 if (PL_opargs[type] & OA_TARGET)
6110 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
6111 return CHECKOP(type, pvop);
6115 Perl_package(pTHX_ OP *o)
6117 SV *const sv = cSVOPo->op_sv;
6119 PERL_ARGS_ASSERT_PACKAGE;
6121 SAVEGENERICSV(PL_curstash);
6122 save_item(PL_curstname);
6124 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
6126 sv_setsv(PL_curstname, sv);
6128 PL_hints |= HINT_BLOCK_SCOPE;
6129 PL_parser->copline = NOLINE;
6135 Perl_package_version( pTHX_ OP *v )
6137 U32 savehints = PL_hints;
6138 PERL_ARGS_ASSERT_PACKAGE_VERSION;
6139 PL_hints &= ~HINT_STRICT_VARS;
6140 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6141 PL_hints = savehints;
6146 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6151 SV *use_version = NULL;
6153 PERL_ARGS_ASSERT_UTILIZE;
6155 if (idop->op_type != OP_CONST)
6156 Perl_croak(aTHX_ "Module name must be constant");
6161 SV * const vesv = ((SVOP*)version)->op_sv;
6163 if (!arg && !SvNIOKp(vesv)) {
6170 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6171 Perl_croak(aTHX_ "Version number must be a constant number");
6173 /* Make copy of idop so we don't free it twice */
6174 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6176 /* Fake up a method call to VERSION */
6177 meth = newSVpvs_share("VERSION");
6178 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6179 op_append_elem(OP_LIST,
6180 op_prepend_elem(OP_LIST, pack, version),
6181 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6185 /* Fake up an import/unimport */
6186 if (arg && arg->op_type == OP_STUB) {
6187 imop = arg; /* no import on explicit () */
6189 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6190 imop = NULL; /* use 5.0; */
6192 use_version = ((SVOP*)idop)->op_sv;
6194 idop->op_private |= OPpCONST_NOVER;
6199 /* Make copy of idop so we don't free it twice */
6200 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6202 /* Fake up a method call to import/unimport */
6204 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6205 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6206 op_append_elem(OP_LIST,
6207 op_prepend_elem(OP_LIST, pack, arg),
6208 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6212 /* Fake up the BEGIN {}, which does its thing immediately. */
6214 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6217 op_append_elem(OP_LINESEQ,
6218 op_append_elem(OP_LINESEQ,
6219 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6220 newSTATEOP(0, NULL, veop)),
6221 newSTATEOP(0, NULL, imop) ));
6225 * feature bundle that corresponds to the required version. */
6226 use_version = sv_2mortal(new_version(use_version));
6227 S_enable_feature_bundle(aTHX_ use_version);
6229 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6230 if (vcmp(use_version,
6231 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6232 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6233 PL_hints |= HINT_STRICT_REFS;
6234 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6235 PL_hints |= HINT_STRICT_SUBS;
6236 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6237 PL_hints |= HINT_STRICT_VARS;
6239 /* otherwise they are off */
6241 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6242 PL_hints &= ~HINT_STRICT_REFS;
6243 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6244 PL_hints &= ~HINT_STRICT_SUBS;
6245 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6246 PL_hints &= ~HINT_STRICT_VARS;
6250 /* The "did you use incorrect case?" warning used to be here.
6251 * The problem is that on case-insensitive filesystems one
6252 * might get false positives for "use" (and "require"):
6253 * "use Strict" or "require CARP" will work. This causes
6254 * portability problems for the script: in case-strict
6255 * filesystems the script will stop working.
6257 * The "incorrect case" warning checked whether "use Foo"
6258 * imported "Foo" to your namespace, but that is wrong, too:
6259 * there is no requirement nor promise in the language that
6260 * a Foo.pm should or would contain anything in package "Foo".
6262 * There is very little Configure-wise that can be done, either:
6263 * the case-sensitivity of the build filesystem of Perl does not
6264 * help in guessing the case-sensitivity of the runtime environment.
6267 PL_hints |= HINT_BLOCK_SCOPE;
6268 PL_parser->copline = NOLINE;
6269 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6273 =head1 Embedding Functions
6275 =for apidoc load_module
6277 Loads the module whose name is pointed to by the string part of C<name>.
6278 Note that the actual module name, not its filename, should be given.
6279 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
6280 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
6281 trailing arguments can be used to specify arguments to the module's C<import()>
6282 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
6283 on the flags. The flags argument is a bitwise-ORed collection of any of
6284 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6285 (or 0 for no flags).
6287 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
6288 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
6289 the trailing optional arguments may be omitted entirely. Otherwise, if
6290 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
6291 exactly one C<OP*>, containing the op tree that produces the relevant import
6292 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
6293 will be used as import arguments; and the list must be terminated with C<(SV*)
6294 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
6295 set, the trailing C<NULL> pointer is needed even if no import arguments are
6296 desired. The reference count for each specified C<SV*> argument is
6297 decremented. In addition, the C<name> argument is modified.
6299 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
6305 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6309 PERL_ARGS_ASSERT_LOAD_MODULE;
6311 va_start(args, ver);
6312 vload_module(flags, name, ver, &args);
6316 #ifdef PERL_IMPLICIT_CONTEXT
6318 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6322 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6323 va_start(args, ver);
6324 vload_module(flags, name, ver, &args);
6330 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6333 OP * const modname = newSVOP(OP_CONST, 0, name);
6335 PERL_ARGS_ASSERT_VLOAD_MODULE;
6337 modname->op_private |= OPpCONST_BARE;
6339 veop = newSVOP(OP_CONST, 0, ver);
6343 if (flags & PERL_LOADMOD_NOIMPORT) {
6344 imop = sawparens(newNULLLIST());
6346 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6347 imop = va_arg(*args, OP*);
6352 sv = va_arg(*args, SV*);
6354 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6355 sv = va_arg(*args, SV*);
6359 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6360 * that it has a PL_parser to play with while doing that, and also
6361 * that it doesn't mess with any existing parser, by creating a tmp
6362 * new parser with lex_start(). This won't actually be used for much,
6363 * since pp_require() will create another parser for the real work.
6364 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6367 SAVEVPTR(PL_curcop);
6368 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6369 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6370 veop, modname, imop);
6374 PERL_STATIC_INLINE OP *
6375 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6377 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6378 newLISTOP(OP_LIST, 0, arg,
6379 newUNOP(OP_RV2CV, 0,
6380 newGVOP(OP_GV, 0, gv))));
6384 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6389 PERL_ARGS_ASSERT_DOFILE;
6391 if (!force_builtin && (gv = gv_override("do", 2))) {
6392 doop = S_new_entersubop(aTHX_ gv, term);
6395 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6401 =head1 Optree construction
6403 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6405 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
6406 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6407 be set automatically, and, shifted up eight bits, the eight bits of
6408 C<op_private>, except that the bit with value 1 or 2 is automatically
6409 set as required. C<listval> and C<subscript> supply the parameters of
6410 the slice; they are consumed by this function and become part of the
6411 constructed op tree.
6417 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6419 return newBINOP(OP_LSLICE, flags,
6420 list(force_list(subscript, 1)),
6421 list(force_list(listval, 1)) );
6424 #define ASSIGN_LIST 1
6425 #define ASSIGN_REF 2
6428 S_assignment_type(pTHX_ const OP *o)
6437 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6438 o = cUNOPo->op_first;
6440 flags = o->op_flags;
6442 if (type == OP_COND_EXPR) {
6443 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6444 const I32 t = assignment_type(sib);
6445 const I32 f = assignment_type(OpSIBLING(sib));
6447 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6449 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6450 yyerror("Assignment to both a list and a scalar");
6454 if (type == OP_SREFGEN)
6456 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6457 type = kid->op_type;
6458 flags |= kid->op_flags;
6459 if (!(flags & OPf_PARENS)
6460 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6461 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6467 if (type == OP_LIST &&
6468 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6469 o->op_private & OPpLVAL_INTRO)
6472 if (type == OP_LIST || flags & OPf_PARENS ||
6473 type == OP_RV2AV || type == OP_RV2HV ||
6474 type == OP_ASLICE || type == OP_HSLICE ||
6475 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6478 if (type == OP_PADAV || type == OP_PADHV)
6481 if (type == OP_RV2SV)
6489 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6491 Constructs, checks, and returns an assignment op. C<left> and C<right>
6492 supply the parameters of the assignment; they are consumed by this
6493 function and become part of the constructed op tree.
6495 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6496 a suitable conditional optree is constructed. If C<optype> is the opcode
6497 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6498 performs the binary operation and assigns the result to the left argument.
6499 Either way, if C<optype> is non-zero then C<flags> has no effect.
6501 If C<optype> is zero, then a plain scalar or list assignment is
6502 constructed. Which type of assignment it is is automatically determined.
6503 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6504 will be set automatically, and, shifted up eight bits, the eight bits
6505 of C<op_private>, except that the bit with value 1 or 2 is automatically
6512 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6518 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6519 right = scalar(right);
6520 return newLOGOP(optype, 0,
6521 op_lvalue(scalar(left), optype),
6522 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
6525 return newBINOP(optype, OPf_STACKED,
6526 op_lvalue(scalar(left), optype), scalar(right));
6530 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6531 static const char no_list_state[] = "Initialization of state variables"
6532 " in list context currently forbidden";
6535 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6536 left->op_private &= ~ OPpSLICEWARNING;
6539 left = op_lvalue(left, OP_AASSIGN);
6540 curop = list(force_list(left, 1));
6541 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6542 o->op_private = (U8)(0 | (flags >> 8));
6544 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6546 OP* lop = ((LISTOP*)left)->op_first;
6548 if ((lop->op_type == OP_PADSV ||
6549 lop->op_type == OP_PADAV ||
6550 lop->op_type == OP_PADHV ||
6551 lop->op_type == OP_PADANY)
6552 && (lop->op_private & OPpPAD_STATE)
6554 yyerror(no_list_state);
6555 lop = OpSIBLING(lop);
6558 else if ( (left->op_private & OPpLVAL_INTRO)
6559 && (left->op_private & OPpPAD_STATE)
6560 && ( left->op_type == OP_PADSV
6561 || left->op_type == OP_PADAV
6562 || left->op_type == OP_PADHV
6563 || left->op_type == OP_PADANY)
6565 /* All single variable list context state assignments, hence
6575 yyerror(no_list_state);
6578 /* optimise @a = split(...) into:
6579 * @{expr}: split(..., @{expr}) (where @a is not flattened)
6580 * @a, my @a, local @a: split(...) (where @a is attached to
6581 * the split op itself)
6585 && right->op_type == OP_SPLIT
6586 /* don't do twice, e.g. @b = (@a = split) */
6587 && !(right->op_private & OPpSPLIT_ASSIGN))
6591 if ( ( left->op_type == OP_RV2AV
6592 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
6593 || left->op_type == OP_PADAV)
6595 /* @pkg or @lex or local @pkg' or 'my @lex' */
6599 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
6600 = cPADOPx(gvop)->op_padix;
6601 cPADOPx(gvop)->op_padix = 0; /* steal it */
6603 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
6604 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
6605 cSVOPx(gvop)->op_sv = NULL; /* steal it */
6607 right->op_private |=
6608 left->op_private & OPpOUR_INTRO;
6611 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
6612 left->op_targ = 0; /* steal it */
6613 right->op_private |= OPpSPLIT_LEX;
6615 right->op_private |= left->op_private & OPpLVAL_INTRO;
6618 tmpop = cUNOPo->op_first; /* to list (nulled) */
6619 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6620 assert(OpSIBLING(tmpop) == right);
6621 assert(!OpHAS_SIBLING(right));
6622 /* detach the split subtreee from the o tree,
6623 * then free the residual o tree */
6624 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
6625 op_free(o); /* blow off assign */
6626 right->op_private |= OPpSPLIT_ASSIGN;
6627 right->op_flags &= ~OPf_WANT;
6628 /* "I don't know and I don't care." */
6631 else if (left->op_type == OP_RV2AV) {
6634 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
6635 assert(OpSIBLING(pushop) == left);
6636 /* Detach the array ... */
6637 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
6638 /* ... and attach it to the split. */
6639 op_sibling_splice(right, cLISTOPx(right)->op_last,
6641 right->op_flags |= OPf_STACKED;
6642 /* Detach split and expunge aassign as above. */
6645 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6646 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6648 /* convert split(...,0) to split(..., PL_modcount+1) */
6650 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6651 SV * const sv = *svp;
6652 if (SvIOK(sv) && SvIVX(sv) == 0)
6654 if (right->op_private & OPpSPLIT_IMPLIM) {
6655 /* our own SV, created in ck_split */
6657 sv_setiv(sv, PL_modcount+1);
6660 /* SV may belong to someone else */
6662 *svp = newSViv(PL_modcount+1);
6669 if (assign_type == ASSIGN_REF)
6670 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6672 right = newOP(OP_UNDEF, 0);
6673 if (right->op_type == OP_READLINE) {
6674 right->op_flags |= OPf_STACKED;
6675 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6679 o = newBINOP(OP_SASSIGN, flags,
6680 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6686 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6688 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6689 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6690 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6691 If C<label> is non-null, it supplies the name of a label to attach to
6692 the state op; this function takes ownership of the memory pointed at by
6693 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
6696 If C<o> is null, the state op is returned. Otherwise the state op is
6697 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
6698 is consumed by this function and becomes part of the returned op tree.
6704 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6707 const U32 seq = intro_my();
6708 const U32 utf8 = flags & SVf_UTF8;
6711 PL_parser->parsed_sub = 0;
6715 NewOp(1101, cop, 1, COP);
6716 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6717 OpTYPE_set(cop, OP_DBSTATE);
6720 OpTYPE_set(cop, OP_NEXTSTATE);
6722 cop->op_flags = (U8)flags;
6723 CopHINTS_set(cop, PL_hints);
6725 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6727 cop->op_next = (OP*)cop;
6730 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6731 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6733 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6735 PL_hints |= HINT_BLOCK_SCOPE;
6736 /* It seems that we need to defer freeing this pointer, as other parts
6737 of the grammar end up wanting to copy it after this op has been
6742 if (PL_parser->preambling != NOLINE) {
6743 CopLINE_set(cop, PL_parser->preambling);
6744 PL_parser->copline = NOLINE;
6746 else if (PL_parser->copline == NOLINE)
6747 CopLINE_set(cop, CopLINE(PL_curcop));
6749 CopLINE_set(cop, PL_parser->copline);
6750 PL_parser->copline = NOLINE;
6753 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6755 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6757 CopSTASH_set(cop, PL_curstash);
6759 if (cop->op_type == OP_DBSTATE) {
6760 /* this line can have a breakpoint - store the cop in IV */
6761 AV *av = CopFILEAVx(PL_curcop);
6763 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6764 if (svp && *svp != &PL_sv_undef ) {
6765 (void)SvIOK_on(*svp);
6766 SvIV_set(*svp, PTR2IV(cop));
6771 if (flags & OPf_SPECIAL)
6773 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6777 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6779 Constructs, checks, and returns a logical (flow control) op. C<type>
6780 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6781 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6782 the eight bits of C<op_private>, except that the bit with value 1 is
6783 automatically set. C<first> supplies the expression controlling the
6784 flow, and C<other> supplies the side (alternate) chain of ops; they are
6785 consumed by this function and become part of the constructed op tree.
6791 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6793 PERL_ARGS_ASSERT_NEWLOGOP;
6795 return new_logop(type, flags, &first, &other);
6799 S_search_const(pTHX_ OP *o)
6801 PERL_ARGS_ASSERT_SEARCH_CONST;
6803 switch (o->op_type) {
6807 if (o->op_flags & OPf_KIDS)
6808 return search_const(cUNOPo->op_first);
6815 if (!(o->op_flags & OPf_KIDS))
6817 kid = cLISTOPo->op_first;
6819 switch (kid->op_type) {
6823 kid = OpSIBLING(kid);
6826 if (kid != cLISTOPo->op_last)
6832 kid = cLISTOPo->op_last;
6834 return search_const(kid);
6842 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6850 int prepend_not = 0;
6852 PERL_ARGS_ASSERT_NEW_LOGOP;
6857 /* [perl #59802]: Warn about things like "return $a or $b", which
6858 is parsed as "(return $a) or $b" rather than "return ($a or
6859 $b)". NB: This also applies to xor, which is why we do it
6862 switch (first->op_type) {
6866 /* XXX: Perhaps we should emit a stronger warning for these.
6867 Even with the high-precedence operator they don't seem to do
6870 But until we do, fall through here.
6876 /* XXX: Currently we allow people to "shoot themselves in the
6877 foot" by explicitly writing "(return $a) or $b".
6879 Warn unless we are looking at the result from folding or if
6880 the programmer explicitly grouped the operators like this.
6881 The former can occur with e.g.
6883 use constant FEATURE => ( $] >= ... );
6884 sub { not FEATURE and return or do_stuff(); }
6886 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6887 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6888 "Possible precedence issue with control flow operator");
6889 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6895 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6896 return newBINOP(type, flags, scalar(first), scalar(other));
6898 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6899 || type == OP_CUSTOM);
6901 scalarboolean(first);
6903 /* search for a constant op that could let us fold the test */
6904 if ((cstop = search_const(first))) {
6905 if (cstop->op_private & OPpCONST_STRICT)
6906 no_bareword_allowed(cstop);
6907 else if ((cstop->op_private & OPpCONST_BARE))
6908 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6909 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6910 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6911 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6912 /* Elide the (constant) lhs, since it can't affect the outcome */
6914 if (other->op_type == OP_CONST)
6915 other->op_private |= OPpCONST_SHORTCIRCUIT;
6917 if (other->op_type == OP_LEAVE)
6918 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6919 else if (other->op_type == OP_MATCH
6920 || other->op_type == OP_SUBST
6921 || other->op_type == OP_TRANSR
6922 || other->op_type == OP_TRANS)
6923 /* Mark the op as being unbindable with =~ */
6924 other->op_flags |= OPf_SPECIAL;
6926 other->op_folded = 1;
6930 /* Elide the rhs, since the outcome is entirely determined by
6931 * the (constant) lhs */
6933 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6934 const OP *o2 = other;
6935 if ( ! (o2->op_type == OP_LIST
6936 && (( o2 = cUNOPx(o2)->op_first))
6937 && o2->op_type == OP_PUSHMARK
6938 && (( o2 = OpSIBLING(o2))) )
6941 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6942 || o2->op_type == OP_PADHV)
6943 && o2->op_private & OPpLVAL_INTRO
6944 && !(o2->op_private & OPpPAD_STATE))
6946 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6947 "Deprecated use of my() in false conditional");
6951 if (cstop->op_type == OP_CONST)
6952 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6957 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6958 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6960 const OP * const k1 = ((UNOP*)first)->op_first;
6961 const OP * const k2 = OpSIBLING(k1);
6963 switch (first->op_type)
6966 if (k2 && k2->op_type == OP_READLINE
6967 && (k2->op_flags & OPf_STACKED)
6968 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6970 warnop = k2->op_type;
6975 if (k1->op_type == OP_READDIR
6976 || k1->op_type == OP_GLOB
6977 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6978 || k1->op_type == OP_EACH
6979 || k1->op_type == OP_AEACH)
6981 warnop = ((k1->op_type == OP_NULL)
6982 ? (OPCODE)k1->op_targ : k1->op_type);
6987 const line_t oldline = CopLINE(PL_curcop);
6988 /* This ensures that warnings are reported at the first line
6989 of the construction, not the last. */
6990 CopLINE_set(PL_curcop, PL_parser->copline);
6991 Perl_warner(aTHX_ packWARN(WARN_MISC),
6992 "Value of %s%s can be \"0\"; test with defined()",
6994 ((warnop == OP_READLINE || warnop == OP_GLOB)
6995 ? " construct" : "() operator"));
6996 CopLINE_set(PL_curcop, oldline);
7000 /* optimize AND and OR ops that have NOTs as children */
7001 if (first->op_type == OP_NOT
7002 && (first->op_flags & OPf_KIDS)
7003 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
7004 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
7006 if (type == OP_AND || type == OP_OR) {
7012 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
7014 prepend_not = 1; /* prepend a NOT op later */
7019 logop = alloc_LOGOP(type, first, LINKLIST(other));
7020 logop->op_flags |= (U8)flags;
7021 logop->op_private = (U8)(1 | (flags >> 8));
7023 /* establish postfix order */
7024 logop->op_next = LINKLIST(first);
7025 first->op_next = (OP*)logop;
7026 assert(!OpHAS_SIBLING(first));
7027 op_sibling_splice((OP*)logop, first, 0, other);
7029 CHECKOP(type,logop);
7031 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7032 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7040 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7042 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7043 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7044 will be set automatically, and, shifted up eight bits, the eight bits of
7045 C<op_private>, except that the bit with value 1 is automatically set.
7046 C<first> supplies the expression selecting between the two branches,
7047 and C<trueop> and C<falseop> supply the branches; they are consumed by
7048 this function and become part of the constructed op tree.
7054 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7062 PERL_ARGS_ASSERT_NEWCONDOP;
7065 return newLOGOP(OP_AND, 0, first, trueop);
7067 return newLOGOP(OP_OR, 0, first, falseop);
7069 scalarboolean(first);
7070 if ((cstop = search_const(first))) {
7071 /* Left or right arm of the conditional? */
7072 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7073 OP *live = left ? trueop : falseop;
7074 OP *const dead = left ? falseop : trueop;
7075 if (cstop->op_private & OPpCONST_BARE &&
7076 cstop->op_private & OPpCONST_STRICT) {
7077 no_bareword_allowed(cstop);
7081 if (live->op_type == OP_LEAVE)
7082 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7083 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7084 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7085 /* Mark the op as being unbindable with =~ */
7086 live->op_flags |= OPf_SPECIAL;
7087 live->op_folded = 1;
7090 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
7091 logop->op_flags |= (U8)flags;
7092 logop->op_private = (U8)(1 | (flags >> 8));
7093 logop->op_next = LINKLIST(falseop);
7095 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7098 /* establish postfix order */
7099 start = LINKLIST(first);
7100 first->op_next = (OP*)logop;
7102 /* make first, trueop, falseop siblings */
7103 op_sibling_splice((OP*)logop, first, 0, trueop);
7104 op_sibling_splice((OP*)logop, trueop, 0, falseop);
7106 o = newUNOP(OP_NULL, 0, (OP*)logop);
7108 trueop->op_next = falseop->op_next = o;
7115 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7117 Constructs and returns a C<range> op, with subordinate C<flip> and
7118 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
7119 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7120 for both the C<flip> and C<range> ops, except that the bit with value
7121 1 is automatically set. C<left> and C<right> supply the expressions
7122 controlling the endpoints of the range; they are consumed by this function
7123 and become part of the constructed op tree.
7129 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7137 PERL_ARGS_ASSERT_NEWRANGE;
7139 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
7140 range->op_flags = OPf_KIDS;
7141 leftstart = LINKLIST(left);
7142 range->op_private = (U8)(1 | (flags >> 8));
7144 /* make left and right siblings */
7145 op_sibling_splice((OP*)range, left, 0, right);
7147 range->op_next = (OP*)range;
7148 flip = newUNOP(OP_FLIP, flags, (OP*)range);
7149 flop = newUNOP(OP_FLOP, 0, flip);
7150 o = newUNOP(OP_NULL, 0, flop);
7152 range->op_next = leftstart;
7154 left->op_next = flip;
7155 right->op_next = flop;
7158 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7159 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7161 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7162 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7163 SvPADTMP_on(PAD_SV(flip->op_targ));
7165 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7166 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7168 /* check barewords before they might be optimized aways */
7169 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7170 no_bareword_allowed(left);
7171 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7172 no_bareword_allowed(right);
7175 if (!flip->op_private || !flop->op_private)
7176 LINKLIST(o); /* blow off optimizer unless constant */
7182 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7184 Constructs, checks, and returns an op tree expressing a loop. This is
7185 only a loop in the control flow through the op tree; it does not have
7186 the heavyweight loop structure that allows exiting the loop by C<last>
7187 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
7188 top-level op, except that some bits will be set automatically as required.
7189 C<expr> supplies the expression controlling loop iteration, and C<block>
7190 supplies the body of the loop; they are consumed by this function and
7191 become part of the constructed op tree. C<debuggable> is currently
7192 unused and should always be 1.
7198 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7202 const bool once = block && block->op_flags & OPf_SPECIAL &&
7203 block->op_type == OP_NULL;
7205 PERL_UNUSED_ARG(debuggable);
7209 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7210 || ( expr->op_type == OP_NOT
7211 && cUNOPx(expr)->op_first->op_type == OP_CONST
7212 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7215 /* Return the block now, so that S_new_logop does not try to
7217 return block; /* do {} while 0 does once */
7218 if (expr->op_type == OP_READLINE
7219 || expr->op_type == OP_READDIR
7220 || expr->op_type == OP_GLOB
7221 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7222 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7223 expr = newUNOP(OP_DEFINED, 0,
7224 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7225 } else if (expr->op_flags & OPf_KIDS) {
7226 const OP * const k1 = ((UNOP*)expr)->op_first;
7227 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7228 switch (expr->op_type) {
7230 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7231 && (k2->op_flags & OPf_STACKED)
7232 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7233 expr = newUNOP(OP_DEFINED, 0, expr);
7237 if (k1 && (k1->op_type == OP_READDIR
7238 || k1->op_type == OP_GLOB
7239 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7240 || k1->op_type == OP_EACH
7241 || k1->op_type == OP_AEACH))
7242 expr = newUNOP(OP_DEFINED, 0, expr);
7248 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7249 * op, in listop. This is wrong. [perl #27024] */
7251 block = newOP(OP_NULL, 0);
7252 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7253 o = new_logop(OP_AND, 0, &expr, &listop);
7260 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7262 if (once && o != listop)
7264 assert(cUNOPo->op_first->op_type == OP_AND
7265 || cUNOPo->op_first->op_type == OP_OR);
7266 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7270 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7272 o->op_flags |= flags;
7274 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7279 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7281 Constructs, checks, and returns an op tree expressing a C<while> loop.
7282 This is a heavyweight loop, with structure that allows exiting the loop
7283 by C<last> and suchlike.
7285 C<loop> is an optional preconstructed C<enterloop> op to use in the
7286 loop; if it is null then a suitable op will be constructed automatically.
7287 C<expr> supplies the loop's controlling expression. C<block> supplies the
7288 main body of the loop, and C<cont> optionally supplies a C<continue> block
7289 that operates as a second half of the body. All of these optree inputs
7290 are consumed by this function and become part of the constructed op tree.
7292 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7293 op and, shifted up eight bits, the eight bits of C<op_private> for
7294 the C<leaveloop> op, except that (in both cases) some bits will be set
7295 automatically. C<debuggable> is currently unused and should always be 1.
7296 C<has_my> can be supplied as true to force the
7297 loop body to be enclosed in its own scope.
7303 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7304 OP *expr, OP *block, OP *cont, I32 has_my)
7313 PERL_UNUSED_ARG(debuggable);
7316 if (expr->op_type == OP_READLINE
7317 || expr->op_type == OP_READDIR
7318 || expr->op_type == OP_GLOB
7319 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7320 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7321 expr = newUNOP(OP_DEFINED, 0,
7322 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7323 } else if (expr->op_flags & OPf_KIDS) {
7324 const OP * const k1 = ((UNOP*)expr)->op_first;
7325 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7326 switch (expr->op_type) {
7328 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7329 && (k2->op_flags & OPf_STACKED)
7330 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7331 expr = newUNOP(OP_DEFINED, 0, expr);
7335 if (k1 && (k1->op_type == OP_READDIR
7336 || k1->op_type == OP_GLOB
7337 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7338 || k1->op_type == OP_EACH
7339 || k1->op_type == OP_AEACH))
7340 expr = newUNOP(OP_DEFINED, 0, expr);
7347 block = newOP(OP_NULL, 0);
7348 else if (cont || has_my) {
7349 block = op_scope(block);
7353 next = LINKLIST(cont);
7356 OP * const unstack = newOP(OP_UNSTACK, 0);
7359 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7363 listop = op_append_list(OP_LINESEQ, block, cont);
7365 redo = LINKLIST(listop);
7369 o = new_logop(OP_AND, 0, &expr, &listop);
7370 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7372 return expr; /* listop already freed by new_logop */
7375 ((LISTOP*)listop)->op_last->op_next =
7376 (o == listop ? redo : LINKLIST(o));
7382 NewOp(1101,loop,1,LOOP);
7383 OpTYPE_set(loop, OP_ENTERLOOP);
7384 loop->op_private = 0;
7385 loop->op_next = (OP*)loop;
7388 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7390 loop->op_redoop = redo;
7391 loop->op_lastop = o;
7392 o->op_private |= loopflags;
7395 loop->op_nextop = next;
7397 loop->op_nextop = o;
7399 o->op_flags |= flags;
7400 o->op_private |= (flags >> 8);
7405 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7407 Constructs, checks, and returns an op tree expressing a C<foreach>
7408 loop (iteration through a list of values). This is a heavyweight loop,
7409 with structure that allows exiting the loop by C<last> and suchlike.
7411 C<sv> optionally supplies the variable that will be aliased to each
7412 item in turn; if null, it defaults to C<$_>.
7413 C<expr> supplies the list of values to iterate over. C<block> supplies
7414 the main body of the loop, and C<cont> optionally supplies a C<continue>
7415 block that operates as a second half of the body. All of these optree
7416 inputs are consumed by this function and become part of the constructed
7419 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7420 op and, shifted up eight bits, the eight bits of C<op_private> for
7421 the C<leaveloop> op, except that (in both cases) some bits will be set
7428 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7433 PADOFFSET padoff = 0;
7437 PERL_ARGS_ASSERT_NEWFOROP;
7440 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7441 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7442 OpTYPE_set(sv, OP_RV2GV);
7444 /* The op_type check is needed to prevent a possible segfault
7445 * if the loop variable is undeclared and 'strict vars' is in
7446 * effect. This is illegal but is nonetheless parsed, so we
7447 * may reach this point with an OP_CONST where we're expecting
7450 if (cUNOPx(sv)->op_first->op_type == OP_GV
7451 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7452 iterpflags |= OPpITER_DEF;
7454 else if (sv->op_type == OP_PADSV) { /* private variable */
7455 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7456 padoff = sv->op_targ;
7460 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7462 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7465 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7467 PADNAME * const pn = PAD_COMPNAME(padoff);
7468 const char * const name = PadnamePV(pn);
7470 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7471 iterpflags |= OPpITER_DEF;
7475 sv = newGVOP(OP_GV, 0, PL_defgv);
7476 iterpflags |= OPpITER_DEF;
7479 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7480 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7481 iterflags |= OPf_STACKED;
7483 else if (expr->op_type == OP_NULL &&
7484 (expr->op_flags & OPf_KIDS) &&
7485 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7487 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7488 * set the STACKED flag to indicate that these values are to be
7489 * treated as min/max values by 'pp_enteriter'.
7491 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7492 LOGOP* const range = (LOGOP*) flip->op_first;
7493 OP* const left = range->op_first;
7494 OP* const right = OpSIBLING(left);
7497 range->op_flags &= ~OPf_KIDS;
7498 /* detach range's children */
7499 op_sibling_splice((OP*)range, NULL, -1, NULL);
7501 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7502 listop->op_first->op_next = range->op_next;
7503 left->op_next = range->op_other;
7504 right->op_next = (OP*)listop;
7505 listop->op_next = listop->op_first;
7508 expr = (OP*)(listop);
7510 iterflags |= OPf_STACKED;
7513 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7516 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7517 op_append_elem(OP_LIST, list(expr),
7519 assert(!loop->op_next);
7520 /* for my $x () sets OPpLVAL_INTRO;
7521 * for our $x () sets OPpOUR_INTRO */
7522 loop->op_private = (U8)iterpflags;
7523 if (loop->op_slabbed
7524 && DIFF(loop, OpSLOT(loop)->opslot_next)
7525 < SIZE_TO_PSIZE(sizeof(LOOP)))
7528 NewOp(1234,tmp,1,LOOP);
7529 Copy(loop,tmp,1,LISTOP);
7530 #ifdef PERL_OP_PARENT
7531 assert(loop->op_last->op_sibparent == (OP*)loop);
7532 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7534 S_op_destroy(aTHX_ (OP*)loop);
7537 else if (!loop->op_slabbed)
7539 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7540 #ifdef PERL_OP_PARENT
7541 OpLASTSIB_set(loop->op_last, (OP*)loop);
7544 loop->op_targ = padoff;
7545 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7550 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7552 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7553 or C<last>). C<type> is the opcode. C<label> supplies the parameter
7554 determining the target of the op; it is consumed by this function and
7555 becomes part of the constructed op tree.
7561 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7565 PERL_ARGS_ASSERT_NEWLOOPEX;
7567 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7568 || type == OP_CUSTOM);
7570 if (type != OP_GOTO) {
7571 /* "last()" means "last" */
7572 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7573 o = newOP(type, OPf_SPECIAL);
7577 /* Check whether it's going to be a goto &function */
7578 if (label->op_type == OP_ENTERSUB
7579 && !(label->op_flags & OPf_STACKED))
7580 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7583 /* Check for a constant argument */
7584 if (label->op_type == OP_CONST) {
7585 SV * const sv = ((SVOP *)label)->op_sv;
7587 const char *s = SvPV_const(sv,l);
7588 if (l == strlen(s)) {
7590 SvUTF8(((SVOP*)label)->op_sv),
7592 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7596 /* If we have already created an op, we do not need the label. */
7599 else o = newUNOP(type, OPf_STACKED, label);
7601 PL_hints |= HINT_BLOCK_SCOPE;
7605 /* if the condition is a literal array or hash
7606 (or @{ ... } etc), make a reference to it.
7609 S_ref_array_or_hash(pTHX_ OP *cond)
7612 && (cond->op_type == OP_RV2AV
7613 || cond->op_type == OP_PADAV
7614 || cond->op_type == OP_RV2HV
7615 || cond->op_type == OP_PADHV))
7617 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7620 && (cond->op_type == OP_ASLICE
7621 || cond->op_type == OP_KVASLICE
7622 || cond->op_type == OP_HSLICE
7623 || cond->op_type == OP_KVHSLICE)) {
7625 /* anonlist now needs a list from this op, was previously used in
7627 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7628 cond->op_flags |= OPf_WANT_LIST;
7630 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7637 /* These construct the optree fragments representing given()
7640 entergiven and enterwhen are LOGOPs; the op_other pointer
7641 points up to the associated leave op. We need this so we
7642 can put it in the context and make break/continue work.
7643 (Also, of course, pp_enterwhen will jump straight to
7644 op_other if the match fails.)
7648 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7649 I32 enter_opcode, I32 leave_opcode,
7650 PADOFFSET entertarg)
7656 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7657 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7659 enterop = alloc_LOGOP(enter_opcode, block, NULL);
7660 enterop->op_targ = 0;
7661 enterop->op_private = 0;
7663 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7666 /* prepend cond if we have one */
7667 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7669 o->op_next = LINKLIST(cond);
7670 cond->op_next = (OP *) enterop;
7673 /* This is a default {} block */
7674 enterop->op_flags |= OPf_SPECIAL;
7675 o ->op_flags |= OPf_SPECIAL;
7677 o->op_next = (OP *) enterop;
7680 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7681 entergiven and enterwhen both
7684 enterop->op_next = LINKLIST(block);
7685 block->op_next = enterop->op_other = o;
7690 /* Does this look like a boolean operation? For these purposes
7691 a boolean operation is:
7692 - a subroutine call [*]
7693 - a logical connective
7694 - a comparison operator
7695 - a filetest operator, with the exception of -s -M -A -C
7696 - defined(), exists() or eof()
7697 - /$re/ or $foo =~ /$re/
7699 [*] possibly surprising
7702 S_looks_like_bool(pTHX_ const OP *o)
7704 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7706 switch(o->op_type) {
7709 return looks_like_bool(cLOGOPo->op_first);
7713 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7716 looks_like_bool(cLOGOPo->op_first)
7717 && looks_like_bool(sibl));
7723 o->op_flags & OPf_KIDS
7724 && looks_like_bool(cUNOPo->op_first));
7728 case OP_NOT: case OP_XOR:
7730 case OP_EQ: case OP_NE: case OP_LT:
7731 case OP_GT: case OP_LE: case OP_GE:
7733 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7734 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7736 case OP_SEQ: case OP_SNE: case OP_SLT:
7737 case OP_SGT: case OP_SLE: case OP_SGE:
7741 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7742 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7743 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7744 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7745 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7746 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7747 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7748 case OP_FTTEXT: case OP_FTBINARY:
7750 case OP_DEFINED: case OP_EXISTS:
7751 case OP_MATCH: case OP_EOF:
7758 /* Detect comparisons that have been optimized away */
7759 if (cSVOPo->op_sv == &PL_sv_yes
7760 || cSVOPo->op_sv == &PL_sv_no)
7773 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7775 Constructs, checks, and returns an op tree expressing a C<given> block.
7776 C<cond> supplies the expression that will be locally assigned to a lexical
7777 variable, and C<block> supplies the body of the C<given> construct; they
7778 are consumed by this function and become part of the constructed op tree.
7779 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7785 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7787 PERL_ARGS_ASSERT_NEWGIVENOP;
7788 PERL_UNUSED_ARG(defsv_off);
7791 return newGIVWHENOP(
7792 ref_array_or_hash(cond),
7794 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7799 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7801 Constructs, checks, and returns an op tree expressing a C<when> block.
7802 C<cond> supplies the test expression, and C<block> supplies the block
7803 that will be executed if the test evaluates to true; they are consumed
7804 by this function and become part of the constructed op tree. C<cond>
7805 will be interpreted DWIMically, often as a comparison against C<$_>,
7806 and may be null to generate a C<default> block.
7812 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7814 const bool cond_llb = (!cond || looks_like_bool(cond));
7817 PERL_ARGS_ASSERT_NEWWHENOP;
7822 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7824 scalar(ref_array_or_hash(cond)));
7827 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7830 /* must not conflict with SVf_UTF8 */
7831 #define CV_CKPROTO_CURSTASH 0x1
7834 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7835 const STRLEN len, const U32 flags)
7837 SV *name = NULL, *msg;
7838 const char * cvp = SvROK(cv)
7839 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7840 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7843 STRLEN clen = CvPROTOLEN(cv), plen = len;
7845 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7847 if (p == NULL && cvp == NULL)
7850 if (!ckWARN_d(WARN_PROTOTYPE))
7854 p = S_strip_spaces(aTHX_ p, &plen);
7855 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7856 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7857 if (plen == clen && memEQ(cvp, p, plen))
7860 if (flags & SVf_UTF8) {
7861 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7865 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7871 msg = sv_newmortal();
7876 gv_efullname3(name = sv_newmortal(), gv, NULL);
7877 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7878 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7879 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7880 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7881 sv_catpvs(name, "::");
7883 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7884 assert (CvNAMED(SvRV_const(gv)));
7885 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7887 else sv_catsv(name, (SV *)gv);
7889 else name = (SV *)gv;
7891 sv_setpvs(msg, "Prototype mismatch:");
7893 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
7895 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
7896 UTF8fARG(SvUTF8(cv),clen,cvp)
7899 sv_catpvs(msg, ": none");
7900 sv_catpvs(msg, " vs ");
7902 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
7904 sv_catpvs(msg, "none");
7905 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
7908 static void const_sv_xsub(pTHX_ CV* cv);
7909 static void const_av_xsub(pTHX_ CV* cv);
7913 =head1 Optree Manipulation Functions
7915 =for apidoc cv_const_sv
7917 If C<cv> is a constant sub eligible for inlining, returns the constant
7918 value returned by the sub. Otherwise, returns C<NULL>.
7920 Constant subs can be created with C<newCONSTSUB> or as described in
7921 L<perlsub/"Constant Functions">.
7926 Perl_cv_const_sv(const CV *const cv)
7931 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7933 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7934 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7939 Perl_cv_const_sv_or_av(const CV * const cv)
7943 if (SvROK(cv)) return SvRV((SV *)cv);
7944 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7945 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7948 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7949 * Can be called in 2 ways:
7952 * look for a single OP_CONST with attached value: return the value
7954 * allow_lex && !CvCONST(cv);
7956 * examine the clone prototype, and if contains only a single
7957 * OP_CONST, return the value; or if it contains a single PADSV ref-
7958 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7959 * a candidate for "constizing" at clone time, and return NULL.
7963 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7971 for (; o; o = o->op_next) {
7972 const OPCODE type = o->op_type;
7974 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7976 || type == OP_PUSHMARK)
7978 if (type == OP_DBSTATE)
7980 if (type == OP_LEAVESUB)
7984 if (type == OP_CONST && cSVOPo->op_sv)
7986 else if (type == OP_UNDEF && !o->op_private) {
7990 else if (allow_lex && type == OP_PADSV) {
7991 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7993 sv = &PL_sv_undef; /* an arbitrary non-null value */
8011 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
8012 PADNAME * const name, SV ** const const_svp)
8018 if (CvFLAGS(PL_compcv)) {
8019 /* might have had built-in attrs applied */
8020 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
8021 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8022 && ckWARN(WARN_MISC))
8024 /* protect against fatal warnings leaking compcv */
8025 SAVEFREESV(PL_compcv);
8026 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8027 SvREFCNT_inc_simple_void_NN(PL_compcv);
8030 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8031 & ~(CVf_LVALUE * pureperl));
8036 /* redundant check for speed: */
8037 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8038 const line_t oldline = CopLINE(PL_curcop);
8041 : sv_2mortal(newSVpvn_utf8(
8042 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8044 if (PL_parser && PL_parser->copline != NOLINE)
8045 /* This ensures that warnings are reported at the first
8046 line of a redefinition, not the last. */
8047 CopLINE_set(PL_curcop, PL_parser->copline);
8048 /* protect against fatal warnings leaking compcv */
8049 SAVEFREESV(PL_compcv);
8050 report_redefined_cv(namesv, cv, const_svp);
8051 SvREFCNT_inc_simple_void_NN(PL_compcv);
8052 CopLINE_set(PL_curcop, oldline);
8059 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8064 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8067 CV *compcv = PL_compcv;
8070 PADOFFSET pax = o->op_targ;
8071 CV *outcv = CvOUTSIDE(PL_compcv);
8074 bool reusable = FALSE;
8076 #ifdef PERL_DEBUG_READONLY_OPS
8077 OPSLAB *slab = NULL;
8080 PERL_ARGS_ASSERT_NEWMYSUB;
8082 /* Find the pad slot for storing the new sub.
8083 We cannot use PL_comppad, as it is the pad owned by the new sub. We
8084 need to look in CvOUTSIDE and find the pad belonging to the enclos-
8085 ing sub. And then we need to dig deeper if this is a lexical from
8087 my sub foo; sub { sub foo { } }
8090 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8091 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8092 pax = PARENT_PAD_INDEX(name);
8093 outcv = CvOUTSIDE(outcv);
8098 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8099 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8100 spot = (CV **)svspot;
8102 if (!(PL_parser && PL_parser->error_count))
8103 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8106 assert(proto->op_type == OP_CONST);
8107 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8108 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8118 if (PL_parser && PL_parser->error_count) {
8120 SvREFCNT_dec(PL_compcv);
8125 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8127 svspot = (SV **)(spot = &clonee);
8129 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8132 assert (SvTYPE(*spot) == SVt_PVCV);
8134 hek = CvNAME_HEK(*spot);
8138 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8139 CvNAME_HEK_set(*spot, hek =
8142 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8146 CvLEXICAL_on(*spot);
8148 cv = PadnamePROTOCV(name);
8149 svspot = (SV **)(spot = &PadnamePROTOCV(name));
8153 /* This makes sub {}; work as expected. */
8154 if (block->op_type == OP_STUB) {
8155 const line_t l = PL_parser->copline;
8157 block = newSTATEOP(0, NULL, 0);
8158 PL_parser->copline = l;
8160 block = CvLVALUE(compcv)
8161 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8162 ? newUNOP(OP_LEAVESUBLV, 0,
8163 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8164 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8165 start = LINKLIST(block);
8167 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8168 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8176 const bool exists = CvROOT(cv) || CvXSUB(cv);
8178 /* if the subroutine doesn't exist and wasn't pre-declared
8179 * with a prototype, assume it will be AUTOLOADed,
8180 * skipping the prototype check
8182 if (exists || SvPOK(cv))
8183 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8185 /* already defined? */
8187 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
8193 /* just a "sub foo;" when &foo is already defined */
8198 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8205 SvREFCNT_inc_simple_void_NN(const_sv);
8206 SvFLAGS(const_sv) |= SVs_PADTMP;
8208 assert(!CvROOT(cv) && !CvCONST(cv));
8212 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8213 CvFILE_set_from_cop(cv, PL_curcop);
8214 CvSTASH_set(cv, PL_curstash);
8217 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
8218 CvXSUBANY(cv).any_ptr = const_sv;
8219 CvXSUB(cv) = const_sv_xsub;
8223 CvFLAGS(cv) |= CvMETHOD(compcv);
8225 SvREFCNT_dec(compcv);
8230 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8231 determine whether this sub definition is in the same scope as its
8232 declaration. If this sub definition is inside an inner named pack-
8233 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8234 the package sub. So check PadnameOUTER(name) too.
8236 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8237 assert(!CvWEAKOUTSIDE(compcv));
8238 SvREFCNT_dec(CvOUTSIDE(compcv));
8239 CvWEAKOUTSIDE_on(compcv);
8241 /* XXX else do we have a circular reference? */
8243 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8244 /* transfer PL_compcv to cv */
8246 cv_flags_t preserved_flags =
8247 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8248 PADLIST *const temp_padl = CvPADLIST(cv);
8249 CV *const temp_cv = CvOUTSIDE(cv);
8250 const cv_flags_t other_flags =
8251 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8252 OP * const cvstart = CvSTART(cv);
8256 CvFLAGS(compcv) | preserved_flags;
8257 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8258 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8259 CvPADLIST_set(cv, CvPADLIST(compcv));
8260 CvOUTSIDE(compcv) = temp_cv;
8261 CvPADLIST_set(compcv, temp_padl);
8262 CvSTART(cv) = CvSTART(compcv);
8263 CvSTART(compcv) = cvstart;
8264 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8265 CvFLAGS(compcv) |= other_flags;
8267 if (CvFILE(cv) && CvDYNFILE(cv)) {
8268 Safefree(CvFILE(cv));
8271 /* inner references to compcv must be fixed up ... */
8272 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8273 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8274 ++PL_sub_generation;
8277 /* Might have had built-in attributes applied -- propagate them. */
8278 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8280 /* ... before we throw it away */
8281 SvREFCNT_dec(compcv);
8282 PL_compcv = compcv = cv;
8291 if (!CvNAME_HEK(cv)) {
8292 if (hek) (void)share_hek_hek(hek);
8296 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8297 hek = share_hek(PadnamePV(name)+1,
8298 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8301 CvNAME_HEK_set(cv, hek);
8307 CvFILE_set_from_cop(cv, PL_curcop);
8308 CvSTASH_set(cv, PL_curstash);
8311 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8313 SvUTF8_on(MUTABLE_SV(cv));
8317 /* If we assign an optree to a PVCV, then we've defined a
8318 * subroutine that the debugger could be able to set a breakpoint
8319 * in, so signal to pp_entereval that it should not throw away any
8320 * saved lines at scope exit. */
8322 PL_breakable_sub_gen++;
8324 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8325 OpREFCNT_set(CvROOT(cv), 1);
8326 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8327 itself has a refcount. */
8329 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8330 #ifdef PERL_DEBUG_READONLY_OPS
8331 slab = (OPSLAB *)CvSTART(cv);
8333 CvSTART(cv) = start;
8335 finalize_optree(CvROOT(cv));
8336 S_prune_chain_head(&CvSTART(cv));
8338 /* now that optimizer has done its work, adjust pad values */
8340 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8345 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8346 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8350 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8351 SV * const tmpstr = sv_newmortal();
8352 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8353 GV_ADDMULTI, SVt_PVHV);
8355 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8358 (long)CopLINE(PL_curcop));
8359 if (HvNAME_HEK(PL_curstash)) {
8360 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8361 sv_catpvs(tmpstr, "::");
8364 sv_setpvs(tmpstr, "__ANON__::");
8366 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8367 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8368 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8369 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8370 hv = GvHVn(db_postponed);
8371 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8372 CV * const pcv = GvCV(db_postponed);
8378 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8386 assert(CvDEPTH(outcv));
8388 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8390 cv_clone_into(clonee, *spot);
8391 else *spot = cv_clone(clonee);
8392 SvREFCNT_dec_NN(clonee);
8396 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8397 PADOFFSET depth = CvDEPTH(outcv);
8400 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8402 *svspot = SvREFCNT_inc_simple_NN(cv);
8403 SvREFCNT_dec(oldcv);
8409 PL_parser->copline = NOLINE;
8411 #ifdef PERL_DEBUG_READONLY_OPS
8422 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8423 OP *block, bool o_is_gv)
8427 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8429 CV *cv = NULL; /* the previous CV with this name, if any */
8431 const bool ec = PL_parser && PL_parser->error_count;
8432 /* If the subroutine has no body, no attributes, and no builtin attributes
8433 then it's just a sub declaration, and we may be able to get away with
8434 storing with a placeholder scalar in the symbol table, rather than a
8435 full CV. If anything is present then it will take a full CV to
8437 const I32 gv_fetch_flags
8438 = ec ? GV_NOADD_NOINIT :
8439 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8440 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8442 const char * const name =
8443 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8445 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8446 bool evanescent = FALSE;
8448 #ifdef PERL_DEBUG_READONLY_OPS
8449 OPSLAB *slab = NULL;
8457 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8458 hek and CvSTASH pointer together can imply the GV. If the name
8459 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8460 CvSTASH, so forego the optimisation if we find any.
8461 Also, we may be called from load_module at run time, so
8462 PL_curstash (which sets CvSTASH) may not point to the stash the
8463 sub is stored in. */
8465 ec ? GV_NOADD_NOINIT
8466 : PL_curstash != CopSTASH(PL_curcop)
8467 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8469 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8470 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8472 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8473 SV * const sv = sv_newmortal();
8474 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
8475 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8476 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8477 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8479 } else if (PL_curstash) {
8480 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8483 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8489 move_proto_attr(&proto, &attrs, gv);
8492 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8497 assert(proto->op_type == OP_CONST);
8498 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8499 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8515 SvREFCNT_dec(PL_compcv);
8520 if (name && block) {
8521 const char *s = strrchr(name, ':');
8523 if (strEQ(s, "BEGIN")) {
8524 if (PL_in_eval & EVAL_KEEPERR)
8525 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8527 SV * const errsv = ERRSV;
8528 /* force display of errors found but not reported */
8529 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8530 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
8537 if (!block && SvTYPE(gv) != SVt_PVGV) {
8538 /* If we are not defining a new sub and the existing one is not a
8540 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8541 /* We are applying attributes to an existing sub, so we need it
8542 upgraded if it is a constant. */
8543 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8544 gv_init_pvn(gv, PL_curstash, name, namlen,
8545 SVf_UTF8 * name_is_utf8);
8547 else { /* Maybe prototype now, and had at maximum
8548 a prototype or const/sub ref before. */
8549 if (SvTYPE(gv) > SVt_NULL) {
8550 cv_ckproto_len_flags((const CV *)gv,
8551 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8557 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8559 SvUTF8_on(MUTABLE_SV(gv));
8562 sv_setiv(MUTABLE_SV(gv), -1);
8565 SvREFCNT_dec(PL_compcv);
8566 cv = PL_compcv = NULL;
8571 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8575 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8581 /* This makes sub {}; work as expected. */
8582 if (block->op_type == OP_STUB) {
8583 const line_t l = PL_parser->copline;
8585 block = newSTATEOP(0, NULL, 0);
8586 PL_parser->copline = l;
8588 block = CvLVALUE(PL_compcv)
8589 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8590 && (!isGV(gv) || !GvASSUMECV(gv)))
8591 ? newUNOP(OP_LEAVESUBLV, 0,
8592 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8593 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8594 start = LINKLIST(block);
8596 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8598 S_op_const_sv(aTHX_ start, PL_compcv,
8599 cBOOL(CvCLONE(PL_compcv)));
8606 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8607 cv_ckproto_len_flags((const CV *)gv,
8608 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8609 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8611 /* All the other code for sub redefinition warnings expects the
8612 clobbered sub to be a CV. Instead of making all those code
8613 paths more complex, just inline the RV version here. */
8614 const line_t oldline = CopLINE(PL_curcop);
8615 assert(IN_PERL_COMPILETIME);
8616 if (PL_parser && PL_parser->copline != NOLINE)
8617 /* This ensures that warnings are reported at the first
8618 line of a redefinition, not the last. */
8619 CopLINE_set(PL_curcop, PL_parser->copline);
8620 /* protect against fatal warnings leaking compcv */
8621 SAVEFREESV(PL_compcv);
8623 if (ckWARN(WARN_REDEFINE)
8624 || ( ckWARN_d(WARN_REDEFINE)
8625 && ( !const_sv || SvRV(gv) == const_sv
8626 || sv_cmp(SvRV(gv), const_sv) ))) {
8628 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8629 "Constant subroutine %" SVf " redefined",
8630 SVfARG(cSVOPo->op_sv));
8633 SvREFCNT_inc_simple_void_NN(PL_compcv);
8634 CopLINE_set(PL_curcop, oldline);
8635 SvREFCNT_dec(SvRV(gv));
8640 const bool exists = CvROOT(cv) || CvXSUB(cv);
8642 /* if the subroutine doesn't exist and wasn't pre-declared
8643 * with a prototype, assume it will be AUTOLOADed,
8644 * skipping the prototype check
8646 if (exists || SvPOK(cv))
8647 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8648 /* already defined (or promised)? */
8649 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8650 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
8656 /* just a "sub foo;" when &foo is already defined */
8657 SAVEFREESV(PL_compcv);
8664 SvREFCNT_inc_simple_void_NN(const_sv);
8665 SvFLAGS(const_sv) |= SVs_PADTMP;
8667 assert(!CvROOT(cv) && !CvCONST(cv));
8669 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
8670 CvXSUBANY(cv).any_ptr = const_sv;
8671 CvXSUB(cv) = const_sv_xsub;
8675 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8678 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8679 if (name && isGV(gv))
8681 cv = newCONSTSUB_flags(
8682 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8685 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8689 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8690 prepare_SV_for_RV((SV *)gv);
8694 SvRV_set(gv, const_sv);
8698 SvREFCNT_dec(PL_compcv);
8703 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
8704 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
8707 if (cv) { /* must reuse cv if autoloaded */
8708 /* transfer PL_compcv to cv */
8710 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8711 PADLIST *const temp_av = CvPADLIST(cv);
8712 CV *const temp_cv = CvOUTSIDE(cv);
8713 const cv_flags_t other_flags =
8714 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8715 OP * const cvstart = CvSTART(cv);
8719 assert(!CvCVGV_RC(cv));
8720 assert(CvGV(cv) == gv);
8725 PERL_HASH(hash, name, namlen);
8735 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8737 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8738 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8739 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8740 CvOUTSIDE(PL_compcv) = temp_cv;
8741 CvPADLIST_set(PL_compcv, temp_av);
8742 CvSTART(cv) = CvSTART(PL_compcv);
8743 CvSTART(PL_compcv) = cvstart;
8744 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8745 CvFLAGS(PL_compcv) |= other_flags;
8747 if (CvFILE(cv) && CvDYNFILE(cv)) {
8748 Safefree(CvFILE(cv));
8750 CvFILE_set_from_cop(cv, PL_curcop);
8751 CvSTASH_set(cv, PL_curstash);
8753 /* inner references to PL_compcv must be fixed up ... */
8754 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8755 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8756 ++PL_sub_generation;
8759 /* Might have had built-in attributes applied -- propagate them. */
8760 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8762 /* ... before we throw it away */
8763 SvREFCNT_dec(PL_compcv);
8768 if (name && isGV(gv)) {
8771 if (HvENAME_HEK(GvSTASH(gv)))
8772 /* sub Foo::bar { (shift)+1 } */
8773 gv_method_changed(gv);
8777 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8778 prepare_SV_for_RV((SV *)gv);
8782 SvRV_set(gv, (SV *)cv);
8792 PERL_HASH(hash, name, namlen);
8793 CvNAME_HEK_set(cv, share_hek(name,
8799 CvFILE_set_from_cop(cv, PL_curcop);
8800 CvSTASH_set(cv, PL_curstash);
8804 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8806 SvUTF8_on(MUTABLE_SV(cv));
8810 /* If we assign an optree to a PVCV, then we've defined a
8811 * subroutine that the debugger could be able to set a breakpoint
8812 * in, so signal to pp_entereval that it should not throw away any
8813 * saved lines at scope exit. */
8815 PL_breakable_sub_gen++;
8817 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8818 OpREFCNT_set(CvROOT(cv), 1);
8819 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8820 itself has a refcount. */
8822 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8823 #ifdef PERL_DEBUG_READONLY_OPS
8824 slab = (OPSLAB *)CvSTART(cv);
8826 CvSTART(cv) = start;
8828 finalize_optree(CvROOT(cv));
8829 S_prune_chain_head(&CvSTART(cv));
8831 /* now that optimizer has done its work, adjust pad values */
8833 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8838 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8839 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8844 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8846 SvREFCNT_inc_simple_void_NN(cv);
8849 if (block && has_name) {
8850 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8851 SV * const tmpstr = cv_name(cv,NULL,0);
8852 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8853 GV_ADDMULTI, SVt_PVHV);
8855 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8858 (long)CopLINE(PL_curcop));
8859 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8860 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8861 hv = GvHVn(db_postponed);
8862 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8863 CV * const pcv = GvCV(db_postponed);
8869 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8875 if (PL_parser && PL_parser->error_count)
8876 clear_special_blocks(name, gv, cv);
8879 process_special_blocks(floor, name, gv, cv);
8885 PL_parser->copline = NOLINE;
8889 #ifdef PERL_DEBUG_READONLY_OPS
8893 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8894 pad_add_weakref(cv);
8900 S_clear_special_blocks(pTHX_ const char *const fullname,
8901 GV *const gv, CV *const cv) {
8905 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8907 colon = strrchr(fullname,':');
8908 name = colon ? colon + 1 : fullname;
8910 if ((*name == 'B' && strEQ(name, "BEGIN"))
8911 || (*name == 'E' && strEQ(name, "END"))
8912 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8913 || (*name == 'C' && strEQ(name, "CHECK"))
8914 || (*name == 'I' && strEQ(name, "INIT"))) {
8920 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8924 /* Returns true if the sub has been freed. */
8926 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8930 const char *const colon = strrchr(fullname,':');
8931 const char *const name = colon ? colon + 1 : fullname;
8933 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8936 if (strEQ(name, "BEGIN")) {
8937 const I32 oldscope = PL_scopestack_ix;
8940 if (floor) LEAVE_SCOPE(floor);
8942 PUSHSTACKi(PERLSI_REQUIRE);
8943 SAVECOPFILE(&PL_compiling);
8944 SAVECOPLINE(&PL_compiling);
8945 SAVEVPTR(PL_curcop);
8947 DEBUG_x( dump_sub(gv) );
8948 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8949 GvCV_set(gv,0); /* cv has been hijacked */
8950 call_list(oldscope, PL_beginav);
8954 return !PL_savebegin;
8960 if strEQ(name, "END") {
8961 DEBUG_x( dump_sub(gv) );
8962 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8965 } else if (*name == 'U') {
8966 if (strEQ(name, "UNITCHECK")) {
8967 /* It's never too late to run a unitcheck block */
8968 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8972 } else if (*name == 'C') {
8973 if (strEQ(name, "CHECK")) {
8975 /* diag_listed_as: Too late to run %s block */
8976 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8977 "Too late to run CHECK block");
8978 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8982 } else if (*name == 'I') {
8983 if (strEQ(name, "INIT")) {
8985 /* diag_listed_as: Too late to run %s block */
8986 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8987 "Too late to run INIT block");
8988 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8994 DEBUG_x( dump_sub(gv) );
8996 GvCV_set(gv,0); /* cv has been hijacked */
9002 =for apidoc newCONSTSUB
9004 See L</newCONSTSUB_flags>.
9010 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
9012 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
9016 =for apidoc newCONSTSUB_flags
9018 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
9019 eligible for inlining at compile-time.
9021 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
9023 The newly created subroutine takes ownership of a reference to the passed in
9026 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
9027 which won't be called if used as a destructor, but will suppress the overhead
9028 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
9035 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
9039 const char *const file = CopFILE(PL_curcop);
9043 if (IN_PERL_RUNTIME) {
9044 /* at runtime, it's not safe to manipulate PL_curcop: it may be
9045 * an op shared between threads. Use a non-shared COP for our
9047 SAVEVPTR(PL_curcop);
9048 SAVECOMPILEWARNINGS();
9049 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9050 PL_curcop = &PL_compiling;
9052 SAVECOPLINE(PL_curcop);
9053 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
9056 PL_hints &= ~HINT_BLOCK_SCOPE;
9059 SAVEGENERICSV(PL_curstash);
9060 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9063 /* Protect sv against leakage caused by fatal warnings. */
9064 if (sv) SAVEFREESV(sv);
9066 /* file becomes the CvFILE. For an XS, it's usually static storage,
9067 and so doesn't get free()d. (It's expected to be from the C pre-
9068 processor __FILE__ directive). But we need a dynamically allocated one,
9069 and we need it to get freed. */
9070 cv = newXS_len_flags(name, len,
9071 sv && SvTYPE(sv) == SVt_PVAV
9074 file ? file : "", "",
9075 &sv, XS_DYNAMIC_FILENAME | flags);
9076 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9085 =for apidoc U||newXS
9087 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
9088 static storage, as it is used directly as CvFILE(), without a copy being made.
9094 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9096 PERL_ARGS_ASSERT_NEWXS;
9097 return newXS_len_flags(
9098 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9103 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9104 const char *const filename, const char *const proto,
9107 PERL_ARGS_ASSERT_NEWXS_FLAGS;
9108 return newXS_len_flags(
9109 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9114 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9116 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9117 return newXS_len_flags(
9118 name, strlen(name), subaddr, NULL, NULL, NULL, 0
9123 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9124 XSUBADDR_t subaddr, const char *const filename,
9125 const char *const proto, SV **const_svp,
9129 bool interleave = FALSE;
9131 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9134 GV * const gv = gv_fetchpvn(
9135 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9136 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9137 sizeof("__ANON__::__ANON__") - 1,
9138 GV_ADDMULTI | flags, SVt_PVCV);
9140 if ((cv = (name ? GvCV(gv) : NULL))) {
9142 /* just a cached method */
9146 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9147 /* already defined (or promised) */
9148 /* Redundant check that allows us to avoid creating an SV
9149 most of the time: */
9150 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9151 report_redefined_cv(newSVpvn_flags(
9152 name,len,(flags&SVf_UTF8)|SVs_TEMP
9163 if (cv) /* must reuse cv if autoloaded */
9166 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9170 if (HvENAME_HEK(GvSTASH(gv)))
9171 gv_method_changed(gv); /* newXS */
9177 /* XSUBs can't be perl lang/perl5db.pl debugged
9178 if (PERLDB_LINE_OR_SAVESRC)
9179 (void)gv_fetchfile(filename); */
9180 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9181 if (flags & XS_DYNAMIC_FILENAME) {
9183 CvFILE(cv) = savepv(filename);
9185 /* NOTE: not copied, as it is expected to be an external constant string */
9186 CvFILE(cv) = (char *)filename;
9189 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9190 CvFILE(cv) = (char*)PL_xsubfilename;
9193 CvXSUB(cv) = subaddr;
9194 #ifndef PERL_IMPLICIT_CONTEXT
9195 CvHSCXT(cv) = &PL_stack_sp;
9201 process_special_blocks(0, name, gv, cv);
9204 } /* <- not a conditional branch */
9207 sv_setpv(MUTABLE_SV(cv), proto);
9208 if (interleave) LEAVE;
9213 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9215 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9217 PERL_ARGS_ASSERT_NEWSTUB;
9221 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
9222 gv_method_changed(gv);
9224 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9229 CvFILE_set_from_cop(cv, PL_curcop);
9230 CvSTASH_set(cv, PL_curstash);
9236 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9242 if (PL_parser && PL_parser->error_count) {
9248 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9249 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9252 if ((cv = GvFORM(gv))) {
9253 if (ckWARN(WARN_REDEFINE)) {
9254 const line_t oldline = CopLINE(PL_curcop);
9255 if (PL_parser && PL_parser->copline != NOLINE)
9256 CopLINE_set(PL_curcop, PL_parser->copline);
9258 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9259 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
9261 /* diag_listed_as: Format %s redefined */
9262 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9263 "Format STDOUT redefined");
9265 CopLINE_set(PL_curcop, oldline);
9270 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9272 CvFILE_set_from_cop(cv, PL_curcop);
9275 pad_tidy(padtidy_FORMAT);
9276 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9277 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9278 OpREFCNT_set(CvROOT(cv), 1);
9279 CvSTART(cv) = LINKLIST(CvROOT(cv));
9280 CvROOT(cv)->op_next = 0;
9281 CALL_PEEP(CvSTART(cv));
9282 finalize_optree(CvROOT(cv));
9283 S_prune_chain_head(&CvSTART(cv));
9289 PL_parser->copline = NOLINE;
9291 PL_compiling.cop_seq = 0;
9295 Perl_newANONLIST(pTHX_ OP *o)
9297 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9301 Perl_newANONHASH(pTHX_ OP *o)
9303 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9307 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9309 return newANONATTRSUB(floor, proto, NULL, block);
9313 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9315 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9317 newSVOP(OP_ANONCODE, 0,
9319 if (CvANONCONST(cv))
9320 anoncode = newUNOP(OP_ANONCONST, 0,
9321 op_convert_list(OP_ENTERSUB,
9322 OPf_STACKED|OPf_WANT_SCALAR,
9324 return newUNOP(OP_REFGEN, 0, anoncode);
9328 Perl_oopsAV(pTHX_ OP *o)
9332 PERL_ARGS_ASSERT_OOPSAV;
9334 switch (o->op_type) {
9337 OpTYPE_set(o, OP_PADAV);
9338 return ref(o, OP_RV2AV);
9342 OpTYPE_set(o, OP_RV2AV);
9347 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9354 Perl_oopsHV(pTHX_ OP *o)
9358 PERL_ARGS_ASSERT_OOPSHV;
9360 switch (o->op_type) {
9363 OpTYPE_set(o, OP_PADHV);
9364 return ref(o, OP_RV2HV);
9368 OpTYPE_set(o, OP_RV2HV);
9373 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9380 Perl_newAVREF(pTHX_ OP *o)
9384 PERL_ARGS_ASSERT_NEWAVREF;
9386 if (o->op_type == OP_PADANY) {
9387 OpTYPE_set(o, OP_PADAV);
9390 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9391 Perl_croak(aTHX_ "Can't use an array as a reference");
9393 return newUNOP(OP_RV2AV, 0, scalar(o));
9397 Perl_newGVREF(pTHX_ I32 type, OP *o)
9399 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9400 return newUNOP(OP_NULL, 0, o);
9401 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9405 Perl_newHVREF(pTHX_ OP *o)
9409 PERL_ARGS_ASSERT_NEWHVREF;
9411 if (o->op_type == OP_PADANY) {
9412 OpTYPE_set(o, OP_PADHV);
9415 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9416 Perl_croak(aTHX_ "Can't use a hash as a reference");
9418 return newUNOP(OP_RV2HV, 0, scalar(o));
9422 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9424 if (o->op_type == OP_PADANY) {
9426 OpTYPE_set(o, OP_PADCV);
9428 return newUNOP(OP_RV2CV, flags, scalar(o));
9432 Perl_newSVREF(pTHX_ OP *o)
9436 PERL_ARGS_ASSERT_NEWSVREF;
9438 if (o->op_type == OP_PADANY) {
9439 OpTYPE_set(o, OP_PADSV);
9443 return newUNOP(OP_RV2SV, 0, scalar(o));
9446 /* Check routines. See the comments at the top of this file for details
9447 * on when these are called */
9450 Perl_ck_anoncode(pTHX_ OP *o)
9452 PERL_ARGS_ASSERT_CK_ANONCODE;
9454 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9455 cSVOPo->op_sv = NULL;
9460 S_io_hints(pTHX_ OP *o)
9462 #if O_BINARY != 0 || O_TEXT != 0
9464 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9466 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9469 const char *d = SvPV_const(*svp, len);
9470 const I32 mode = mode_from_discipline(d, len);
9471 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9473 if (mode & O_BINARY)
9474 o->op_private |= OPpOPEN_IN_RAW;
9478 o->op_private |= OPpOPEN_IN_CRLF;
9482 svp = hv_fetchs(table, "open_OUT", FALSE);
9485 const char *d = SvPV_const(*svp, len);
9486 const I32 mode = mode_from_discipline(d, len);
9487 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9489 if (mode & O_BINARY)
9490 o->op_private |= OPpOPEN_OUT_RAW;
9494 o->op_private |= OPpOPEN_OUT_CRLF;
9499 PERL_UNUSED_CONTEXT;
9505 Perl_ck_backtick(pTHX_ OP *o)
9510 PERL_ARGS_ASSERT_CK_BACKTICK;
9511 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9512 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9513 && (gv = gv_override("readpipe",8)))
9515 /* detach rest of siblings from o and its first child */
9516 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9517 newop = S_new_entersubop(aTHX_ gv, sibl);
9519 else if (!(o->op_flags & OPf_KIDS))
9520 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9525 S_io_hints(aTHX_ o);
9530 Perl_ck_bitop(pTHX_ OP *o)
9532 PERL_ARGS_ASSERT_CK_BITOP;
9534 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9536 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9537 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9538 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9539 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9540 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9541 "The bitwise feature is experimental");
9542 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9543 && OP_IS_INFIX_BIT(o->op_type))
9545 const OP * const left = cBINOPo->op_first;
9546 const OP * const right = OpSIBLING(left);
9547 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9548 (left->op_flags & OPf_PARENS) == 0) ||
9549 (OP_IS_NUMCOMPARE(right->op_type) &&
9550 (right->op_flags & OPf_PARENS) == 0))
9551 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9552 "Possible precedence problem on bitwise %s operator",
9553 o->op_type == OP_BIT_OR
9554 ||o->op_type == OP_NBIT_OR ? "|"
9555 : o->op_type == OP_BIT_AND
9556 ||o->op_type == OP_NBIT_AND ? "&"
9557 : o->op_type == OP_BIT_XOR
9558 ||o->op_type == OP_NBIT_XOR ? "^"
9559 : o->op_type == OP_SBIT_OR ? "|."
9560 : o->op_type == OP_SBIT_AND ? "&." : "^."
9566 PERL_STATIC_INLINE bool
9567 is_dollar_bracket(pTHX_ const OP * const o)
9570 PERL_UNUSED_CONTEXT;
9571 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9572 && (kid = cUNOPx(o)->op_first)
9573 && kid->op_type == OP_GV
9574 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9578 Perl_ck_cmp(pTHX_ OP *o)
9580 PERL_ARGS_ASSERT_CK_CMP;
9581 if (ckWARN(WARN_SYNTAX)) {
9582 const OP *kid = cUNOPo->op_first;
9585 ( is_dollar_bracket(aTHX_ kid)
9586 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9588 || ( kid->op_type == OP_CONST
9589 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9593 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9594 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9600 Perl_ck_concat(pTHX_ OP *o)
9602 const OP * const kid = cUNOPo->op_first;
9604 PERL_ARGS_ASSERT_CK_CONCAT;
9605 PERL_UNUSED_CONTEXT;
9607 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9608 !(kUNOP->op_first->op_flags & OPf_MOD))
9609 o->op_flags |= OPf_STACKED;
9614 Perl_ck_spair(pTHX_ OP *o)
9618 PERL_ARGS_ASSERT_CK_SPAIR;
9620 if (o->op_flags & OPf_KIDS) {
9624 const OPCODE type = o->op_type;
9625 o = modkids(ck_fun(o), type);
9626 kid = cUNOPo->op_first;
9627 kidkid = kUNOP->op_first;
9628 newop = OpSIBLING(kidkid);
9630 const OPCODE type = newop->op_type;
9631 if (OpHAS_SIBLING(newop))
9633 if (o->op_type == OP_REFGEN
9634 && ( type == OP_RV2CV
9635 || ( !(newop->op_flags & OPf_PARENS)
9636 && ( type == OP_RV2AV || type == OP_PADAV
9637 || type == OP_RV2HV || type == OP_PADHV))))
9638 NOOP; /* OK (allow srefgen for \@a and \%h) */
9639 else if (OP_GIMME(newop,0) != G_SCALAR)
9642 /* excise first sibling */
9643 op_sibling_splice(kid, NULL, 1, NULL);
9646 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9647 * and OP_CHOMP into OP_SCHOMP */
9648 o->op_ppaddr = PL_ppaddr[++o->op_type];
9653 Perl_ck_delete(pTHX_ OP *o)
9655 PERL_ARGS_ASSERT_CK_DELETE;
9659 if (o->op_flags & OPf_KIDS) {
9660 OP * const kid = cUNOPo->op_first;
9661 switch (kid->op_type) {
9663 o->op_flags |= OPf_SPECIAL;
9666 o->op_private |= OPpSLICE;
9669 o->op_flags |= OPf_SPECIAL;
9674 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9675 " use array slice");
9677 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9680 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9681 "element or slice");
9683 if (kid->op_private & OPpLVAL_INTRO)
9684 o->op_private |= OPpLVAL_INTRO;
9691 Perl_ck_eof(pTHX_ OP *o)
9693 PERL_ARGS_ASSERT_CK_EOF;
9695 if (o->op_flags & OPf_KIDS) {
9697 if (cLISTOPo->op_first->op_type == OP_STUB) {
9699 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9704 kid = cLISTOPo->op_first;
9705 if (kid->op_type == OP_RV2GV)
9706 kid->op_private |= OPpALLOW_FAKE;
9712 Perl_ck_eval(pTHX_ OP *o)
9716 PERL_ARGS_ASSERT_CK_EVAL;
9718 PL_hints |= HINT_BLOCK_SCOPE;
9719 if (o->op_flags & OPf_KIDS) {
9720 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9723 if (o->op_type == OP_ENTERTRY) {
9726 /* cut whole sibling chain free from o */
9727 op_sibling_splice(o, NULL, -1, NULL);
9730 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
9732 /* establish postfix order */
9733 enter->op_next = (OP*)enter;
9735 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9736 OpTYPE_set(o, OP_LEAVETRY);
9737 enter->op_other = o;
9742 S_set_haseval(aTHX);
9746 const U8 priv = o->op_private;
9748 /* the newUNOP will recursively call ck_eval(), which will handle
9749 * all the stuff at the end of this function, like adding
9752 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9754 o->op_targ = (PADOFFSET)PL_hints;
9755 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9756 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9757 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9758 /* Store a copy of %^H that pp_entereval can pick up. */
9759 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9760 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9761 /* append hhop to only child */
9762 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9764 o->op_private |= OPpEVAL_HAS_HH;
9766 if (!(o->op_private & OPpEVAL_BYTES)
9767 && FEATURE_UNIEVAL_IS_ENABLED)
9768 o->op_private |= OPpEVAL_UNICODE;
9773 Perl_ck_exec(pTHX_ OP *o)
9775 PERL_ARGS_ASSERT_CK_EXEC;
9777 if (o->op_flags & OPf_STACKED) {
9780 kid = OpSIBLING(cUNOPo->op_first);
9781 if (kid->op_type == OP_RV2GV)
9790 Perl_ck_exists(pTHX_ OP *o)
9792 PERL_ARGS_ASSERT_CK_EXISTS;
9795 if (o->op_flags & OPf_KIDS) {
9796 OP * const kid = cUNOPo->op_first;
9797 if (kid->op_type == OP_ENTERSUB) {
9798 (void) ref(kid, o->op_type);
9799 if (kid->op_type != OP_RV2CV
9800 && !(PL_parser && PL_parser->error_count))
9802 "exists argument is not a subroutine name");
9803 o->op_private |= OPpEXISTS_SUB;
9805 else if (kid->op_type == OP_AELEM)
9806 o->op_flags |= OPf_SPECIAL;
9807 else if (kid->op_type != OP_HELEM)
9808 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9809 "element or a subroutine");
9816 Perl_ck_rvconst(pTHX_ OP *o)
9819 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9821 PERL_ARGS_ASSERT_CK_RVCONST;
9823 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9825 if (kid->op_type == OP_CONST) {
9828 SV * const kidsv = kid->op_sv;
9830 /* Is it a constant from cv_const_sv()? */
9831 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9834 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9835 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9836 const char *badthing;
9837 switch (o->op_type) {
9839 badthing = "a SCALAR";
9842 badthing = "an ARRAY";
9845 badthing = "a HASH";
9853 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
9854 SVfARG(kidsv), badthing);
9857 * This is a little tricky. We only want to add the symbol if we
9858 * didn't add it in the lexer. Otherwise we get duplicate strict
9859 * warnings. But if we didn't add it in the lexer, we must at
9860 * least pretend like we wanted to add it even if it existed before,
9861 * or we get possible typo warnings. OPpCONST_ENTERED says
9862 * whether the lexer already added THIS instance of this symbol.
9864 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9865 gv = gv_fetchsv(kidsv,
9866 o->op_type == OP_RV2CV
9867 && o->op_private & OPpMAY_RETURN_CONSTANT
9869 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9872 : o->op_type == OP_RV2SV
9874 : o->op_type == OP_RV2AV
9876 : o->op_type == OP_RV2HV
9883 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9884 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9885 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9887 OpTYPE_set(kid, OP_GV);
9888 SvREFCNT_dec(kid->op_sv);
9890 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9891 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9892 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9893 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9894 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9896 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9898 kid->op_private = 0;
9899 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9907 Perl_ck_ftst(pTHX_ OP *o)
9910 const I32 type = o->op_type;
9912 PERL_ARGS_ASSERT_CK_FTST;
9914 if (o->op_flags & OPf_REF) {
9917 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9918 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9919 const OPCODE kidtype = kid->op_type;
9921 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9922 && !kid->op_folded) {
9923 OP * const newop = newGVOP(type, OPf_REF,
9924 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9929 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
9930 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
9932 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9933 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
9934 array_passed_to_stat, name);
9937 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9938 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
9942 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9943 o->op_private |= OPpFT_ACCESS;
9944 if (type != OP_STAT && type != OP_LSTAT
9945 && PL_check[kidtype] == Perl_ck_ftst
9946 && kidtype != OP_STAT && kidtype != OP_LSTAT
9948 o->op_private |= OPpFT_STACKED;
9949 kid->op_private |= OPpFT_STACKING;
9950 if (kidtype == OP_FTTTY && (
9951 !(kid->op_private & OPpFT_STACKED)
9952 || kid->op_private & OPpFT_AFTER_t
9954 o->op_private |= OPpFT_AFTER_t;
9959 if (type == OP_FTTTY)
9960 o = newGVOP(type, OPf_REF, PL_stdingv);
9962 o = newUNOP(type, 0, newDEFSVOP());
9968 Perl_ck_fun(pTHX_ OP *o)
9970 const int type = o->op_type;
9971 I32 oa = PL_opargs[type] >> OASHIFT;
9973 PERL_ARGS_ASSERT_CK_FUN;
9975 if (o->op_flags & OPf_STACKED) {
9976 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9979 return no_fh_allowed(o);
9982 if (o->op_flags & OPf_KIDS) {
9983 OP *prev_kid = NULL;
9984 OP *kid = cLISTOPo->op_first;
9986 bool seen_optional = FALSE;
9988 if (kid->op_type == OP_PUSHMARK ||
9989 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9992 kid = OpSIBLING(kid);
9994 if (kid && kid->op_type == OP_COREARGS) {
9995 bool optional = FALSE;
9998 if (oa & OA_OPTIONAL) optional = TRUE;
10001 if (optional) o->op_private |= numargs;
10006 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
10007 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
10008 kid = newDEFSVOP();
10009 /* append kid to chain */
10010 op_sibling_splice(o, prev_kid, 0, kid);
10012 seen_optional = TRUE;
10019 /* list seen where single (scalar) arg expected? */
10020 if (numargs == 1 && !(oa >> 4)
10021 && kid->op_type == OP_LIST && type != OP_SCALAR)
10023 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10025 if (type != OP_DELETE) scalar(kid);
10036 if ((type == OP_PUSH || type == OP_UNSHIFT)
10037 && !OpHAS_SIBLING(kid))
10038 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10039 "Useless use of %s with no values",
10042 if (kid->op_type == OP_CONST
10043 && ( !SvROK(cSVOPx_sv(kid))
10044 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
10046 bad_type_pv(numargs, "array", o, kid);
10047 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
10048 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
10049 PL_op_desc[type]), 0);
10052 op_lvalue(kid, type);
10056 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
10057 bad_type_pv(numargs, "hash", o, kid);
10058 op_lvalue(kid, type);
10062 /* replace kid with newop in chain */
10064 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
10065 newop->op_next = newop;
10070 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
10071 if (kid->op_type == OP_CONST &&
10072 (kid->op_private & OPpCONST_BARE))
10074 OP * const newop = newGVOP(OP_GV, 0,
10075 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10076 /* replace kid with newop in chain */
10077 op_sibling_splice(o, prev_kid, 1, newop);
10081 else if (kid->op_type == OP_READLINE) {
10082 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10083 bad_type_pv(numargs, "HANDLE", o, kid);
10086 I32 flags = OPf_SPECIAL;
10088 PADOFFSET targ = 0;
10090 /* is this op a FH constructor? */
10091 if (is_handle_constructor(o,numargs)) {
10092 const char *name = NULL;
10095 bool want_dollar = TRUE;
10098 /* Set a flag to tell rv2gv to vivify
10099 * need to "prove" flag does not mean something
10100 * else already - NI-S 1999/05/07
10103 if (kid->op_type == OP_PADSV) {
10105 = PAD_COMPNAME_SV(kid->op_targ);
10106 name = PadnamePV (pn);
10107 len = PadnameLEN(pn);
10108 name_utf8 = PadnameUTF8(pn);
10110 else if (kid->op_type == OP_RV2SV
10111 && kUNOP->op_first->op_type == OP_GV)
10113 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10115 len = GvNAMELEN(gv);
10116 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10118 else if (kid->op_type == OP_AELEM
10119 || kid->op_type == OP_HELEM)
10122 OP *op = ((BINOP*)kid)->op_first;
10126 const char * const a =
10127 kid->op_type == OP_AELEM ?
10129 if (((op->op_type == OP_RV2AV) ||
10130 (op->op_type == OP_RV2HV)) &&
10131 (firstop = ((UNOP*)op)->op_first) &&
10132 (firstop->op_type == OP_GV)) {
10133 /* packagevar $a[] or $h{} */
10134 GV * const gv = cGVOPx_gv(firstop);
10137 Perl_newSVpvf(aTHX_
10142 else if (op->op_type == OP_PADAV
10143 || op->op_type == OP_PADHV) {
10144 /* lexicalvar $a[] or $h{} */
10145 const char * const padname =
10146 PAD_COMPNAME_PV(op->op_targ);
10149 Perl_newSVpvf(aTHX_
10155 name = SvPV_const(tmpstr, len);
10156 name_utf8 = SvUTF8(tmpstr);
10157 sv_2mortal(tmpstr);
10161 name = "__ANONIO__";
10163 want_dollar = FALSE;
10165 op_lvalue(kid, type);
10169 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10170 namesv = PAD_SVl(targ);
10171 if (want_dollar && *name != '$')
10172 sv_setpvs(namesv, "$");
10175 sv_catpvn(namesv, name, len);
10176 if ( name_utf8 ) SvUTF8_on(namesv);
10180 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10182 kid->op_targ = targ;
10183 kid->op_private |= priv;
10189 if ((type == OP_UNDEF || type == OP_POS)
10190 && numargs == 1 && !(oa >> 4)
10191 && kid->op_type == OP_LIST)
10192 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10193 op_lvalue(scalar(kid), type);
10198 kid = OpSIBLING(kid);
10200 /* FIXME - should the numargs or-ing move after the too many
10201 * arguments check? */
10202 o->op_private |= numargs;
10204 return too_many_arguments_pv(o,OP_DESC(o), 0);
10207 else if (PL_opargs[type] & OA_DEFGV) {
10208 /* Ordering of these two is important to keep f_map.t passing. */
10210 return newUNOP(type, 0, newDEFSVOP());
10214 while (oa & OA_OPTIONAL)
10216 if (oa && oa != OA_LIST)
10217 return too_few_arguments_pv(o,OP_DESC(o), 0);
10223 Perl_ck_glob(pTHX_ OP *o)
10227 PERL_ARGS_ASSERT_CK_GLOB;
10230 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10231 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10233 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10237 * \ null - const(wildcard)
10242 * \ mark - glob - rv2cv
10243 * | \ gv(CORE::GLOBAL::glob)
10245 * \ null - const(wildcard)
10247 o->op_flags |= OPf_SPECIAL;
10248 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10249 o = S_new_entersubop(aTHX_ gv, o);
10250 o = newUNOP(OP_NULL, 0, o);
10251 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10254 else o->op_flags &= ~OPf_SPECIAL;
10255 #if !defined(PERL_EXTERNAL_GLOB)
10256 if (!PL_globhook) {
10258 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10259 newSVpvs("File::Glob"), NULL, NULL, NULL);
10262 #endif /* !PERL_EXTERNAL_GLOB */
10263 gv = (GV *)newSV(0);
10264 gv_init(gv, 0, "", 0, 0);
10266 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10267 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10273 Perl_ck_grep(pTHX_ OP *o)
10277 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10279 PERL_ARGS_ASSERT_CK_GREP;
10281 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10283 if (o->op_flags & OPf_STACKED) {
10284 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10285 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10286 return no_fh_allowed(o);
10287 o->op_flags &= ~OPf_STACKED;
10289 kid = OpSIBLING(cLISTOPo->op_first);
10290 if (type == OP_MAPWHILE)
10295 if (PL_parser && PL_parser->error_count)
10297 kid = OpSIBLING(cLISTOPo->op_first);
10298 if (kid->op_type != OP_NULL)
10299 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10300 kid = kUNOP->op_first;
10302 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
10303 kid->op_next = (OP*)gwop;
10304 o->op_private = gwop->op_private = 0;
10305 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10307 kid = OpSIBLING(cLISTOPo->op_first);
10308 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10309 op_lvalue(kid, OP_GREPSTART);
10315 Perl_ck_index(pTHX_ OP *o)
10317 PERL_ARGS_ASSERT_CK_INDEX;
10319 if (o->op_flags & OPf_KIDS) {
10320 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10322 kid = OpSIBLING(kid); /* get past "big" */
10323 if (kid && kid->op_type == OP_CONST) {
10324 const bool save_taint = TAINT_get;
10325 SV *sv = kSVOP->op_sv;
10326 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10328 sv_copypv(sv, kSVOP->op_sv);
10329 SvREFCNT_dec_NN(kSVOP->op_sv);
10332 if (SvOK(sv)) fbm_compile(sv, 0);
10333 TAINT_set(save_taint);
10334 #ifdef NO_TAINT_SUPPORT
10335 PERL_UNUSED_VAR(save_taint);
10343 Perl_ck_lfun(pTHX_ OP *o)
10345 const OPCODE type = o->op_type;
10347 PERL_ARGS_ASSERT_CK_LFUN;
10349 return modkids(ck_fun(o), type);
10353 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10355 PERL_ARGS_ASSERT_CK_DEFINED;
10357 if ((o->op_flags & OPf_KIDS)) {
10358 switch (cUNOPo->op_first->op_type) {
10361 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10362 " (Maybe you should just omit the defined()?)");
10366 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10367 " (Maybe you should just omit the defined()?)");
10378 Perl_ck_readline(pTHX_ OP *o)
10380 PERL_ARGS_ASSERT_CK_READLINE;
10382 if (o->op_flags & OPf_KIDS) {
10383 OP *kid = cLISTOPo->op_first;
10384 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10388 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10396 Perl_ck_rfun(pTHX_ OP *o)
10398 const OPCODE type = o->op_type;
10400 PERL_ARGS_ASSERT_CK_RFUN;
10402 return refkids(ck_fun(o), type);
10406 Perl_ck_listiob(pTHX_ OP *o)
10410 PERL_ARGS_ASSERT_CK_LISTIOB;
10412 kid = cLISTOPo->op_first;
10414 o = force_list(o, 1);
10415 kid = cLISTOPo->op_first;
10417 if (kid->op_type == OP_PUSHMARK)
10418 kid = OpSIBLING(kid);
10419 if (kid && o->op_flags & OPf_STACKED)
10420 kid = OpSIBLING(kid);
10421 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10422 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10423 && !kid->op_folded) {
10424 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10426 /* replace old const op with new OP_RV2GV parent */
10427 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10428 OP_RV2GV, OPf_REF);
10429 kid = OpSIBLING(kid);
10434 op_append_elem(o->op_type, o, newDEFSVOP());
10436 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10437 return listkids(o);
10441 Perl_ck_smartmatch(pTHX_ OP *o)
10444 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10445 if (0 == (o->op_flags & OPf_SPECIAL)) {
10446 OP *first = cBINOPo->op_first;
10447 OP *second = OpSIBLING(first);
10449 /* Implicitly take a reference to an array or hash */
10451 /* remove the original two siblings, then add back the
10452 * (possibly different) first and second sibs.
10454 op_sibling_splice(o, NULL, 1, NULL);
10455 op_sibling_splice(o, NULL, 1, NULL);
10456 first = ref_array_or_hash(first);
10457 second = ref_array_or_hash(second);
10458 op_sibling_splice(o, NULL, 0, second);
10459 op_sibling_splice(o, NULL, 0, first);
10461 /* Implicitly take a reference to a regular expression */
10462 if (first->op_type == OP_MATCH) {
10463 OpTYPE_set(first, OP_QR);
10465 if (second->op_type == OP_MATCH) {
10466 OpTYPE_set(second, OP_QR);
10475 S_maybe_targlex(pTHX_ OP *o)
10477 OP * const kid = cLISTOPo->op_first;
10478 /* has a disposable target? */
10479 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10480 && !(kid->op_flags & OPf_STACKED)
10481 /* Cannot steal the second time! */
10482 && !(kid->op_private & OPpTARGET_MY)
10485 OP * const kkid = OpSIBLING(kid);
10487 /* Can just relocate the target. */
10488 if (kkid && kkid->op_type == OP_PADSV
10489 && (!(kkid->op_private & OPpLVAL_INTRO)
10490 || kkid->op_private & OPpPAD_STATE))
10492 kid->op_targ = kkid->op_targ;
10494 /* Now we do not need PADSV and SASSIGN.
10495 * Detach kid and free the rest. */
10496 op_sibling_splice(o, NULL, 1, NULL);
10498 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10506 Perl_ck_sassign(pTHX_ OP *o)
10509 OP * const kid = cBINOPo->op_first;
10511 PERL_ARGS_ASSERT_CK_SASSIGN;
10513 if (OpHAS_SIBLING(kid)) {
10514 OP *kkid = OpSIBLING(kid);
10515 /* For state variable assignment with attributes, kkid is a list op
10516 whose op_last is a padsv. */
10517 if ((kkid->op_type == OP_PADSV ||
10518 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10519 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10522 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10523 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10524 const PADOFFSET target = kkid->op_targ;
10525 OP *const other = newOP(OP_PADSV,
10527 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10528 OP *const first = newOP(OP_NULL, 0);
10530 newCONDOP(0, first, o, other);
10531 /* XXX targlex disabled for now; see ticket #124160
10532 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10534 OP *const condop = first->op_next;
10536 OpTYPE_set(condop, OP_ONCE);
10537 other->op_targ = target;
10538 nullop->op_flags |= OPf_WANT_SCALAR;
10540 /* Store the initializedness of state vars in a separate
10543 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10544 /* hijacking PADSTALE for uninitialized state variables */
10545 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10550 return S_maybe_targlex(aTHX_ o);
10554 Perl_ck_match(pTHX_ OP *o)
10556 PERL_UNUSED_CONTEXT;
10557 PERL_ARGS_ASSERT_CK_MATCH;
10563 Perl_ck_method(pTHX_ OP *o)
10565 SV *sv, *methsv, *rclass;
10566 const char* method;
10569 STRLEN len, nsplit = 0, i;
10571 OP * const kid = cUNOPo->op_first;
10573 PERL_ARGS_ASSERT_CK_METHOD;
10574 if (kid->op_type != OP_CONST) return o;
10578 /* replace ' with :: */
10579 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10581 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10584 method = SvPVX_const(sv);
10586 utf8 = SvUTF8(sv) ? -1 : 1;
10588 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10593 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10595 if (!nsplit) { /* $proto->method() */
10597 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10600 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10602 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10605 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10606 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10607 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10608 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10610 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10611 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10613 #ifdef USE_ITHREADS
10614 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10616 cMETHOPx(new_op)->op_rclass_sv = rclass;
10623 Perl_ck_null(pTHX_ OP *o)
10625 PERL_ARGS_ASSERT_CK_NULL;
10626 PERL_UNUSED_CONTEXT;
10631 Perl_ck_open(pTHX_ OP *o)
10633 PERL_ARGS_ASSERT_CK_OPEN;
10635 S_io_hints(aTHX_ o);
10637 /* In case of three-arg dup open remove strictness
10638 * from the last arg if it is a bareword. */
10639 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10640 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10644 if ((last->op_type == OP_CONST) && /* The bareword. */
10645 (last->op_private & OPpCONST_BARE) &&
10646 (last->op_private & OPpCONST_STRICT) &&
10647 (oa = OpSIBLING(first)) && /* The fh. */
10648 (oa = OpSIBLING(oa)) && /* The mode. */
10649 (oa->op_type == OP_CONST) &&
10650 SvPOK(((SVOP*)oa)->op_sv) &&
10651 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10652 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10653 (last == OpSIBLING(oa))) /* The bareword. */
10654 last->op_private &= ~OPpCONST_STRICT;
10660 Perl_ck_prototype(pTHX_ OP *o)
10662 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10663 if (!(o->op_flags & OPf_KIDS)) {
10665 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10671 Perl_ck_refassign(pTHX_ OP *o)
10673 OP * const right = cLISTOPo->op_first;
10674 OP * const left = OpSIBLING(right);
10675 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10678 PERL_ARGS_ASSERT_CK_REFASSIGN;
10680 assert (left->op_type == OP_SREFGEN);
10683 /* we use OPpPAD_STATE in refassign to mean either of those things,
10684 * and the code assumes the two flags occupy the same bit position
10685 * in the various ops below */
10686 assert(OPpPAD_STATE == OPpOUR_INTRO);
10688 switch (varop->op_type) {
10690 o->op_private |= OPpLVREF_AV;
10693 o->op_private |= OPpLVREF_HV;
10697 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10698 o->op_targ = varop->op_targ;
10699 varop->op_targ = 0;
10700 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10704 o->op_private |= OPpLVREF_AV;
10706 NOT_REACHED; /* NOTREACHED */
10708 o->op_private |= OPpLVREF_HV;
10712 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10713 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10715 /* Point varop to its GV kid, detached. */
10716 varop = op_sibling_splice(varop, NULL, -1, NULL);
10720 OP * const kidparent =
10721 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10722 OP * const kid = cUNOPx(kidparent)->op_first;
10723 o->op_private |= OPpLVREF_CV;
10724 if (kid->op_type == OP_GV) {
10726 goto detach_and_stack;
10728 if (kid->op_type != OP_PADCV) goto bad;
10729 o->op_targ = kid->op_targ;
10735 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10736 o->op_private |= OPpLVREF_ELEM;
10739 /* Detach varop. */
10740 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10744 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10745 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10750 if (!FEATURE_REFALIASING_IS_ENABLED)
10752 "Experimental aliasing via reference not enabled");
10753 Perl_ck_warner_d(aTHX_
10754 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10755 "Aliasing via reference is experimental");
10757 o->op_flags |= OPf_STACKED;
10758 op_sibling_splice(o, right, 1, varop);
10761 o->op_flags &=~ OPf_STACKED;
10762 op_sibling_splice(o, right, 1, NULL);
10769 Perl_ck_repeat(pTHX_ OP *o)
10771 PERL_ARGS_ASSERT_CK_REPEAT;
10773 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10775 o->op_private |= OPpREPEAT_DOLIST;
10776 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10777 kids = force_list(kids, 1); /* promote it to a list */
10778 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10786 Perl_ck_require(pTHX_ OP *o)
10790 PERL_ARGS_ASSERT_CK_REQUIRE;
10792 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10793 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10798 if (kid->op_type == OP_CONST) {
10799 SV * const sv = kid->op_sv;
10800 U32 const was_readonly = SvREADONLY(sv);
10801 if (kid->op_private & OPpCONST_BARE) {
10805 if (was_readonly) {
10806 SvREADONLY_off(sv);
10808 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10813 /* treat ::foo::bar as foo::bar */
10814 if (len >= 2 && s[0] == ':' && s[1] == ':')
10815 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
10817 DIE(aTHX_ "Bareword in require maps to empty filename");
10819 for (; s < end; s++) {
10820 if (*s == ':' && s[1] == ':') {
10822 Move(s+2, s+1, end - s - 1, char);
10826 SvEND_set(sv, end);
10827 sv_catpvs(sv, ".pm");
10828 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10829 hek = share_hek(SvPVX(sv),
10830 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10832 sv_sethek(sv, hek);
10834 SvFLAGS(sv) |= was_readonly;
10836 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10839 if (SvREFCNT(sv) > 1) {
10840 kid->op_sv = newSVpvn_share(
10841 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10842 SvREFCNT_dec_NN(sv);
10846 if (was_readonly) SvREADONLY_off(sv);
10847 PERL_HASH(hash, s, len);
10849 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10851 sv_sethek(sv, hek);
10853 SvFLAGS(sv) |= was_readonly;
10859 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10860 /* handle override, if any */
10861 && (gv = gv_override("require", 7))) {
10863 if (o->op_flags & OPf_KIDS) {
10864 kid = cUNOPo->op_first;
10865 op_sibling_splice(o, NULL, -1, NULL);
10868 kid = newDEFSVOP();
10871 newop = S_new_entersubop(aTHX_ gv, kid);
10879 Perl_ck_return(pTHX_ OP *o)
10883 PERL_ARGS_ASSERT_CK_RETURN;
10885 kid = OpSIBLING(cLISTOPo->op_first);
10886 if (CvLVALUE(PL_compcv)) {
10887 for (; kid; kid = OpSIBLING(kid))
10888 op_lvalue(kid, OP_LEAVESUBLV);
10895 Perl_ck_select(pTHX_ OP *o)
10900 PERL_ARGS_ASSERT_CK_SELECT;
10902 if (o->op_flags & OPf_KIDS) {
10903 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10904 if (kid && OpHAS_SIBLING(kid)) {
10905 OpTYPE_set(o, OP_SSELECT);
10907 return fold_constants(op_integerize(op_std_init(o)));
10911 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10912 if (kid && kid->op_type == OP_RV2GV)
10913 kid->op_private &= ~HINT_STRICT_REFS;
10918 Perl_ck_shift(pTHX_ OP *o)
10920 const I32 type = o->op_type;
10922 PERL_ARGS_ASSERT_CK_SHIFT;
10924 if (!(o->op_flags & OPf_KIDS)) {
10927 if (!CvUNIQUE(PL_compcv)) {
10928 o->op_flags |= OPf_SPECIAL;
10932 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10934 return newUNOP(type, 0, scalar(argop));
10936 return scalar(ck_fun(o));
10940 Perl_ck_sort(pTHX_ OP *o)
10944 HV * const hinthv =
10945 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10948 PERL_ARGS_ASSERT_CK_SORT;
10951 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10953 const I32 sorthints = (I32)SvIV(*svp);
10954 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10955 o->op_private |= OPpSORT_QSORT;
10956 if ((sorthints & HINT_SORT_STABLE) != 0)
10957 o->op_private |= OPpSORT_STABLE;
10961 if (o->op_flags & OPf_STACKED)
10963 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10965 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10966 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10968 /* if the first arg is a code block, process it and mark sort as
10970 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10972 if (kid->op_type == OP_LEAVE)
10973 op_null(kid); /* wipe out leave */
10974 /* Prevent execution from escaping out of the sort block. */
10977 /* provide scalar context for comparison function/block */
10978 kid = scalar(firstkid);
10979 kid->op_next = kid;
10980 o->op_flags |= OPf_SPECIAL;
10982 else if (kid->op_type == OP_CONST
10983 && kid->op_private & OPpCONST_BARE) {
10987 const char * const name = SvPV(kSVOP_sv, len);
10989 assert (len < 256);
10990 Copy(name, tmpbuf+1, len, char);
10991 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10992 if (off != NOT_IN_PAD) {
10993 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10995 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10996 sv_catpvs(fq, "::");
10997 sv_catsv(fq, kSVOP_sv);
10998 SvREFCNT_dec_NN(kSVOP_sv);
11002 OP * const padop = newOP(OP_PADCV, 0);
11003 padop->op_targ = off;
11004 /* replace the const op with the pad op */
11005 op_sibling_splice(firstkid, NULL, 1, padop);
11011 firstkid = OpSIBLING(firstkid);
11014 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
11015 /* provide list context for arguments */
11018 op_lvalue(kid, OP_GREPSTART);
11024 /* for sort { X } ..., where X is one of
11025 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
11026 * elide the second child of the sort (the one containing X),
11027 * and set these flags as appropriate
11031 * Also, check and warn on lexical $a, $b.
11035 S_simplify_sort(pTHX_ OP *o)
11037 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
11041 const char *gvname;
11044 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
11046 kid = kUNOP->op_first; /* get past null */
11047 if (!(have_scopeop = kid->op_type == OP_SCOPE)
11048 && kid->op_type != OP_LEAVE)
11050 kid = kLISTOP->op_last; /* get past scope */
11051 switch(kid->op_type) {
11055 if (!have_scopeop) goto padkids;
11060 k = kid; /* remember this node*/
11061 if (kBINOP->op_first->op_type != OP_RV2SV
11062 || kBINOP->op_last ->op_type != OP_RV2SV)
11065 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
11066 then used in a comparison. This catches most, but not
11067 all cases. For instance, it catches
11068 sort { my($a); $a <=> $b }
11070 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
11071 (although why you'd do that is anyone's guess).
11075 if (!ckWARN(WARN_SYNTAX)) return;
11076 kid = kBINOP->op_first;
11078 if (kid->op_type == OP_PADSV) {
11079 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11080 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11081 && ( PadnamePV(name)[1] == 'a'
11082 || PadnamePV(name)[1] == 'b' ))
11083 /* diag_listed_as: "my %s" used in sort comparison */
11084 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11085 "\"%s %s\" used in sort comparison",
11086 PadnameIsSTATE(name)
11091 } while ((kid = OpSIBLING(kid)));
11094 kid = kBINOP->op_first; /* get past cmp */
11095 if (kUNOP->op_first->op_type != OP_GV)
11097 kid = kUNOP->op_first; /* get past rv2sv */
11099 if (GvSTASH(gv) != PL_curstash)
11101 gvname = GvNAME(gv);
11102 if (*gvname == 'a' && gvname[1] == '\0')
11104 else if (*gvname == 'b' && gvname[1] == '\0')
11109 kid = k; /* back to cmp */
11110 /* already checked above that it is rv2sv */
11111 kid = kBINOP->op_last; /* down to 2nd arg */
11112 if (kUNOP->op_first->op_type != OP_GV)
11114 kid = kUNOP->op_first; /* get past rv2sv */
11116 if (GvSTASH(gv) != PL_curstash)
11118 gvname = GvNAME(gv);
11120 ? !(*gvname == 'a' && gvname[1] == '\0')
11121 : !(*gvname == 'b' && gvname[1] == '\0'))
11123 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11125 o->op_private |= OPpSORT_DESCEND;
11126 if (k->op_type == OP_NCMP)
11127 o->op_private |= OPpSORT_NUMERIC;
11128 if (k->op_type == OP_I_NCMP)
11129 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11130 kid = OpSIBLING(cLISTOPo->op_first);
11131 /* cut out and delete old block (second sibling) */
11132 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11137 Perl_ck_split(pTHX_ OP *o)
11143 PERL_ARGS_ASSERT_CK_SPLIT;
11145 assert(o->op_type == OP_LIST);
11147 if (o->op_flags & OPf_STACKED)
11148 return no_fh_allowed(o);
11150 kid = cLISTOPo->op_first;
11151 /* delete leading NULL node, then add a CONST if no other nodes */
11152 assert(kid->op_type == OP_NULL);
11153 op_sibling_splice(o, NULL, 1,
11154 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11156 kid = cLISTOPo->op_first;
11158 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11159 /* remove match expression, and replace with new optree with
11160 * a match op at its head */
11161 op_sibling_splice(o, NULL, 1, NULL);
11162 /* pmruntime will handle split " " behavior with flag==2 */
11163 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
11164 op_sibling_splice(o, NULL, 0, kid);
11167 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
11169 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11170 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11171 "Use of /g modifier is meaningless in split");
11174 /* eliminate the split op, and move the match op (plus any children)
11175 * into its place, then convert the match op into a split op. i.e.
11177 * SPLIT MATCH SPLIT(ex-MATCH)
11179 * MATCH - A - B - C => R - A - B - C => R - A - B - C
11185 * (R, if it exists, will be a regcomp op)
11188 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
11189 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
11190 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
11191 OpTYPE_set(kid, OP_SPLIT);
11192 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
11193 kid->op_private = o->op_private;
11196 kid = sibs; /* kid is now the string arg of the split */
11199 kid = newDEFSVOP();
11200 op_append_elem(OP_SPLIT, o, kid);
11204 kid = OpSIBLING(kid);
11206 kid = newSVOP(OP_CONST, 0, newSViv(0));
11207 op_append_elem(OP_SPLIT, o, kid);
11208 o->op_private |= OPpSPLIT_IMPLIM;
11212 if (OpHAS_SIBLING(kid))
11213 return too_many_arguments_pv(o,OP_DESC(o), 0);
11219 Perl_ck_stringify(pTHX_ OP *o)
11221 OP * const kid = OpSIBLING(cUNOPo->op_first);
11222 PERL_ARGS_ASSERT_CK_STRINGIFY;
11223 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11224 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
11225 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
11226 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11228 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11236 Perl_ck_join(pTHX_ OP *o)
11238 OP * const kid = OpSIBLING(cLISTOPo->op_first);
11240 PERL_ARGS_ASSERT_CK_JOIN;
11242 if (kid && kid->op_type == OP_MATCH) {
11243 if (ckWARN(WARN_SYNTAX)) {
11244 const REGEXP *re = PM_GETRE(kPMOP);
11246 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11247 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11248 : newSVpvs_flags( "STRING", SVs_TEMP );
11249 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11250 "/%" SVf "/ should probably be written as \"%" SVf "\"",
11251 SVfARG(msg), SVfARG(msg));
11255 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11256 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11257 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11258 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11260 const OP * const bairn = OpSIBLING(kid); /* the list */
11261 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11262 && OP_GIMME(bairn,0) == G_SCALAR)
11264 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11265 op_sibling_splice(o, kid, 1, NULL));
11275 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11277 Examines an op, which is expected to identify a subroutine at runtime,
11278 and attempts to determine at compile time which subroutine it identifies.
11279 This is normally used during Perl compilation to determine whether
11280 a prototype can be applied to a function call. C<cvop> is the op
11281 being considered, normally an C<rv2cv> op. A pointer to the identified
11282 subroutine is returned, if it could be determined statically, and a null
11283 pointer is returned if it was not possible to determine statically.
11285 Currently, the subroutine can be identified statically if the RV that the
11286 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11287 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11288 suitable if the constant value must be an RV pointing to a CV. Details of
11289 this process may change in future versions of Perl. If the C<rv2cv> op
11290 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11291 the subroutine statically: this flag is used to suppress compile-time
11292 magic on a subroutine call, forcing it to use default runtime behaviour.
11294 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11295 of a GV reference is modified. If a GV was examined and its CV slot was
11296 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11297 If the op is not optimised away, and the CV slot is later populated with
11298 a subroutine having a prototype, that flag eventually triggers the warning
11299 "called too early to check prototype".
11301 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11302 of returning a pointer to the subroutine it returns a pointer to the
11303 GV giving the most appropriate name for the subroutine in this context.
11304 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11305 (C<CvANON>) subroutine that is referenced through a GV it will be the
11306 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11307 A null pointer is returned as usual if there is no statically-determinable
11313 /* shared by toke.c:yylex */
11315 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11317 PADNAME *name = PAD_COMPNAME(off);
11318 CV *compcv = PL_compcv;
11319 while (PadnameOUTER(name)) {
11320 assert(PARENT_PAD_INDEX(name));
11321 compcv = CvOUTSIDE(compcv);
11322 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11323 [off = PARENT_PAD_INDEX(name)];
11325 assert(!PadnameIsOUR(name));
11326 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11327 return PadnamePROTOCV(name);
11329 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11333 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11338 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11339 if (flags & ~RV2CVOPCV_FLAG_MASK)
11340 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11341 if (cvop->op_type != OP_RV2CV)
11343 if (cvop->op_private & OPpENTERSUB_AMPER)
11345 if (!(cvop->op_flags & OPf_KIDS))
11347 rvop = cUNOPx(cvop)->op_first;
11348 switch (rvop->op_type) {
11350 gv = cGVOPx_gv(rvop);
11352 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11353 cv = MUTABLE_CV(SvRV(gv));
11357 if (flags & RV2CVOPCV_RETURN_STUB)
11363 if (flags & RV2CVOPCV_MARK_EARLY)
11364 rvop->op_private |= OPpEARLY_CV;
11369 SV *rv = cSVOPx_sv(rvop);
11372 cv = (CV*)SvRV(rv);
11376 cv = find_lexical_cv(rvop->op_targ);
11381 } NOT_REACHED; /* NOTREACHED */
11383 if (SvTYPE((SV*)cv) != SVt_PVCV)
11385 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11386 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11387 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11396 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11398 Performs the default fixup of the arguments part of an C<entersub>
11399 op tree. This consists of applying list context to each of the
11400 argument ops. This is the standard treatment used on a call marked
11401 with C<&>, or a method call, or a call through a subroutine reference,
11402 or any other call where the callee can't be identified at compile time,
11403 or a call where the callee has no prototype.
11409 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11413 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11415 aop = cUNOPx(entersubop)->op_first;
11416 if (!OpHAS_SIBLING(aop))
11417 aop = cUNOPx(aop)->op_first;
11418 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11419 /* skip the extra attributes->import() call implicitly added in
11420 * something like foo(my $x : bar)
11422 if ( aop->op_type == OP_ENTERSUB
11423 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11427 op_lvalue(aop, OP_ENTERSUB);
11433 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11435 Performs the fixup of the arguments part of an C<entersub> op tree
11436 based on a subroutine prototype. This makes various modifications to
11437 the argument ops, from applying context up to inserting C<refgen> ops,
11438 and checking the number and syntactic types of arguments, as directed by
11439 the prototype. This is the standard treatment used on a subroutine call,
11440 not marked with C<&>, where the callee can be identified at compile time
11441 and has a prototype.
11443 C<protosv> supplies the subroutine prototype to be applied to the call.
11444 It may be a normal defined scalar, of which the string value will be used.
11445 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11446 that has been cast to C<SV*>) which has a prototype. The prototype
11447 supplied, in whichever form, does not need to match the actual callee
11448 referenced by the op tree.
11450 If the argument ops disagree with the prototype, for example by having
11451 an unacceptable number of arguments, a valid op tree is returned anyway.
11452 The error is reflected in the parser state, normally resulting in a single
11453 exception at the top level of parsing which covers all the compilation
11454 errors that occurred. In the error message, the callee is referred to
11455 by the name defined by the C<namegv> parameter.
11461 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11464 const char *proto, *proto_end;
11465 OP *aop, *prev, *cvop, *parent;
11468 I32 contextclass = 0;
11469 const char *e = NULL;
11470 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11471 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11472 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11473 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11474 if (SvTYPE(protosv) == SVt_PVCV)
11475 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11476 else proto = SvPV(protosv, proto_len);
11477 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11478 proto_end = proto + proto_len;
11479 parent = entersubop;
11480 aop = cUNOPx(entersubop)->op_first;
11481 if (!OpHAS_SIBLING(aop)) {
11483 aop = cUNOPx(aop)->op_first;
11486 aop = OpSIBLING(aop);
11487 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11488 while (aop != cvop) {
11491 if (proto >= proto_end)
11493 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11494 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
11495 SVfARG(namesv)), SvUTF8(namesv));
11505 /* _ must be at the end */
11506 if (proto[1] && !strchr(";@%", proto[1]))
11522 if ( o3->op_type != OP_UNDEF
11523 && (o3->op_type != OP_SREFGEN
11524 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11526 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11528 bad_type_gv(arg, namegv, o3,
11529 arg == 1 ? "block or sub {}" : "sub {}");
11532 /* '*' allows any scalar type, including bareword */
11535 if (o3->op_type == OP_RV2GV)
11536 goto wrapref; /* autoconvert GLOB -> GLOBref */
11537 else if (o3->op_type == OP_CONST)
11538 o3->op_private &= ~OPpCONST_STRICT;
11544 if (o3->op_type == OP_RV2AV ||
11545 o3->op_type == OP_PADAV ||
11546 o3->op_type == OP_RV2HV ||
11547 o3->op_type == OP_PADHV
11553 case '[': case ']':
11560 switch (*proto++) {
11562 if (contextclass++ == 0) {
11563 e = strchr(proto, ']');
11564 if (!e || e == proto)
11572 if (contextclass) {
11573 const char *p = proto;
11574 const char *const end = proto;
11576 while (*--p != '[')
11577 /* \[$] accepts any scalar lvalue */
11579 && Perl_op_lvalue_flags(aTHX_
11581 OP_READ, /* not entersub */
11584 bad_type_gv(arg, namegv, o3,
11585 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11590 if (o3->op_type == OP_RV2GV)
11593 bad_type_gv(arg, namegv, o3, "symbol");
11596 if (o3->op_type == OP_ENTERSUB
11597 && !(o3->op_flags & OPf_STACKED))
11600 bad_type_gv(arg, namegv, o3, "subroutine");
11603 if (o3->op_type == OP_RV2SV ||
11604 o3->op_type == OP_PADSV ||
11605 o3->op_type == OP_HELEM ||
11606 o3->op_type == OP_AELEM)
11608 if (!contextclass) {
11609 /* \$ accepts any scalar lvalue */
11610 if (Perl_op_lvalue_flags(aTHX_
11612 OP_READ, /* not entersub */
11615 bad_type_gv(arg, namegv, o3, "scalar");
11619 if (o3->op_type == OP_RV2AV ||
11620 o3->op_type == OP_PADAV)
11622 o3->op_flags &=~ OPf_PARENS;
11626 bad_type_gv(arg, namegv, o3, "array");
11629 if (o3->op_type == OP_RV2HV ||
11630 o3->op_type == OP_PADHV)
11632 o3->op_flags &=~ OPf_PARENS;
11636 bad_type_gv(arg, namegv, o3, "hash");
11639 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11641 if (contextclass && e) {
11646 default: goto oops;
11656 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
11657 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11662 op_lvalue(aop, OP_ENTERSUB);
11664 aop = OpSIBLING(aop);
11666 if (aop == cvop && *proto == '_') {
11667 /* generate an access to $_ */
11668 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11670 if (!optional && proto_end > proto &&
11671 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11673 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11674 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
11675 SVfARG(namesv)), SvUTF8(namesv));
11681 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11683 Performs the fixup of the arguments part of an C<entersub> op tree either
11684 based on a subroutine prototype or using default list-context processing.
11685 This is the standard treatment used on a subroutine call, not marked
11686 with C<&>, where the callee can be identified at compile time.
11688 C<protosv> supplies the subroutine prototype to be applied to the call,
11689 or indicates that there is no prototype. It may be a normal scalar,
11690 in which case if it is defined then the string value will be used
11691 as a prototype, and if it is undefined then there is no prototype.
11692 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11693 that has been cast to C<SV*>), of which the prototype will be used if it
11694 has one. The prototype (or lack thereof) supplied, in whichever form,
11695 does not need to match the actual callee referenced by the op tree.
11697 If the argument ops disagree with the prototype, for example by having
11698 an unacceptable number of arguments, a valid op tree is returned anyway.
11699 The error is reflected in the parser state, normally resulting in a single
11700 exception at the top level of parsing which covers all the compilation
11701 errors that occurred. In the error message, the callee is referred to
11702 by the name defined by the C<namegv> parameter.
11708 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11709 GV *namegv, SV *protosv)
11711 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11712 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11713 return ck_entersub_args_proto(entersubop, namegv, protosv);
11715 return ck_entersub_args_list(entersubop);
11719 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11721 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11722 OP *aop = cUNOPx(entersubop)->op_first;
11724 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11728 if (!OpHAS_SIBLING(aop))
11729 aop = cUNOPx(aop)->op_first;
11730 aop = OpSIBLING(aop);
11731 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11733 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11735 op_free(entersubop);
11736 switch(GvNAME(namegv)[2]) {
11737 case 'F': return newSVOP(OP_CONST, 0,
11738 newSVpv(CopFILE(PL_curcop),0));
11739 case 'L': return newSVOP(
11741 Perl_newSVpvf(aTHX_
11742 "%" IVdf, (IV)CopLINE(PL_curcop)
11745 case 'P': return newSVOP(OP_CONST, 0,
11747 ? newSVhek(HvNAME_HEK(PL_curstash))
11752 NOT_REACHED; /* NOTREACHED */
11755 OP *prev, *cvop, *first, *parent;
11758 parent = entersubop;
11759 if (!OpHAS_SIBLING(aop)) {
11761 aop = cUNOPx(aop)->op_first;
11764 first = prev = aop;
11765 aop = OpSIBLING(aop);
11766 /* find last sibling */
11768 OpHAS_SIBLING(cvop);
11769 prev = cvop, cvop = OpSIBLING(cvop))
11771 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11772 /* Usually, OPf_SPECIAL on an op with no args means that it had
11773 * parens, but these have their own meaning for that flag: */
11774 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11775 && opnum != OP_DELETE && opnum != OP_EXISTS)
11776 flags |= OPf_SPECIAL;
11777 /* excise cvop from end of sibling chain */
11778 op_sibling_splice(parent, prev, 1, NULL);
11780 if (aop == cvop) aop = NULL;
11782 /* detach remaining siblings from the first sibling, then
11783 * dispose of original optree */
11786 op_sibling_splice(parent, first, -1, NULL);
11787 op_free(entersubop);
11789 if (opnum == OP_ENTEREVAL
11790 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11791 flags |= OPpEVAL_BYTES <<8;
11793 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11795 case OA_BASEOP_OR_UNOP:
11796 case OA_FILESTATOP:
11797 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11800 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11803 return opnum == OP_RUNCV
11804 ? newPVOP(OP_RUNCV,0,NULL)
11807 return op_convert_list(opnum,0,aop);
11810 NOT_REACHED; /* NOTREACHED */
11815 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11817 Retrieves the function that will be used to fix up a call to C<cv>.
11818 Specifically, the function is applied to an C<entersub> op tree for a
11819 subroutine call, not marked with C<&>, where the callee can be identified
11820 at compile time as C<cv>.
11822 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11823 argument for it is returned in C<*ckobj_p>. The function is intended
11824 to be called in this manner:
11826 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11828 In this call, C<entersubop> is a pointer to the C<entersub> op,
11829 which may be replaced by the check function, and C<namegv> is a GV
11830 supplying the name that should be used by the check function to refer
11831 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11832 It is permitted to apply the check function in non-standard situations,
11833 such as to a call to a different subroutine or to a method call.
11835 By default, the function is
11836 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11837 and the SV parameter is C<cv> itself. This implements standard
11838 prototype processing. It can be changed, for a particular subroutine,
11839 by L</cv_set_call_checker>.
11845 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11849 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11851 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11852 *ckobj_p = callmg->mg_obj;
11853 if (flagsp) *flagsp = callmg->mg_flags;
11855 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11856 *ckobj_p = (SV*)cv;
11857 if (flagsp) *flagsp = 0;
11862 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11864 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11865 PERL_UNUSED_CONTEXT;
11866 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11870 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11872 Sets the function that will be used to fix up a call to C<cv>.
11873 Specifically, the function is applied to an C<entersub> op tree for a
11874 subroutine call, not marked with C<&>, where the callee can be identified
11875 at compile time as C<cv>.
11877 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11878 for it is supplied in C<ckobj>. The function should be defined like this:
11880 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11882 It is intended to be called in this manner:
11884 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11886 In this call, C<entersubop> is a pointer to the C<entersub> op,
11887 which may be replaced by the check function, and C<namegv> supplies
11888 the name that should be used by the check function to refer
11889 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11890 It is permitted to apply the check function in non-standard situations,
11891 such as to a call to a different subroutine or to a method call.
11893 C<namegv> may not actually be a GV. For efficiency, perl may pass a
11894 CV or other SV instead. Whatever is passed can be used as the first
11895 argument to L</cv_name>. You can force perl to pass a GV by including
11896 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11898 The current setting for a particular CV can be retrieved by
11899 L</cv_get_call_checker>.
11901 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11903 The original form of L</cv_set_call_checker_flags>, which passes it the
11904 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11910 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11912 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11913 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11917 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11918 SV *ckobj, U32 flags)
11920 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11921 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11922 if (SvMAGICAL((SV*)cv))
11923 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11926 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11927 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11929 if (callmg->mg_flags & MGf_REFCOUNTED) {
11930 SvREFCNT_dec(callmg->mg_obj);
11931 callmg->mg_flags &= ~MGf_REFCOUNTED;
11933 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11934 callmg->mg_obj = ckobj;
11935 if (ckobj != (SV*)cv) {
11936 SvREFCNT_inc_simple_void_NN(ckobj);
11937 callmg->mg_flags |= MGf_REFCOUNTED;
11939 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11940 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11945 S_entersub_alloc_targ(pTHX_ OP * const o)
11947 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11948 o->op_private |= OPpENTERSUB_HASTARG;
11952 Perl_ck_subr(pTHX_ OP *o)
11957 SV **const_class = NULL;
11959 PERL_ARGS_ASSERT_CK_SUBR;
11961 aop = cUNOPx(o)->op_first;
11962 if (!OpHAS_SIBLING(aop))
11963 aop = cUNOPx(aop)->op_first;
11964 aop = OpSIBLING(aop);
11965 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11966 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11967 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11969 o->op_private &= ~1;
11970 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11971 if (PERLDB_SUB && PL_curstash != PL_debstash)
11972 o->op_private |= OPpENTERSUB_DB;
11973 switch (cvop->op_type) {
11975 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11979 case OP_METHOD_NAMED:
11980 case OP_METHOD_SUPER:
11981 case OP_METHOD_REDIR:
11982 case OP_METHOD_REDIR_SUPER:
11983 o->op_flags |= OPf_REF;
11984 if (aop->op_type == OP_CONST) {
11985 aop->op_private &= ~OPpCONST_STRICT;
11986 const_class = &cSVOPx(aop)->op_sv;
11988 else if (aop->op_type == OP_LIST) {
11989 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11990 if (sib && sib->op_type == OP_CONST) {
11991 sib->op_private &= ~OPpCONST_STRICT;
11992 const_class = &cSVOPx(sib)->op_sv;
11995 /* make class name a shared cow string to speedup method calls */
11996 /* constant string might be replaced with object, f.e. bigint */
11997 if (const_class && SvPOK(*const_class)) {
11999 const char* str = SvPV(*const_class, len);
12001 SV* const shared = newSVpvn_share(
12002 str, SvUTF8(*const_class)
12003 ? -(SSize_t)len : (SSize_t)len,
12006 if (SvREADONLY(*const_class))
12007 SvREADONLY_on(shared);
12008 SvREFCNT_dec(*const_class);
12009 *const_class = shared;
12016 S_entersub_alloc_targ(aTHX_ o);
12017 return ck_entersub_args_list(o);
12019 Perl_call_checker ckfun;
12022 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
12023 if (CvISXSUB(cv) || !CvROOT(cv))
12024 S_entersub_alloc_targ(aTHX_ o);
12026 /* The original call checker API guarantees that a GV will be
12027 be provided with the right name. So, if the old API was
12028 used (or the REQUIRE_GV flag was passed), we have to reify
12029 the CV’s GV, unless this is an anonymous sub. This is not
12030 ideal for lexical subs, as its stringification will include
12031 the package. But it is the best we can do. */
12032 if (flags & MGf_REQUIRE_GV) {
12033 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
12036 else namegv = MUTABLE_GV(cv);
12037 /* After a syntax error in a lexical sub, the cv that
12038 rv2cv_op_cv returns may be a nameless stub. */
12039 if (!namegv) return ck_entersub_args_list(o);
12042 return ckfun(aTHX_ o, namegv, ckobj);
12047 Perl_ck_svconst(pTHX_ OP *o)
12049 SV * const sv = cSVOPo->op_sv;
12050 PERL_ARGS_ASSERT_CK_SVCONST;
12051 PERL_UNUSED_CONTEXT;
12052 #ifdef PERL_COPY_ON_WRITE
12053 /* Since the read-only flag may be used to protect a string buffer, we
12054 cannot do copy-on-write with existing read-only scalars that are not
12055 already copy-on-write scalars. To allow $_ = "hello" to do COW with
12056 that constant, mark the constant as COWable here, if it is not
12057 already read-only. */
12058 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
12061 # ifdef PERL_DEBUG_READONLY_COW
12071 Perl_ck_trunc(pTHX_ OP *o)
12073 PERL_ARGS_ASSERT_CK_TRUNC;
12075 if (o->op_flags & OPf_KIDS) {
12076 SVOP *kid = (SVOP*)cUNOPo->op_first;
12078 if (kid->op_type == OP_NULL)
12079 kid = (SVOP*)OpSIBLING(kid);
12080 if (kid && kid->op_type == OP_CONST &&
12081 (kid->op_private & OPpCONST_BARE) &&
12084 o->op_flags |= OPf_SPECIAL;
12085 kid->op_private &= ~OPpCONST_STRICT;
12092 Perl_ck_substr(pTHX_ OP *o)
12094 PERL_ARGS_ASSERT_CK_SUBSTR;
12097 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
12098 OP *kid = cLISTOPo->op_first;
12100 if (kid->op_type == OP_NULL)
12101 kid = OpSIBLING(kid);
12103 kid->op_flags |= OPf_MOD;
12110 Perl_ck_tell(pTHX_ OP *o)
12112 PERL_ARGS_ASSERT_CK_TELL;
12114 if (o->op_flags & OPf_KIDS) {
12115 OP *kid = cLISTOPo->op_first;
12116 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12117 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12123 Perl_ck_each(pTHX_ OP *o)
12126 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12127 const unsigned orig_type = o->op_type;
12129 PERL_ARGS_ASSERT_CK_EACH;
12132 switch (kid->op_type) {
12138 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
12139 : orig_type == OP_KEYS ? OP_AKEYS
12143 if (kid->op_private == OPpCONST_BARE
12144 || !SvROK(cSVOPx_sv(kid))
12145 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12146 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
12151 qerror(Perl_mess(aTHX_
12152 "Experimental %s on scalar is now forbidden",
12153 PL_op_desc[orig_type]));
12155 bad_type_pv(1, "hash or array", o, kid);
12163 Perl_ck_length(pTHX_ OP *o)
12165 PERL_ARGS_ASSERT_CK_LENGTH;
12169 if (ckWARN(WARN_SYNTAX)) {
12170 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12174 const bool hash = kid->op_type == OP_PADHV
12175 || kid->op_type == OP_RV2HV;
12176 switch (kid->op_type) {
12181 name = S_op_varname(aTHX_ kid);
12187 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12188 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
12190 SVfARG(name), hash ? "keys " : "", SVfARG(name)
12193 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12194 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12195 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12197 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12198 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12199 "length() used on @array (did you mean \"scalar(@array)\"?)");
12209 ---------------------------------------------------------
12211 Common vars in list assignment
12213 There now follows some enums and static functions for detecting
12214 common variables in list assignments. Here is a little essay I wrote
12215 for myself when trying to get my head around this. DAPM.
12219 First some random observations:
12221 * If a lexical var is an alias of something else, e.g.
12222 for my $x ($lex, $pkg, $a[0]) {...}
12223 then the act of aliasing will increase the reference count of the SV
12225 * If a package var is an alias of something else, it may still have a
12226 reference count of 1, depending on how the alias was created, e.g.
12227 in *a = *b, $a may have a refcount of 1 since the GP is shared
12228 with a single GvSV pointer to the SV. So If it's an alias of another
12229 package var, then RC may be 1; if it's an alias of another scalar, e.g.
12230 a lexical var or an array element, then it will have RC > 1.
12232 * There are many ways to create a package alias; ultimately, XS code
12233 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12234 run-time tracing mechanisms are unlikely to be able to catch all cases.
12236 * When the LHS is all my declarations, the same vars can't appear directly
12237 on the RHS, but they can indirectly via closures, aliasing and lvalue
12238 subs. But those techniques all involve an increase in the lexical
12239 scalar's ref count.
12241 * When the LHS is all lexical vars (but not necessarily my declarations),
12242 it is possible for the same lexicals to appear directly on the RHS, and
12243 without an increased ref count, since the stack isn't refcounted.
12244 This case can be detected at compile time by scanning for common lex
12245 vars with PL_generation.
12247 * lvalue subs defeat common var detection, but they do at least
12248 return vars with a temporary ref count increment. Also, you can't
12249 tell at compile time whether a sub call is lvalue.
12254 A: There are a few circumstances where there definitely can't be any
12257 LHS empty: () = (...);
12258 RHS empty: (....) = ();
12259 RHS contains only constants or other 'can't possibly be shared'
12260 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
12261 i.e. they only contain ops not marked as dangerous, whose children
12262 are also not dangerous;
12264 LHS contains a single scalar element: e.g. ($x) = (....); because
12265 after $x has been modified, it won't be used again on the RHS;
12266 RHS contains a single element with no aggregate on LHS: e.g.
12267 ($a,$b,$c) = ($x); again, once $a has been modified, its value
12268 won't be used again.
12270 B: If LHS are all 'my' lexical var declarations (or safe ops, which
12273 my ($a, $b, @c) = ...;
12275 Due to closure and goto tricks, these vars may already have content.
12276 For the same reason, an element on the RHS may be a lexical or package
12277 alias of one of the vars on the left, or share common elements, for
12280 my ($x,$y) = f(); # $x and $y on both sides
12281 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12286 my @a = @$ra; # elements of @a on both sides
12287 sub f { @a = 1..4; \@a }
12290 First, just consider scalar vars on LHS:
12292 RHS is safe only if (A), or in addition,
12293 * contains only lexical *scalar* vars, where neither side's
12294 lexicals have been flagged as aliases
12296 If RHS is not safe, then it's always legal to check LHS vars for
12297 RC==1, since the only RHS aliases will always be associated
12300 Note that in particular, RHS is not safe if:
12302 * it contains package scalar vars; e.g.:
12305 my ($x, $y) = (2, $x_alias);
12306 sub f { $x = 1; *x_alias = \$x; }
12308 * It contains other general elements, such as flattened or
12309 * spliced or single array or hash elements, e.g.
12312 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12316 use feature 'refaliasing';
12317 \($a[0], $a[1]) = \($y,$x);
12320 It doesn't matter if the array/hash is lexical or package.
12322 * it contains a function call that happens to be an lvalue
12323 sub which returns one or more of the above, e.g.
12334 (so a sub call on the RHS should be treated the same
12335 as having a package var on the RHS).
12337 * any other "dangerous" thing, such an op or built-in that
12338 returns one of the above, e.g. pp_preinc
12341 If RHS is not safe, what we can do however is at compile time flag
12342 that the LHS are all my declarations, and at run time check whether
12343 all the LHS have RC == 1, and if so skip the full scan.
12345 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12347 Here the issue is whether there can be elements of @a on the RHS
12348 which will get prematurely freed when @a is cleared prior to
12349 assignment. This is only a problem if the aliasing mechanism
12350 is one which doesn't increase the refcount - only if RC == 1
12351 will the RHS element be prematurely freed.
12353 Because the array/hash is being INTROed, it or its elements
12354 can't directly appear on the RHS:
12356 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12358 but can indirectly, e.g.:
12362 sub f { @a = 1..3; \@a }
12364 So if the RHS isn't safe as defined by (A), we must always
12365 mortalise and bump the ref count of any remaining RHS elements
12366 when assigning to a non-empty LHS aggregate.
12368 Lexical scalars on the RHS aren't safe if they've been involved in
12371 use feature 'refaliasing';
12374 \(my $lex) = \$pkg;
12375 my @a = ($lex,3); # equivalent to ($a[0],3)
12382 Similarly with lexical arrays and hashes on the RHS:
12396 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12397 my $a; ($a, my $b) = (....);
12399 The difference between (B) and (C) is that it is now physically
12400 possible for the LHS vars to appear on the RHS too, where they
12401 are not reference counted; but in this case, the compile-time
12402 PL_generation sweep will detect such common vars.
12404 So the rules for (C) differ from (B) in that if common vars are
12405 detected, the runtime "test RC==1" optimisation can no longer be used,
12406 and a full mark and sweep is required
12408 D: As (C), but in addition the LHS may contain package vars.
12410 Since package vars can be aliased without a corresponding refcount
12411 increase, all bets are off. It's only safe if (A). E.g.
12413 my ($x, $y) = (1,2);
12415 for $x_alias ($x) {
12416 ($x_alias, $y) = (3, $x); # whoops
12419 Ditto for LHS aggregate package vars.
12421 E: Any other dangerous ops on LHS, e.g.
12422 (f(), $a[0], @$r) = (...);
12424 this is similar to (E) in that all bets are off. In addition, it's
12425 impossible to determine at compile time whether the LHS
12426 contains a scalar or an aggregate, e.g.
12428 sub f : lvalue { @a }
12431 * ---------------------------------------------------------
12435 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12436 * that at least one of the things flagged was seen.
12440 AAS_MY_SCALAR = 0x001, /* my $scalar */
12441 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
12442 AAS_LEX_SCALAR = 0x004, /* $lexical */
12443 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
12444 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12445 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
12446 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
12447 AAS_DANGEROUS = 0x080, /* an op (other than the above)
12448 that's flagged OA_DANGEROUS */
12449 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
12450 not in any of the categories above */
12451 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
12456 /* helper function for S_aassign_scan().
12457 * check a PAD-related op for commonality and/or set its generation number.
12458 * Returns a boolean indicating whether its shared */
12461 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12463 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12464 /* lexical used in aliasing */
12468 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12470 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12477 Helper function for OPpASSIGN_COMMON* detection in rpeep().
12478 It scans the left or right hand subtree of the aassign op, and returns a
12479 set of flags indicating what sorts of things it found there.
12480 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12481 set PL_generation on lexical vars; if the latter, we see if
12482 PL_generation matches.
12483 'top' indicates whether we're recursing or at the top level.
12484 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12485 This fn will increment it by the number seen. It's not intended to
12486 be an accurate count (especially as many ops can push a variable
12487 number of SVs onto the stack); rather it's used as to test whether there
12488 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12492 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12495 bool kid_top = FALSE;
12497 /* first, look for a solitary @_ on the RHS */
12500 && (o->op_flags & OPf_KIDS)
12501 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12503 OP *kid = cUNOPo->op_first;
12504 if ( ( kid->op_type == OP_PUSHMARK
12505 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12506 && ((kid = OpSIBLING(kid)))
12507 && !OpHAS_SIBLING(kid)
12508 && kid->op_type == OP_RV2AV
12509 && !(kid->op_flags & OPf_REF)
12510 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12511 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12512 && ((kid = cUNOPx(kid)->op_first))
12513 && kid->op_type == OP_GV
12514 && cGVOPx_gv(kid) == PL_defgv
12516 flags |= AAS_DEFAV;
12519 switch (o->op_type) {
12522 return AAS_PKG_SCALAR;
12527 /* if !top, could be e.g. @a[0,1] */
12528 if (top && (o->op_flags & OPf_REF))
12529 return (o->op_private & OPpLVAL_INTRO)
12530 ? AAS_MY_AGG : AAS_LEX_AGG;
12531 return AAS_DANGEROUS;
12535 int comm = S_aassign_padcheck(aTHX_ o, rhs)
12536 ? AAS_LEX_SCALAR_COMM : 0;
12538 return (o->op_private & OPpLVAL_INTRO)
12539 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12545 if (cUNOPx(o)->op_first->op_type != OP_GV)
12546 return AAS_DANGEROUS; /* @{expr}, %{expr} */
12548 /* if !top, could be e.g. @a[0,1] */
12549 if (top && (o->op_flags & OPf_REF))
12550 return AAS_PKG_AGG;
12551 return AAS_DANGEROUS;
12555 if (cUNOPx(o)->op_first->op_type != OP_GV) {
12557 return AAS_DANGEROUS; /* ${expr} */
12559 return AAS_PKG_SCALAR; /* $pkg */
12562 if (o->op_private & OPpSPLIT_ASSIGN) {
12563 /* the assign in @a = split() has been optimised away
12564 * and the @a attached directly to the split op
12565 * Treat the array as appearing on the RHS, i.e.
12566 * ... = (@a = split)
12571 if (o->op_flags & OPf_STACKED)
12572 /* @{expr} = split() - the array expression is tacked
12573 * on as an extra child to split - process kid */
12574 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
12577 /* ... else array is directly attached to split op */
12579 if (PL_op->op_private & OPpSPLIT_LEX)
12580 return (o->op_private & OPpLVAL_INTRO)
12581 ? AAS_MY_AGG : AAS_LEX_AGG;
12583 return AAS_PKG_AGG;
12586 /* other args of split can't be returned */
12587 return AAS_SAFE_SCALAR;
12590 /* undef counts as a scalar on the RHS:
12591 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
12592 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
12596 flags = AAS_SAFE_SCALAR;
12601 /* these are all no-ops; they don't push a potentially common SV
12602 * onto the stack, so they are neither AAS_DANGEROUS nor
12603 * AAS_SAFE_SCALAR */
12606 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12611 /* these do nothing but may have children; but their children
12612 * should also be treated as top-level */
12617 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12619 flags = AAS_DANGEROUS;
12623 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
12624 && (o->op_private & OPpTARGET_MY))
12627 return S_aassign_padcheck(aTHX_ o, rhs)
12628 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12631 /* if its an unrecognised, non-dangerous op, assume that it
12632 * it the cause of at least one safe scalar */
12634 flags = AAS_SAFE_SCALAR;
12638 /* XXX this assumes that all other ops are "transparent" - i.e. that
12639 * they can return some of their children. While this true for e.g.
12640 * sort and grep, it's not true for e.g. map. We really need a
12641 * 'transparent' flag added to regen/opcodes
12643 if (o->op_flags & OPf_KIDS) {
12645 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12646 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12652 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12653 and modify the optree to make them work inplace */
12656 S_inplace_aassign(pTHX_ OP *o) {
12658 OP *modop, *modop_pushmark;
12660 OP *oleft, *oleft_pushmark;
12662 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12664 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12666 assert(cUNOPo->op_first->op_type == OP_NULL);
12667 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12668 assert(modop_pushmark->op_type == OP_PUSHMARK);
12669 modop = OpSIBLING(modop_pushmark);
12671 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12674 /* no other operation except sort/reverse */
12675 if (OpHAS_SIBLING(modop))
12678 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12679 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12681 if (modop->op_flags & OPf_STACKED) {
12682 /* skip sort subroutine/block */
12683 assert(oright->op_type == OP_NULL);
12684 oright = OpSIBLING(oright);
12687 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12688 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12689 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12690 oleft = OpSIBLING(oleft_pushmark);
12692 /* Check the lhs is an array */
12694 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12695 || OpHAS_SIBLING(oleft)
12696 || (oleft->op_private & OPpLVAL_INTRO)
12700 /* Only one thing on the rhs */
12701 if (OpHAS_SIBLING(oright))
12704 /* check the array is the same on both sides */
12705 if (oleft->op_type == OP_RV2AV) {
12706 if (oright->op_type != OP_RV2AV
12707 || !cUNOPx(oright)->op_first
12708 || cUNOPx(oright)->op_first->op_type != OP_GV
12709 || cUNOPx(oleft )->op_first->op_type != OP_GV
12710 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12711 cGVOPx_gv(cUNOPx(oright)->op_first)
12715 else if (oright->op_type != OP_PADAV
12716 || oright->op_targ != oleft->op_targ
12720 /* This actually is an inplace assignment */
12722 modop->op_private |= OPpSORT_INPLACE;
12724 /* transfer MODishness etc from LHS arg to RHS arg */
12725 oright->op_flags = oleft->op_flags;
12727 /* remove the aassign op and the lhs */
12729 op_null(oleft_pushmark);
12730 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12731 op_null(cUNOPx(oleft)->op_first);
12737 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12738 * that potentially represent a series of one or more aggregate derefs
12739 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12740 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12741 * additional ops left in too).
12743 * The caller will have already verified that the first few ops in the
12744 * chain following 'start' indicate a multideref candidate, and will have
12745 * set 'orig_o' to the point further on in the chain where the first index
12746 * expression (if any) begins. 'orig_action' specifies what type of
12747 * beginning has already been determined by the ops between start..orig_o
12748 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12750 * 'hints' contains any hints flags that need adding (currently just
12751 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12755 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12759 UNOP_AUX_item *arg_buf = NULL;
12760 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12761 int index_skip = -1; /* don't output index arg on this action */
12763 /* similar to regex compiling, do two passes; the first pass
12764 * determines whether the op chain is convertible and calculates the
12765 * buffer size; the second pass populates the buffer and makes any
12766 * changes necessary to ops (such as moving consts to the pad on
12767 * threaded builds).
12769 * NB: for things like Coverity, note that both passes take the same
12770 * path through the logic tree (except for 'if (pass)' bits), since
12771 * both passes are following the same op_next chain; and in
12772 * particular, if it would return early on the second pass, it would
12773 * already have returned early on the first pass.
12775 for (pass = 0; pass < 2; pass++) {
12777 UV action = orig_action;
12778 OP *first_elem_op = NULL; /* first seen aelem/helem */
12779 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12780 int action_count = 0; /* number of actions seen so far */
12781 int action_ix = 0; /* action_count % (actions per IV) */
12782 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12783 bool is_last = FALSE; /* no more derefs to follow */
12784 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12785 UNOP_AUX_item *arg = arg_buf;
12786 UNOP_AUX_item *action_ptr = arg_buf;
12789 action_ptr->uv = 0;
12793 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12794 case MDEREF_HV_gvhv_helem:
12795 next_is_hash = TRUE;
12797 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12798 case MDEREF_AV_gvav_aelem:
12800 #ifdef USE_ITHREADS
12801 arg->pad_offset = cPADOPx(start)->op_padix;
12802 /* stop it being swiped when nulled */
12803 cPADOPx(start)->op_padix = 0;
12805 arg->sv = cSVOPx(start)->op_sv;
12806 cSVOPx(start)->op_sv = NULL;
12812 case MDEREF_HV_padhv_helem:
12813 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12814 next_is_hash = TRUE;
12816 case MDEREF_AV_padav_aelem:
12817 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12819 arg->pad_offset = start->op_targ;
12820 /* we skip setting op_targ = 0 for now, since the intact
12821 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12822 reset_start_targ = TRUE;
12827 case MDEREF_HV_pop_rv2hv_helem:
12828 next_is_hash = TRUE;
12830 case MDEREF_AV_pop_rv2av_aelem:
12834 NOT_REACHED; /* NOTREACHED */
12839 /* look for another (rv2av/hv; get index;
12840 * aelem/helem/exists/delele) sequence */
12845 UV index_type = MDEREF_INDEX_none;
12847 if (action_count) {
12848 /* if this is not the first lookup, consume the rv2av/hv */
12850 /* for N levels of aggregate lookup, we normally expect
12851 * that the first N-1 [ah]elem ops will be flagged as
12852 * /DEREF (so they autovivifiy if necessary), and the last
12853 * lookup op not to be.
12854 * For other things (like @{$h{k1}{k2}}) extra scope or
12855 * leave ops can appear, so abandon the effort in that
12857 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12860 /* rv2av or rv2hv sKR/1 */
12862 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12863 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12864 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12867 /* at this point, we wouldn't expect any of these
12868 * possible private flags:
12869 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12870 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12872 ASSUME(!(o->op_private &
12873 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12875 hints = (o->op_private & OPpHINT_STRICT_REFS);
12877 /* make sure the type of the previous /DEREF matches the
12878 * type of the next lookup */
12879 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12882 action = next_is_hash
12883 ? MDEREF_HV_vivify_rv2hv_helem
12884 : MDEREF_AV_vivify_rv2av_aelem;
12888 /* if this is the second pass, and we're at the depth where
12889 * previously we encountered a non-simple index expression,
12890 * stop processing the index at this point */
12891 if (action_count != index_skip) {
12893 /* look for one or more simple ops that return an array
12894 * index or hash key */
12896 switch (o->op_type) {
12898 /* it may be a lexical var index */
12899 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12900 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12901 ASSUME(!(o->op_private &
12902 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12904 if ( OP_GIMME(o,0) == G_SCALAR
12905 && !(o->op_flags & (OPf_REF|OPf_MOD))
12906 && o->op_private == 0)
12909 arg->pad_offset = o->op_targ;
12911 index_type = MDEREF_INDEX_padsv;
12917 if (next_is_hash) {
12918 /* it's a constant hash index */
12919 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12920 /* "use constant foo => FOO; $h{+foo}" for
12921 * some weird FOO, can leave you with constants
12922 * that aren't simple strings. It's not worth
12923 * the extra hassle for those edge cases */
12928 OP * helem_op = o->op_next;
12930 ASSUME( helem_op->op_type == OP_HELEM
12931 || helem_op->op_type == OP_NULL);
12932 if (helem_op->op_type == OP_HELEM) {
12933 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12934 if ( helem_op->op_private & OPpLVAL_INTRO
12935 || rop->op_type != OP_RV2HV
12939 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12941 #ifdef USE_ITHREADS
12942 /* Relocate sv to the pad for thread safety */
12943 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12944 arg->pad_offset = o->op_targ;
12947 arg->sv = cSVOPx_sv(o);
12952 /* it's a constant array index */
12954 SV *ix_sv = cSVOPo->op_sv;
12959 if ( action_count == 0
12962 && ( action == MDEREF_AV_padav_aelem
12963 || action == MDEREF_AV_gvav_aelem)
12965 maybe_aelemfast = TRUE;
12969 SvREFCNT_dec_NN(cSVOPo->op_sv);
12973 /* we've taken ownership of the SV */
12974 cSVOPo->op_sv = NULL;
12976 index_type = MDEREF_INDEX_const;
12981 /* it may be a package var index */
12983 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12984 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12985 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12986 || o->op_private != 0
12991 if (kid->op_type != OP_RV2SV)
12994 ASSUME(!(kid->op_flags &
12995 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12996 |OPf_SPECIAL|OPf_PARENS)));
12997 ASSUME(!(kid->op_private &
12999 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
13000 |OPpDEREF|OPpLVAL_INTRO)));
13001 if( (kid->op_flags &~ OPf_PARENS)
13002 != (OPf_WANT_SCALAR|OPf_KIDS)
13003 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
13008 #ifdef USE_ITHREADS
13009 arg->pad_offset = cPADOPx(o)->op_padix;
13010 /* stop it being swiped when nulled */
13011 cPADOPx(o)->op_padix = 0;
13013 arg->sv = cSVOPx(o)->op_sv;
13014 cSVOPo->op_sv = NULL;
13018 index_type = MDEREF_INDEX_gvsv;
13023 } /* action_count != index_skip */
13025 action |= index_type;
13028 /* at this point we have either:
13029 * * detected what looks like a simple index expression,
13030 * and expect the next op to be an [ah]elem, or
13031 * an nulled [ah]elem followed by a delete or exists;
13032 * * found a more complex expression, so something other
13033 * than the above follows.
13036 /* possibly an optimised away [ah]elem (where op_next is
13037 * exists or delete) */
13038 if (o->op_type == OP_NULL)
13041 /* at this point we're looking for an OP_AELEM, OP_HELEM,
13042 * OP_EXISTS or OP_DELETE */
13044 /* if something like arybase (a.k.a $[ ) is in scope,
13045 * abandon optimisation attempt */
13046 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
13047 && PL_check[o->op_type] != Perl_ck_null)
13049 /* similarly for customised exists and delete */
13050 if ( (o->op_type == OP_EXISTS)
13051 && PL_check[o->op_type] != Perl_ck_exists)
13053 if ( (o->op_type == OP_DELETE)
13054 && PL_check[o->op_type] != Perl_ck_delete)
13057 if ( o->op_type != OP_AELEM
13058 || (o->op_private &
13059 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
13061 maybe_aelemfast = FALSE;
13063 /* look for aelem/helem/exists/delete. If it's not the last elem
13064 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
13065 * flags; if it's the last, then it mustn't have
13066 * OPpDEREF_AV/HV, but may have lots of other flags, like
13067 * OPpLVAL_INTRO etc
13070 if ( index_type == MDEREF_INDEX_none
13071 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
13072 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
13076 /* we have aelem/helem/exists/delete with valid simple index */
13078 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
13079 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
13080 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
13083 ASSUME(!(o->op_flags &
13084 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
13085 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
13087 ok = (o->op_flags &~ OPf_PARENS)
13088 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
13089 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
13091 else if (o->op_type == OP_EXISTS) {
13092 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13093 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13094 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
13095 ok = !(o->op_private & ~OPpARG1_MASK);
13097 else if (o->op_type == OP_DELETE) {
13098 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13099 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13100 ASSUME(!(o->op_private &
13101 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
13102 /* don't handle slices or 'local delete'; the latter
13103 * is fairly rare, and has a complex runtime */
13104 ok = !(o->op_private & ~OPpARG1_MASK);
13105 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
13106 /* skip handling run-tome error */
13107 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
13110 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
13111 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
13112 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
13113 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
13114 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
13115 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
13120 if (!first_elem_op)
13124 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
13129 action |= MDEREF_FLAG_last;
13133 /* at this point we have something that started
13134 * promisingly enough (with rv2av or whatever), but failed
13135 * to find a simple index followed by an
13136 * aelem/helem/exists/delete. If this is the first action,
13137 * give up; but if we've already seen at least one
13138 * aelem/helem, then keep them and add a new action with
13139 * MDEREF_INDEX_none, which causes it to do the vivify
13140 * from the end of the previous lookup, and do the deref,
13141 * but stop at that point. So $a[0][expr] will do one
13142 * av_fetch, vivify and deref, then continue executing at
13147 index_skip = action_count;
13148 action |= MDEREF_FLAG_last;
13149 if (index_type != MDEREF_INDEX_none)
13154 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
13157 /* if there's no space for the next action, create a new slot
13158 * for it *before* we start adding args for that action */
13159 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
13166 } /* while !is_last */
13174 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
13175 if (index_skip == -1) {
13176 mderef->op_flags = o->op_flags
13177 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
13178 if (o->op_type == OP_EXISTS)
13179 mderef->op_private = OPpMULTIDEREF_EXISTS;
13180 else if (o->op_type == OP_DELETE)
13181 mderef->op_private = OPpMULTIDEREF_DELETE;
13183 mderef->op_private = o->op_private
13184 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
13186 /* accumulate strictness from every level (although I don't think
13187 * they can actually vary) */
13188 mderef->op_private |= hints;
13190 /* integrate the new multideref op into the optree and the
13193 * In general an op like aelem or helem has two child
13194 * sub-trees: the aggregate expression (a_expr) and the
13195 * index expression (i_expr):
13201 * The a_expr returns an AV or HV, while the i-expr returns an
13202 * index. In general a multideref replaces most or all of a
13203 * multi-level tree, e.g.
13219 * With multideref, all the i_exprs will be simple vars or
13220 * constants, except that i_expr1 may be arbitrary in the case
13221 * of MDEREF_INDEX_none.
13223 * The bottom-most a_expr will be either:
13224 * 1) a simple var (so padXv or gv+rv2Xv);
13225 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
13226 * so a simple var with an extra rv2Xv;
13227 * 3) or an arbitrary expression.
13229 * 'start', the first op in the execution chain, will point to
13230 * 1),2): the padXv or gv op;
13231 * 3): the rv2Xv which forms the last op in the a_expr
13232 * execution chain, and the top-most op in the a_expr
13235 * For all cases, the 'start' node is no longer required,
13236 * but we can't free it since one or more external nodes
13237 * may point to it. E.g. consider
13238 * $h{foo} = $a ? $b : $c
13239 * Here, both the op_next and op_other branches of the
13240 * cond_expr point to the gv[*h] of the hash expression, so
13241 * we can't free the 'start' op.
13243 * For expr->[...], we need to save the subtree containing the
13244 * expression; for the other cases, we just need to save the
13246 * So in all cases, we null the start op and keep it around by
13247 * making it the child of the multideref op; for the expr->
13248 * case, the expr will be a subtree of the start node.
13250 * So in the simple 1,2 case the optree above changes to
13256 * ex-gv (or ex-padxv)
13258 * with the op_next chain being
13260 * -> ex-gv -> multideref -> op-following-ex-exists ->
13262 * In the 3 case, we have
13275 * -> rest-of-a_expr subtree ->
13276 * ex-rv2xv -> multideref -> op-following-ex-exists ->
13279 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13280 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13281 * multideref attached as the child, e.g.
13287 * ex-rv2av - i_expr1
13295 /* if we free this op, don't free the pad entry */
13296 if (reset_start_targ)
13297 start->op_targ = 0;
13300 /* Cut the bit we need to save out of the tree and attach to
13301 * the multideref op, then free the rest of the tree */
13303 /* find parent of node to be detached (for use by splice) */
13305 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
13306 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13308 /* there is an arbitrary expression preceding us, e.g.
13309 * expr->[..]? so we need to save the 'expr' subtree */
13310 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13311 p = cUNOPx(p)->op_first;
13312 ASSUME( start->op_type == OP_RV2AV
13313 || start->op_type == OP_RV2HV);
13316 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13317 * above for exists/delete. */
13318 while ( (p->op_flags & OPf_KIDS)
13319 && cUNOPx(p)->op_first != start
13321 p = cUNOPx(p)->op_first;
13323 ASSUME(cUNOPx(p)->op_first == start);
13325 /* detach from main tree, and re-attach under the multideref */
13326 op_sibling_splice(mderef, NULL, 0,
13327 op_sibling_splice(p, NULL, 1, NULL));
13330 start->op_next = mderef;
13332 mderef->op_next = index_skip == -1 ? o->op_next : o;
13334 /* excise and free the original tree, and replace with
13335 * the multideref op */
13336 p = op_sibling_splice(top_op, NULL, -1, mderef);
13345 Size_t size = arg - arg_buf;
13347 if (maybe_aelemfast && action_count == 1)
13350 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13351 sizeof(UNOP_AUX_item) * (size + 1));
13352 /* for dumping etc: store the length in a hidden first slot;
13353 * we set the op_aux pointer to the second slot */
13354 arg_buf->uv = size;
13357 } /* for (pass = ...) */
13362 /* mechanism for deferring recursion in rpeep() */
13364 #define MAX_DEFERRED 4
13368 if (defer_ix == (MAX_DEFERRED-1)) { \
13369 OP **defer = defer_queue[defer_base]; \
13370 CALL_RPEEP(*defer); \
13371 S_prune_chain_head(defer); \
13372 defer_base = (defer_base + 1) % MAX_DEFERRED; \
13375 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13378 #define IS_AND_OP(o) (o->op_type == OP_AND)
13379 #define IS_OR_OP(o) (o->op_type == OP_OR)
13382 /* A peephole optimizer. We visit the ops in the order they're to execute.
13383 * See the comments at the top of this file for more details about when
13384 * peep() is called */
13387 Perl_rpeep(pTHX_ OP *o)
13391 OP* oldoldop = NULL;
13392 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13393 int defer_base = 0;
13398 if (!o || o->op_opt)
13401 assert(o->op_type != OP_FREED);
13405 SAVEVPTR(PL_curcop);
13406 for (;; o = o->op_next) {
13407 if (o && o->op_opt)
13410 while (defer_ix >= 0) {
13412 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13413 CALL_RPEEP(*defer);
13414 S_prune_chain_head(defer);
13421 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13422 assert(!oldoldop || oldoldop->op_next == oldop);
13423 assert(!oldop || oldop->op_next == o);
13425 /* By default, this op has now been optimised. A couple of cases below
13426 clear this again. */
13430 /* look for a series of 1 or more aggregate derefs, e.g.
13431 * $a[1]{foo}[$i]{$k}
13432 * and replace with a single OP_MULTIDEREF op.
13433 * Each index must be either a const, or a simple variable,
13435 * First, look for likely combinations of starting ops,
13436 * corresponding to (global and lexical variants of)
13438 * $r->[...] $r->{...}
13439 * (preceding expression)->[...]
13440 * (preceding expression)->{...}
13441 * and if so, call maybe_multideref() to do a full inspection
13442 * of the op chain and if appropriate, replace with an
13450 switch (o2->op_type) {
13452 /* $pkg[..] : gv[*pkg]
13453 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
13455 /* Fail if there are new op flag combinations that we're
13456 * not aware of, rather than:
13457 * * silently failing to optimise, or
13458 * * silently optimising the flag away.
13459 * If this ASSUME starts failing, examine what new flag
13460 * has been added to the op, and decide whether the
13461 * optimisation should still occur with that flag, then
13462 * update the code accordingly. This applies to all the
13463 * other ASSUMEs in the block of code too.
13465 ASSUME(!(o2->op_flags &
13466 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13467 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13471 if (o2->op_type == OP_RV2AV) {
13472 action = MDEREF_AV_gvav_aelem;
13476 if (o2->op_type == OP_RV2HV) {
13477 action = MDEREF_HV_gvhv_helem;
13481 if (o2->op_type != OP_RV2SV)
13484 /* at this point we've seen gv,rv2sv, so the only valid
13485 * construct left is $pkg->[] or $pkg->{} */
13487 ASSUME(!(o2->op_flags & OPf_STACKED));
13488 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13489 != (OPf_WANT_SCALAR|OPf_MOD))
13492 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13493 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13494 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13496 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
13497 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13501 if (o2->op_type == OP_RV2AV) {
13502 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13505 if (o2->op_type == OP_RV2HV) {
13506 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13512 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13514 ASSUME(!(o2->op_flags &
13515 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13516 if ((o2->op_flags &
13517 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13518 != (OPf_WANT_SCALAR|OPf_MOD))
13521 ASSUME(!(o2->op_private &
13522 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13523 /* skip if state or intro, or not a deref */
13524 if ( o2->op_private != OPpDEREF_AV
13525 && o2->op_private != OPpDEREF_HV)
13529 if (o2->op_type == OP_RV2AV) {
13530 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13533 if (o2->op_type == OP_RV2HV) {
13534 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13541 /* $lex[..]: padav[@lex:1,2] sR *
13542 * or $lex{..}: padhv[%lex:1,2] sR */
13543 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13544 OPf_REF|OPf_SPECIAL)));
13545 if ((o2->op_flags &
13546 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13547 != (OPf_WANT_SCALAR|OPf_REF))
13549 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13551 /* OPf_PARENS isn't currently used in this case;
13552 * if that changes, let us know! */
13553 ASSUME(!(o2->op_flags & OPf_PARENS));
13555 /* at this point, we wouldn't expect any of the remaining
13556 * possible private flags:
13557 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13558 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13560 * OPpSLICEWARNING shouldn't affect runtime
13562 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13564 action = o2->op_type == OP_PADAV
13565 ? MDEREF_AV_padav_aelem
13566 : MDEREF_HV_padhv_helem;
13568 S_maybe_multideref(aTHX_ o, o2, action, 0);
13574 action = o2->op_type == OP_RV2AV
13575 ? MDEREF_AV_pop_rv2av_aelem
13576 : MDEREF_HV_pop_rv2hv_helem;
13579 /* (expr)->[...]: rv2av sKR/1;
13580 * (expr)->{...}: rv2hv sKR/1; */
13582 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13584 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13585 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13586 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13589 /* at this point, we wouldn't expect any of these
13590 * possible private flags:
13591 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13592 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13594 ASSUME(!(o2->op_private &
13595 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13597 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13601 S_maybe_multideref(aTHX_ o, o2, action, hints);
13610 switch (o->op_type) {
13612 PL_curcop = ((COP*)o); /* for warnings */
13615 PL_curcop = ((COP*)o); /* for warnings */
13617 /* Optimise a "return ..." at the end of a sub to just be "...".
13618 * This saves 2 ops. Before:
13619 * 1 <;> nextstate(main 1 -e:1) v ->2
13620 * 4 <@> return K ->5
13621 * 2 <0> pushmark s ->3
13622 * - <1> ex-rv2sv sK/1 ->4
13623 * 3 <#> gvsv[*cat] s ->4
13626 * - <@> return K ->-
13627 * - <0> pushmark s ->2
13628 * - <1> ex-rv2sv sK/1 ->-
13629 * 2 <$> gvsv(*cat) s ->3
13632 OP *next = o->op_next;
13633 OP *sibling = OpSIBLING(o);
13634 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13635 && OP_TYPE_IS(sibling, OP_RETURN)
13636 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13637 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13638 ||OP_TYPE_IS(sibling->op_next->op_next,
13640 && cUNOPx(sibling)->op_first == next
13641 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13644 /* Look through the PUSHMARK's siblings for one that
13645 * points to the RETURN */
13646 OP *top = OpSIBLING(next);
13647 while (top && top->op_next) {
13648 if (top->op_next == sibling) {
13649 top->op_next = sibling->op_next;
13650 o->op_next = next->op_next;
13653 top = OpSIBLING(top);
13658 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13660 * This latter form is then suitable for conversion into padrange
13661 * later on. Convert:
13663 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13667 * nextstate1 -> listop -> nextstate3
13669 * pushmark -> padop1 -> padop2
13671 if (o->op_next && (
13672 o->op_next->op_type == OP_PADSV
13673 || o->op_next->op_type == OP_PADAV
13674 || o->op_next->op_type == OP_PADHV
13676 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13677 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13678 && o->op_next->op_next->op_next && (
13679 o->op_next->op_next->op_next->op_type == OP_PADSV
13680 || o->op_next->op_next->op_next->op_type == OP_PADAV
13681 || o->op_next->op_next->op_next->op_type == OP_PADHV
13683 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13684 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13685 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13686 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13688 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13691 ns2 = pad1->op_next;
13692 pad2 = ns2->op_next;
13693 ns3 = pad2->op_next;
13695 /* we assume here that the op_next chain is the same as
13696 * the op_sibling chain */
13697 assert(OpSIBLING(o) == pad1);
13698 assert(OpSIBLING(pad1) == ns2);
13699 assert(OpSIBLING(ns2) == pad2);
13700 assert(OpSIBLING(pad2) == ns3);
13702 /* excise and delete ns2 */
13703 op_sibling_splice(NULL, pad1, 1, NULL);
13706 /* excise pad1 and pad2 */
13707 op_sibling_splice(NULL, o, 2, NULL);
13709 /* create new listop, with children consisting of:
13710 * a new pushmark, pad1, pad2. */
13711 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13712 newop->op_flags |= OPf_PARENS;
13713 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13715 /* insert newop between o and ns3 */
13716 op_sibling_splice(NULL, o, 0, newop);
13718 /*fixup op_next chain */
13719 newpm = cUNOPx(newop)->op_first; /* pushmark */
13720 o ->op_next = newpm;
13721 newpm->op_next = pad1;
13722 pad1 ->op_next = pad2;
13723 pad2 ->op_next = newop; /* listop */
13724 newop->op_next = ns3;
13726 /* Ensure pushmark has this flag if padops do */
13727 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13728 newpm->op_flags |= OPf_MOD;
13734 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13735 to carry two labels. For now, take the easier option, and skip
13736 this optimisation if the first NEXTSTATE has a label. */
13737 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13738 OP *nextop = o->op_next;
13739 while (nextop && nextop->op_type == OP_NULL)
13740 nextop = nextop->op_next;
13742 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13745 oldop->op_next = nextop;
13747 /* Skip (old)oldop assignment since the current oldop's
13748 op_next already points to the next op. */
13755 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13756 if (o->op_next->op_private & OPpTARGET_MY) {
13757 if (o->op_flags & OPf_STACKED) /* chained concats */
13758 break; /* ignore_optimization */
13760 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13761 o->op_targ = o->op_next->op_targ;
13762 o->op_next->op_targ = 0;
13763 o->op_private |= OPpTARGET_MY;
13766 op_null(o->op_next);
13770 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13771 break; /* Scalar stub must produce undef. List stub is noop */
13775 if (o->op_targ == OP_NEXTSTATE
13776 || o->op_targ == OP_DBSTATE)
13778 PL_curcop = ((COP*)o);
13780 /* XXX: We avoid setting op_seq here to prevent later calls
13781 to rpeep() from mistakenly concluding that optimisation
13782 has already occurred. This doesn't fix the real problem,
13783 though (See 20010220.007 (#5874)). AMS 20010719 */
13784 /* op_seq functionality is now replaced by op_opt */
13792 oldop->op_next = o->op_next;
13806 convert repeat into a stub with no kids.
13808 if (o->op_next->op_type == OP_CONST
13809 || ( o->op_next->op_type == OP_PADSV
13810 && !(o->op_next->op_private & OPpLVAL_INTRO))
13811 || ( o->op_next->op_type == OP_GV
13812 && o->op_next->op_next->op_type == OP_RV2SV
13813 && !(o->op_next->op_next->op_private
13814 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13816 const OP *kid = o->op_next->op_next;
13817 if (o->op_next->op_type == OP_GV)
13818 kid = kid->op_next;
13819 /* kid is now the ex-list. */
13820 if (kid->op_type == OP_NULL
13821 && (kid = kid->op_next)->op_type == OP_CONST
13822 /* kid is now the repeat count. */
13823 && kid->op_next->op_type == OP_REPEAT
13824 && kid->op_next->op_private & OPpREPEAT_DOLIST
13825 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13826 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13828 o = kid->op_next; /* repeat */
13830 oldop->op_next = o;
13831 op_free(cBINOPo->op_first);
13832 op_free(cBINOPo->op_last );
13833 o->op_flags &=~ OPf_KIDS;
13834 /* stub is a baseop; repeat is a binop */
13835 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13836 OpTYPE_set(o, OP_STUB);
13842 /* Convert a series of PAD ops for my vars plus support into a
13843 * single padrange op. Basically
13845 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13847 * becomes, depending on circumstances, one of
13849 * padrange ----------------------------------> (list) -> rest
13850 * padrange --------------------------------------------> rest
13852 * where all the pad indexes are sequential and of the same type
13854 * We convert the pushmark into a padrange op, then skip
13855 * any other pad ops, and possibly some trailing ops.
13856 * Note that we don't null() the skipped ops, to make it
13857 * easier for Deparse to undo this optimisation (and none of
13858 * the skipped ops are holding any resourses). It also makes
13859 * it easier for find_uninit_var(), as it can just ignore
13860 * padrange, and examine the original pad ops.
13864 OP *followop = NULL; /* the op that will follow the padrange op */
13867 PADOFFSET base = 0; /* init only to stop compiler whining */
13868 bool gvoid = 0; /* init only to stop compiler whining */
13869 bool defav = 0; /* seen (...) = @_ */
13870 bool reuse = 0; /* reuse an existing padrange op */
13872 /* look for a pushmark -> gv[_] -> rv2av */
13877 if ( p->op_type == OP_GV
13878 && cGVOPx_gv(p) == PL_defgv
13879 && (rv2av = p->op_next)
13880 && rv2av->op_type == OP_RV2AV
13881 && !(rv2av->op_flags & OPf_REF)
13882 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13883 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13885 q = rv2av->op_next;
13886 if (q->op_type == OP_NULL)
13888 if (q->op_type == OP_PUSHMARK) {
13898 /* scan for PAD ops */
13900 for (p = p->op_next; p; p = p->op_next) {
13901 if (p->op_type == OP_NULL)
13904 if (( p->op_type != OP_PADSV
13905 && p->op_type != OP_PADAV
13906 && p->op_type != OP_PADHV
13908 /* any private flag other than INTRO? e.g. STATE */
13909 || (p->op_private & ~OPpLVAL_INTRO)
13913 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13915 if ( p->op_type == OP_PADAV
13917 && p->op_next->op_type == OP_CONST
13918 && p->op_next->op_next
13919 && p->op_next->op_next->op_type == OP_AELEM
13923 /* for 1st padop, note what type it is and the range
13924 * start; for the others, check that it's the same type
13925 * and that the targs are contiguous */
13927 intro = (p->op_private & OPpLVAL_INTRO);
13929 gvoid = OP_GIMME(p,0) == G_VOID;
13932 if ((p->op_private & OPpLVAL_INTRO) != intro)
13934 /* Note that you'd normally expect targs to be
13935 * contiguous in my($a,$b,$c), but that's not the case
13936 * when external modules start doing things, e.g.
13937 * Function::Parameters */
13938 if (p->op_targ != base + count)
13940 assert(p->op_targ == base + count);
13941 /* Either all the padops or none of the padops should
13942 be in void context. Since we only do the optimisa-
13943 tion for av/hv when the aggregate itself is pushed
13944 on to the stack (one item), there is no need to dis-
13945 tinguish list from scalar context. */
13946 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13950 /* for AV, HV, only when we're not flattening */
13951 if ( p->op_type != OP_PADSV
13953 && !(p->op_flags & OPf_REF)
13957 if (count >= OPpPADRANGE_COUNTMASK)
13960 /* there's a biggest base we can fit into a
13961 * SAVEt_CLEARPADRANGE in pp_padrange.
13962 * (The sizeof() stuff will be constant-folded, and is
13963 * intended to avoid getting "comparison is always false"
13964 * compiler warnings. See the comments above
13965 * MEM_WRAP_CHECK for more explanation on why we do this
13966 * in a weird way to avoid compiler warnings.)
13969 && (8*sizeof(base) >
13970 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13972 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13974 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13978 /* Success! We've got another valid pad op to optimise away */
13980 followop = p->op_next;
13983 if (count < 1 || (count == 1 && !defav))
13986 /* pp_padrange in specifically compile-time void context
13987 * skips pushing a mark and lexicals; in all other contexts
13988 * (including unknown till runtime) it pushes a mark and the
13989 * lexicals. We must be very careful then, that the ops we
13990 * optimise away would have exactly the same effect as the
13992 * In particular in void context, we can only optimise to
13993 * a padrange if we see the complete sequence
13994 * pushmark, pad*v, ...., list
13995 * which has the net effect of leaving the markstack as it
13996 * was. Not pushing onto the stack (whereas padsv does touch
13997 * the stack) makes no difference in void context.
14001 if (followop->op_type == OP_LIST
14002 && OP_GIMME(followop,0) == G_VOID
14005 followop = followop->op_next; /* skip OP_LIST */
14007 /* consolidate two successive my(...);'s */
14010 && oldoldop->op_type == OP_PADRANGE
14011 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
14012 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
14013 && !(oldoldop->op_flags & OPf_SPECIAL)
14016 assert(oldoldop->op_next == oldop);
14017 assert( oldop->op_type == OP_NEXTSTATE
14018 || oldop->op_type == OP_DBSTATE);
14019 assert(oldop->op_next == o);
14022 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
14024 /* Do not assume pad offsets for $c and $d are con-
14029 if ( oldoldop->op_targ + old_count == base
14030 && old_count < OPpPADRANGE_COUNTMASK - count) {
14031 base = oldoldop->op_targ;
14032 count += old_count;
14037 /* if there's any immediately following singleton
14038 * my var's; then swallow them and the associated
14040 * my ($a,$b); my $c; my $d;
14042 * my ($a,$b,$c,$d);
14045 while ( ((p = followop->op_next))
14046 && ( p->op_type == OP_PADSV
14047 || p->op_type == OP_PADAV
14048 || p->op_type == OP_PADHV)
14049 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
14050 && (p->op_private & OPpLVAL_INTRO) == intro
14051 && !(p->op_private & ~OPpLVAL_INTRO)
14053 && ( p->op_next->op_type == OP_NEXTSTATE
14054 || p->op_next->op_type == OP_DBSTATE)
14055 && count < OPpPADRANGE_COUNTMASK
14056 && base + count == p->op_targ
14059 followop = p->op_next;
14067 assert(oldoldop->op_type == OP_PADRANGE);
14068 oldoldop->op_next = followop;
14069 oldoldop->op_private = (intro | count);
14075 /* Convert the pushmark into a padrange.
14076 * To make Deparse easier, we guarantee that a padrange was
14077 * *always* formerly a pushmark */
14078 assert(o->op_type == OP_PUSHMARK);
14079 o->op_next = followop;
14080 OpTYPE_set(o, OP_PADRANGE);
14082 /* bit 7: INTRO; bit 6..0: count */
14083 o->op_private = (intro | count);
14084 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
14085 | gvoid * OPf_WANT_VOID
14086 | (defav ? OPf_SPECIAL : 0));
14094 /* Skip over state($x) in void context. */
14095 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
14096 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
14098 oldop->op_next = o->op_next;
14099 goto redo_nextstate;
14101 if (o->op_type != OP_PADAV)
14105 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
14106 OP* const pop = (o->op_type == OP_PADAV) ?
14107 o->op_next : o->op_next->op_next;
14109 if (pop && pop->op_type == OP_CONST &&
14110 ((PL_op = pop->op_next)) &&
14111 pop->op_next->op_type == OP_AELEM &&
14112 !(pop->op_next->op_private &
14113 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
14114 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
14117 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
14118 no_bareword_allowed(pop);
14119 if (o->op_type == OP_GV)
14120 op_null(o->op_next);
14121 op_null(pop->op_next);
14123 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
14124 o->op_next = pop->op_next->op_next;
14125 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
14126 o->op_private = (U8)i;
14127 if (o->op_type == OP_GV) {
14130 o->op_type = OP_AELEMFAST;
14133 o->op_type = OP_AELEMFAST_LEX;
14135 if (o->op_type != OP_GV)
14139 /* Remove $foo from the op_next chain in void context. */
14141 && ( o->op_next->op_type == OP_RV2SV
14142 || o->op_next->op_type == OP_RV2AV
14143 || o->op_next->op_type == OP_RV2HV )
14144 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14145 && !(o->op_next->op_private & OPpLVAL_INTRO))
14147 oldop->op_next = o->op_next->op_next;
14148 /* Reprocess the previous op if it is a nextstate, to
14149 allow double-nextstate optimisation. */
14151 if (oldop->op_type == OP_NEXTSTATE) {
14158 o = oldop->op_next;
14161 else if (o->op_next->op_type == OP_RV2SV) {
14162 if (!(o->op_next->op_private & OPpDEREF)) {
14163 op_null(o->op_next);
14164 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
14166 o->op_next = o->op_next->op_next;
14167 OpTYPE_set(o, OP_GVSV);
14170 else if (o->op_next->op_type == OP_READLINE
14171 && o->op_next->op_next->op_type == OP_CONCAT
14172 && (o->op_next->op_next->op_flags & OPf_STACKED))
14174 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
14175 OpTYPE_set(o, OP_RCATLINE);
14176 o->op_flags |= OPf_STACKED;
14177 op_null(o->op_next->op_next);
14178 op_null(o->op_next);
14183 #define HV_OR_SCALARHV(op) \
14184 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
14186 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
14187 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
14188 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
14189 ? cUNOPx(op)->op_first \
14193 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
14194 fop->op_private |= OPpTRUEBOOL;
14200 fop = cLOGOP->op_first;
14201 sop = OpSIBLING(fop);
14202 while (cLOGOP->op_other->op_type == OP_NULL)
14203 cLOGOP->op_other = cLOGOP->op_other->op_next;
14204 while (o->op_next && ( o->op_type == o->op_next->op_type
14205 || o->op_next->op_type == OP_NULL))
14206 o->op_next = o->op_next->op_next;
14208 /* If we're an OR and our next is an AND in void context, we'll
14209 follow its op_other on short circuit, same for reverse.
14210 We can't do this with OP_DOR since if it's true, its return
14211 value is the underlying value which must be evaluated
14215 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
14216 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
14218 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14220 o->op_next = ((LOGOP*)o->op_next)->op_other;
14222 DEFER(cLOGOP->op_other);
14225 fop = HV_OR_SCALARHV(fop);
14226 if (sop) sop = HV_OR_SCALARHV(sop);
14231 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
14232 while (nop && nop->op_next) {
14233 switch (nop->op_next->op_type) {
14238 lop = nop = nop->op_next;
14241 nop = nop->op_next;
14250 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14251 || o->op_type == OP_AND )
14252 fop->op_private |= OPpTRUEBOOL;
14253 else if (!(lop->op_flags & OPf_WANT))
14254 fop->op_private |= OPpMAYBE_TRUEBOOL;
14256 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14258 sop->op_private |= OPpTRUEBOOL;
14265 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
14266 fop->op_private |= OPpTRUEBOOL;
14267 #undef HV_OR_SCALARHV
14268 /* GERONIMO! */ /* FALLTHROUGH */
14277 case OP_ARGDEFELEM:
14278 while (cLOGOP->op_other->op_type == OP_NULL)
14279 cLOGOP->op_other = cLOGOP->op_other->op_next;
14280 DEFER(cLOGOP->op_other);
14285 while (cLOOP->op_redoop->op_type == OP_NULL)
14286 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14287 while (cLOOP->op_nextop->op_type == OP_NULL)
14288 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14289 while (cLOOP->op_lastop->op_type == OP_NULL)
14290 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14291 /* a while(1) loop doesn't have an op_next that escapes the
14292 * loop, so we have to explicitly follow the op_lastop to
14293 * process the rest of the code */
14294 DEFER(cLOOP->op_lastop);
14298 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14299 DEFER(cLOGOPo->op_other);
14303 assert(!(cPMOP->op_pmflags & PMf_ONCE));
14304 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14305 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14306 cPMOP->op_pmstashstartu.op_pmreplstart
14307 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14308 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14314 if (o->op_flags & OPf_SPECIAL) {
14315 /* first arg is a code block */
14316 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14317 OP * kid = cUNOPx(nullop)->op_first;
14319 assert(nullop->op_type == OP_NULL);
14320 assert(kid->op_type == OP_SCOPE
14321 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14322 /* since OP_SORT doesn't have a handy op_other-style
14323 * field that can point directly to the start of the code
14324 * block, store it in the otherwise-unused op_next field
14325 * of the top-level OP_NULL. This will be quicker at
14326 * run-time, and it will also allow us to remove leading
14327 * OP_NULLs by just messing with op_nexts without
14328 * altering the basic op_first/op_sibling layout. */
14329 kid = kLISTOP->op_first;
14331 (kid->op_type == OP_NULL
14332 && ( kid->op_targ == OP_NEXTSTATE
14333 || kid->op_targ == OP_DBSTATE ))
14334 || kid->op_type == OP_STUB
14335 || kid->op_type == OP_ENTER);
14336 nullop->op_next = kLISTOP->op_next;
14337 DEFER(nullop->op_next);
14340 /* check that RHS of sort is a single plain array */
14341 oright = cUNOPo->op_first;
14342 if (!oright || oright->op_type != OP_PUSHMARK)
14345 if (o->op_private & OPpSORT_INPLACE)
14348 /* reverse sort ... can be optimised. */
14349 if (!OpHAS_SIBLING(cUNOPo)) {
14350 /* Nothing follows us on the list. */
14351 OP * const reverse = o->op_next;
14353 if (reverse->op_type == OP_REVERSE &&
14354 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14355 OP * const pushmark = cUNOPx(reverse)->op_first;
14356 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14357 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14358 /* reverse -> pushmark -> sort */
14359 o->op_private |= OPpSORT_REVERSE;
14361 pushmark->op_next = oright->op_next;
14371 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14373 LISTOP *enter, *exlist;
14375 if (o->op_private & OPpSORT_INPLACE)
14378 enter = (LISTOP *) o->op_next;
14381 if (enter->op_type == OP_NULL) {
14382 enter = (LISTOP *) enter->op_next;
14386 /* for $a (...) will have OP_GV then OP_RV2GV here.
14387 for (...) just has an OP_GV. */
14388 if (enter->op_type == OP_GV) {
14389 gvop = (OP *) enter;
14390 enter = (LISTOP *) enter->op_next;
14393 if (enter->op_type == OP_RV2GV) {
14394 enter = (LISTOP *) enter->op_next;
14400 if (enter->op_type != OP_ENTERITER)
14403 iter = enter->op_next;
14404 if (!iter || iter->op_type != OP_ITER)
14407 expushmark = enter->op_first;
14408 if (!expushmark || expushmark->op_type != OP_NULL
14409 || expushmark->op_targ != OP_PUSHMARK)
14412 exlist = (LISTOP *) OpSIBLING(expushmark);
14413 if (!exlist || exlist->op_type != OP_NULL
14414 || exlist->op_targ != OP_LIST)
14417 if (exlist->op_last != o) {
14418 /* Mmm. Was expecting to point back to this op. */
14421 theirmark = exlist->op_first;
14422 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14425 if (OpSIBLING(theirmark) != o) {
14426 /* There's something between the mark and the reverse, eg
14427 for (1, reverse (...))
14432 ourmark = ((LISTOP *)o)->op_first;
14433 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14436 ourlast = ((LISTOP *)o)->op_last;
14437 if (!ourlast || ourlast->op_next != o)
14440 rv2av = OpSIBLING(ourmark);
14441 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14442 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14443 /* We're just reversing a single array. */
14444 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14445 enter->op_flags |= OPf_STACKED;
14448 /* We don't have control over who points to theirmark, so sacrifice
14450 theirmark->op_next = ourmark->op_next;
14451 theirmark->op_flags = ourmark->op_flags;
14452 ourlast->op_next = gvop ? gvop : (OP *) enter;
14455 enter->op_private |= OPpITER_REVERSED;
14456 iter->op_private |= OPpITER_REVERSED;
14460 o = oldop->op_next;
14468 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14469 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14474 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14475 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14478 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14480 sv = newRV((SV *)PL_compcv);
14484 OpTYPE_set(o, OP_CONST);
14485 o->op_flags |= OPf_SPECIAL;
14486 cSVOPo->op_sv = sv;
14491 if (OP_GIMME(o,0) == G_VOID
14492 || ( o->op_next->op_type == OP_LINESEQ
14493 && ( o->op_next->op_next->op_type == OP_LEAVESUB
14494 || ( o->op_next->op_next->op_type == OP_RETURN
14495 && !CvLVALUE(PL_compcv)))))
14497 OP *right = cBINOP->op_first;
14516 OP *left = OpSIBLING(right);
14517 if (left->op_type == OP_SUBSTR
14518 && (left->op_private & 7) < 4) {
14520 /* cut out right */
14521 op_sibling_splice(o, NULL, 1, NULL);
14522 /* and insert it as second child of OP_SUBSTR */
14523 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14525 left->op_private |= OPpSUBSTR_REPL_FIRST;
14527 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14534 int l, r, lr, lscalars, rscalars;
14536 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14537 Note that we do this now rather than in newASSIGNOP(),
14538 since only by now are aliased lexicals flagged as such
14540 See the essay "Common vars in list assignment" above for
14541 the full details of the rationale behind all the conditions
14544 PL_generation sorcery:
14545 To detect whether there are common vars, the global var
14546 PL_generation is incremented for each assign op we scan.
14547 Then we run through all the lexical variables on the LHS,
14548 of the assignment, setting a spare slot in each of them to
14549 PL_generation. Then we scan the RHS, and if any lexicals
14550 already have that value, we know we've got commonality.
14551 Also, if the generation number is already set to
14552 PERL_INT_MAX, then the variable is involved in aliasing, so
14553 we also have potential commonality in that case.
14559 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
14562 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14566 /* After looking for things which are *always* safe, this main
14567 * if/else chain selects primarily based on the type of the
14568 * LHS, gradually working its way down from the more dangerous
14569 * to the more restrictive and thus safer cases */
14571 if ( !l /* () = ....; */
14572 || !r /* .... = (); */
14573 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14574 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14575 || (lscalars < 2) /* ($x, undef) = ... */
14577 NOOP; /* always safe */
14579 else if (l & AAS_DANGEROUS) {
14580 /* always dangerous */
14581 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14582 o->op_private |= OPpASSIGN_COMMON_AGG;
14584 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14585 /* package vars are always dangerous - too many
14586 * aliasing possibilities */
14587 if (l & AAS_PKG_SCALAR)
14588 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14589 if (l & AAS_PKG_AGG)
14590 o->op_private |= OPpASSIGN_COMMON_AGG;
14592 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14593 |AAS_LEX_SCALAR|AAS_LEX_AGG))
14595 /* LHS contains only lexicals and safe ops */
14597 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14598 o->op_private |= OPpASSIGN_COMMON_AGG;
14600 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14601 if (lr & AAS_LEX_SCALAR_COMM)
14602 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14603 else if ( !(l & AAS_LEX_SCALAR)
14604 && (r & AAS_DEFAV))
14608 * as scalar-safe for performance reasons.
14609 * (it will still have been marked _AGG if necessary */
14612 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14613 /* if there are only lexicals on the LHS and no
14614 * common ones on the RHS, then we assume that the
14615 * only way those lexicals could also get
14616 * on the RHS is via some sort of dereffing or
14619 * ($lex, $x) = (1, $$r)
14620 * and in this case we assume the var must have
14621 * a bumped ref count. So if its ref count is 1,
14622 * it must only be on the LHS.
14624 o->op_private |= OPpASSIGN_COMMON_RC1;
14629 * may have to handle aggregate on LHS, but we can't
14630 * have common scalars. */
14633 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14639 Perl_cpeep_t cpeep =
14640 XopENTRYCUSTOM(o, xop_peep);
14642 cpeep(aTHX_ o, oldop);
14647 /* did we just null the current op? If so, re-process it to handle
14648 * eliding "empty" ops from the chain */
14649 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14662 Perl_peep(pTHX_ OP *o)
14668 =head1 Custom Operators
14670 =for apidoc Ao||custom_op_xop
14671 Return the XOP structure for a given custom op. This macro should be
14672 considered internal to C<OP_NAME> and the other access macros: use them instead.
14673 This macro does call a function. Prior
14674 to 5.19.6, this was implemented as a
14681 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14687 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14689 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14690 assert(o->op_type == OP_CUSTOM);
14692 /* This is wrong. It assumes a function pointer can be cast to IV,
14693 * which isn't guaranteed, but this is what the old custom OP code
14694 * did. In principle it should be safer to Copy the bytes of the
14695 * pointer into a PV: since the new interface is hidden behind
14696 * functions, this can be changed later if necessary. */
14697 /* Change custom_op_xop if this ever happens */
14698 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14701 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14703 /* assume noone will have just registered a desc */
14704 if (!he && PL_custom_op_names &&
14705 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14710 /* XXX does all this need to be shared mem? */
14711 Newxz(xop, 1, XOP);
14712 pv = SvPV(HeVAL(he), l);
14713 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14714 if (PL_custom_op_descs &&
14715 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14717 pv = SvPV(HeVAL(he), l);
14718 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14720 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14724 xop = (XOP *)&xop_null;
14726 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14730 if(field == XOPe_xop_ptr) {
14733 const U32 flags = XopFLAGS(xop);
14734 if(flags & field) {
14736 case XOPe_xop_name:
14737 any.xop_name = xop->xop_name;
14739 case XOPe_xop_desc:
14740 any.xop_desc = xop->xop_desc;
14742 case XOPe_xop_class:
14743 any.xop_class = xop->xop_class;
14745 case XOPe_xop_peep:
14746 any.xop_peep = xop->xop_peep;
14749 NOT_REACHED; /* NOTREACHED */
14754 case XOPe_xop_name:
14755 any.xop_name = XOPd_xop_name;
14757 case XOPe_xop_desc:
14758 any.xop_desc = XOPd_xop_desc;
14760 case XOPe_xop_class:
14761 any.xop_class = XOPd_xop_class;
14763 case XOPe_xop_peep:
14764 any.xop_peep = XOPd_xop_peep;
14767 NOT_REACHED; /* NOTREACHED */
14772 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14773 * op.c: In function 'Perl_custom_op_get_field':
14774 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14775 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14776 * expands to assert(0), which expands to ((0) ? (void)0 :
14777 * __assert(...)), and gcc doesn't know that __assert can never return. */
14783 =for apidoc Ao||custom_op_register
14784 Register a custom op. See L<perlguts/"Custom Operators">.
14790 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14794 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14796 /* see the comment in custom_op_xop */
14797 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14799 if (!PL_custom_ops)
14800 PL_custom_ops = newHV();
14802 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14803 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14808 =for apidoc core_prototype
14810 This function assigns the prototype of the named core function to C<sv>, or
14811 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
14812 C<NULL> if the core function has no prototype. C<code> is a code as returned
14813 by C<keyword()>. It must not be equal to 0.
14819 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14822 int i = 0, n = 0, seen_question = 0, defgv = 0;
14824 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14825 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14826 bool nullret = FALSE;
14828 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14832 if (!sv) sv = sv_newmortal();
14834 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14836 switch (code < 0 ? -code : code) {
14837 case KEY_and : case KEY_chop: case KEY_chomp:
14838 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14839 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14840 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14841 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14842 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14843 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14844 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14845 case KEY_x : case KEY_xor :
14846 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14847 case KEY_glob: retsetpvs("_;", OP_GLOB);
14848 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
14849 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
14850 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
14851 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14852 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14854 case KEY_evalbytes:
14855 name = "entereval"; break;
14863 while (i < MAXO) { /* The slow way. */
14864 if (strEQ(name, PL_op_name[i])
14865 || strEQ(name, PL_op_desc[i]))
14867 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14874 defgv = PL_opargs[i] & OA_DEFGV;
14875 oa = PL_opargs[i] >> OASHIFT;
14877 if (oa & OA_OPTIONAL && !seen_question && (
14878 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14883 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14884 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14885 /* But globs are already references (kinda) */
14886 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14890 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14891 && !scalar_mod_type(NULL, i)) {
14896 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14900 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14901 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14902 str[n-1] = '_'; defgv = 0;
14906 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14908 sv_setpvn(sv, str, n - 1);
14909 if (opnum) *opnum = i;
14914 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14917 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14920 PERL_ARGS_ASSERT_CORESUB_OP;
14924 return op_append_elem(OP_LINESEQ,
14927 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14934 o = newUNOP(OP_AVHVSWITCH,0,argop);
14935 o->op_private = opnum-OP_EACH;
14937 case OP_SELECT: /* which represents OP_SSELECT as well */
14942 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14943 newSVOP(OP_CONST, 0, newSVuv(1))
14945 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14947 coresub_op(coreargssv, 0, OP_SELECT)
14951 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14953 return op_append_elem(
14956 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14957 ? OPpOFFBYONE << 8 : 0)
14959 case OA_BASEOP_OR_UNOP:
14960 if (opnum == OP_ENTEREVAL) {
14961 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14962 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14964 else o = newUNOP(opnum,0,argop);
14965 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14968 if (is_handle_constructor(o, 1))
14969 argop->op_private |= OPpCOREARGS_DEREF1;
14970 if (scalar_mod_type(NULL, opnum))
14971 argop->op_private |= OPpCOREARGS_SCALARMOD;
14975 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14976 if (is_handle_constructor(o, 2))
14977 argop->op_private |= OPpCOREARGS_DEREF2;
14978 if (opnum == OP_SUBSTR) {
14979 o->op_private |= OPpMAYBE_LVSUB;
14988 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14989 SV * const *new_const_svp)
14991 const char *hvname;
14992 bool is_const = !!CvCONST(old_cv);
14993 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14995 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14997 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14999 /* They are 2 constant subroutines generated from
15000 the same constant. This probably means that
15001 they are really the "same" proxy subroutine
15002 instantiated in 2 places. Most likely this is
15003 when a constant is exported twice. Don't warn.
15006 (ckWARN(WARN_REDEFINE)
15008 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
15009 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
15010 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
15011 strEQ(hvname, "autouse"))
15015 && ckWARN_d(WARN_REDEFINE)
15016 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
15019 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
15021 ? "Constant subroutine %" SVf " redefined"
15022 : "Subroutine %" SVf " redefined",
15027 =head1 Hook manipulation
15029 These functions provide convenient and thread-safe means of manipulating
15036 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
15038 Puts a C function into the chain of check functions for a specified op
15039 type. This is the preferred way to manipulate the L</PL_check> array.
15040 C<opcode> specifies which type of op is to be affected. C<new_checker>
15041 is a pointer to the C function that is to be added to that opcode's
15042 check chain, and C<old_checker_p> points to the storage location where a
15043 pointer to the next function in the chain will be stored. The value of
15044 C<new_pointer> is written into the L</PL_check> array, while the value
15045 previously stored there is written to C<*old_checker_p>.
15047 The function should be defined like this:
15049 static OP *new_checker(pTHX_ OP *op) { ... }
15051 It is intended to be called in this manner:
15053 new_checker(aTHX_ op)
15055 C<old_checker_p> should be defined like this:
15057 static Perl_check_t old_checker_p;
15059 L</PL_check> is global to an entire process, and a module wishing to
15060 hook op checking may find itself invoked more than once per process,
15061 typically in different threads. To handle that situation, this function
15062 is idempotent. The location C<*old_checker_p> must initially (once
15063 per process) contain a null pointer. A C variable of static duration
15064 (declared at file scope, typically also marked C<static> to give
15065 it internal linkage) will be implicitly initialised appropriately,
15066 if it does not have an explicit initialiser. This function will only
15067 actually modify the check chain if it finds C<*old_checker_p> to be null.
15068 This function is also thread safe on the small scale. It uses appropriate
15069 locking to avoid race conditions in accessing L</PL_check>.
15071 When this function is called, the function referenced by C<new_checker>
15072 must be ready to be called, except for C<*old_checker_p> being unfilled.
15073 In a threading situation, C<new_checker> may be called immediately,
15074 even before this function has returned. C<*old_checker_p> will always
15075 be appropriately set before C<new_checker> is called. If C<new_checker>
15076 decides not to do anything special with an op that it is given (which
15077 is the usual case for most uses of op check hooking), it must chain the
15078 check function referenced by C<*old_checker_p>.
15080 If you want to influence compilation of calls to a specific subroutine,
15081 then use L</cv_set_call_checker> rather than hooking checking of all
15088 Perl_wrap_op_checker(pTHX_ Optype opcode,
15089 Perl_check_t new_checker, Perl_check_t *old_checker_p)
15093 PERL_UNUSED_CONTEXT;
15094 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
15095 if (*old_checker_p) return;
15096 OP_CHECK_MUTEX_LOCK;
15097 if (!*old_checker_p) {
15098 *old_checker_p = PL_check[opcode];
15099 PL_check[opcode] = new_checker;
15101 OP_CHECK_MUTEX_UNLOCK;
15106 /* Efficient sub that returns a constant scalar value. */
15108 const_sv_xsub(pTHX_ CV* cv)
15111 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
15112 PERL_UNUSED_ARG(items);
15122 const_av_xsub(pTHX_ CV* cv)
15125 AV * const av = MUTABLE_AV(XSANY.any_ptr);
15133 if (SvRMAGICAL(av))
15134 Perl_croak(aTHX_ "Magical list constants are not supported");
15135 if (GIMME_V != G_ARRAY) {
15137 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15140 EXTEND(SP, AvFILLp(av)+1);
15141 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15142 XSRETURN(AvFILLp(av)+1);
15147 * ex: set ts=8 sts=4 sw=4 et: