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 "
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 name.
6278 Note that the actual module name, not its filename, should be given.
6279 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
6280 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6281 (or 0 for no flags). ver, if specified
6282 and not NULL, provides version semantics
6283 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
6284 arguments can be used to specify arguments to the module's C<import()>
6285 method, similar to C<use Foo::Bar VERSION LIST>. They must be
6286 terminated with a final C<NULL> pointer. Note that this list can only
6287 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6288 Otherwise at least a single C<NULL> pointer to designate the default
6289 import list is required.
6291 The reference count for each specified C<SV*> parameter is decremented.
6296 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6300 PERL_ARGS_ASSERT_LOAD_MODULE;
6302 va_start(args, ver);
6303 vload_module(flags, name, ver, &args);
6307 #ifdef PERL_IMPLICIT_CONTEXT
6309 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6313 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6314 va_start(args, ver);
6315 vload_module(flags, name, ver, &args);
6321 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6324 OP * const modname = newSVOP(OP_CONST, 0, name);
6326 PERL_ARGS_ASSERT_VLOAD_MODULE;
6328 modname->op_private |= OPpCONST_BARE;
6330 veop = newSVOP(OP_CONST, 0, ver);
6334 if (flags & PERL_LOADMOD_NOIMPORT) {
6335 imop = sawparens(newNULLLIST());
6337 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6338 imop = va_arg(*args, OP*);
6343 sv = va_arg(*args, SV*);
6345 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6346 sv = va_arg(*args, SV*);
6350 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6351 * that it has a PL_parser to play with while doing that, and also
6352 * that it doesn't mess with any existing parser, by creating a tmp
6353 * new parser with lex_start(). This won't actually be used for much,
6354 * since pp_require() will create another parser for the real work.
6355 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6358 SAVEVPTR(PL_curcop);
6359 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6360 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6361 veop, modname, imop);
6365 PERL_STATIC_INLINE OP *
6366 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6368 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6369 newLISTOP(OP_LIST, 0, arg,
6370 newUNOP(OP_RV2CV, 0,
6371 newGVOP(OP_GV, 0, gv))));
6375 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6380 PERL_ARGS_ASSERT_DOFILE;
6382 if (!force_builtin && (gv = gv_override("do", 2))) {
6383 doop = S_new_entersubop(aTHX_ gv, term);
6386 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6392 =head1 Optree construction
6394 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6396 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
6397 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6398 be set automatically, and, shifted up eight bits, the eight bits of
6399 C<op_private>, except that the bit with value 1 or 2 is automatically
6400 set as required. C<listval> and C<subscript> supply the parameters of
6401 the slice; they are consumed by this function and become part of the
6402 constructed op tree.
6408 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6410 return newBINOP(OP_LSLICE, flags,
6411 list(force_list(subscript, 1)),
6412 list(force_list(listval, 1)) );
6415 #define ASSIGN_LIST 1
6416 #define ASSIGN_REF 2
6419 S_assignment_type(pTHX_ const OP *o)
6428 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6429 o = cUNOPo->op_first;
6431 flags = o->op_flags;
6433 if (type == OP_COND_EXPR) {
6434 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6435 const I32 t = assignment_type(sib);
6436 const I32 f = assignment_type(OpSIBLING(sib));
6438 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6440 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6441 yyerror("Assignment to both a list and a scalar");
6445 if (type == OP_SREFGEN)
6447 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6448 type = kid->op_type;
6449 flags |= kid->op_flags;
6450 if (!(flags & OPf_PARENS)
6451 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6452 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6458 if (type == OP_LIST &&
6459 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6460 o->op_private & OPpLVAL_INTRO)
6463 if (type == OP_LIST || flags & OPf_PARENS ||
6464 type == OP_RV2AV || type == OP_RV2HV ||
6465 type == OP_ASLICE || type == OP_HSLICE ||
6466 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6469 if (type == OP_PADAV || type == OP_PADHV)
6472 if (type == OP_RV2SV)
6480 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6482 Constructs, checks, and returns an assignment op. C<left> and C<right>
6483 supply the parameters of the assignment; they are consumed by this
6484 function and become part of the constructed op tree.
6486 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6487 a suitable conditional optree is constructed. If C<optype> is the opcode
6488 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6489 performs the binary operation and assigns the result to the left argument.
6490 Either way, if C<optype> is non-zero then C<flags> has no effect.
6492 If C<optype> is zero, then a plain scalar or list assignment is
6493 constructed. Which type of assignment it is is automatically determined.
6494 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6495 will be set automatically, and, shifted up eight bits, the eight bits
6496 of C<op_private>, except that the bit with value 1 or 2 is automatically
6503 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6509 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6510 right = scalar(right);
6511 return newLOGOP(optype, 0,
6512 op_lvalue(scalar(left), optype),
6513 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
6516 return newBINOP(optype, OPf_STACKED,
6517 op_lvalue(scalar(left), optype), scalar(right));
6521 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6522 static const char no_list_state[] = "Initialization of state variables"
6523 " in list context currently forbidden";
6526 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6527 left->op_private &= ~ OPpSLICEWARNING;
6530 left = op_lvalue(left, OP_AASSIGN);
6531 curop = list(force_list(left, 1));
6532 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6533 o->op_private = (U8)(0 | (flags >> 8));
6535 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6537 OP* lop = ((LISTOP*)left)->op_first;
6539 if ((lop->op_type == OP_PADSV ||
6540 lop->op_type == OP_PADAV ||
6541 lop->op_type == OP_PADHV ||
6542 lop->op_type == OP_PADANY)
6543 && (lop->op_private & OPpPAD_STATE)
6545 yyerror(no_list_state);
6546 lop = OpSIBLING(lop);
6549 else if ( (left->op_private & OPpLVAL_INTRO)
6550 && (left->op_private & OPpPAD_STATE)
6551 && ( left->op_type == OP_PADSV
6552 || left->op_type == OP_PADAV
6553 || left->op_type == OP_PADHV
6554 || left->op_type == OP_PADANY)
6556 /* All single variable list context state assignments, hence
6566 yyerror(no_list_state);
6569 /* optimise @a = split(...) into:
6570 * @{expr}: split(..., @{expr}) (where @a is not flattened)
6571 * @a, my @a, local @a: split(...) (where @a is attached to
6572 * the split op itself)
6576 && right->op_type == OP_SPLIT
6577 /* don't do twice, e.g. @b = (@a = split) */
6578 && !(right->op_private & OPpSPLIT_ASSIGN))
6582 if ( ( left->op_type == OP_RV2AV
6583 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
6584 || left->op_type == OP_PADAV)
6586 /* @pkg or @lex or local @pkg' or 'my @lex' */
6590 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
6591 = cPADOPx(gvop)->op_padix;
6592 cPADOPx(gvop)->op_padix = 0; /* steal it */
6594 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
6595 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
6596 cSVOPx(gvop)->op_sv = NULL; /* steal it */
6598 right->op_private |=
6599 left->op_private & OPpOUR_INTRO;
6602 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
6603 left->op_targ = 0; /* steal it */
6604 right->op_private |= OPpSPLIT_LEX;
6606 right->op_private |= left->op_private & OPpLVAL_INTRO;
6609 tmpop = cUNOPo->op_first; /* to list (nulled) */
6610 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6611 assert(OpSIBLING(tmpop) == right);
6612 assert(!OpHAS_SIBLING(right));
6613 /* detach the split subtreee from the o tree,
6614 * then free the residual o tree */
6615 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
6616 op_free(o); /* blow off assign */
6617 right->op_private |= OPpSPLIT_ASSIGN;
6618 right->op_flags &= ~OPf_WANT;
6619 /* "I don't know and I don't care." */
6622 else if (left->op_type == OP_RV2AV) {
6625 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
6626 assert(OpSIBLING(pushop) == left);
6627 /* Detach the array ... */
6628 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
6629 /* ... and attach it to the split. */
6630 op_sibling_splice(right, cLISTOPx(right)->op_last,
6632 right->op_flags |= OPf_STACKED;
6633 /* Detach split and expunge aassign as above. */
6636 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6637 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6639 /* convert split(...,0) to split(..., PL_modcount+1) */
6641 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6642 SV * const sv = *svp;
6643 if (SvIOK(sv) && SvIVX(sv) == 0)
6645 if (right->op_private & OPpSPLIT_IMPLIM) {
6646 /* our own SV, created in ck_split */
6648 sv_setiv(sv, PL_modcount+1);
6651 /* SV may belong to someone else */
6653 *svp = newSViv(PL_modcount+1);
6660 if (assign_type == ASSIGN_REF)
6661 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6663 right = newOP(OP_UNDEF, 0);
6664 if (right->op_type == OP_READLINE) {
6665 right->op_flags |= OPf_STACKED;
6666 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6670 o = newBINOP(OP_SASSIGN, flags,
6671 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6677 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6679 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6680 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6681 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6682 If C<label> is non-null, it supplies the name of a label to attach to
6683 the state op; this function takes ownership of the memory pointed at by
6684 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
6687 If C<o> is null, the state op is returned. Otherwise the state op is
6688 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
6689 is consumed by this function and becomes part of the returned op tree.
6695 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6698 const U32 seq = intro_my();
6699 const U32 utf8 = flags & SVf_UTF8;
6702 PL_parser->parsed_sub = 0;
6706 NewOp(1101, cop, 1, COP);
6707 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6708 OpTYPE_set(cop, OP_DBSTATE);
6711 OpTYPE_set(cop, OP_NEXTSTATE);
6713 cop->op_flags = (U8)flags;
6714 CopHINTS_set(cop, PL_hints);
6716 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6718 cop->op_next = (OP*)cop;
6721 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6722 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6724 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6726 PL_hints |= HINT_BLOCK_SCOPE;
6727 /* It seems that we need to defer freeing this pointer, as other parts
6728 of the grammar end up wanting to copy it after this op has been
6733 if (PL_parser->preambling != NOLINE) {
6734 CopLINE_set(cop, PL_parser->preambling);
6735 PL_parser->copline = NOLINE;
6737 else if (PL_parser->copline == NOLINE)
6738 CopLINE_set(cop, CopLINE(PL_curcop));
6740 CopLINE_set(cop, PL_parser->copline);
6741 PL_parser->copline = NOLINE;
6744 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6746 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6748 CopSTASH_set(cop, PL_curstash);
6750 if (cop->op_type == OP_DBSTATE) {
6751 /* this line can have a breakpoint - store the cop in IV */
6752 AV *av = CopFILEAVx(PL_curcop);
6754 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6755 if (svp && *svp != &PL_sv_undef ) {
6756 (void)SvIOK_on(*svp);
6757 SvIV_set(*svp, PTR2IV(cop));
6762 if (flags & OPf_SPECIAL)
6764 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6768 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6770 Constructs, checks, and returns a logical (flow control) op. C<type>
6771 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6772 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6773 the eight bits of C<op_private>, except that the bit with value 1 is
6774 automatically set. C<first> supplies the expression controlling the
6775 flow, and C<other> supplies the side (alternate) chain of ops; they are
6776 consumed by this function and become part of the constructed op tree.
6782 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6784 PERL_ARGS_ASSERT_NEWLOGOP;
6786 return new_logop(type, flags, &first, &other);
6790 S_search_const(pTHX_ OP *o)
6792 PERL_ARGS_ASSERT_SEARCH_CONST;
6794 switch (o->op_type) {
6798 if (o->op_flags & OPf_KIDS)
6799 return search_const(cUNOPo->op_first);
6806 if (!(o->op_flags & OPf_KIDS))
6808 kid = cLISTOPo->op_first;
6810 switch (kid->op_type) {
6814 kid = OpSIBLING(kid);
6817 if (kid != cLISTOPo->op_last)
6823 kid = cLISTOPo->op_last;
6825 return search_const(kid);
6833 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6841 int prepend_not = 0;
6843 PERL_ARGS_ASSERT_NEW_LOGOP;
6848 /* [perl #59802]: Warn about things like "return $a or $b", which
6849 is parsed as "(return $a) or $b" rather than "return ($a or
6850 $b)". NB: This also applies to xor, which is why we do it
6853 switch (first->op_type) {
6857 /* XXX: Perhaps we should emit a stronger warning for these.
6858 Even with the high-precedence operator they don't seem to do
6861 But until we do, fall through here.
6867 /* XXX: Currently we allow people to "shoot themselves in the
6868 foot" by explicitly writing "(return $a) or $b".
6870 Warn unless we are looking at the result from folding or if
6871 the programmer explicitly grouped the operators like this.
6872 The former can occur with e.g.
6874 use constant FEATURE => ( $] >= ... );
6875 sub { not FEATURE and return or do_stuff(); }
6877 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6878 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6879 "Possible precedence issue with control flow operator");
6880 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6886 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6887 return newBINOP(type, flags, scalar(first), scalar(other));
6889 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6890 || type == OP_CUSTOM);
6892 scalarboolean(first);
6894 /* search for a constant op that could let us fold the test */
6895 if ((cstop = search_const(first))) {
6896 if (cstop->op_private & OPpCONST_STRICT)
6897 no_bareword_allowed(cstop);
6898 else if ((cstop->op_private & OPpCONST_BARE))
6899 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6900 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6901 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6902 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6903 /* Elide the (constant) lhs, since it can't affect the outcome */
6905 if (other->op_type == OP_CONST)
6906 other->op_private |= OPpCONST_SHORTCIRCUIT;
6908 if (other->op_type == OP_LEAVE)
6909 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6910 else if (other->op_type == OP_MATCH
6911 || other->op_type == OP_SUBST
6912 || other->op_type == OP_TRANSR
6913 || other->op_type == OP_TRANS)
6914 /* Mark the op as being unbindable with =~ */
6915 other->op_flags |= OPf_SPECIAL;
6917 other->op_folded = 1;
6921 /* Elide the rhs, since the outcome is entirely determined by
6922 * the (constant) lhs */
6924 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6925 const OP *o2 = other;
6926 if ( ! (o2->op_type == OP_LIST
6927 && (( o2 = cUNOPx(o2)->op_first))
6928 && o2->op_type == OP_PUSHMARK
6929 && (( o2 = OpSIBLING(o2))) )
6932 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6933 || o2->op_type == OP_PADHV)
6934 && o2->op_private & OPpLVAL_INTRO
6935 && !(o2->op_private & OPpPAD_STATE))
6937 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6938 "Deprecated use of my() in false conditional");
6942 if (cstop->op_type == OP_CONST)
6943 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6948 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6949 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6951 const OP * const k1 = ((UNOP*)first)->op_first;
6952 const OP * const k2 = OpSIBLING(k1);
6954 switch (first->op_type)
6957 if (k2 && k2->op_type == OP_READLINE
6958 && (k2->op_flags & OPf_STACKED)
6959 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6961 warnop = k2->op_type;
6966 if (k1->op_type == OP_READDIR
6967 || k1->op_type == OP_GLOB
6968 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6969 || k1->op_type == OP_EACH
6970 || k1->op_type == OP_AEACH)
6972 warnop = ((k1->op_type == OP_NULL)
6973 ? (OPCODE)k1->op_targ : k1->op_type);
6978 const line_t oldline = CopLINE(PL_curcop);
6979 /* This ensures that warnings are reported at the first line
6980 of the construction, not the last. */
6981 CopLINE_set(PL_curcop, PL_parser->copline);
6982 Perl_warner(aTHX_ packWARN(WARN_MISC),
6983 "Value of %s%s can be \"0\"; test with defined()",
6985 ((warnop == OP_READLINE || warnop == OP_GLOB)
6986 ? " construct" : "() operator"));
6987 CopLINE_set(PL_curcop, oldline);
6991 /* optimize AND and OR ops that have NOTs as children */
6992 if (first->op_type == OP_NOT
6993 && (first->op_flags & OPf_KIDS)
6994 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6995 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6997 if (type == OP_AND || type == OP_OR) {
7003 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
7005 prepend_not = 1; /* prepend a NOT op later */
7010 logop = alloc_LOGOP(type, first, LINKLIST(other));
7011 logop->op_flags |= (U8)flags;
7012 logop->op_private = (U8)(1 | (flags >> 8));
7014 /* establish postfix order */
7015 logop->op_next = LINKLIST(first);
7016 first->op_next = (OP*)logop;
7017 assert(!OpHAS_SIBLING(first));
7018 op_sibling_splice((OP*)logop, first, 0, other);
7020 CHECKOP(type,logop);
7022 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7023 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7031 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7033 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7034 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7035 will be set automatically, and, shifted up eight bits, the eight bits of
7036 C<op_private>, except that the bit with value 1 is automatically set.
7037 C<first> supplies the expression selecting between the two branches,
7038 and C<trueop> and C<falseop> supply the branches; they are consumed by
7039 this function and become part of the constructed op tree.
7045 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7053 PERL_ARGS_ASSERT_NEWCONDOP;
7056 return newLOGOP(OP_AND, 0, first, trueop);
7058 return newLOGOP(OP_OR, 0, first, falseop);
7060 scalarboolean(first);
7061 if ((cstop = search_const(first))) {
7062 /* Left or right arm of the conditional? */
7063 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7064 OP *live = left ? trueop : falseop;
7065 OP *const dead = left ? falseop : trueop;
7066 if (cstop->op_private & OPpCONST_BARE &&
7067 cstop->op_private & OPpCONST_STRICT) {
7068 no_bareword_allowed(cstop);
7072 if (live->op_type == OP_LEAVE)
7073 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7074 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7075 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7076 /* Mark the op as being unbindable with =~ */
7077 live->op_flags |= OPf_SPECIAL;
7078 live->op_folded = 1;
7081 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
7082 logop->op_flags |= (U8)flags;
7083 logop->op_private = (U8)(1 | (flags >> 8));
7084 logop->op_next = LINKLIST(falseop);
7086 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7089 /* establish postfix order */
7090 start = LINKLIST(first);
7091 first->op_next = (OP*)logop;
7093 /* make first, trueop, falseop siblings */
7094 op_sibling_splice((OP*)logop, first, 0, trueop);
7095 op_sibling_splice((OP*)logop, trueop, 0, falseop);
7097 o = newUNOP(OP_NULL, 0, (OP*)logop);
7099 trueop->op_next = falseop->op_next = o;
7106 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7108 Constructs and returns a C<range> op, with subordinate C<flip> and
7109 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
7110 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7111 for both the C<flip> and C<range> ops, except that the bit with value
7112 1 is automatically set. C<left> and C<right> supply the expressions
7113 controlling the endpoints of the range; they are consumed by this function
7114 and become part of the constructed op tree.
7120 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7128 PERL_ARGS_ASSERT_NEWRANGE;
7130 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
7131 range->op_flags = OPf_KIDS;
7132 leftstart = LINKLIST(left);
7133 range->op_private = (U8)(1 | (flags >> 8));
7135 /* make left and right siblings */
7136 op_sibling_splice((OP*)range, left, 0, right);
7138 range->op_next = (OP*)range;
7139 flip = newUNOP(OP_FLIP, flags, (OP*)range);
7140 flop = newUNOP(OP_FLOP, 0, flip);
7141 o = newUNOP(OP_NULL, 0, flop);
7143 range->op_next = leftstart;
7145 left->op_next = flip;
7146 right->op_next = flop;
7149 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7150 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7152 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7153 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7154 SvPADTMP_on(PAD_SV(flip->op_targ));
7156 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7157 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7159 /* check barewords before they might be optimized aways */
7160 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7161 no_bareword_allowed(left);
7162 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7163 no_bareword_allowed(right);
7166 if (!flip->op_private || !flop->op_private)
7167 LINKLIST(o); /* blow off optimizer unless constant */
7173 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7175 Constructs, checks, and returns an op tree expressing a loop. This is
7176 only a loop in the control flow through the op tree; it does not have
7177 the heavyweight loop structure that allows exiting the loop by C<last>
7178 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
7179 top-level op, except that some bits will be set automatically as required.
7180 C<expr> supplies the expression controlling loop iteration, and C<block>
7181 supplies the body of the loop; they are consumed by this function and
7182 become part of the constructed op tree. C<debuggable> is currently
7183 unused and should always be 1.
7189 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7193 const bool once = block && block->op_flags & OPf_SPECIAL &&
7194 block->op_type == OP_NULL;
7196 PERL_UNUSED_ARG(debuggable);
7200 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7201 || ( expr->op_type == OP_NOT
7202 && cUNOPx(expr)->op_first->op_type == OP_CONST
7203 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7206 /* Return the block now, so that S_new_logop does not try to
7208 return block; /* do {} while 0 does once */
7209 if (expr->op_type == OP_READLINE
7210 || expr->op_type == OP_READDIR
7211 || expr->op_type == OP_GLOB
7212 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7213 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7214 expr = newUNOP(OP_DEFINED, 0,
7215 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7216 } else if (expr->op_flags & OPf_KIDS) {
7217 const OP * const k1 = ((UNOP*)expr)->op_first;
7218 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7219 switch (expr->op_type) {
7221 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7222 && (k2->op_flags & OPf_STACKED)
7223 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7224 expr = newUNOP(OP_DEFINED, 0, expr);
7228 if (k1 && (k1->op_type == OP_READDIR
7229 || k1->op_type == OP_GLOB
7230 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7231 || k1->op_type == OP_EACH
7232 || k1->op_type == OP_AEACH))
7233 expr = newUNOP(OP_DEFINED, 0, expr);
7239 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7240 * op, in listop. This is wrong. [perl #27024] */
7242 block = newOP(OP_NULL, 0);
7243 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7244 o = new_logop(OP_AND, 0, &expr, &listop);
7251 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7253 if (once && o != listop)
7255 assert(cUNOPo->op_first->op_type == OP_AND
7256 || cUNOPo->op_first->op_type == OP_OR);
7257 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7261 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7263 o->op_flags |= flags;
7265 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7270 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7272 Constructs, checks, and returns an op tree expressing a C<while> loop.
7273 This is a heavyweight loop, with structure that allows exiting the loop
7274 by C<last> and suchlike.
7276 C<loop> is an optional preconstructed C<enterloop> op to use in the
7277 loop; if it is null then a suitable op will be constructed automatically.
7278 C<expr> supplies the loop's controlling expression. C<block> supplies the
7279 main body of the loop, and C<cont> optionally supplies a C<continue> block
7280 that operates as a second half of the body. All of these optree inputs
7281 are consumed by this function and become part of the constructed op tree.
7283 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7284 op and, shifted up eight bits, the eight bits of C<op_private> for
7285 the C<leaveloop> op, except that (in both cases) some bits will be set
7286 automatically. C<debuggable> is currently unused and should always be 1.
7287 C<has_my> can be supplied as true to force the
7288 loop body to be enclosed in its own scope.
7294 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7295 OP *expr, OP *block, OP *cont, I32 has_my)
7304 PERL_UNUSED_ARG(debuggable);
7307 if (expr->op_type == OP_READLINE
7308 || expr->op_type == OP_READDIR
7309 || expr->op_type == OP_GLOB
7310 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7311 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7312 expr = newUNOP(OP_DEFINED, 0,
7313 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7314 } else if (expr->op_flags & OPf_KIDS) {
7315 const OP * const k1 = ((UNOP*)expr)->op_first;
7316 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7317 switch (expr->op_type) {
7319 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7320 && (k2->op_flags & OPf_STACKED)
7321 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7322 expr = newUNOP(OP_DEFINED, 0, expr);
7326 if (k1 && (k1->op_type == OP_READDIR
7327 || k1->op_type == OP_GLOB
7328 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7329 || k1->op_type == OP_EACH
7330 || k1->op_type == OP_AEACH))
7331 expr = newUNOP(OP_DEFINED, 0, expr);
7338 block = newOP(OP_NULL, 0);
7339 else if (cont || has_my) {
7340 block = op_scope(block);
7344 next = LINKLIST(cont);
7347 OP * const unstack = newOP(OP_UNSTACK, 0);
7350 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7354 listop = op_append_list(OP_LINESEQ, block, cont);
7356 redo = LINKLIST(listop);
7360 o = new_logop(OP_AND, 0, &expr, &listop);
7361 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7363 return expr; /* listop already freed by new_logop */
7366 ((LISTOP*)listop)->op_last->op_next =
7367 (o == listop ? redo : LINKLIST(o));
7373 NewOp(1101,loop,1,LOOP);
7374 OpTYPE_set(loop, OP_ENTERLOOP);
7375 loop->op_private = 0;
7376 loop->op_next = (OP*)loop;
7379 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7381 loop->op_redoop = redo;
7382 loop->op_lastop = o;
7383 o->op_private |= loopflags;
7386 loop->op_nextop = next;
7388 loop->op_nextop = o;
7390 o->op_flags |= flags;
7391 o->op_private |= (flags >> 8);
7396 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7398 Constructs, checks, and returns an op tree expressing a C<foreach>
7399 loop (iteration through a list of values). This is a heavyweight loop,
7400 with structure that allows exiting the loop by C<last> and suchlike.
7402 C<sv> optionally supplies the variable that will be aliased to each
7403 item in turn; if null, it defaults to C<$_>.
7404 C<expr> supplies the list of values to iterate over. C<block> supplies
7405 the main body of the loop, and C<cont> optionally supplies a C<continue>
7406 block that operates as a second half of the body. All of these optree
7407 inputs are consumed by this function and become part of the constructed
7410 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7411 op and, shifted up eight bits, the eight bits of C<op_private> for
7412 the C<leaveloop> op, except that (in both cases) some bits will be set
7419 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7424 PADOFFSET padoff = 0;
7428 PERL_ARGS_ASSERT_NEWFOROP;
7431 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7432 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7433 OpTYPE_set(sv, OP_RV2GV);
7435 /* The op_type check is needed to prevent a possible segfault
7436 * if the loop variable is undeclared and 'strict vars' is in
7437 * effect. This is illegal but is nonetheless parsed, so we
7438 * may reach this point with an OP_CONST where we're expecting
7441 if (cUNOPx(sv)->op_first->op_type == OP_GV
7442 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7443 iterpflags |= OPpITER_DEF;
7445 else if (sv->op_type == OP_PADSV) { /* private variable */
7446 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7447 padoff = sv->op_targ;
7451 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7453 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7456 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7458 PADNAME * const pn = PAD_COMPNAME(padoff);
7459 const char * const name = PadnamePV(pn);
7461 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7462 iterpflags |= OPpITER_DEF;
7466 sv = newGVOP(OP_GV, 0, PL_defgv);
7467 iterpflags |= OPpITER_DEF;
7470 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7471 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7472 iterflags |= OPf_STACKED;
7474 else if (expr->op_type == OP_NULL &&
7475 (expr->op_flags & OPf_KIDS) &&
7476 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7478 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7479 * set the STACKED flag to indicate that these values are to be
7480 * treated as min/max values by 'pp_enteriter'.
7482 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7483 LOGOP* const range = (LOGOP*) flip->op_first;
7484 OP* const left = range->op_first;
7485 OP* const right = OpSIBLING(left);
7488 range->op_flags &= ~OPf_KIDS;
7489 /* detach range's children */
7490 op_sibling_splice((OP*)range, NULL, -1, NULL);
7492 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7493 listop->op_first->op_next = range->op_next;
7494 left->op_next = range->op_other;
7495 right->op_next = (OP*)listop;
7496 listop->op_next = listop->op_first;
7499 expr = (OP*)(listop);
7501 iterflags |= OPf_STACKED;
7504 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7507 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7508 op_append_elem(OP_LIST, list(expr),
7510 assert(!loop->op_next);
7511 /* for my $x () sets OPpLVAL_INTRO;
7512 * for our $x () sets OPpOUR_INTRO */
7513 loop->op_private = (U8)iterpflags;
7514 if (loop->op_slabbed
7515 && DIFF(loop, OpSLOT(loop)->opslot_next)
7516 < SIZE_TO_PSIZE(sizeof(LOOP)))
7519 NewOp(1234,tmp,1,LOOP);
7520 Copy(loop,tmp,1,LISTOP);
7521 #ifdef PERL_OP_PARENT
7522 assert(loop->op_last->op_sibparent == (OP*)loop);
7523 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7525 S_op_destroy(aTHX_ (OP*)loop);
7528 else if (!loop->op_slabbed)
7530 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7531 #ifdef PERL_OP_PARENT
7532 OpLASTSIB_set(loop->op_last, (OP*)loop);
7535 loop->op_targ = padoff;
7536 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7541 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7543 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7544 or C<last>). C<type> is the opcode. C<label> supplies the parameter
7545 determining the target of the op; it is consumed by this function and
7546 becomes part of the constructed op tree.
7552 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7556 PERL_ARGS_ASSERT_NEWLOOPEX;
7558 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7559 || type == OP_CUSTOM);
7561 if (type != OP_GOTO) {
7562 /* "last()" means "last" */
7563 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7564 o = newOP(type, OPf_SPECIAL);
7568 /* Check whether it's going to be a goto &function */
7569 if (label->op_type == OP_ENTERSUB
7570 && !(label->op_flags & OPf_STACKED))
7571 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7574 /* Check for a constant argument */
7575 if (label->op_type == OP_CONST) {
7576 SV * const sv = ((SVOP *)label)->op_sv;
7578 const char *s = SvPV_const(sv,l);
7579 if (l == strlen(s)) {
7581 SvUTF8(((SVOP*)label)->op_sv),
7583 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7587 /* If we have already created an op, we do not need the label. */
7590 else o = newUNOP(type, OPf_STACKED, label);
7592 PL_hints |= HINT_BLOCK_SCOPE;
7596 /* if the condition is a literal array or hash
7597 (or @{ ... } etc), make a reference to it.
7600 S_ref_array_or_hash(pTHX_ OP *cond)
7603 && (cond->op_type == OP_RV2AV
7604 || cond->op_type == OP_PADAV
7605 || cond->op_type == OP_RV2HV
7606 || cond->op_type == OP_PADHV))
7608 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7611 && (cond->op_type == OP_ASLICE
7612 || cond->op_type == OP_KVASLICE
7613 || cond->op_type == OP_HSLICE
7614 || cond->op_type == OP_KVHSLICE)) {
7616 /* anonlist now needs a list from this op, was previously used in
7618 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7619 cond->op_flags |= OPf_WANT_LIST;
7621 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7628 /* These construct the optree fragments representing given()
7631 entergiven and enterwhen are LOGOPs; the op_other pointer
7632 points up to the associated leave op. We need this so we
7633 can put it in the context and make break/continue work.
7634 (Also, of course, pp_enterwhen will jump straight to
7635 op_other if the match fails.)
7639 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7640 I32 enter_opcode, I32 leave_opcode,
7641 PADOFFSET entertarg)
7647 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7648 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7650 enterop = alloc_LOGOP(enter_opcode, block, NULL);
7651 enterop->op_targ = 0;
7652 enterop->op_private = 0;
7654 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7657 /* prepend cond if we have one */
7658 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7660 o->op_next = LINKLIST(cond);
7661 cond->op_next = (OP *) enterop;
7664 /* This is a default {} block */
7665 enterop->op_flags |= OPf_SPECIAL;
7666 o ->op_flags |= OPf_SPECIAL;
7668 o->op_next = (OP *) enterop;
7671 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7672 entergiven and enterwhen both
7675 enterop->op_next = LINKLIST(block);
7676 block->op_next = enterop->op_other = o;
7681 /* Does this look like a boolean operation? For these purposes
7682 a boolean operation is:
7683 - a subroutine call [*]
7684 - a logical connective
7685 - a comparison operator
7686 - a filetest operator, with the exception of -s -M -A -C
7687 - defined(), exists() or eof()
7688 - /$re/ or $foo =~ /$re/
7690 [*] possibly surprising
7693 S_looks_like_bool(pTHX_ const OP *o)
7695 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7697 switch(o->op_type) {
7700 return looks_like_bool(cLOGOPo->op_first);
7704 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7707 looks_like_bool(cLOGOPo->op_first)
7708 && looks_like_bool(sibl));
7714 o->op_flags & OPf_KIDS
7715 && looks_like_bool(cUNOPo->op_first));
7719 case OP_NOT: case OP_XOR:
7721 case OP_EQ: case OP_NE: case OP_LT:
7722 case OP_GT: case OP_LE: case OP_GE:
7724 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7725 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7727 case OP_SEQ: case OP_SNE: case OP_SLT:
7728 case OP_SGT: case OP_SLE: case OP_SGE:
7732 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7733 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7734 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7735 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7736 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7737 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7738 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7739 case OP_FTTEXT: case OP_FTBINARY:
7741 case OP_DEFINED: case OP_EXISTS:
7742 case OP_MATCH: case OP_EOF:
7749 /* Detect comparisons that have been optimized away */
7750 if (cSVOPo->op_sv == &PL_sv_yes
7751 || cSVOPo->op_sv == &PL_sv_no)
7764 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7766 Constructs, checks, and returns an op tree expressing a C<given> block.
7767 C<cond> supplies the expression that will be locally assigned to a lexical
7768 variable, and C<block> supplies the body of the C<given> construct; they
7769 are consumed by this function and become part of the constructed op tree.
7770 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7776 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7778 PERL_ARGS_ASSERT_NEWGIVENOP;
7779 PERL_UNUSED_ARG(defsv_off);
7782 return newGIVWHENOP(
7783 ref_array_or_hash(cond),
7785 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7790 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7792 Constructs, checks, and returns an op tree expressing a C<when> block.
7793 C<cond> supplies the test expression, and C<block> supplies the block
7794 that will be executed if the test evaluates to true; they are consumed
7795 by this function and become part of the constructed op tree. C<cond>
7796 will be interpreted DWIMically, often as a comparison against C<$_>,
7797 and may be null to generate a C<default> block.
7803 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7805 const bool cond_llb = (!cond || looks_like_bool(cond));
7808 PERL_ARGS_ASSERT_NEWWHENOP;
7813 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7815 scalar(ref_array_or_hash(cond)));
7818 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7821 /* must not conflict with SVf_UTF8 */
7822 #define CV_CKPROTO_CURSTASH 0x1
7825 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7826 const STRLEN len, const U32 flags)
7828 SV *name = NULL, *msg;
7829 const char * cvp = SvROK(cv)
7830 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7831 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7834 STRLEN clen = CvPROTOLEN(cv), plen = len;
7836 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7838 if (p == NULL && cvp == NULL)
7841 if (!ckWARN_d(WARN_PROTOTYPE))
7845 p = S_strip_spaces(aTHX_ p, &plen);
7846 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7847 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7848 if (plen == clen && memEQ(cvp, p, plen))
7851 if (flags & SVf_UTF8) {
7852 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7856 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7862 msg = sv_newmortal();
7867 gv_efullname3(name = sv_newmortal(), gv, NULL);
7868 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7869 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7870 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7871 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7872 sv_catpvs(name, "::");
7874 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7875 assert (CvNAMED(SvRV_const(gv)));
7876 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7878 else sv_catsv(name, (SV *)gv);
7880 else name = (SV *)gv;
7882 sv_setpvs(msg, "Prototype mismatch:");
7884 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7886 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7887 UTF8fARG(SvUTF8(cv),clen,cvp)
7890 sv_catpvs(msg, ": none");
7891 sv_catpvs(msg, " vs ");
7893 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7895 sv_catpvs(msg, "none");
7896 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7899 static void const_sv_xsub(pTHX_ CV* cv);
7900 static void const_av_xsub(pTHX_ CV* cv);
7904 =head1 Optree Manipulation Functions
7906 =for apidoc cv_const_sv
7908 If C<cv> is a constant sub eligible for inlining, returns the constant
7909 value returned by the sub. Otherwise, returns C<NULL>.
7911 Constant subs can be created with C<newCONSTSUB> or as described in
7912 L<perlsub/"Constant Functions">.
7917 Perl_cv_const_sv(const CV *const cv)
7922 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7924 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7925 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7930 Perl_cv_const_sv_or_av(const CV * const cv)
7934 if (SvROK(cv)) return SvRV((SV *)cv);
7935 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7936 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7939 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7940 * Can be called in 2 ways:
7943 * look for a single OP_CONST with attached value: return the value
7945 * allow_lex && !CvCONST(cv);
7947 * examine the clone prototype, and if contains only a single
7948 * OP_CONST, return the value; or if it contains a single PADSV ref-
7949 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7950 * a candidate for "constizing" at clone time, and return NULL.
7954 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7962 for (; o; o = o->op_next) {
7963 const OPCODE type = o->op_type;
7965 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7967 || type == OP_PUSHMARK)
7969 if (type == OP_DBSTATE)
7971 if (type == OP_LEAVESUB)
7975 if (type == OP_CONST && cSVOPo->op_sv)
7977 else if (type == OP_UNDEF && !o->op_private) {
7981 else if (allow_lex && type == OP_PADSV) {
7982 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7984 sv = &PL_sv_undef; /* an arbitrary non-null value */
8002 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
8003 PADNAME * const name, SV ** const const_svp)
8009 if (CvFLAGS(PL_compcv)) {
8010 /* might have had built-in attrs applied */
8011 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
8012 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8013 && ckWARN(WARN_MISC))
8015 /* protect against fatal warnings leaking compcv */
8016 SAVEFREESV(PL_compcv);
8017 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8018 SvREFCNT_inc_simple_void_NN(PL_compcv);
8021 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8022 & ~(CVf_LVALUE * pureperl));
8027 /* redundant check for speed: */
8028 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8029 const line_t oldline = CopLINE(PL_curcop);
8032 : sv_2mortal(newSVpvn_utf8(
8033 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8035 if (PL_parser && PL_parser->copline != NOLINE)
8036 /* This ensures that warnings are reported at the first
8037 line of a redefinition, not the last. */
8038 CopLINE_set(PL_curcop, PL_parser->copline);
8039 /* protect against fatal warnings leaking compcv */
8040 SAVEFREESV(PL_compcv);
8041 report_redefined_cv(namesv, cv, const_svp);
8042 SvREFCNT_inc_simple_void_NN(PL_compcv);
8043 CopLINE_set(PL_curcop, oldline);
8050 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8055 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8058 CV *compcv = PL_compcv;
8061 PADOFFSET pax = o->op_targ;
8062 CV *outcv = CvOUTSIDE(PL_compcv);
8065 bool reusable = FALSE;
8067 #ifdef PERL_DEBUG_READONLY_OPS
8068 OPSLAB *slab = NULL;
8071 PERL_ARGS_ASSERT_NEWMYSUB;
8073 /* Find the pad slot for storing the new sub.
8074 We cannot use PL_comppad, as it is the pad owned by the new sub. We
8075 need to look in CvOUTSIDE and find the pad belonging to the enclos-
8076 ing sub. And then we need to dig deeper if this is a lexical from
8078 my sub foo; sub { sub foo { } }
8081 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8082 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8083 pax = PARENT_PAD_INDEX(name);
8084 outcv = CvOUTSIDE(outcv);
8089 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8090 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8091 spot = (CV **)svspot;
8093 if (!(PL_parser && PL_parser->error_count))
8094 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8097 assert(proto->op_type == OP_CONST);
8098 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8099 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8109 if (PL_parser && PL_parser->error_count) {
8111 SvREFCNT_dec(PL_compcv);
8116 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8118 svspot = (SV **)(spot = &clonee);
8120 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8123 assert (SvTYPE(*spot) == SVt_PVCV);
8125 hek = CvNAME_HEK(*spot);
8129 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8130 CvNAME_HEK_set(*spot, hek =
8133 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8137 CvLEXICAL_on(*spot);
8139 cv = PadnamePROTOCV(name);
8140 svspot = (SV **)(spot = &PadnamePROTOCV(name));
8144 /* This makes sub {}; work as expected. */
8145 if (block->op_type == OP_STUB) {
8146 const line_t l = PL_parser->copline;
8148 block = newSTATEOP(0, NULL, 0);
8149 PL_parser->copline = l;
8151 block = CvLVALUE(compcv)
8152 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8153 ? newUNOP(OP_LEAVESUBLV, 0,
8154 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8155 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8156 start = LINKLIST(block);
8158 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8159 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8167 const bool exists = CvROOT(cv) || CvXSUB(cv);
8169 /* if the subroutine doesn't exist and wasn't pre-declared
8170 * with a prototype, assume it will be AUTOLOADed,
8171 * skipping the prototype check
8173 if (exists || SvPOK(cv))
8174 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8176 /* already defined? */
8178 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
8184 /* just a "sub foo;" when &foo is already defined */
8189 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8196 SvREFCNT_inc_simple_void_NN(const_sv);
8197 SvFLAGS(const_sv) |= SVs_PADTMP;
8199 assert(!CvROOT(cv) && !CvCONST(cv));
8203 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8204 CvFILE_set_from_cop(cv, PL_curcop);
8205 CvSTASH_set(cv, PL_curstash);
8208 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
8209 CvXSUBANY(cv).any_ptr = const_sv;
8210 CvXSUB(cv) = const_sv_xsub;
8214 CvFLAGS(cv) |= CvMETHOD(compcv);
8216 SvREFCNT_dec(compcv);
8221 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8222 determine whether this sub definition is in the same scope as its
8223 declaration. If this sub definition is inside an inner named pack-
8224 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8225 the package sub. So check PadnameOUTER(name) too.
8227 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8228 assert(!CvWEAKOUTSIDE(compcv));
8229 SvREFCNT_dec(CvOUTSIDE(compcv));
8230 CvWEAKOUTSIDE_on(compcv);
8232 /* XXX else do we have a circular reference? */
8234 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8235 /* transfer PL_compcv to cv */
8237 cv_flags_t preserved_flags =
8238 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8239 PADLIST *const temp_padl = CvPADLIST(cv);
8240 CV *const temp_cv = CvOUTSIDE(cv);
8241 const cv_flags_t other_flags =
8242 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8243 OP * const cvstart = CvSTART(cv);
8247 CvFLAGS(compcv) | preserved_flags;
8248 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8249 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8250 CvPADLIST_set(cv, CvPADLIST(compcv));
8251 CvOUTSIDE(compcv) = temp_cv;
8252 CvPADLIST_set(compcv, temp_padl);
8253 CvSTART(cv) = CvSTART(compcv);
8254 CvSTART(compcv) = cvstart;
8255 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8256 CvFLAGS(compcv) |= other_flags;
8258 if (CvFILE(cv) && CvDYNFILE(cv)) {
8259 Safefree(CvFILE(cv));
8262 /* inner references to compcv must be fixed up ... */
8263 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8264 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8265 ++PL_sub_generation;
8268 /* Might have had built-in attributes applied -- propagate them. */
8269 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8271 /* ... before we throw it away */
8272 SvREFCNT_dec(compcv);
8273 PL_compcv = compcv = cv;
8282 if (!CvNAME_HEK(cv)) {
8283 if (hek) (void)share_hek_hek(hek);
8287 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8288 hek = share_hek(PadnamePV(name)+1,
8289 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8292 CvNAME_HEK_set(cv, hek);
8298 CvFILE_set_from_cop(cv, PL_curcop);
8299 CvSTASH_set(cv, PL_curstash);
8302 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8304 SvUTF8_on(MUTABLE_SV(cv));
8308 /* If we assign an optree to a PVCV, then we've defined a
8309 * subroutine that the debugger could be able to set a breakpoint
8310 * in, so signal to pp_entereval that it should not throw away any
8311 * saved lines at scope exit. */
8313 PL_breakable_sub_gen++;
8315 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8316 OpREFCNT_set(CvROOT(cv), 1);
8317 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8318 itself has a refcount. */
8320 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8321 #ifdef PERL_DEBUG_READONLY_OPS
8322 slab = (OPSLAB *)CvSTART(cv);
8324 CvSTART(cv) = start;
8326 finalize_optree(CvROOT(cv));
8327 S_prune_chain_head(&CvSTART(cv));
8329 /* now that optimizer has done its work, adjust pad values */
8331 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8336 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8337 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8341 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8342 SV * const tmpstr = sv_newmortal();
8343 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8344 GV_ADDMULTI, SVt_PVHV);
8346 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8349 (long)CopLINE(PL_curcop));
8350 if (HvNAME_HEK(PL_curstash)) {
8351 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8352 sv_catpvs(tmpstr, "::");
8355 sv_setpvs(tmpstr, "__ANON__::");
8357 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8358 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8359 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8360 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8361 hv = GvHVn(db_postponed);
8362 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8363 CV * const pcv = GvCV(db_postponed);
8369 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8377 assert(CvDEPTH(outcv));
8379 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8381 cv_clone_into(clonee, *spot);
8382 else *spot = cv_clone(clonee);
8383 SvREFCNT_dec_NN(clonee);
8387 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8388 PADOFFSET depth = CvDEPTH(outcv);
8391 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8393 *svspot = SvREFCNT_inc_simple_NN(cv);
8394 SvREFCNT_dec(oldcv);
8400 PL_parser->copline = NOLINE;
8402 #ifdef PERL_DEBUG_READONLY_OPS
8413 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8414 OP *block, bool o_is_gv)
8418 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8420 CV *cv = NULL; /* the previous CV with this name, if any */
8422 const bool ec = PL_parser && PL_parser->error_count;
8423 /* If the subroutine has no body, no attributes, and no builtin attributes
8424 then it's just a sub declaration, and we may be able to get away with
8425 storing with a placeholder scalar in the symbol table, rather than a
8426 full CV. If anything is present then it will take a full CV to
8428 const I32 gv_fetch_flags
8429 = ec ? GV_NOADD_NOINIT :
8430 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8431 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8433 const char * const name =
8434 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8436 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8437 bool evanescent = FALSE;
8439 #ifdef PERL_DEBUG_READONLY_OPS
8440 OPSLAB *slab = NULL;
8448 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8449 hek and CvSTASH pointer together can imply the GV. If the name
8450 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8451 CvSTASH, so forego the optimisation if we find any.
8452 Also, we may be called from load_module at run time, so
8453 PL_curstash (which sets CvSTASH) may not point to the stash the
8454 sub is stored in. */
8456 ec ? GV_NOADD_NOINIT
8457 : PL_curstash != CopSTASH(PL_curcop)
8458 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8460 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8461 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8463 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8464 SV * const sv = sv_newmortal();
8465 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8466 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8467 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8468 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8470 } else if (PL_curstash) {
8471 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8474 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8480 move_proto_attr(&proto, &attrs, gv);
8483 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8488 assert(proto->op_type == OP_CONST);
8489 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8490 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8506 SvREFCNT_dec(PL_compcv);
8511 if (name && block) {
8512 const char *s = strrchr(name, ':');
8514 if (strEQ(s, "BEGIN")) {
8515 if (PL_in_eval & EVAL_KEEPERR)
8516 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8518 SV * const errsv = ERRSV;
8519 /* force display of errors found but not reported */
8520 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8521 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8528 if (!block && SvTYPE(gv) != SVt_PVGV) {
8529 /* If we are not defining a new sub and the existing one is not a
8531 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8532 /* We are applying attributes to an existing sub, so we need it
8533 upgraded if it is a constant. */
8534 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8535 gv_init_pvn(gv, PL_curstash, name, namlen,
8536 SVf_UTF8 * name_is_utf8);
8538 else { /* Maybe prototype now, and had at maximum
8539 a prototype or const/sub ref before. */
8540 if (SvTYPE(gv) > SVt_NULL) {
8541 cv_ckproto_len_flags((const CV *)gv,
8542 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8548 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8550 SvUTF8_on(MUTABLE_SV(gv));
8553 sv_setiv(MUTABLE_SV(gv), -1);
8556 SvREFCNT_dec(PL_compcv);
8557 cv = PL_compcv = NULL;
8562 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8566 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8572 /* This makes sub {}; work as expected. */
8573 if (block->op_type == OP_STUB) {
8574 const line_t l = PL_parser->copline;
8576 block = newSTATEOP(0, NULL, 0);
8577 PL_parser->copline = l;
8579 block = CvLVALUE(PL_compcv)
8580 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8581 && (!isGV(gv) || !GvASSUMECV(gv)))
8582 ? newUNOP(OP_LEAVESUBLV, 0,
8583 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8584 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8585 start = LINKLIST(block);
8587 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8589 S_op_const_sv(aTHX_ start, PL_compcv,
8590 cBOOL(CvCLONE(PL_compcv)));
8597 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8598 cv_ckproto_len_flags((const CV *)gv,
8599 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8600 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8602 /* All the other code for sub redefinition warnings expects the
8603 clobbered sub to be a CV. Instead of making all those code
8604 paths more complex, just inline the RV version here. */
8605 const line_t oldline = CopLINE(PL_curcop);
8606 assert(IN_PERL_COMPILETIME);
8607 if (PL_parser && PL_parser->copline != NOLINE)
8608 /* This ensures that warnings are reported at the first
8609 line of a redefinition, not the last. */
8610 CopLINE_set(PL_curcop, PL_parser->copline);
8611 /* protect against fatal warnings leaking compcv */
8612 SAVEFREESV(PL_compcv);
8614 if (ckWARN(WARN_REDEFINE)
8615 || ( ckWARN_d(WARN_REDEFINE)
8616 && ( !const_sv || SvRV(gv) == const_sv
8617 || sv_cmp(SvRV(gv), const_sv) ))) {
8619 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8620 "Constant subroutine %"SVf" redefined",
8621 SVfARG(cSVOPo->op_sv));
8624 SvREFCNT_inc_simple_void_NN(PL_compcv);
8625 CopLINE_set(PL_curcop, oldline);
8626 SvREFCNT_dec(SvRV(gv));
8631 const bool exists = CvROOT(cv) || CvXSUB(cv);
8633 /* if the subroutine doesn't exist and wasn't pre-declared
8634 * with a prototype, assume it will be AUTOLOADed,
8635 * skipping the prototype check
8637 if (exists || SvPOK(cv))
8638 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8639 /* already defined (or promised)? */
8640 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8641 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
8647 /* just a "sub foo;" when &foo is already defined */
8648 SAVEFREESV(PL_compcv);
8655 SvREFCNT_inc_simple_void_NN(const_sv);
8656 SvFLAGS(const_sv) |= SVs_PADTMP;
8658 assert(!CvROOT(cv) && !CvCONST(cv));
8660 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
8661 CvXSUBANY(cv).any_ptr = const_sv;
8662 CvXSUB(cv) = const_sv_xsub;
8666 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8669 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8670 if (name && isGV(gv))
8672 cv = newCONSTSUB_flags(
8673 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8676 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8680 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8681 prepare_SV_for_RV((SV *)gv);
8685 SvRV_set(gv, const_sv);
8689 SvREFCNT_dec(PL_compcv);
8694 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
8695 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
8698 if (cv) { /* must reuse cv if autoloaded */
8699 /* transfer PL_compcv to cv */
8701 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8702 PADLIST *const temp_av = CvPADLIST(cv);
8703 CV *const temp_cv = CvOUTSIDE(cv);
8704 const cv_flags_t other_flags =
8705 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8706 OP * const cvstart = CvSTART(cv);
8710 assert(!CvCVGV_RC(cv));
8711 assert(CvGV(cv) == gv);
8716 PERL_HASH(hash, name, namlen);
8726 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8728 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8729 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8730 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8731 CvOUTSIDE(PL_compcv) = temp_cv;
8732 CvPADLIST_set(PL_compcv, temp_av);
8733 CvSTART(cv) = CvSTART(PL_compcv);
8734 CvSTART(PL_compcv) = cvstart;
8735 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8736 CvFLAGS(PL_compcv) |= other_flags;
8738 if (CvFILE(cv) && CvDYNFILE(cv)) {
8739 Safefree(CvFILE(cv));
8741 CvFILE_set_from_cop(cv, PL_curcop);
8742 CvSTASH_set(cv, PL_curstash);
8744 /* inner references to PL_compcv must be fixed up ... */
8745 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8746 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8747 ++PL_sub_generation;
8750 /* Might have had built-in attributes applied -- propagate them. */
8751 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8753 /* ... before we throw it away */
8754 SvREFCNT_dec(PL_compcv);
8759 if (name && isGV(gv)) {
8762 if (HvENAME_HEK(GvSTASH(gv)))
8763 /* sub Foo::bar { (shift)+1 } */
8764 gv_method_changed(gv);
8768 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8769 prepare_SV_for_RV((SV *)gv);
8773 SvRV_set(gv, (SV *)cv);
8783 PERL_HASH(hash, name, namlen);
8784 CvNAME_HEK_set(cv, share_hek(name,
8790 CvFILE_set_from_cop(cv, PL_curcop);
8791 CvSTASH_set(cv, PL_curstash);
8795 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8797 SvUTF8_on(MUTABLE_SV(cv));
8801 /* If we assign an optree to a PVCV, then we've defined a
8802 * subroutine that the debugger could be able to set a breakpoint
8803 * in, so signal to pp_entereval that it should not throw away any
8804 * saved lines at scope exit. */
8806 PL_breakable_sub_gen++;
8808 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8809 OpREFCNT_set(CvROOT(cv), 1);
8810 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8811 itself has a refcount. */
8813 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8814 #ifdef PERL_DEBUG_READONLY_OPS
8815 slab = (OPSLAB *)CvSTART(cv);
8817 CvSTART(cv) = start;
8819 finalize_optree(CvROOT(cv));
8820 S_prune_chain_head(&CvSTART(cv));
8822 /* now that optimizer has done its work, adjust pad values */
8824 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8829 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8830 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8835 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8837 SvREFCNT_inc_simple_void_NN(cv);
8840 if (block && has_name) {
8841 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8842 SV * const tmpstr = cv_name(cv,NULL,0);
8843 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8844 GV_ADDMULTI, SVt_PVHV);
8846 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8849 (long)CopLINE(PL_curcop));
8850 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8851 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8852 hv = GvHVn(db_postponed);
8853 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8854 CV * const pcv = GvCV(db_postponed);
8860 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8866 if (PL_parser && PL_parser->error_count)
8867 clear_special_blocks(name, gv, cv);
8870 process_special_blocks(floor, name, gv, cv);
8876 PL_parser->copline = NOLINE;
8880 #ifdef PERL_DEBUG_READONLY_OPS
8884 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8885 pad_add_weakref(cv);
8891 S_clear_special_blocks(pTHX_ const char *const fullname,
8892 GV *const gv, CV *const cv) {
8896 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8898 colon = strrchr(fullname,':');
8899 name = colon ? colon + 1 : fullname;
8901 if ((*name == 'B' && strEQ(name, "BEGIN"))
8902 || (*name == 'E' && strEQ(name, "END"))
8903 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8904 || (*name == 'C' && strEQ(name, "CHECK"))
8905 || (*name == 'I' && strEQ(name, "INIT"))) {
8911 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8915 /* Returns true if the sub has been freed. */
8917 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8921 const char *const colon = strrchr(fullname,':');
8922 const char *const name = colon ? colon + 1 : fullname;
8924 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8927 if (strEQ(name, "BEGIN")) {
8928 const I32 oldscope = PL_scopestack_ix;
8931 if (floor) LEAVE_SCOPE(floor);
8933 PUSHSTACKi(PERLSI_REQUIRE);
8934 SAVECOPFILE(&PL_compiling);
8935 SAVECOPLINE(&PL_compiling);
8936 SAVEVPTR(PL_curcop);
8938 DEBUG_x( dump_sub(gv) );
8939 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8940 GvCV_set(gv,0); /* cv has been hijacked */
8941 call_list(oldscope, PL_beginav);
8945 return !PL_savebegin;
8951 if strEQ(name, "END") {
8952 DEBUG_x( dump_sub(gv) );
8953 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8956 } else if (*name == 'U') {
8957 if (strEQ(name, "UNITCHECK")) {
8958 /* It's never too late to run a unitcheck block */
8959 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8963 } else if (*name == 'C') {
8964 if (strEQ(name, "CHECK")) {
8966 /* diag_listed_as: Too late to run %s block */
8967 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8968 "Too late to run CHECK block");
8969 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8973 } else if (*name == 'I') {
8974 if (strEQ(name, "INIT")) {
8976 /* diag_listed_as: Too late to run %s block */
8977 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8978 "Too late to run INIT block");
8979 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8985 DEBUG_x( dump_sub(gv) );
8987 GvCV_set(gv,0); /* cv has been hijacked */
8993 =for apidoc newCONSTSUB
8995 See L</newCONSTSUB_flags>.
9001 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
9003 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
9007 =for apidoc newCONSTSUB_flags
9009 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
9010 eligible for inlining at compile-time.
9012 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
9014 The newly created subroutine takes ownership of a reference to the passed in
9017 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
9018 which won't be called if used as a destructor, but will suppress the overhead
9019 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
9026 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
9030 const char *const file = CopFILE(PL_curcop);
9034 if (IN_PERL_RUNTIME) {
9035 /* at runtime, it's not safe to manipulate PL_curcop: it may be
9036 * an op shared between threads. Use a non-shared COP for our
9038 SAVEVPTR(PL_curcop);
9039 SAVECOMPILEWARNINGS();
9040 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9041 PL_curcop = &PL_compiling;
9043 SAVECOPLINE(PL_curcop);
9044 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
9047 PL_hints &= ~HINT_BLOCK_SCOPE;
9050 SAVEGENERICSV(PL_curstash);
9051 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9054 /* Protect sv against leakage caused by fatal warnings. */
9055 if (sv) SAVEFREESV(sv);
9057 /* file becomes the CvFILE. For an XS, it's usually static storage,
9058 and so doesn't get free()d. (It's expected to be from the C pre-
9059 processor __FILE__ directive). But we need a dynamically allocated one,
9060 and we need it to get freed. */
9061 cv = newXS_len_flags(name, len,
9062 sv && SvTYPE(sv) == SVt_PVAV
9065 file ? file : "", "",
9066 &sv, XS_DYNAMIC_FILENAME | flags);
9067 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9076 =for apidoc U||newXS
9078 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
9079 static storage, as it is used directly as CvFILE(), without a copy being made.
9085 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9087 PERL_ARGS_ASSERT_NEWXS;
9088 return newXS_len_flags(
9089 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9094 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9095 const char *const filename, const char *const proto,
9098 PERL_ARGS_ASSERT_NEWXS_FLAGS;
9099 return newXS_len_flags(
9100 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9105 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9107 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9108 return newXS_len_flags(
9109 name, strlen(name), subaddr, NULL, NULL, NULL, 0
9114 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9115 XSUBADDR_t subaddr, const char *const filename,
9116 const char *const proto, SV **const_svp,
9120 bool interleave = FALSE;
9122 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9125 GV * const gv = gv_fetchpvn(
9126 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9127 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9128 sizeof("__ANON__::__ANON__") - 1,
9129 GV_ADDMULTI | flags, SVt_PVCV);
9131 if ((cv = (name ? GvCV(gv) : NULL))) {
9133 /* just a cached method */
9137 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9138 /* already defined (or promised) */
9139 /* Redundant check that allows us to avoid creating an SV
9140 most of the time: */
9141 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9142 report_redefined_cv(newSVpvn_flags(
9143 name,len,(flags&SVf_UTF8)|SVs_TEMP
9154 if (cv) /* must reuse cv if autoloaded */
9157 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9161 if (HvENAME_HEK(GvSTASH(gv)))
9162 gv_method_changed(gv); /* newXS */
9168 /* XSUBs can't be perl lang/perl5db.pl debugged
9169 if (PERLDB_LINE_OR_SAVESRC)
9170 (void)gv_fetchfile(filename); */
9171 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9172 if (flags & XS_DYNAMIC_FILENAME) {
9174 CvFILE(cv) = savepv(filename);
9176 /* NOTE: not copied, as it is expected to be an external constant string */
9177 CvFILE(cv) = (char *)filename;
9180 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9181 CvFILE(cv) = (char*)PL_xsubfilename;
9184 CvXSUB(cv) = subaddr;
9185 #ifndef PERL_IMPLICIT_CONTEXT
9186 CvHSCXT(cv) = &PL_stack_sp;
9192 process_special_blocks(0, name, gv, cv);
9195 } /* <- not a conditional branch */
9198 sv_setpv(MUTABLE_SV(cv), proto);
9199 if (interleave) LEAVE;
9204 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9206 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9208 PERL_ARGS_ASSERT_NEWSTUB;
9212 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
9213 gv_method_changed(gv);
9215 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9220 CvFILE_set_from_cop(cv, PL_curcop);
9221 CvSTASH_set(cv, PL_curstash);
9227 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9233 if (PL_parser && PL_parser->error_count) {
9239 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9240 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9243 if ((cv = GvFORM(gv))) {
9244 if (ckWARN(WARN_REDEFINE)) {
9245 const line_t oldline = CopLINE(PL_curcop);
9246 if (PL_parser && PL_parser->copline != NOLINE)
9247 CopLINE_set(PL_curcop, PL_parser->copline);
9249 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9250 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9252 /* diag_listed_as: Format %s redefined */
9253 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9254 "Format STDOUT redefined");
9256 CopLINE_set(PL_curcop, oldline);
9261 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9263 CvFILE_set_from_cop(cv, PL_curcop);
9266 pad_tidy(padtidy_FORMAT);
9267 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9268 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9269 OpREFCNT_set(CvROOT(cv), 1);
9270 CvSTART(cv) = LINKLIST(CvROOT(cv));
9271 CvROOT(cv)->op_next = 0;
9272 CALL_PEEP(CvSTART(cv));
9273 finalize_optree(CvROOT(cv));
9274 S_prune_chain_head(&CvSTART(cv));
9280 PL_parser->copline = NOLINE;
9282 PL_compiling.cop_seq = 0;
9286 Perl_newANONLIST(pTHX_ OP *o)
9288 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9292 Perl_newANONHASH(pTHX_ OP *o)
9294 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9298 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9300 return newANONATTRSUB(floor, proto, NULL, block);
9304 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9306 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9308 newSVOP(OP_ANONCODE, 0,
9310 if (CvANONCONST(cv))
9311 anoncode = newUNOP(OP_ANONCONST, 0,
9312 op_convert_list(OP_ENTERSUB,
9313 OPf_STACKED|OPf_WANT_SCALAR,
9315 return newUNOP(OP_REFGEN, 0, anoncode);
9319 Perl_oopsAV(pTHX_ OP *o)
9323 PERL_ARGS_ASSERT_OOPSAV;
9325 switch (o->op_type) {
9328 OpTYPE_set(o, OP_PADAV);
9329 return ref(o, OP_RV2AV);
9333 OpTYPE_set(o, OP_RV2AV);
9338 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9345 Perl_oopsHV(pTHX_ OP *o)
9349 PERL_ARGS_ASSERT_OOPSHV;
9351 switch (o->op_type) {
9354 OpTYPE_set(o, OP_PADHV);
9355 return ref(o, OP_RV2HV);
9359 OpTYPE_set(o, OP_RV2HV);
9364 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9371 Perl_newAVREF(pTHX_ OP *o)
9375 PERL_ARGS_ASSERT_NEWAVREF;
9377 if (o->op_type == OP_PADANY) {
9378 OpTYPE_set(o, OP_PADAV);
9381 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9382 Perl_croak(aTHX_ "Can't use an array as a reference");
9384 return newUNOP(OP_RV2AV, 0, scalar(o));
9388 Perl_newGVREF(pTHX_ I32 type, OP *o)
9390 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9391 return newUNOP(OP_NULL, 0, o);
9392 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9396 Perl_newHVREF(pTHX_ OP *o)
9400 PERL_ARGS_ASSERT_NEWHVREF;
9402 if (o->op_type == OP_PADANY) {
9403 OpTYPE_set(o, OP_PADHV);
9406 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9407 Perl_croak(aTHX_ "Can't use a hash as a reference");
9409 return newUNOP(OP_RV2HV, 0, scalar(o));
9413 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9415 if (o->op_type == OP_PADANY) {
9417 OpTYPE_set(o, OP_PADCV);
9419 return newUNOP(OP_RV2CV, flags, scalar(o));
9423 Perl_newSVREF(pTHX_ OP *o)
9427 PERL_ARGS_ASSERT_NEWSVREF;
9429 if (o->op_type == OP_PADANY) {
9430 OpTYPE_set(o, OP_PADSV);
9434 return newUNOP(OP_RV2SV, 0, scalar(o));
9437 /* Check routines. See the comments at the top of this file for details
9438 * on when these are called */
9441 Perl_ck_anoncode(pTHX_ OP *o)
9443 PERL_ARGS_ASSERT_CK_ANONCODE;
9445 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9446 cSVOPo->op_sv = NULL;
9451 S_io_hints(pTHX_ OP *o)
9453 #if O_BINARY != 0 || O_TEXT != 0
9455 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9457 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9460 const char *d = SvPV_const(*svp, len);
9461 const I32 mode = mode_from_discipline(d, len);
9462 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9464 if (mode & O_BINARY)
9465 o->op_private |= OPpOPEN_IN_RAW;
9469 o->op_private |= OPpOPEN_IN_CRLF;
9473 svp = hv_fetchs(table, "open_OUT", FALSE);
9476 const char *d = SvPV_const(*svp, len);
9477 const I32 mode = mode_from_discipline(d, len);
9478 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9480 if (mode & O_BINARY)
9481 o->op_private |= OPpOPEN_OUT_RAW;
9485 o->op_private |= OPpOPEN_OUT_CRLF;
9490 PERL_UNUSED_CONTEXT;
9496 Perl_ck_backtick(pTHX_ OP *o)
9501 PERL_ARGS_ASSERT_CK_BACKTICK;
9502 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9503 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9504 && (gv = gv_override("readpipe",8)))
9506 /* detach rest of siblings from o and its first child */
9507 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9508 newop = S_new_entersubop(aTHX_ gv, sibl);
9510 else if (!(o->op_flags & OPf_KIDS))
9511 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9516 S_io_hints(aTHX_ o);
9521 Perl_ck_bitop(pTHX_ OP *o)
9523 PERL_ARGS_ASSERT_CK_BITOP;
9525 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9527 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9528 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9529 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9530 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9531 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9532 "The bitwise feature is experimental");
9533 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9534 && OP_IS_INFIX_BIT(o->op_type))
9536 const OP * const left = cBINOPo->op_first;
9537 const OP * const right = OpSIBLING(left);
9538 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9539 (left->op_flags & OPf_PARENS) == 0) ||
9540 (OP_IS_NUMCOMPARE(right->op_type) &&
9541 (right->op_flags & OPf_PARENS) == 0))
9542 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9543 "Possible precedence problem on bitwise %s operator",
9544 o->op_type == OP_BIT_OR
9545 ||o->op_type == OP_NBIT_OR ? "|"
9546 : o->op_type == OP_BIT_AND
9547 ||o->op_type == OP_NBIT_AND ? "&"
9548 : o->op_type == OP_BIT_XOR
9549 ||o->op_type == OP_NBIT_XOR ? "^"
9550 : o->op_type == OP_SBIT_OR ? "|."
9551 : o->op_type == OP_SBIT_AND ? "&." : "^."
9557 PERL_STATIC_INLINE bool
9558 is_dollar_bracket(pTHX_ const OP * const o)
9561 PERL_UNUSED_CONTEXT;
9562 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9563 && (kid = cUNOPx(o)->op_first)
9564 && kid->op_type == OP_GV
9565 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9569 Perl_ck_cmp(pTHX_ OP *o)
9571 PERL_ARGS_ASSERT_CK_CMP;
9572 if (ckWARN(WARN_SYNTAX)) {
9573 const OP *kid = cUNOPo->op_first;
9576 ( is_dollar_bracket(aTHX_ kid)
9577 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9579 || ( kid->op_type == OP_CONST
9580 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9584 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9585 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9591 Perl_ck_concat(pTHX_ OP *o)
9593 const OP * const kid = cUNOPo->op_first;
9595 PERL_ARGS_ASSERT_CK_CONCAT;
9596 PERL_UNUSED_CONTEXT;
9598 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9599 !(kUNOP->op_first->op_flags & OPf_MOD))
9600 o->op_flags |= OPf_STACKED;
9605 Perl_ck_spair(pTHX_ OP *o)
9609 PERL_ARGS_ASSERT_CK_SPAIR;
9611 if (o->op_flags & OPf_KIDS) {
9615 const OPCODE type = o->op_type;
9616 o = modkids(ck_fun(o), type);
9617 kid = cUNOPo->op_first;
9618 kidkid = kUNOP->op_first;
9619 newop = OpSIBLING(kidkid);
9621 const OPCODE type = newop->op_type;
9622 if (OpHAS_SIBLING(newop))
9624 if (o->op_type == OP_REFGEN
9625 && ( type == OP_RV2CV
9626 || ( !(newop->op_flags & OPf_PARENS)
9627 && ( type == OP_RV2AV || type == OP_PADAV
9628 || type == OP_RV2HV || type == OP_PADHV))))
9629 NOOP; /* OK (allow srefgen for \@a and \%h) */
9630 else if (OP_GIMME(newop,0) != G_SCALAR)
9633 /* excise first sibling */
9634 op_sibling_splice(kid, NULL, 1, NULL);
9637 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9638 * and OP_CHOMP into OP_SCHOMP */
9639 o->op_ppaddr = PL_ppaddr[++o->op_type];
9644 Perl_ck_delete(pTHX_ OP *o)
9646 PERL_ARGS_ASSERT_CK_DELETE;
9650 if (o->op_flags & OPf_KIDS) {
9651 OP * const kid = cUNOPo->op_first;
9652 switch (kid->op_type) {
9654 o->op_flags |= OPf_SPECIAL;
9657 o->op_private |= OPpSLICE;
9660 o->op_flags |= OPf_SPECIAL;
9665 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9666 " use array slice");
9668 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9671 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9672 "element or slice");
9674 if (kid->op_private & OPpLVAL_INTRO)
9675 o->op_private |= OPpLVAL_INTRO;
9682 Perl_ck_eof(pTHX_ OP *o)
9684 PERL_ARGS_ASSERT_CK_EOF;
9686 if (o->op_flags & OPf_KIDS) {
9688 if (cLISTOPo->op_first->op_type == OP_STUB) {
9690 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9695 kid = cLISTOPo->op_first;
9696 if (kid->op_type == OP_RV2GV)
9697 kid->op_private |= OPpALLOW_FAKE;
9703 Perl_ck_eval(pTHX_ OP *o)
9707 PERL_ARGS_ASSERT_CK_EVAL;
9709 PL_hints |= HINT_BLOCK_SCOPE;
9710 if (o->op_flags & OPf_KIDS) {
9711 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9714 if (o->op_type == OP_ENTERTRY) {
9717 /* cut whole sibling chain free from o */
9718 op_sibling_splice(o, NULL, -1, NULL);
9721 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
9723 /* establish postfix order */
9724 enter->op_next = (OP*)enter;
9726 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9727 OpTYPE_set(o, OP_LEAVETRY);
9728 enter->op_other = o;
9733 S_set_haseval(aTHX);
9737 const U8 priv = o->op_private;
9739 /* the newUNOP will recursively call ck_eval(), which will handle
9740 * all the stuff at the end of this function, like adding
9743 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9745 o->op_targ = (PADOFFSET)PL_hints;
9746 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9747 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9748 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9749 /* Store a copy of %^H that pp_entereval can pick up. */
9750 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9751 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9752 /* append hhop to only child */
9753 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9755 o->op_private |= OPpEVAL_HAS_HH;
9757 if (!(o->op_private & OPpEVAL_BYTES)
9758 && FEATURE_UNIEVAL_IS_ENABLED)
9759 o->op_private |= OPpEVAL_UNICODE;
9764 Perl_ck_exec(pTHX_ OP *o)
9766 PERL_ARGS_ASSERT_CK_EXEC;
9768 if (o->op_flags & OPf_STACKED) {
9771 kid = OpSIBLING(cUNOPo->op_first);
9772 if (kid->op_type == OP_RV2GV)
9781 Perl_ck_exists(pTHX_ OP *o)
9783 PERL_ARGS_ASSERT_CK_EXISTS;
9786 if (o->op_flags & OPf_KIDS) {
9787 OP * const kid = cUNOPo->op_first;
9788 if (kid->op_type == OP_ENTERSUB) {
9789 (void) ref(kid, o->op_type);
9790 if (kid->op_type != OP_RV2CV
9791 && !(PL_parser && PL_parser->error_count))
9793 "exists argument is not a subroutine name");
9794 o->op_private |= OPpEXISTS_SUB;
9796 else if (kid->op_type == OP_AELEM)
9797 o->op_flags |= OPf_SPECIAL;
9798 else if (kid->op_type != OP_HELEM)
9799 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9800 "element or a subroutine");
9807 Perl_ck_rvconst(pTHX_ OP *o)
9810 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9812 PERL_ARGS_ASSERT_CK_RVCONST;
9814 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9816 if (kid->op_type == OP_CONST) {
9819 SV * const kidsv = kid->op_sv;
9821 /* Is it a constant from cv_const_sv()? */
9822 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9825 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9826 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9827 const char *badthing;
9828 switch (o->op_type) {
9830 badthing = "a SCALAR";
9833 badthing = "an ARRAY";
9836 badthing = "a HASH";
9844 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9845 SVfARG(kidsv), badthing);
9848 * This is a little tricky. We only want to add the symbol if we
9849 * didn't add it in the lexer. Otherwise we get duplicate strict
9850 * warnings. But if we didn't add it in the lexer, we must at
9851 * least pretend like we wanted to add it even if it existed before,
9852 * or we get possible typo warnings. OPpCONST_ENTERED says
9853 * whether the lexer already added THIS instance of this symbol.
9855 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9856 gv = gv_fetchsv(kidsv,
9857 o->op_type == OP_RV2CV
9858 && o->op_private & OPpMAY_RETURN_CONSTANT
9860 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9863 : o->op_type == OP_RV2SV
9865 : o->op_type == OP_RV2AV
9867 : o->op_type == OP_RV2HV
9874 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9875 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9876 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9878 OpTYPE_set(kid, OP_GV);
9879 SvREFCNT_dec(kid->op_sv);
9881 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9882 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9883 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9884 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9885 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9887 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9889 kid->op_private = 0;
9890 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9898 Perl_ck_ftst(pTHX_ OP *o)
9901 const I32 type = o->op_type;
9903 PERL_ARGS_ASSERT_CK_FTST;
9905 if (o->op_flags & OPf_REF) {
9908 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9909 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9910 const OPCODE kidtype = kid->op_type;
9912 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9913 && !kid->op_folded) {
9914 OP * const newop = newGVOP(type, OPf_REF,
9915 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9920 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
9921 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
9923 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9924 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
9925 array_passed_to_stat, name);
9928 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9929 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
9933 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9934 o->op_private |= OPpFT_ACCESS;
9935 if (type != OP_STAT && type != OP_LSTAT
9936 && PL_check[kidtype] == Perl_ck_ftst
9937 && kidtype != OP_STAT && kidtype != OP_LSTAT
9939 o->op_private |= OPpFT_STACKED;
9940 kid->op_private |= OPpFT_STACKING;
9941 if (kidtype == OP_FTTTY && (
9942 !(kid->op_private & OPpFT_STACKED)
9943 || kid->op_private & OPpFT_AFTER_t
9945 o->op_private |= OPpFT_AFTER_t;
9950 if (type == OP_FTTTY)
9951 o = newGVOP(type, OPf_REF, PL_stdingv);
9953 o = newUNOP(type, 0, newDEFSVOP());
9959 Perl_ck_fun(pTHX_ OP *o)
9961 const int type = o->op_type;
9962 I32 oa = PL_opargs[type] >> OASHIFT;
9964 PERL_ARGS_ASSERT_CK_FUN;
9966 if (o->op_flags & OPf_STACKED) {
9967 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9970 return no_fh_allowed(o);
9973 if (o->op_flags & OPf_KIDS) {
9974 OP *prev_kid = NULL;
9975 OP *kid = cLISTOPo->op_first;
9977 bool seen_optional = FALSE;
9979 if (kid->op_type == OP_PUSHMARK ||
9980 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9983 kid = OpSIBLING(kid);
9985 if (kid && kid->op_type == OP_COREARGS) {
9986 bool optional = FALSE;
9989 if (oa & OA_OPTIONAL) optional = TRUE;
9992 if (optional) o->op_private |= numargs;
9997 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9998 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
10000 /* append kid to chain */
10001 op_sibling_splice(o, prev_kid, 0, kid);
10003 seen_optional = TRUE;
10010 /* list seen where single (scalar) arg expected? */
10011 if (numargs == 1 && !(oa >> 4)
10012 && kid->op_type == OP_LIST && type != OP_SCALAR)
10014 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10016 if (type != OP_DELETE) scalar(kid);
10027 if ((type == OP_PUSH || type == OP_UNSHIFT)
10028 && !OpHAS_SIBLING(kid))
10029 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10030 "Useless use of %s with no values",
10033 if (kid->op_type == OP_CONST
10034 && ( !SvROK(cSVOPx_sv(kid))
10035 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
10037 bad_type_pv(numargs, "array", o, kid);
10038 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
10039 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
10040 PL_op_desc[type]), 0);
10043 op_lvalue(kid, type);
10047 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
10048 bad_type_pv(numargs, "hash", o, kid);
10049 op_lvalue(kid, type);
10053 /* replace kid with newop in chain */
10055 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
10056 newop->op_next = newop;
10061 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
10062 if (kid->op_type == OP_CONST &&
10063 (kid->op_private & OPpCONST_BARE))
10065 OP * const newop = newGVOP(OP_GV, 0,
10066 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10067 /* replace kid with newop in chain */
10068 op_sibling_splice(o, prev_kid, 1, newop);
10072 else if (kid->op_type == OP_READLINE) {
10073 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10074 bad_type_pv(numargs, "HANDLE", o, kid);
10077 I32 flags = OPf_SPECIAL;
10079 PADOFFSET targ = 0;
10081 /* is this op a FH constructor? */
10082 if (is_handle_constructor(o,numargs)) {
10083 const char *name = NULL;
10086 bool want_dollar = TRUE;
10089 /* Set a flag to tell rv2gv to vivify
10090 * need to "prove" flag does not mean something
10091 * else already - NI-S 1999/05/07
10094 if (kid->op_type == OP_PADSV) {
10096 = PAD_COMPNAME_SV(kid->op_targ);
10097 name = PadnamePV (pn);
10098 len = PadnameLEN(pn);
10099 name_utf8 = PadnameUTF8(pn);
10101 else if (kid->op_type == OP_RV2SV
10102 && kUNOP->op_first->op_type == OP_GV)
10104 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10106 len = GvNAMELEN(gv);
10107 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10109 else if (kid->op_type == OP_AELEM
10110 || kid->op_type == OP_HELEM)
10113 OP *op = ((BINOP*)kid)->op_first;
10117 const char * const a =
10118 kid->op_type == OP_AELEM ?
10120 if (((op->op_type == OP_RV2AV) ||
10121 (op->op_type == OP_RV2HV)) &&
10122 (firstop = ((UNOP*)op)->op_first) &&
10123 (firstop->op_type == OP_GV)) {
10124 /* packagevar $a[] or $h{} */
10125 GV * const gv = cGVOPx_gv(firstop);
10128 Perl_newSVpvf(aTHX_
10133 else if (op->op_type == OP_PADAV
10134 || op->op_type == OP_PADHV) {
10135 /* lexicalvar $a[] or $h{} */
10136 const char * const padname =
10137 PAD_COMPNAME_PV(op->op_targ);
10140 Perl_newSVpvf(aTHX_
10146 name = SvPV_const(tmpstr, len);
10147 name_utf8 = SvUTF8(tmpstr);
10148 sv_2mortal(tmpstr);
10152 name = "__ANONIO__";
10154 want_dollar = FALSE;
10156 op_lvalue(kid, type);
10160 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10161 namesv = PAD_SVl(targ);
10162 if (want_dollar && *name != '$')
10163 sv_setpvs(namesv, "$");
10166 sv_catpvn(namesv, name, len);
10167 if ( name_utf8 ) SvUTF8_on(namesv);
10171 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10173 kid->op_targ = targ;
10174 kid->op_private |= priv;
10180 if ((type == OP_UNDEF || type == OP_POS)
10181 && numargs == 1 && !(oa >> 4)
10182 && kid->op_type == OP_LIST)
10183 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10184 op_lvalue(scalar(kid), type);
10189 kid = OpSIBLING(kid);
10191 /* FIXME - should the numargs or-ing move after the too many
10192 * arguments check? */
10193 o->op_private |= numargs;
10195 return too_many_arguments_pv(o,OP_DESC(o), 0);
10198 else if (PL_opargs[type] & OA_DEFGV) {
10199 /* Ordering of these two is important to keep f_map.t passing. */
10201 return newUNOP(type, 0, newDEFSVOP());
10205 while (oa & OA_OPTIONAL)
10207 if (oa && oa != OA_LIST)
10208 return too_few_arguments_pv(o,OP_DESC(o), 0);
10214 Perl_ck_glob(pTHX_ OP *o)
10218 PERL_ARGS_ASSERT_CK_GLOB;
10221 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10222 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10224 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10228 * \ null - const(wildcard)
10233 * \ mark - glob - rv2cv
10234 * | \ gv(CORE::GLOBAL::glob)
10236 * \ null - const(wildcard)
10238 o->op_flags |= OPf_SPECIAL;
10239 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10240 o = S_new_entersubop(aTHX_ gv, o);
10241 o = newUNOP(OP_NULL, 0, o);
10242 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10245 else o->op_flags &= ~OPf_SPECIAL;
10246 #if !defined(PERL_EXTERNAL_GLOB)
10247 if (!PL_globhook) {
10249 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10250 newSVpvs("File::Glob"), NULL, NULL, NULL);
10253 #endif /* !PERL_EXTERNAL_GLOB */
10254 gv = (GV *)newSV(0);
10255 gv_init(gv, 0, "", 0, 0);
10257 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10258 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10264 Perl_ck_grep(pTHX_ OP *o)
10268 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10270 PERL_ARGS_ASSERT_CK_GREP;
10272 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10274 if (o->op_flags & OPf_STACKED) {
10275 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10276 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10277 return no_fh_allowed(o);
10278 o->op_flags &= ~OPf_STACKED;
10280 kid = OpSIBLING(cLISTOPo->op_first);
10281 if (type == OP_MAPWHILE)
10286 if (PL_parser && PL_parser->error_count)
10288 kid = OpSIBLING(cLISTOPo->op_first);
10289 if (kid->op_type != OP_NULL)
10290 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10291 kid = kUNOP->op_first;
10293 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
10294 kid->op_next = (OP*)gwop;
10295 o->op_private = gwop->op_private = 0;
10296 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10298 kid = OpSIBLING(cLISTOPo->op_first);
10299 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10300 op_lvalue(kid, OP_GREPSTART);
10306 Perl_ck_index(pTHX_ OP *o)
10308 PERL_ARGS_ASSERT_CK_INDEX;
10310 if (o->op_flags & OPf_KIDS) {
10311 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10313 kid = OpSIBLING(kid); /* get past "big" */
10314 if (kid && kid->op_type == OP_CONST) {
10315 const bool save_taint = TAINT_get;
10316 SV *sv = kSVOP->op_sv;
10317 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10319 sv_copypv(sv, kSVOP->op_sv);
10320 SvREFCNT_dec_NN(kSVOP->op_sv);
10323 if (SvOK(sv)) fbm_compile(sv, 0);
10324 TAINT_set(save_taint);
10325 #ifdef NO_TAINT_SUPPORT
10326 PERL_UNUSED_VAR(save_taint);
10334 Perl_ck_lfun(pTHX_ OP *o)
10336 const OPCODE type = o->op_type;
10338 PERL_ARGS_ASSERT_CK_LFUN;
10340 return modkids(ck_fun(o), type);
10344 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10346 PERL_ARGS_ASSERT_CK_DEFINED;
10348 if ((o->op_flags & OPf_KIDS)) {
10349 switch (cUNOPo->op_first->op_type) {
10352 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10353 " (Maybe you should just omit the defined()?)");
10357 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10358 " (Maybe you should just omit the defined()?)");
10369 Perl_ck_readline(pTHX_ OP *o)
10371 PERL_ARGS_ASSERT_CK_READLINE;
10373 if (o->op_flags & OPf_KIDS) {
10374 OP *kid = cLISTOPo->op_first;
10375 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10379 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10387 Perl_ck_rfun(pTHX_ OP *o)
10389 const OPCODE type = o->op_type;
10391 PERL_ARGS_ASSERT_CK_RFUN;
10393 return refkids(ck_fun(o), type);
10397 Perl_ck_listiob(pTHX_ OP *o)
10401 PERL_ARGS_ASSERT_CK_LISTIOB;
10403 kid = cLISTOPo->op_first;
10405 o = force_list(o, 1);
10406 kid = cLISTOPo->op_first;
10408 if (kid->op_type == OP_PUSHMARK)
10409 kid = OpSIBLING(kid);
10410 if (kid && o->op_flags & OPf_STACKED)
10411 kid = OpSIBLING(kid);
10412 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10413 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10414 && !kid->op_folded) {
10415 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10417 /* replace old const op with new OP_RV2GV parent */
10418 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10419 OP_RV2GV, OPf_REF);
10420 kid = OpSIBLING(kid);
10425 op_append_elem(o->op_type, o, newDEFSVOP());
10427 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10428 return listkids(o);
10432 Perl_ck_smartmatch(pTHX_ OP *o)
10435 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10436 if (0 == (o->op_flags & OPf_SPECIAL)) {
10437 OP *first = cBINOPo->op_first;
10438 OP *second = OpSIBLING(first);
10440 /* Implicitly take a reference to an array or hash */
10442 /* remove the original two siblings, then add back the
10443 * (possibly different) first and second sibs.
10445 op_sibling_splice(o, NULL, 1, NULL);
10446 op_sibling_splice(o, NULL, 1, NULL);
10447 first = ref_array_or_hash(first);
10448 second = ref_array_or_hash(second);
10449 op_sibling_splice(o, NULL, 0, second);
10450 op_sibling_splice(o, NULL, 0, first);
10452 /* Implicitly take a reference to a regular expression */
10453 if (first->op_type == OP_MATCH) {
10454 OpTYPE_set(first, OP_QR);
10456 if (second->op_type == OP_MATCH) {
10457 OpTYPE_set(second, OP_QR);
10466 S_maybe_targlex(pTHX_ OP *o)
10468 OP * const kid = cLISTOPo->op_first;
10469 /* has a disposable target? */
10470 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10471 && !(kid->op_flags & OPf_STACKED)
10472 /* Cannot steal the second time! */
10473 && !(kid->op_private & OPpTARGET_MY)
10476 OP * const kkid = OpSIBLING(kid);
10478 /* Can just relocate the target. */
10479 if (kkid && kkid->op_type == OP_PADSV
10480 && (!(kkid->op_private & OPpLVAL_INTRO)
10481 || kkid->op_private & OPpPAD_STATE))
10483 kid->op_targ = kkid->op_targ;
10485 /* Now we do not need PADSV and SASSIGN.
10486 * Detach kid and free the rest. */
10487 op_sibling_splice(o, NULL, 1, NULL);
10489 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10497 Perl_ck_sassign(pTHX_ OP *o)
10500 OP * const kid = cBINOPo->op_first;
10502 PERL_ARGS_ASSERT_CK_SASSIGN;
10504 if (OpHAS_SIBLING(kid)) {
10505 OP *kkid = OpSIBLING(kid);
10506 /* For state variable assignment with attributes, kkid is a list op
10507 whose op_last is a padsv. */
10508 if ((kkid->op_type == OP_PADSV ||
10509 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10510 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10513 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10514 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10515 const PADOFFSET target = kkid->op_targ;
10516 OP *const other = newOP(OP_PADSV,
10518 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10519 OP *const first = newOP(OP_NULL, 0);
10521 newCONDOP(0, first, o, other);
10522 /* XXX targlex disabled for now; see ticket #124160
10523 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10525 OP *const condop = first->op_next;
10527 OpTYPE_set(condop, OP_ONCE);
10528 other->op_targ = target;
10529 nullop->op_flags |= OPf_WANT_SCALAR;
10531 /* Store the initializedness of state vars in a separate
10534 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10535 /* hijacking PADSTALE for uninitialized state variables */
10536 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10541 return S_maybe_targlex(aTHX_ o);
10545 Perl_ck_match(pTHX_ OP *o)
10547 PERL_UNUSED_CONTEXT;
10548 PERL_ARGS_ASSERT_CK_MATCH;
10550 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10551 o->op_private |= OPpRUNTIME;
10556 Perl_ck_method(pTHX_ OP *o)
10558 SV *sv, *methsv, *rclass;
10559 const char* method;
10562 STRLEN len, nsplit = 0, i;
10564 OP * const kid = cUNOPo->op_first;
10566 PERL_ARGS_ASSERT_CK_METHOD;
10567 if (kid->op_type != OP_CONST) return o;
10571 /* replace ' with :: */
10572 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10574 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10577 method = SvPVX_const(sv);
10579 utf8 = SvUTF8(sv) ? -1 : 1;
10581 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10586 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10588 if (!nsplit) { /* $proto->method() */
10590 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10593 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10595 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10598 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10599 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10600 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10601 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10603 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10604 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10606 #ifdef USE_ITHREADS
10607 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10609 cMETHOPx(new_op)->op_rclass_sv = rclass;
10616 Perl_ck_null(pTHX_ OP *o)
10618 PERL_ARGS_ASSERT_CK_NULL;
10619 PERL_UNUSED_CONTEXT;
10624 Perl_ck_open(pTHX_ OP *o)
10626 PERL_ARGS_ASSERT_CK_OPEN;
10628 S_io_hints(aTHX_ o);
10630 /* In case of three-arg dup open remove strictness
10631 * from the last arg if it is a bareword. */
10632 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10633 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10637 if ((last->op_type == OP_CONST) && /* The bareword. */
10638 (last->op_private & OPpCONST_BARE) &&
10639 (last->op_private & OPpCONST_STRICT) &&
10640 (oa = OpSIBLING(first)) && /* The fh. */
10641 (oa = OpSIBLING(oa)) && /* The mode. */
10642 (oa->op_type == OP_CONST) &&
10643 SvPOK(((SVOP*)oa)->op_sv) &&
10644 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10645 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10646 (last == OpSIBLING(oa))) /* The bareword. */
10647 last->op_private &= ~OPpCONST_STRICT;
10653 Perl_ck_prototype(pTHX_ OP *o)
10655 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10656 if (!(o->op_flags & OPf_KIDS)) {
10658 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10664 Perl_ck_refassign(pTHX_ OP *o)
10666 OP * const right = cLISTOPo->op_first;
10667 OP * const left = OpSIBLING(right);
10668 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10671 PERL_ARGS_ASSERT_CK_REFASSIGN;
10673 assert (left->op_type == OP_SREFGEN);
10676 /* we use OPpPAD_STATE in refassign to mean either of those things,
10677 * and the code assumes the two flags occupy the same bit position
10678 * in the various ops below */
10679 assert(OPpPAD_STATE == OPpOUR_INTRO);
10681 switch (varop->op_type) {
10683 o->op_private |= OPpLVREF_AV;
10686 o->op_private |= OPpLVREF_HV;
10690 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10691 o->op_targ = varop->op_targ;
10692 varop->op_targ = 0;
10693 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10697 o->op_private |= OPpLVREF_AV;
10699 NOT_REACHED; /* NOTREACHED */
10701 o->op_private |= OPpLVREF_HV;
10705 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10706 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10708 /* Point varop to its GV kid, detached. */
10709 varop = op_sibling_splice(varop, NULL, -1, NULL);
10713 OP * const kidparent =
10714 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10715 OP * const kid = cUNOPx(kidparent)->op_first;
10716 o->op_private |= OPpLVREF_CV;
10717 if (kid->op_type == OP_GV) {
10719 goto detach_and_stack;
10721 if (kid->op_type != OP_PADCV) goto bad;
10722 o->op_targ = kid->op_targ;
10728 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10729 o->op_private |= OPpLVREF_ELEM;
10732 /* Detach varop. */
10733 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10737 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10738 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10743 if (!FEATURE_REFALIASING_IS_ENABLED)
10745 "Experimental aliasing via reference not enabled");
10746 Perl_ck_warner_d(aTHX_
10747 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10748 "Aliasing via reference is experimental");
10750 o->op_flags |= OPf_STACKED;
10751 op_sibling_splice(o, right, 1, varop);
10754 o->op_flags &=~ OPf_STACKED;
10755 op_sibling_splice(o, right, 1, NULL);
10762 Perl_ck_repeat(pTHX_ OP *o)
10764 PERL_ARGS_ASSERT_CK_REPEAT;
10766 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10768 o->op_private |= OPpREPEAT_DOLIST;
10769 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10770 kids = force_list(kids, 1); /* promote it to a list */
10771 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10779 Perl_ck_require(pTHX_ OP *o)
10783 PERL_ARGS_ASSERT_CK_REQUIRE;
10785 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10786 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10791 if (kid->op_type == OP_CONST) {
10792 SV * const sv = kid->op_sv;
10793 U32 const was_readonly = SvREADONLY(sv);
10794 if (kid->op_private & OPpCONST_BARE) {
10798 if (was_readonly) {
10799 SvREADONLY_off(sv);
10801 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10806 /* treat ::foo::bar as foo::bar */
10807 if (len >= 2 && s[0] == ':' && s[1] == ':')
10808 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
10810 DIE(aTHX_ "Bareword in require maps to empty filename");
10812 for (; s < end; s++) {
10813 if (*s == ':' && s[1] == ':') {
10815 Move(s+2, s+1, end - s - 1, char);
10819 SvEND_set(sv, end);
10820 sv_catpvs(sv, ".pm");
10821 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10822 hek = share_hek(SvPVX(sv),
10823 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10825 sv_sethek(sv, hek);
10827 SvFLAGS(sv) |= was_readonly;
10829 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10832 if (SvREFCNT(sv) > 1) {
10833 kid->op_sv = newSVpvn_share(
10834 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10835 SvREFCNT_dec_NN(sv);
10839 if (was_readonly) SvREADONLY_off(sv);
10840 PERL_HASH(hash, s, len);
10842 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10844 sv_sethek(sv, hek);
10846 SvFLAGS(sv) |= was_readonly;
10852 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10853 /* handle override, if any */
10854 && (gv = gv_override("require", 7))) {
10856 if (o->op_flags & OPf_KIDS) {
10857 kid = cUNOPo->op_first;
10858 op_sibling_splice(o, NULL, -1, NULL);
10861 kid = newDEFSVOP();
10864 newop = S_new_entersubop(aTHX_ gv, kid);
10872 Perl_ck_return(pTHX_ OP *o)
10876 PERL_ARGS_ASSERT_CK_RETURN;
10878 kid = OpSIBLING(cLISTOPo->op_first);
10879 if (CvLVALUE(PL_compcv)) {
10880 for (; kid; kid = OpSIBLING(kid))
10881 op_lvalue(kid, OP_LEAVESUBLV);
10888 Perl_ck_select(pTHX_ OP *o)
10893 PERL_ARGS_ASSERT_CK_SELECT;
10895 if (o->op_flags & OPf_KIDS) {
10896 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10897 if (kid && OpHAS_SIBLING(kid)) {
10898 OpTYPE_set(o, OP_SSELECT);
10900 return fold_constants(op_integerize(op_std_init(o)));
10904 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10905 if (kid && kid->op_type == OP_RV2GV)
10906 kid->op_private &= ~HINT_STRICT_REFS;
10911 Perl_ck_shift(pTHX_ OP *o)
10913 const I32 type = o->op_type;
10915 PERL_ARGS_ASSERT_CK_SHIFT;
10917 if (!(o->op_flags & OPf_KIDS)) {
10920 if (!CvUNIQUE(PL_compcv)) {
10921 o->op_flags |= OPf_SPECIAL;
10925 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10927 return newUNOP(type, 0, scalar(argop));
10929 return scalar(ck_fun(o));
10933 Perl_ck_sort(pTHX_ OP *o)
10937 HV * const hinthv =
10938 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10941 PERL_ARGS_ASSERT_CK_SORT;
10944 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10946 const I32 sorthints = (I32)SvIV(*svp);
10947 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10948 o->op_private |= OPpSORT_QSORT;
10949 if ((sorthints & HINT_SORT_STABLE) != 0)
10950 o->op_private |= OPpSORT_STABLE;
10954 if (o->op_flags & OPf_STACKED)
10956 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10958 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10959 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10961 /* if the first arg is a code block, process it and mark sort as
10963 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10965 if (kid->op_type == OP_LEAVE)
10966 op_null(kid); /* wipe out leave */
10967 /* Prevent execution from escaping out of the sort block. */
10970 /* provide scalar context for comparison function/block */
10971 kid = scalar(firstkid);
10972 kid->op_next = kid;
10973 o->op_flags |= OPf_SPECIAL;
10975 else if (kid->op_type == OP_CONST
10976 && kid->op_private & OPpCONST_BARE) {
10980 const char * const name = SvPV(kSVOP_sv, len);
10982 assert (len < 256);
10983 Copy(name, tmpbuf+1, len, char);
10984 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10985 if (off != NOT_IN_PAD) {
10986 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10988 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10989 sv_catpvs(fq, "::");
10990 sv_catsv(fq, kSVOP_sv);
10991 SvREFCNT_dec_NN(kSVOP_sv);
10995 OP * const padop = newOP(OP_PADCV, 0);
10996 padop->op_targ = off;
10997 /* replace the const op with the pad op */
10998 op_sibling_splice(firstkid, NULL, 1, padop);
11004 firstkid = OpSIBLING(firstkid);
11007 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
11008 /* provide list context for arguments */
11011 op_lvalue(kid, OP_GREPSTART);
11017 /* for sort { X } ..., where X is one of
11018 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
11019 * elide the second child of the sort (the one containing X),
11020 * and set these flags as appropriate
11024 * Also, check and warn on lexical $a, $b.
11028 S_simplify_sort(pTHX_ OP *o)
11030 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
11034 const char *gvname;
11037 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
11039 kid = kUNOP->op_first; /* get past null */
11040 if (!(have_scopeop = kid->op_type == OP_SCOPE)
11041 && kid->op_type != OP_LEAVE)
11043 kid = kLISTOP->op_last; /* get past scope */
11044 switch(kid->op_type) {
11048 if (!have_scopeop) goto padkids;
11053 k = kid; /* remember this node*/
11054 if (kBINOP->op_first->op_type != OP_RV2SV
11055 || kBINOP->op_last ->op_type != OP_RV2SV)
11058 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
11059 then used in a comparison. This catches most, but not
11060 all cases. For instance, it catches
11061 sort { my($a); $a <=> $b }
11063 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
11064 (although why you'd do that is anyone's guess).
11068 if (!ckWARN(WARN_SYNTAX)) return;
11069 kid = kBINOP->op_first;
11071 if (kid->op_type == OP_PADSV) {
11072 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11073 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11074 && ( PadnamePV(name)[1] == 'a'
11075 || PadnamePV(name)[1] == 'b' ))
11076 /* diag_listed_as: "my %s" used in sort comparison */
11077 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11078 "\"%s %s\" used in sort comparison",
11079 PadnameIsSTATE(name)
11084 } while ((kid = OpSIBLING(kid)));
11087 kid = kBINOP->op_first; /* get past cmp */
11088 if (kUNOP->op_first->op_type != OP_GV)
11090 kid = kUNOP->op_first; /* get past rv2sv */
11092 if (GvSTASH(gv) != PL_curstash)
11094 gvname = GvNAME(gv);
11095 if (*gvname == 'a' && gvname[1] == '\0')
11097 else if (*gvname == 'b' && gvname[1] == '\0')
11102 kid = k; /* back to cmp */
11103 /* already checked above that it is rv2sv */
11104 kid = kBINOP->op_last; /* down to 2nd arg */
11105 if (kUNOP->op_first->op_type != OP_GV)
11107 kid = kUNOP->op_first; /* get past rv2sv */
11109 if (GvSTASH(gv) != PL_curstash)
11111 gvname = GvNAME(gv);
11113 ? !(*gvname == 'a' && gvname[1] == '\0')
11114 : !(*gvname == 'b' && gvname[1] == '\0'))
11116 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11118 o->op_private |= OPpSORT_DESCEND;
11119 if (k->op_type == OP_NCMP)
11120 o->op_private |= OPpSORT_NUMERIC;
11121 if (k->op_type == OP_I_NCMP)
11122 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11123 kid = OpSIBLING(cLISTOPo->op_first);
11124 /* cut out and delete old block (second sibling) */
11125 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11130 Perl_ck_split(pTHX_ OP *o)
11136 PERL_ARGS_ASSERT_CK_SPLIT;
11138 assert(o->op_type == OP_LIST);
11140 if (o->op_flags & OPf_STACKED)
11141 return no_fh_allowed(o);
11143 kid = cLISTOPo->op_first;
11144 /* delete leading NULL node, then add a CONST if no other nodes */
11145 assert(kid->op_type == OP_NULL);
11146 op_sibling_splice(o, NULL, 1,
11147 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11149 kid = cLISTOPo->op_first;
11151 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11152 /* remove match expression, and replace with new optree with
11153 * a match op at its head */
11154 op_sibling_splice(o, NULL, 1, NULL);
11155 /* pmruntime will handle split " " behavior with flag==2 */
11156 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
11157 op_sibling_splice(o, NULL, 0, kid);
11160 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
11162 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11163 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11164 "Use of /g modifier is meaningless in split");
11167 /* eliminate the split op, and move the match op (plus any children)
11168 * into its place, then convert the match op into a split op. i.e.
11170 * SPLIT MATCH SPLIT(ex-MATCH)
11172 * MATCH - A - B - C => R - A - B - C => R - A - B - C
11178 * (R, if it exists, will be a regcomp op)
11181 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
11182 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
11183 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
11184 OpTYPE_set(kid, OP_SPLIT);
11185 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
11186 assert(!(kid->op_private & ~OPpRUNTIME));
11187 kid->op_private = (o->op_private | (kid->op_private & OPpRUNTIME));
11190 kid = sibs; /* kid is now the string arg of the split */
11193 kid = newDEFSVOP();
11194 op_append_elem(OP_SPLIT, o, kid);
11198 kid = OpSIBLING(kid);
11200 kid = newSVOP(OP_CONST, 0, newSViv(0));
11201 op_append_elem(OP_SPLIT, o, kid);
11202 o->op_private |= OPpSPLIT_IMPLIM;
11206 if (OpHAS_SIBLING(kid))
11207 return too_many_arguments_pv(o,OP_DESC(o), 0);
11213 Perl_ck_stringify(pTHX_ OP *o)
11215 OP * const kid = OpSIBLING(cUNOPo->op_first);
11216 PERL_ARGS_ASSERT_CK_STRINGIFY;
11217 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11218 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
11219 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
11220 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11222 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11230 Perl_ck_join(pTHX_ OP *o)
11232 OP * const kid = OpSIBLING(cLISTOPo->op_first);
11234 PERL_ARGS_ASSERT_CK_JOIN;
11236 if (kid && kid->op_type == OP_MATCH) {
11237 if (ckWARN(WARN_SYNTAX)) {
11238 const REGEXP *re = PM_GETRE(kPMOP);
11240 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11241 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11242 : newSVpvs_flags( "STRING", SVs_TEMP );
11243 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11244 "/%"SVf"/ should probably be written as \"%"SVf"\"",
11245 SVfARG(msg), SVfARG(msg));
11249 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11250 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11251 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11252 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11254 const OP * const bairn = OpSIBLING(kid); /* the list */
11255 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11256 && OP_GIMME(bairn,0) == G_SCALAR)
11258 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11259 op_sibling_splice(o, kid, 1, NULL));
11269 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11271 Examines an op, which is expected to identify a subroutine at runtime,
11272 and attempts to determine at compile time which subroutine it identifies.
11273 This is normally used during Perl compilation to determine whether
11274 a prototype can be applied to a function call. C<cvop> is the op
11275 being considered, normally an C<rv2cv> op. A pointer to the identified
11276 subroutine is returned, if it could be determined statically, and a null
11277 pointer is returned if it was not possible to determine statically.
11279 Currently, the subroutine can be identified statically if the RV that the
11280 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11281 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11282 suitable if the constant value must be an RV pointing to a CV. Details of
11283 this process may change in future versions of Perl. If the C<rv2cv> op
11284 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11285 the subroutine statically: this flag is used to suppress compile-time
11286 magic on a subroutine call, forcing it to use default runtime behaviour.
11288 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11289 of a GV reference is modified. If a GV was examined and its CV slot was
11290 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11291 If the op is not optimised away, and the CV slot is later populated with
11292 a subroutine having a prototype, that flag eventually triggers the warning
11293 "called too early to check prototype".
11295 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11296 of returning a pointer to the subroutine it returns a pointer to the
11297 GV giving the most appropriate name for the subroutine in this context.
11298 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11299 (C<CvANON>) subroutine that is referenced through a GV it will be the
11300 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11301 A null pointer is returned as usual if there is no statically-determinable
11307 /* shared by toke.c:yylex */
11309 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11311 PADNAME *name = PAD_COMPNAME(off);
11312 CV *compcv = PL_compcv;
11313 while (PadnameOUTER(name)) {
11314 assert(PARENT_PAD_INDEX(name));
11315 compcv = CvOUTSIDE(compcv);
11316 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11317 [off = PARENT_PAD_INDEX(name)];
11319 assert(!PadnameIsOUR(name));
11320 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11321 return PadnamePROTOCV(name);
11323 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11327 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11332 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11333 if (flags & ~RV2CVOPCV_FLAG_MASK)
11334 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11335 if (cvop->op_type != OP_RV2CV)
11337 if (cvop->op_private & OPpENTERSUB_AMPER)
11339 if (!(cvop->op_flags & OPf_KIDS))
11341 rvop = cUNOPx(cvop)->op_first;
11342 switch (rvop->op_type) {
11344 gv = cGVOPx_gv(rvop);
11346 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11347 cv = MUTABLE_CV(SvRV(gv));
11351 if (flags & RV2CVOPCV_RETURN_STUB)
11357 if (flags & RV2CVOPCV_MARK_EARLY)
11358 rvop->op_private |= OPpEARLY_CV;
11363 SV *rv = cSVOPx_sv(rvop);
11366 cv = (CV*)SvRV(rv);
11370 cv = find_lexical_cv(rvop->op_targ);
11375 } NOT_REACHED; /* NOTREACHED */
11377 if (SvTYPE((SV*)cv) != SVt_PVCV)
11379 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11380 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11381 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11390 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11392 Performs the default fixup of the arguments part of an C<entersub>
11393 op tree. This consists of applying list context to each of the
11394 argument ops. This is the standard treatment used on a call marked
11395 with C<&>, or a method call, or a call through a subroutine reference,
11396 or any other call where the callee can't be identified at compile time,
11397 or a call where the callee has no prototype.
11403 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11407 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11409 aop = cUNOPx(entersubop)->op_first;
11410 if (!OpHAS_SIBLING(aop))
11411 aop = cUNOPx(aop)->op_first;
11412 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11413 /* skip the extra attributes->import() call implicitly added in
11414 * something like foo(my $x : bar)
11416 if ( aop->op_type == OP_ENTERSUB
11417 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11421 op_lvalue(aop, OP_ENTERSUB);
11427 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11429 Performs the fixup of the arguments part of an C<entersub> op tree
11430 based on a subroutine prototype. This makes various modifications to
11431 the argument ops, from applying context up to inserting C<refgen> ops,
11432 and checking the number and syntactic types of arguments, as directed by
11433 the prototype. This is the standard treatment used on a subroutine call,
11434 not marked with C<&>, where the callee can be identified at compile time
11435 and has a prototype.
11437 C<protosv> supplies the subroutine prototype to be applied to the call.
11438 It may be a normal defined scalar, of which the string value will be used.
11439 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11440 that has been cast to C<SV*>) which has a prototype. The prototype
11441 supplied, in whichever form, does not need to match the actual callee
11442 referenced by the op tree.
11444 If the argument ops disagree with the prototype, for example by having
11445 an unacceptable number of arguments, a valid op tree is returned anyway.
11446 The error is reflected in the parser state, normally resulting in a single
11447 exception at the top level of parsing which covers all the compilation
11448 errors that occurred. In the error message, the callee is referred to
11449 by the name defined by the C<namegv> parameter.
11455 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11458 const char *proto, *proto_end;
11459 OP *aop, *prev, *cvop, *parent;
11462 I32 contextclass = 0;
11463 const char *e = NULL;
11464 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11465 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11466 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11467 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11468 if (SvTYPE(protosv) == SVt_PVCV)
11469 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11470 else proto = SvPV(protosv, proto_len);
11471 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11472 proto_end = proto + proto_len;
11473 parent = entersubop;
11474 aop = cUNOPx(entersubop)->op_first;
11475 if (!OpHAS_SIBLING(aop)) {
11477 aop = cUNOPx(aop)->op_first;
11480 aop = OpSIBLING(aop);
11481 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11482 while (aop != cvop) {
11485 if (proto >= proto_end)
11487 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11488 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11489 SVfARG(namesv)), SvUTF8(namesv));
11499 /* _ must be at the end */
11500 if (proto[1] && !strchr(";@%", proto[1]))
11516 if ( o3->op_type != OP_UNDEF
11517 && (o3->op_type != OP_SREFGEN
11518 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11520 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11522 bad_type_gv(arg, namegv, o3,
11523 arg == 1 ? "block or sub {}" : "sub {}");
11526 /* '*' allows any scalar type, including bareword */
11529 if (o3->op_type == OP_RV2GV)
11530 goto wrapref; /* autoconvert GLOB -> GLOBref */
11531 else if (o3->op_type == OP_CONST)
11532 o3->op_private &= ~OPpCONST_STRICT;
11538 if (o3->op_type == OP_RV2AV ||
11539 o3->op_type == OP_PADAV ||
11540 o3->op_type == OP_RV2HV ||
11541 o3->op_type == OP_PADHV
11547 case '[': case ']':
11554 switch (*proto++) {
11556 if (contextclass++ == 0) {
11557 e = strchr(proto, ']');
11558 if (!e || e == proto)
11566 if (contextclass) {
11567 const char *p = proto;
11568 const char *const end = proto;
11570 while (*--p != '[')
11571 /* \[$] accepts any scalar lvalue */
11573 && Perl_op_lvalue_flags(aTHX_
11575 OP_READ, /* not entersub */
11578 bad_type_gv(arg, namegv, o3,
11579 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11584 if (o3->op_type == OP_RV2GV)
11587 bad_type_gv(arg, namegv, o3, "symbol");
11590 if (o3->op_type == OP_ENTERSUB
11591 && !(o3->op_flags & OPf_STACKED))
11594 bad_type_gv(arg, namegv, o3, "subroutine");
11597 if (o3->op_type == OP_RV2SV ||
11598 o3->op_type == OP_PADSV ||
11599 o3->op_type == OP_HELEM ||
11600 o3->op_type == OP_AELEM)
11602 if (!contextclass) {
11603 /* \$ accepts any scalar lvalue */
11604 if (Perl_op_lvalue_flags(aTHX_
11606 OP_READ, /* not entersub */
11609 bad_type_gv(arg, namegv, o3, "scalar");
11613 if (o3->op_type == OP_RV2AV ||
11614 o3->op_type == OP_PADAV)
11616 o3->op_flags &=~ OPf_PARENS;
11620 bad_type_gv(arg, namegv, o3, "array");
11623 if (o3->op_type == OP_RV2HV ||
11624 o3->op_type == OP_PADHV)
11626 o3->op_flags &=~ OPf_PARENS;
11630 bad_type_gv(arg, namegv, o3, "hash");
11633 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11635 if (contextclass && e) {
11640 default: goto oops;
11650 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11651 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11656 op_lvalue(aop, OP_ENTERSUB);
11658 aop = OpSIBLING(aop);
11660 if (aop == cvop && *proto == '_') {
11661 /* generate an access to $_ */
11662 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11664 if (!optional && proto_end > proto &&
11665 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11667 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11668 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11669 SVfARG(namesv)), SvUTF8(namesv));
11675 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11677 Performs the fixup of the arguments part of an C<entersub> op tree either
11678 based on a subroutine prototype or using default list-context processing.
11679 This is the standard treatment used on a subroutine call, not marked
11680 with C<&>, where the callee can be identified at compile time.
11682 C<protosv> supplies the subroutine prototype to be applied to the call,
11683 or indicates that there is no prototype. It may be a normal scalar,
11684 in which case if it is defined then the string value will be used
11685 as a prototype, and if it is undefined then there is no prototype.
11686 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11687 that has been cast to C<SV*>), of which the prototype will be used if it
11688 has one. The prototype (or lack thereof) supplied, in whichever form,
11689 does not need to match the actual callee referenced by the op tree.
11691 If the argument ops disagree with the prototype, for example by having
11692 an unacceptable number of arguments, a valid op tree is returned anyway.
11693 The error is reflected in the parser state, normally resulting in a single
11694 exception at the top level of parsing which covers all the compilation
11695 errors that occurred. In the error message, the callee is referred to
11696 by the name defined by the C<namegv> parameter.
11702 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11703 GV *namegv, SV *protosv)
11705 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11706 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11707 return ck_entersub_args_proto(entersubop, namegv, protosv);
11709 return ck_entersub_args_list(entersubop);
11713 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11715 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11716 OP *aop = cUNOPx(entersubop)->op_first;
11718 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11722 if (!OpHAS_SIBLING(aop))
11723 aop = cUNOPx(aop)->op_first;
11724 aop = OpSIBLING(aop);
11725 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11727 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11729 op_free(entersubop);
11730 switch(GvNAME(namegv)[2]) {
11731 case 'F': return newSVOP(OP_CONST, 0,
11732 newSVpv(CopFILE(PL_curcop),0));
11733 case 'L': return newSVOP(
11735 Perl_newSVpvf(aTHX_
11736 "%"IVdf, (IV)CopLINE(PL_curcop)
11739 case 'P': return newSVOP(OP_CONST, 0,
11741 ? newSVhek(HvNAME_HEK(PL_curstash))
11746 NOT_REACHED; /* NOTREACHED */
11749 OP *prev, *cvop, *first, *parent;
11752 parent = entersubop;
11753 if (!OpHAS_SIBLING(aop)) {
11755 aop = cUNOPx(aop)->op_first;
11758 first = prev = aop;
11759 aop = OpSIBLING(aop);
11760 /* find last sibling */
11762 OpHAS_SIBLING(cvop);
11763 prev = cvop, cvop = OpSIBLING(cvop))
11765 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11766 /* Usually, OPf_SPECIAL on an op with no args means that it had
11767 * parens, but these have their own meaning for that flag: */
11768 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11769 && opnum != OP_DELETE && opnum != OP_EXISTS)
11770 flags |= OPf_SPECIAL;
11771 /* excise cvop from end of sibling chain */
11772 op_sibling_splice(parent, prev, 1, NULL);
11774 if (aop == cvop) aop = NULL;
11776 /* detach remaining siblings from the first sibling, then
11777 * dispose of original optree */
11780 op_sibling_splice(parent, first, -1, NULL);
11781 op_free(entersubop);
11783 if (opnum == OP_ENTEREVAL
11784 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11785 flags |= OPpEVAL_BYTES <<8;
11787 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11789 case OA_BASEOP_OR_UNOP:
11790 case OA_FILESTATOP:
11791 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11794 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11797 return opnum == OP_RUNCV
11798 ? newPVOP(OP_RUNCV,0,NULL)
11801 return op_convert_list(opnum,0,aop);
11804 NOT_REACHED; /* NOTREACHED */
11809 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11811 Retrieves the function that will be used to fix up a call to C<cv>.
11812 Specifically, the function is applied to an C<entersub> op tree for a
11813 subroutine call, not marked with C<&>, where the callee can be identified
11814 at compile time as C<cv>.
11816 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11817 argument for it is returned in C<*ckobj_p>. The function is intended
11818 to be called in this manner:
11820 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11822 In this call, C<entersubop> is a pointer to the C<entersub> op,
11823 which may be replaced by the check function, and C<namegv> is a GV
11824 supplying the name that should be used by the check function to refer
11825 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11826 It is permitted to apply the check function in non-standard situations,
11827 such as to a call to a different subroutine or to a method call.
11829 By default, the function is
11830 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11831 and the SV parameter is C<cv> itself. This implements standard
11832 prototype processing. It can be changed, for a particular subroutine,
11833 by L</cv_set_call_checker>.
11839 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11843 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11845 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11846 *ckobj_p = callmg->mg_obj;
11847 if (flagsp) *flagsp = callmg->mg_flags;
11849 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11850 *ckobj_p = (SV*)cv;
11851 if (flagsp) *flagsp = 0;
11856 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11858 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11859 PERL_UNUSED_CONTEXT;
11860 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11864 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11866 Sets the function that will be used to fix up a call to C<cv>.
11867 Specifically, the function is applied to an C<entersub> op tree for a
11868 subroutine call, not marked with C<&>, where the callee can be identified
11869 at compile time as C<cv>.
11871 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11872 for it is supplied in C<ckobj>. The function should be defined like this:
11874 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11876 It is intended to be called in this manner:
11878 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11880 In this call, C<entersubop> is a pointer to the C<entersub> op,
11881 which may be replaced by the check function, and C<namegv> supplies
11882 the name that should be used by the check function to refer
11883 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11884 It is permitted to apply the check function in non-standard situations,
11885 such as to a call to a different subroutine or to a method call.
11887 C<namegv> may not actually be a GV. For efficiency, perl may pass a
11888 CV or other SV instead. Whatever is passed can be used as the first
11889 argument to L</cv_name>. You can force perl to pass a GV by including
11890 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11892 The current setting for a particular CV can be retrieved by
11893 L</cv_get_call_checker>.
11895 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11897 The original form of L</cv_set_call_checker_flags>, which passes it the
11898 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11904 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11906 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11907 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11911 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11912 SV *ckobj, U32 flags)
11914 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11915 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11916 if (SvMAGICAL((SV*)cv))
11917 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11920 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11921 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11923 if (callmg->mg_flags & MGf_REFCOUNTED) {
11924 SvREFCNT_dec(callmg->mg_obj);
11925 callmg->mg_flags &= ~MGf_REFCOUNTED;
11927 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11928 callmg->mg_obj = ckobj;
11929 if (ckobj != (SV*)cv) {
11930 SvREFCNT_inc_simple_void_NN(ckobj);
11931 callmg->mg_flags |= MGf_REFCOUNTED;
11933 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11934 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11939 S_entersub_alloc_targ(pTHX_ OP * const o)
11941 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11942 o->op_private |= OPpENTERSUB_HASTARG;
11946 Perl_ck_subr(pTHX_ OP *o)
11951 SV **const_class = NULL;
11953 PERL_ARGS_ASSERT_CK_SUBR;
11955 aop = cUNOPx(o)->op_first;
11956 if (!OpHAS_SIBLING(aop))
11957 aop = cUNOPx(aop)->op_first;
11958 aop = OpSIBLING(aop);
11959 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11960 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11961 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11963 o->op_private &= ~1;
11964 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11965 if (PERLDB_SUB && PL_curstash != PL_debstash)
11966 o->op_private |= OPpENTERSUB_DB;
11967 switch (cvop->op_type) {
11969 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11973 case OP_METHOD_NAMED:
11974 case OP_METHOD_SUPER:
11975 case OP_METHOD_REDIR:
11976 case OP_METHOD_REDIR_SUPER:
11977 o->op_flags |= OPf_REF;
11978 if (aop->op_type == OP_CONST) {
11979 aop->op_private &= ~OPpCONST_STRICT;
11980 const_class = &cSVOPx(aop)->op_sv;
11982 else if (aop->op_type == OP_LIST) {
11983 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11984 if (sib && sib->op_type == OP_CONST) {
11985 sib->op_private &= ~OPpCONST_STRICT;
11986 const_class = &cSVOPx(sib)->op_sv;
11989 /* make class name a shared cow string to speedup method calls */
11990 /* constant string might be replaced with object, f.e. bigint */
11991 if (const_class && SvPOK(*const_class)) {
11993 const char* str = SvPV(*const_class, len);
11995 SV* const shared = newSVpvn_share(
11996 str, SvUTF8(*const_class)
11997 ? -(SSize_t)len : (SSize_t)len,
12000 if (SvREADONLY(*const_class))
12001 SvREADONLY_on(shared);
12002 SvREFCNT_dec(*const_class);
12003 *const_class = shared;
12010 S_entersub_alloc_targ(aTHX_ o);
12011 return ck_entersub_args_list(o);
12013 Perl_call_checker ckfun;
12016 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
12017 if (CvISXSUB(cv) || !CvROOT(cv))
12018 S_entersub_alloc_targ(aTHX_ o);
12020 /* The original call checker API guarantees that a GV will be
12021 be provided with the right name. So, if the old API was
12022 used (or the REQUIRE_GV flag was passed), we have to reify
12023 the CV’s GV, unless this is an anonymous sub. This is not
12024 ideal for lexical subs, as its stringification will include
12025 the package. But it is the best we can do. */
12026 if (flags & MGf_REQUIRE_GV) {
12027 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
12030 else namegv = MUTABLE_GV(cv);
12031 /* After a syntax error in a lexical sub, the cv that
12032 rv2cv_op_cv returns may be a nameless stub. */
12033 if (!namegv) return ck_entersub_args_list(o);
12036 return ckfun(aTHX_ o, namegv, ckobj);
12041 Perl_ck_svconst(pTHX_ OP *o)
12043 SV * const sv = cSVOPo->op_sv;
12044 PERL_ARGS_ASSERT_CK_SVCONST;
12045 PERL_UNUSED_CONTEXT;
12046 #ifdef PERL_COPY_ON_WRITE
12047 /* Since the read-only flag may be used to protect a string buffer, we
12048 cannot do copy-on-write with existing read-only scalars that are not
12049 already copy-on-write scalars. To allow $_ = "hello" to do COW with
12050 that constant, mark the constant as COWable here, if it is not
12051 already read-only. */
12052 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
12055 # ifdef PERL_DEBUG_READONLY_COW
12065 Perl_ck_trunc(pTHX_ OP *o)
12067 PERL_ARGS_ASSERT_CK_TRUNC;
12069 if (o->op_flags & OPf_KIDS) {
12070 SVOP *kid = (SVOP*)cUNOPo->op_first;
12072 if (kid->op_type == OP_NULL)
12073 kid = (SVOP*)OpSIBLING(kid);
12074 if (kid && kid->op_type == OP_CONST &&
12075 (kid->op_private & OPpCONST_BARE) &&
12078 o->op_flags |= OPf_SPECIAL;
12079 kid->op_private &= ~OPpCONST_STRICT;
12086 Perl_ck_substr(pTHX_ OP *o)
12088 PERL_ARGS_ASSERT_CK_SUBSTR;
12091 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
12092 OP *kid = cLISTOPo->op_first;
12094 if (kid->op_type == OP_NULL)
12095 kid = OpSIBLING(kid);
12097 kid->op_flags |= OPf_MOD;
12104 Perl_ck_tell(pTHX_ OP *o)
12106 PERL_ARGS_ASSERT_CK_TELL;
12108 if (o->op_flags & OPf_KIDS) {
12109 OP *kid = cLISTOPo->op_first;
12110 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12111 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12117 Perl_ck_each(pTHX_ OP *o)
12120 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12121 const unsigned orig_type = o->op_type;
12123 PERL_ARGS_ASSERT_CK_EACH;
12126 switch (kid->op_type) {
12132 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
12133 : orig_type == OP_KEYS ? OP_AKEYS
12137 if (kid->op_private == OPpCONST_BARE
12138 || !SvROK(cSVOPx_sv(kid))
12139 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12140 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
12145 qerror(Perl_mess(aTHX_
12146 "Experimental %s on scalar is now forbidden",
12147 PL_op_desc[orig_type]));
12149 bad_type_pv(1, "hash or array", o, kid);
12157 Perl_ck_length(pTHX_ OP *o)
12159 PERL_ARGS_ASSERT_CK_LENGTH;
12163 if (ckWARN(WARN_SYNTAX)) {
12164 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12168 const bool hash = kid->op_type == OP_PADHV
12169 || kid->op_type == OP_RV2HV;
12170 switch (kid->op_type) {
12175 name = S_op_varname(aTHX_ kid);
12181 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12182 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
12184 SVfARG(name), hash ? "keys " : "", SVfARG(name)
12187 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12188 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12189 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12191 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12192 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12193 "length() used on @array (did you mean \"scalar(@array)\"?)");
12203 ---------------------------------------------------------
12205 Common vars in list assignment
12207 There now follows some enums and static functions for detecting
12208 common variables in list assignments. Here is a little essay I wrote
12209 for myself when trying to get my head around this. DAPM.
12213 First some random observations:
12215 * If a lexical var is an alias of something else, e.g.
12216 for my $x ($lex, $pkg, $a[0]) {...}
12217 then the act of aliasing will increase the reference count of the SV
12219 * If a package var is an alias of something else, it may still have a
12220 reference count of 1, depending on how the alias was created, e.g.
12221 in *a = *b, $a may have a refcount of 1 since the GP is shared
12222 with a single GvSV pointer to the SV. So If it's an alias of another
12223 package var, then RC may be 1; if it's an alias of another scalar, e.g.
12224 a lexical var or an array element, then it will have RC > 1.
12226 * There are many ways to create a package alias; ultimately, XS code
12227 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12228 run-time tracing mechanisms are unlikely to be able to catch all cases.
12230 * When the LHS is all my declarations, the same vars can't appear directly
12231 on the RHS, but they can indirectly via closures, aliasing and lvalue
12232 subs. But those techniques all involve an increase in the lexical
12233 scalar's ref count.
12235 * When the LHS is all lexical vars (but not necessarily my declarations),
12236 it is possible for the same lexicals to appear directly on the RHS, and
12237 without an increased ref count, since the stack isn't refcounted.
12238 This case can be detected at compile time by scanning for common lex
12239 vars with PL_generation.
12241 * lvalue subs defeat common var detection, but they do at least
12242 return vars with a temporary ref count increment. Also, you can't
12243 tell at compile time whether a sub call is lvalue.
12248 A: There are a few circumstances where there definitely can't be any
12251 LHS empty: () = (...);
12252 RHS empty: (....) = ();
12253 RHS contains only constants or other 'can't possibly be shared'
12254 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
12255 i.e. they only contain ops not marked as dangerous, whose children
12256 are also not dangerous;
12258 LHS contains a single scalar element: e.g. ($x) = (....); because
12259 after $x has been modified, it won't be used again on the RHS;
12260 RHS contains a single element with no aggregate on LHS: e.g.
12261 ($a,$b,$c) = ($x); again, once $a has been modified, its value
12262 won't be used again.
12264 B: If LHS are all 'my' lexical var declarations (or safe ops, which
12267 my ($a, $b, @c) = ...;
12269 Due to closure and goto tricks, these vars may already have content.
12270 For the same reason, an element on the RHS may be a lexical or package
12271 alias of one of the vars on the left, or share common elements, for
12274 my ($x,$y) = f(); # $x and $y on both sides
12275 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12280 my @a = @$ra; # elements of @a on both sides
12281 sub f { @a = 1..4; \@a }
12284 First, just consider scalar vars on LHS:
12286 RHS is safe only if (A), or in addition,
12287 * contains only lexical *scalar* vars, where neither side's
12288 lexicals have been flagged as aliases
12290 If RHS is not safe, then it's always legal to check LHS vars for
12291 RC==1, since the only RHS aliases will always be associated
12294 Note that in particular, RHS is not safe if:
12296 * it contains package scalar vars; e.g.:
12299 my ($x, $y) = (2, $x_alias);
12300 sub f { $x = 1; *x_alias = \$x; }
12302 * It contains other general elements, such as flattened or
12303 * spliced or single array or hash elements, e.g.
12306 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12310 use feature 'refaliasing';
12311 \($a[0], $a[1]) = \($y,$x);
12314 It doesn't matter if the array/hash is lexical or package.
12316 * it contains a function call that happens to be an lvalue
12317 sub which returns one or more of the above, e.g.
12328 (so a sub call on the RHS should be treated the same
12329 as having a package var on the RHS).
12331 * any other "dangerous" thing, such an op or built-in that
12332 returns one of the above, e.g. pp_preinc
12335 If RHS is not safe, what we can do however is at compile time flag
12336 that the LHS are all my declarations, and at run time check whether
12337 all the LHS have RC == 1, and if so skip the full scan.
12339 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12341 Here the issue is whether there can be elements of @a on the RHS
12342 which will get prematurely freed when @a is cleared prior to
12343 assignment. This is only a problem if the aliasing mechanism
12344 is one which doesn't increase the refcount - only if RC == 1
12345 will the RHS element be prematurely freed.
12347 Because the array/hash is being INTROed, it or its elements
12348 can't directly appear on the RHS:
12350 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12352 but can indirectly, e.g.:
12356 sub f { @a = 1..3; \@a }
12358 So if the RHS isn't safe as defined by (A), we must always
12359 mortalise and bump the ref count of any remaining RHS elements
12360 when assigning to a non-empty LHS aggregate.
12362 Lexical scalars on the RHS aren't safe if they've been involved in
12365 use feature 'refaliasing';
12368 \(my $lex) = \$pkg;
12369 my @a = ($lex,3); # equivalent to ($a[0],3)
12376 Similarly with lexical arrays and hashes on the RHS:
12390 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12391 my $a; ($a, my $b) = (....);
12393 The difference between (B) and (C) is that it is now physically
12394 possible for the LHS vars to appear on the RHS too, where they
12395 are not reference counted; but in this case, the compile-time
12396 PL_generation sweep will detect such common vars.
12398 So the rules for (C) differ from (B) in that if common vars are
12399 detected, the runtime "test RC==1" optimisation can no longer be used,
12400 and a full mark and sweep is required
12402 D: As (C), but in addition the LHS may contain package vars.
12404 Since package vars can be aliased without a corresponding refcount
12405 increase, all bets are off. It's only safe if (A). E.g.
12407 my ($x, $y) = (1,2);
12409 for $x_alias ($x) {
12410 ($x_alias, $y) = (3, $x); # whoops
12413 Ditto for LHS aggregate package vars.
12415 E: Any other dangerous ops on LHS, e.g.
12416 (f(), $a[0], @$r) = (...);
12418 this is similar to (E) in that all bets are off. In addition, it's
12419 impossible to determine at compile time whether the LHS
12420 contains a scalar or an aggregate, e.g.
12422 sub f : lvalue { @a }
12425 * ---------------------------------------------------------
12429 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12430 * that at least one of the things flagged was seen.
12434 AAS_MY_SCALAR = 0x001, /* my $scalar */
12435 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
12436 AAS_LEX_SCALAR = 0x004, /* $lexical */
12437 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
12438 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12439 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
12440 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
12441 AAS_DANGEROUS = 0x080, /* an op (other than the above)
12442 that's flagged OA_DANGEROUS */
12443 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
12444 not in any of the categories above */
12445 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
12450 /* helper function for S_aassign_scan().
12451 * check a PAD-related op for commonality and/or set its generation number.
12452 * Returns a boolean indicating whether its shared */
12455 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12457 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12458 /* lexical used in aliasing */
12462 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12464 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12471 Helper function for OPpASSIGN_COMMON* detection in rpeep().
12472 It scans the left or right hand subtree of the aassign op, and returns a
12473 set of flags indicating what sorts of things it found there.
12474 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12475 set PL_generation on lexical vars; if the latter, we see if
12476 PL_generation matches.
12477 'top' indicates whether we're recursing or at the top level.
12478 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12479 This fn will increment it by the number seen. It's not intended to
12480 be an accurate count (especially as many ops can push a variable
12481 number of SVs onto the stack); rather it's used as to test whether there
12482 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12486 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12489 bool kid_top = FALSE;
12491 /* first, look for a solitary @_ on the RHS */
12494 && (o->op_flags & OPf_KIDS)
12495 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12497 OP *kid = cUNOPo->op_first;
12498 if ( ( kid->op_type == OP_PUSHMARK
12499 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12500 && ((kid = OpSIBLING(kid)))
12501 && !OpHAS_SIBLING(kid)
12502 && kid->op_type == OP_RV2AV
12503 && !(kid->op_flags & OPf_REF)
12504 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12505 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12506 && ((kid = cUNOPx(kid)->op_first))
12507 && kid->op_type == OP_GV
12508 && cGVOPx_gv(kid) == PL_defgv
12510 flags |= AAS_DEFAV;
12513 switch (o->op_type) {
12516 return AAS_PKG_SCALAR;
12521 /* if !top, could be e.g. @a[0,1] */
12522 if (top && (o->op_flags & OPf_REF))
12523 return (o->op_private & OPpLVAL_INTRO)
12524 ? AAS_MY_AGG : AAS_LEX_AGG;
12525 return AAS_DANGEROUS;
12529 int comm = S_aassign_padcheck(aTHX_ o, rhs)
12530 ? AAS_LEX_SCALAR_COMM : 0;
12532 return (o->op_private & OPpLVAL_INTRO)
12533 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12539 if (cUNOPx(o)->op_first->op_type != OP_GV)
12540 return AAS_DANGEROUS; /* @{expr}, %{expr} */
12542 /* if !top, could be e.g. @a[0,1] */
12543 if (top && (o->op_flags & OPf_REF))
12544 return AAS_PKG_AGG;
12545 return AAS_DANGEROUS;
12549 if (cUNOPx(o)->op_first->op_type != OP_GV) {
12551 return AAS_DANGEROUS; /* ${expr} */
12553 return AAS_PKG_SCALAR; /* $pkg */
12556 if (o->op_private & OPpSPLIT_ASSIGN) {
12557 /* the assign in @a = split() has been optimised away
12558 * and the @a attached directly to the split op
12559 * Treat the array as appearing on the RHS, i.e.
12560 * ... = (@a = split)
12565 if (o->op_flags & OPf_STACKED)
12566 /* @{expr} = split() - the array expression is tacked
12567 * on as an extra child to split - process kid */
12568 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
12571 /* ... else array is directly attached to split op */
12573 if (PL_op->op_private & OPpSPLIT_LEX)
12574 return (o->op_private & OPpLVAL_INTRO)
12575 ? AAS_MY_AGG : AAS_LEX_AGG;
12577 return AAS_PKG_AGG;
12580 /* other args of split can't be returned */
12581 return AAS_SAFE_SCALAR;
12584 /* undef counts as a scalar on the RHS:
12585 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
12586 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
12590 flags = AAS_SAFE_SCALAR;
12595 /* these are all no-ops; they don't push a potentially common SV
12596 * onto the stack, so they are neither AAS_DANGEROUS nor
12597 * AAS_SAFE_SCALAR */
12600 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12605 /* these do nothing but may have children; but their children
12606 * should also be treated as top-level */
12611 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12613 flags = AAS_DANGEROUS;
12617 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
12618 && (o->op_private & OPpTARGET_MY))
12621 return S_aassign_padcheck(aTHX_ o, rhs)
12622 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12625 /* if its an unrecognised, non-dangerous op, assume that it
12626 * it the cause of at least one safe scalar */
12628 flags = AAS_SAFE_SCALAR;
12632 if (o->op_flags & OPf_KIDS) {
12634 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12635 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12641 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12642 and modify the optree to make them work inplace */
12645 S_inplace_aassign(pTHX_ OP *o) {
12647 OP *modop, *modop_pushmark;
12649 OP *oleft, *oleft_pushmark;
12651 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12653 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12655 assert(cUNOPo->op_first->op_type == OP_NULL);
12656 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12657 assert(modop_pushmark->op_type == OP_PUSHMARK);
12658 modop = OpSIBLING(modop_pushmark);
12660 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12663 /* no other operation except sort/reverse */
12664 if (OpHAS_SIBLING(modop))
12667 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12668 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12670 if (modop->op_flags & OPf_STACKED) {
12671 /* skip sort subroutine/block */
12672 assert(oright->op_type == OP_NULL);
12673 oright = OpSIBLING(oright);
12676 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12677 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12678 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12679 oleft = OpSIBLING(oleft_pushmark);
12681 /* Check the lhs is an array */
12683 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12684 || OpHAS_SIBLING(oleft)
12685 || (oleft->op_private & OPpLVAL_INTRO)
12689 /* Only one thing on the rhs */
12690 if (OpHAS_SIBLING(oright))
12693 /* check the array is the same on both sides */
12694 if (oleft->op_type == OP_RV2AV) {
12695 if (oright->op_type != OP_RV2AV
12696 || !cUNOPx(oright)->op_first
12697 || cUNOPx(oright)->op_first->op_type != OP_GV
12698 || cUNOPx(oleft )->op_first->op_type != OP_GV
12699 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12700 cGVOPx_gv(cUNOPx(oright)->op_first)
12704 else if (oright->op_type != OP_PADAV
12705 || oright->op_targ != oleft->op_targ
12709 /* This actually is an inplace assignment */
12711 modop->op_private |= OPpSORT_INPLACE;
12713 /* transfer MODishness etc from LHS arg to RHS arg */
12714 oright->op_flags = oleft->op_flags;
12716 /* remove the aassign op and the lhs */
12718 op_null(oleft_pushmark);
12719 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12720 op_null(cUNOPx(oleft)->op_first);
12726 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12727 * that potentially represent a series of one or more aggregate derefs
12728 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12729 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12730 * additional ops left in too).
12732 * The caller will have already verified that the first few ops in the
12733 * chain following 'start' indicate a multideref candidate, and will have
12734 * set 'orig_o' to the point further on in the chain where the first index
12735 * expression (if any) begins. 'orig_action' specifies what type of
12736 * beginning has already been determined by the ops between start..orig_o
12737 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12739 * 'hints' contains any hints flags that need adding (currently just
12740 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12744 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12748 UNOP_AUX_item *arg_buf = NULL;
12749 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12750 int index_skip = -1; /* don't output index arg on this action */
12752 /* similar to regex compiling, do two passes; the first pass
12753 * determines whether the op chain is convertible and calculates the
12754 * buffer size; the second pass populates the buffer and makes any
12755 * changes necessary to ops (such as moving consts to the pad on
12756 * threaded builds).
12758 * NB: for things like Coverity, note that both passes take the same
12759 * path through the logic tree (except for 'if (pass)' bits), since
12760 * both passes are following the same op_next chain; and in
12761 * particular, if it would return early on the second pass, it would
12762 * already have returned early on the first pass.
12764 for (pass = 0; pass < 2; pass++) {
12766 UV action = orig_action;
12767 OP *first_elem_op = NULL; /* first seen aelem/helem */
12768 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12769 int action_count = 0; /* number of actions seen so far */
12770 int action_ix = 0; /* action_count % (actions per IV) */
12771 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12772 bool is_last = FALSE; /* no more derefs to follow */
12773 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12774 UNOP_AUX_item *arg = arg_buf;
12775 UNOP_AUX_item *action_ptr = arg_buf;
12778 action_ptr->uv = 0;
12782 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12783 case MDEREF_HV_gvhv_helem:
12784 next_is_hash = TRUE;
12786 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12787 case MDEREF_AV_gvav_aelem:
12789 #ifdef USE_ITHREADS
12790 arg->pad_offset = cPADOPx(start)->op_padix;
12791 /* stop it being swiped when nulled */
12792 cPADOPx(start)->op_padix = 0;
12794 arg->sv = cSVOPx(start)->op_sv;
12795 cSVOPx(start)->op_sv = NULL;
12801 case MDEREF_HV_padhv_helem:
12802 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12803 next_is_hash = TRUE;
12805 case MDEREF_AV_padav_aelem:
12806 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12808 arg->pad_offset = start->op_targ;
12809 /* we skip setting op_targ = 0 for now, since the intact
12810 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12811 reset_start_targ = TRUE;
12816 case MDEREF_HV_pop_rv2hv_helem:
12817 next_is_hash = TRUE;
12819 case MDEREF_AV_pop_rv2av_aelem:
12823 NOT_REACHED; /* NOTREACHED */
12828 /* look for another (rv2av/hv; get index;
12829 * aelem/helem/exists/delele) sequence */
12834 UV index_type = MDEREF_INDEX_none;
12836 if (action_count) {
12837 /* if this is not the first lookup, consume the rv2av/hv */
12839 /* for N levels of aggregate lookup, we normally expect
12840 * that the first N-1 [ah]elem ops will be flagged as
12841 * /DEREF (so they autovivifiy if necessary), and the last
12842 * lookup op not to be.
12843 * For other things (like @{$h{k1}{k2}}) extra scope or
12844 * leave ops can appear, so abandon the effort in that
12846 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12849 /* rv2av or rv2hv sKR/1 */
12851 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12852 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12853 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12856 /* at this point, we wouldn't expect any of these
12857 * possible private flags:
12858 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12859 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12861 ASSUME(!(o->op_private &
12862 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12864 hints = (o->op_private & OPpHINT_STRICT_REFS);
12866 /* make sure the type of the previous /DEREF matches the
12867 * type of the next lookup */
12868 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12871 action = next_is_hash
12872 ? MDEREF_HV_vivify_rv2hv_helem
12873 : MDEREF_AV_vivify_rv2av_aelem;
12877 /* if this is the second pass, and we're at the depth where
12878 * previously we encountered a non-simple index expression,
12879 * stop processing the index at this point */
12880 if (action_count != index_skip) {
12882 /* look for one or more simple ops that return an array
12883 * index or hash key */
12885 switch (o->op_type) {
12887 /* it may be a lexical var index */
12888 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12889 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12890 ASSUME(!(o->op_private &
12891 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12893 if ( OP_GIMME(o,0) == G_SCALAR
12894 && !(o->op_flags & (OPf_REF|OPf_MOD))
12895 && o->op_private == 0)
12898 arg->pad_offset = o->op_targ;
12900 index_type = MDEREF_INDEX_padsv;
12906 if (next_is_hash) {
12907 /* it's a constant hash index */
12908 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12909 /* "use constant foo => FOO; $h{+foo}" for
12910 * some weird FOO, can leave you with constants
12911 * that aren't simple strings. It's not worth
12912 * the extra hassle for those edge cases */
12917 OP * helem_op = o->op_next;
12919 ASSUME( helem_op->op_type == OP_HELEM
12920 || helem_op->op_type == OP_NULL);
12921 if (helem_op->op_type == OP_HELEM) {
12922 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12923 if ( helem_op->op_private & OPpLVAL_INTRO
12924 || rop->op_type != OP_RV2HV
12928 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12930 #ifdef USE_ITHREADS
12931 /* Relocate sv to the pad for thread safety */
12932 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12933 arg->pad_offset = o->op_targ;
12936 arg->sv = cSVOPx_sv(o);
12941 /* it's a constant array index */
12943 SV *ix_sv = cSVOPo->op_sv;
12948 if ( action_count == 0
12951 && ( action == MDEREF_AV_padav_aelem
12952 || action == MDEREF_AV_gvav_aelem)
12954 maybe_aelemfast = TRUE;
12958 SvREFCNT_dec_NN(cSVOPo->op_sv);
12962 /* we've taken ownership of the SV */
12963 cSVOPo->op_sv = NULL;
12965 index_type = MDEREF_INDEX_const;
12970 /* it may be a package var index */
12972 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12973 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12974 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12975 || o->op_private != 0
12980 if (kid->op_type != OP_RV2SV)
12983 ASSUME(!(kid->op_flags &
12984 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12985 |OPf_SPECIAL|OPf_PARENS)));
12986 ASSUME(!(kid->op_private &
12988 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12989 |OPpDEREF|OPpLVAL_INTRO)));
12990 if( (kid->op_flags &~ OPf_PARENS)
12991 != (OPf_WANT_SCALAR|OPf_KIDS)
12992 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12997 #ifdef USE_ITHREADS
12998 arg->pad_offset = cPADOPx(o)->op_padix;
12999 /* stop it being swiped when nulled */
13000 cPADOPx(o)->op_padix = 0;
13002 arg->sv = cSVOPx(o)->op_sv;
13003 cSVOPo->op_sv = NULL;
13007 index_type = MDEREF_INDEX_gvsv;
13012 } /* action_count != index_skip */
13014 action |= index_type;
13017 /* at this point we have either:
13018 * * detected what looks like a simple index expression,
13019 * and expect the next op to be an [ah]elem, or
13020 * an nulled [ah]elem followed by a delete or exists;
13021 * * found a more complex expression, so something other
13022 * than the above follows.
13025 /* possibly an optimised away [ah]elem (where op_next is
13026 * exists or delete) */
13027 if (o->op_type == OP_NULL)
13030 /* at this point we're looking for an OP_AELEM, OP_HELEM,
13031 * OP_EXISTS or OP_DELETE */
13033 /* if something like arybase (a.k.a $[ ) is in scope,
13034 * abandon optimisation attempt */
13035 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
13036 && PL_check[o->op_type] != Perl_ck_null)
13038 /* similarly for customised exists and delete */
13039 if ( (o->op_type == OP_EXISTS)
13040 && PL_check[o->op_type] != Perl_ck_exists)
13042 if ( (o->op_type == OP_DELETE)
13043 && PL_check[o->op_type] != Perl_ck_delete)
13046 if ( o->op_type != OP_AELEM
13047 || (o->op_private &
13048 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
13050 maybe_aelemfast = FALSE;
13052 /* look for aelem/helem/exists/delete. If it's not the last elem
13053 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
13054 * flags; if it's the last, then it mustn't have
13055 * OPpDEREF_AV/HV, but may have lots of other flags, like
13056 * OPpLVAL_INTRO etc
13059 if ( index_type == MDEREF_INDEX_none
13060 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
13061 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
13065 /* we have aelem/helem/exists/delete with valid simple index */
13067 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
13068 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
13069 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
13072 ASSUME(!(o->op_flags &
13073 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
13074 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
13076 ok = (o->op_flags &~ OPf_PARENS)
13077 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
13078 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
13080 else if (o->op_type == OP_EXISTS) {
13081 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13082 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13083 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
13084 ok = !(o->op_private & ~OPpARG1_MASK);
13086 else if (o->op_type == OP_DELETE) {
13087 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13088 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13089 ASSUME(!(o->op_private &
13090 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
13091 /* don't handle slices or 'local delete'; the latter
13092 * is fairly rare, and has a complex runtime */
13093 ok = !(o->op_private & ~OPpARG1_MASK);
13094 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
13095 /* skip handling run-tome error */
13096 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
13099 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
13100 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
13101 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
13102 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
13103 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
13104 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
13109 if (!first_elem_op)
13113 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
13118 action |= MDEREF_FLAG_last;
13122 /* at this point we have something that started
13123 * promisingly enough (with rv2av or whatever), but failed
13124 * to find a simple index followed by an
13125 * aelem/helem/exists/delete. If this is the first action,
13126 * give up; but if we've already seen at least one
13127 * aelem/helem, then keep them and add a new action with
13128 * MDEREF_INDEX_none, which causes it to do the vivify
13129 * from the end of the previous lookup, and do the deref,
13130 * but stop at that point. So $a[0][expr] will do one
13131 * av_fetch, vivify and deref, then continue executing at
13136 index_skip = action_count;
13137 action |= MDEREF_FLAG_last;
13138 if (index_type != MDEREF_INDEX_none)
13143 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
13146 /* if there's no space for the next action, create a new slot
13147 * for it *before* we start adding args for that action */
13148 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
13155 } /* while !is_last */
13163 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
13164 if (index_skip == -1) {
13165 mderef->op_flags = o->op_flags
13166 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
13167 if (o->op_type == OP_EXISTS)
13168 mderef->op_private = OPpMULTIDEREF_EXISTS;
13169 else if (o->op_type == OP_DELETE)
13170 mderef->op_private = OPpMULTIDEREF_DELETE;
13172 mderef->op_private = o->op_private
13173 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
13175 /* accumulate strictness from every level (although I don't think
13176 * they can actually vary) */
13177 mderef->op_private |= hints;
13179 /* integrate the new multideref op into the optree and the
13182 * In general an op like aelem or helem has two child
13183 * sub-trees: the aggregate expression (a_expr) and the
13184 * index expression (i_expr):
13190 * The a_expr returns an AV or HV, while the i-expr returns an
13191 * index. In general a multideref replaces most or all of a
13192 * multi-level tree, e.g.
13208 * With multideref, all the i_exprs will be simple vars or
13209 * constants, except that i_expr1 may be arbitrary in the case
13210 * of MDEREF_INDEX_none.
13212 * The bottom-most a_expr will be either:
13213 * 1) a simple var (so padXv or gv+rv2Xv);
13214 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
13215 * so a simple var with an extra rv2Xv;
13216 * 3) or an arbitrary expression.
13218 * 'start', the first op in the execution chain, will point to
13219 * 1),2): the padXv or gv op;
13220 * 3): the rv2Xv which forms the last op in the a_expr
13221 * execution chain, and the top-most op in the a_expr
13224 * For all cases, the 'start' node is no longer required,
13225 * but we can't free it since one or more external nodes
13226 * may point to it. E.g. consider
13227 * $h{foo} = $a ? $b : $c
13228 * Here, both the op_next and op_other branches of the
13229 * cond_expr point to the gv[*h] of the hash expression, so
13230 * we can't free the 'start' op.
13232 * For expr->[...], we need to save the subtree containing the
13233 * expression; for the other cases, we just need to save the
13235 * So in all cases, we null the start op and keep it around by
13236 * making it the child of the multideref op; for the expr->
13237 * case, the expr will be a subtree of the start node.
13239 * So in the simple 1,2 case the optree above changes to
13245 * ex-gv (or ex-padxv)
13247 * with the op_next chain being
13249 * -> ex-gv -> multideref -> op-following-ex-exists ->
13251 * In the 3 case, we have
13264 * -> rest-of-a_expr subtree ->
13265 * ex-rv2xv -> multideref -> op-following-ex-exists ->
13268 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13269 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13270 * multideref attached as the child, e.g.
13276 * ex-rv2av - i_expr1
13284 /* if we free this op, don't free the pad entry */
13285 if (reset_start_targ)
13286 start->op_targ = 0;
13289 /* Cut the bit we need to save out of the tree and attach to
13290 * the multideref op, then free the rest of the tree */
13292 /* find parent of node to be detached (for use by splice) */
13294 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
13295 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13297 /* there is an arbitrary expression preceding us, e.g.
13298 * expr->[..]? so we need to save the 'expr' subtree */
13299 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13300 p = cUNOPx(p)->op_first;
13301 ASSUME( start->op_type == OP_RV2AV
13302 || start->op_type == OP_RV2HV);
13305 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13306 * above for exists/delete. */
13307 while ( (p->op_flags & OPf_KIDS)
13308 && cUNOPx(p)->op_first != start
13310 p = cUNOPx(p)->op_first;
13312 ASSUME(cUNOPx(p)->op_first == start);
13314 /* detach from main tree, and re-attach under the multideref */
13315 op_sibling_splice(mderef, NULL, 0,
13316 op_sibling_splice(p, NULL, 1, NULL));
13319 start->op_next = mderef;
13321 mderef->op_next = index_skip == -1 ? o->op_next : o;
13323 /* excise and free the original tree, and replace with
13324 * the multideref op */
13325 p = op_sibling_splice(top_op, NULL, -1, mderef);
13334 Size_t size = arg - arg_buf;
13336 if (maybe_aelemfast && action_count == 1)
13339 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13340 sizeof(UNOP_AUX_item) * (size + 1));
13341 /* for dumping etc: store the length in a hidden first slot;
13342 * we set the op_aux pointer to the second slot */
13343 arg_buf->uv = size;
13346 } /* for (pass = ...) */
13351 /* mechanism for deferring recursion in rpeep() */
13353 #define MAX_DEFERRED 4
13357 if (defer_ix == (MAX_DEFERRED-1)) { \
13358 OP **defer = defer_queue[defer_base]; \
13359 CALL_RPEEP(*defer); \
13360 S_prune_chain_head(defer); \
13361 defer_base = (defer_base + 1) % MAX_DEFERRED; \
13364 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13367 #define IS_AND_OP(o) (o->op_type == OP_AND)
13368 #define IS_OR_OP(o) (o->op_type == OP_OR)
13371 /* A peephole optimizer. We visit the ops in the order they're to execute.
13372 * See the comments at the top of this file for more details about when
13373 * peep() is called */
13376 Perl_rpeep(pTHX_ OP *o)
13380 OP* oldoldop = NULL;
13381 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13382 int defer_base = 0;
13387 if (!o || o->op_opt)
13390 assert(o->op_type != OP_FREED);
13394 SAVEVPTR(PL_curcop);
13395 for (;; o = o->op_next) {
13396 if (o && o->op_opt)
13399 while (defer_ix >= 0) {
13401 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13402 CALL_RPEEP(*defer);
13403 S_prune_chain_head(defer);
13410 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13411 assert(!oldoldop || oldoldop->op_next == oldop);
13412 assert(!oldop || oldop->op_next == o);
13414 /* By default, this op has now been optimised. A couple of cases below
13415 clear this again. */
13419 /* look for a series of 1 or more aggregate derefs, e.g.
13420 * $a[1]{foo}[$i]{$k}
13421 * and replace with a single OP_MULTIDEREF op.
13422 * Each index must be either a const, or a simple variable,
13424 * First, look for likely combinations of starting ops,
13425 * corresponding to (global and lexical variants of)
13427 * $r->[...] $r->{...}
13428 * (preceding expression)->[...]
13429 * (preceding expression)->{...}
13430 * and if so, call maybe_multideref() to do a full inspection
13431 * of the op chain and if appropriate, replace with an
13439 switch (o2->op_type) {
13441 /* $pkg[..] : gv[*pkg]
13442 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
13444 /* Fail if there are new op flag combinations that we're
13445 * not aware of, rather than:
13446 * * silently failing to optimise, or
13447 * * silently optimising the flag away.
13448 * If this ASSUME starts failing, examine what new flag
13449 * has been added to the op, and decide whether the
13450 * optimisation should still occur with that flag, then
13451 * update the code accordingly. This applies to all the
13452 * other ASSUMEs in the block of code too.
13454 ASSUME(!(o2->op_flags &
13455 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13456 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13460 if (o2->op_type == OP_RV2AV) {
13461 action = MDEREF_AV_gvav_aelem;
13465 if (o2->op_type == OP_RV2HV) {
13466 action = MDEREF_HV_gvhv_helem;
13470 if (o2->op_type != OP_RV2SV)
13473 /* at this point we've seen gv,rv2sv, so the only valid
13474 * construct left is $pkg->[] or $pkg->{} */
13476 ASSUME(!(o2->op_flags & OPf_STACKED));
13477 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13478 != (OPf_WANT_SCALAR|OPf_MOD))
13481 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13482 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13483 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13485 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
13486 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13490 if (o2->op_type == OP_RV2AV) {
13491 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13494 if (o2->op_type == OP_RV2HV) {
13495 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13501 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13503 ASSUME(!(o2->op_flags &
13504 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13505 if ((o2->op_flags &
13506 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13507 != (OPf_WANT_SCALAR|OPf_MOD))
13510 ASSUME(!(o2->op_private &
13511 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13512 /* skip if state or intro, or not a deref */
13513 if ( o2->op_private != OPpDEREF_AV
13514 && o2->op_private != OPpDEREF_HV)
13518 if (o2->op_type == OP_RV2AV) {
13519 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13522 if (o2->op_type == OP_RV2HV) {
13523 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13530 /* $lex[..]: padav[@lex:1,2] sR *
13531 * or $lex{..}: padhv[%lex:1,2] sR */
13532 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13533 OPf_REF|OPf_SPECIAL)));
13534 if ((o2->op_flags &
13535 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13536 != (OPf_WANT_SCALAR|OPf_REF))
13538 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13540 /* OPf_PARENS isn't currently used in this case;
13541 * if that changes, let us know! */
13542 ASSUME(!(o2->op_flags & OPf_PARENS));
13544 /* at this point, we wouldn't expect any of the remaining
13545 * possible private flags:
13546 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13547 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13549 * OPpSLICEWARNING shouldn't affect runtime
13551 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13553 action = o2->op_type == OP_PADAV
13554 ? MDEREF_AV_padav_aelem
13555 : MDEREF_HV_padhv_helem;
13557 S_maybe_multideref(aTHX_ o, o2, action, 0);
13563 action = o2->op_type == OP_RV2AV
13564 ? MDEREF_AV_pop_rv2av_aelem
13565 : MDEREF_HV_pop_rv2hv_helem;
13568 /* (expr)->[...]: rv2av sKR/1;
13569 * (expr)->{...}: rv2hv sKR/1; */
13571 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13573 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13574 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13575 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13578 /* at this point, we wouldn't expect any of these
13579 * possible private flags:
13580 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13581 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13583 ASSUME(!(o2->op_private &
13584 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13586 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13590 S_maybe_multideref(aTHX_ o, o2, action, hints);
13599 switch (o->op_type) {
13601 PL_curcop = ((COP*)o); /* for warnings */
13604 PL_curcop = ((COP*)o); /* for warnings */
13606 /* Optimise a "return ..." at the end of a sub to just be "...".
13607 * This saves 2 ops. Before:
13608 * 1 <;> nextstate(main 1 -e:1) v ->2
13609 * 4 <@> return K ->5
13610 * 2 <0> pushmark s ->3
13611 * - <1> ex-rv2sv sK/1 ->4
13612 * 3 <#> gvsv[*cat] s ->4
13615 * - <@> return K ->-
13616 * - <0> pushmark s ->2
13617 * - <1> ex-rv2sv sK/1 ->-
13618 * 2 <$> gvsv(*cat) s ->3
13621 OP *next = o->op_next;
13622 OP *sibling = OpSIBLING(o);
13623 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13624 && OP_TYPE_IS(sibling, OP_RETURN)
13625 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13626 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13627 ||OP_TYPE_IS(sibling->op_next->op_next,
13629 && cUNOPx(sibling)->op_first == next
13630 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13633 /* Look through the PUSHMARK's siblings for one that
13634 * points to the RETURN */
13635 OP *top = OpSIBLING(next);
13636 while (top && top->op_next) {
13637 if (top->op_next == sibling) {
13638 top->op_next = sibling->op_next;
13639 o->op_next = next->op_next;
13642 top = OpSIBLING(top);
13647 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13649 * This latter form is then suitable for conversion into padrange
13650 * later on. Convert:
13652 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13656 * nextstate1 -> listop -> nextstate3
13658 * pushmark -> padop1 -> padop2
13660 if (o->op_next && (
13661 o->op_next->op_type == OP_PADSV
13662 || o->op_next->op_type == OP_PADAV
13663 || o->op_next->op_type == OP_PADHV
13665 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13666 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13667 && o->op_next->op_next->op_next && (
13668 o->op_next->op_next->op_next->op_type == OP_PADSV
13669 || o->op_next->op_next->op_next->op_type == OP_PADAV
13670 || o->op_next->op_next->op_next->op_type == OP_PADHV
13672 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13673 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13674 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13675 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13677 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13680 ns2 = pad1->op_next;
13681 pad2 = ns2->op_next;
13682 ns3 = pad2->op_next;
13684 /* we assume here that the op_next chain is the same as
13685 * the op_sibling chain */
13686 assert(OpSIBLING(o) == pad1);
13687 assert(OpSIBLING(pad1) == ns2);
13688 assert(OpSIBLING(ns2) == pad2);
13689 assert(OpSIBLING(pad2) == ns3);
13691 /* excise and delete ns2 */
13692 op_sibling_splice(NULL, pad1, 1, NULL);
13695 /* excise pad1 and pad2 */
13696 op_sibling_splice(NULL, o, 2, NULL);
13698 /* create new listop, with children consisting of:
13699 * a new pushmark, pad1, pad2. */
13700 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13701 newop->op_flags |= OPf_PARENS;
13702 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13704 /* insert newop between o and ns3 */
13705 op_sibling_splice(NULL, o, 0, newop);
13707 /*fixup op_next chain */
13708 newpm = cUNOPx(newop)->op_first; /* pushmark */
13709 o ->op_next = newpm;
13710 newpm->op_next = pad1;
13711 pad1 ->op_next = pad2;
13712 pad2 ->op_next = newop; /* listop */
13713 newop->op_next = ns3;
13715 /* Ensure pushmark has this flag if padops do */
13716 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13717 newpm->op_flags |= OPf_MOD;
13723 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13724 to carry two labels. For now, take the easier option, and skip
13725 this optimisation if the first NEXTSTATE has a label. */
13726 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13727 OP *nextop = o->op_next;
13728 while (nextop && nextop->op_type == OP_NULL)
13729 nextop = nextop->op_next;
13731 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13734 oldop->op_next = nextop;
13736 /* Skip (old)oldop assignment since the current oldop's
13737 op_next already points to the next op. */
13744 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13745 if (o->op_next->op_private & OPpTARGET_MY) {
13746 if (o->op_flags & OPf_STACKED) /* chained concats */
13747 break; /* ignore_optimization */
13749 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13750 o->op_targ = o->op_next->op_targ;
13751 o->op_next->op_targ = 0;
13752 o->op_private |= OPpTARGET_MY;
13755 op_null(o->op_next);
13759 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13760 break; /* Scalar stub must produce undef. List stub is noop */
13764 if (o->op_targ == OP_NEXTSTATE
13765 || o->op_targ == OP_DBSTATE)
13767 PL_curcop = ((COP*)o);
13769 /* XXX: We avoid setting op_seq here to prevent later calls
13770 to rpeep() from mistakenly concluding that optimisation
13771 has already occurred. This doesn't fix the real problem,
13772 though (See 20010220.007 (#5874)). AMS 20010719 */
13773 /* op_seq functionality is now replaced by op_opt */
13781 oldop->op_next = o->op_next;
13795 convert repeat into a stub with no kids.
13797 if (o->op_next->op_type == OP_CONST
13798 || ( o->op_next->op_type == OP_PADSV
13799 && !(o->op_next->op_private & OPpLVAL_INTRO))
13800 || ( o->op_next->op_type == OP_GV
13801 && o->op_next->op_next->op_type == OP_RV2SV
13802 && !(o->op_next->op_next->op_private
13803 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13805 const OP *kid = o->op_next->op_next;
13806 if (o->op_next->op_type == OP_GV)
13807 kid = kid->op_next;
13808 /* kid is now the ex-list. */
13809 if (kid->op_type == OP_NULL
13810 && (kid = kid->op_next)->op_type == OP_CONST
13811 /* kid is now the repeat count. */
13812 && kid->op_next->op_type == OP_REPEAT
13813 && kid->op_next->op_private & OPpREPEAT_DOLIST
13814 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13815 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13817 o = kid->op_next; /* repeat */
13819 oldop->op_next = o;
13820 op_free(cBINOPo->op_first);
13821 op_free(cBINOPo->op_last );
13822 o->op_flags &=~ OPf_KIDS;
13823 /* stub is a baseop; repeat is a binop */
13824 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13825 OpTYPE_set(o, OP_STUB);
13831 /* Convert a series of PAD ops for my vars plus support into a
13832 * single padrange op. Basically
13834 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13836 * becomes, depending on circumstances, one of
13838 * padrange ----------------------------------> (list) -> rest
13839 * padrange --------------------------------------------> rest
13841 * where all the pad indexes are sequential and of the same type
13843 * We convert the pushmark into a padrange op, then skip
13844 * any other pad ops, and possibly some trailing ops.
13845 * Note that we don't null() the skipped ops, to make it
13846 * easier for Deparse to undo this optimisation (and none of
13847 * the skipped ops are holding any resourses). It also makes
13848 * it easier for find_uninit_var(), as it can just ignore
13849 * padrange, and examine the original pad ops.
13853 OP *followop = NULL; /* the op that will follow the padrange op */
13856 PADOFFSET base = 0; /* init only to stop compiler whining */
13857 bool gvoid = 0; /* init only to stop compiler whining */
13858 bool defav = 0; /* seen (...) = @_ */
13859 bool reuse = 0; /* reuse an existing padrange op */
13861 /* look for a pushmark -> gv[_] -> rv2av */
13866 if ( p->op_type == OP_GV
13867 && cGVOPx_gv(p) == PL_defgv
13868 && (rv2av = p->op_next)
13869 && rv2av->op_type == OP_RV2AV
13870 && !(rv2av->op_flags & OPf_REF)
13871 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13872 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13874 q = rv2av->op_next;
13875 if (q->op_type == OP_NULL)
13877 if (q->op_type == OP_PUSHMARK) {
13887 /* scan for PAD ops */
13889 for (p = p->op_next; p; p = p->op_next) {
13890 if (p->op_type == OP_NULL)
13893 if (( p->op_type != OP_PADSV
13894 && p->op_type != OP_PADAV
13895 && p->op_type != OP_PADHV
13897 /* any private flag other than INTRO? e.g. STATE */
13898 || (p->op_private & ~OPpLVAL_INTRO)
13902 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13904 if ( p->op_type == OP_PADAV
13906 && p->op_next->op_type == OP_CONST
13907 && p->op_next->op_next
13908 && p->op_next->op_next->op_type == OP_AELEM
13912 /* for 1st padop, note what type it is and the range
13913 * start; for the others, check that it's the same type
13914 * and that the targs are contiguous */
13916 intro = (p->op_private & OPpLVAL_INTRO);
13918 gvoid = OP_GIMME(p,0) == G_VOID;
13921 if ((p->op_private & OPpLVAL_INTRO) != intro)
13923 /* Note that you'd normally expect targs to be
13924 * contiguous in my($a,$b,$c), but that's not the case
13925 * when external modules start doing things, e.g.
13926 * Function::Parameters */
13927 if (p->op_targ != base + count)
13929 assert(p->op_targ == base + count);
13930 /* Either all the padops or none of the padops should
13931 be in void context. Since we only do the optimisa-
13932 tion for av/hv when the aggregate itself is pushed
13933 on to the stack (one item), there is no need to dis-
13934 tinguish list from scalar context. */
13935 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13939 /* for AV, HV, only when we're not flattening */
13940 if ( p->op_type != OP_PADSV
13942 && !(p->op_flags & OPf_REF)
13946 if (count >= OPpPADRANGE_COUNTMASK)
13949 /* there's a biggest base we can fit into a
13950 * SAVEt_CLEARPADRANGE in pp_padrange.
13951 * (The sizeof() stuff will be constant-folded, and is
13952 * intended to avoid getting "comparison is always false"
13953 * compiler warnings. See the comments above
13954 * MEM_WRAP_CHECK for more explanation on why we do this
13955 * in a weird way to avoid compiler warnings.)
13958 && (8*sizeof(base) >
13959 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13961 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13963 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13967 /* Success! We've got another valid pad op to optimise away */
13969 followop = p->op_next;
13972 if (count < 1 || (count == 1 && !defav))
13975 /* pp_padrange in specifically compile-time void context
13976 * skips pushing a mark and lexicals; in all other contexts
13977 * (including unknown till runtime) it pushes a mark and the
13978 * lexicals. We must be very careful then, that the ops we
13979 * optimise away would have exactly the same effect as the
13981 * In particular in void context, we can only optimise to
13982 * a padrange if we see the complete sequence
13983 * pushmark, pad*v, ...., list
13984 * which has the net effect of leaving the markstack as it
13985 * was. Not pushing onto the stack (whereas padsv does touch
13986 * the stack) makes no difference in void context.
13990 if (followop->op_type == OP_LIST
13991 && OP_GIMME(followop,0) == G_VOID
13994 followop = followop->op_next; /* skip OP_LIST */
13996 /* consolidate two successive my(...);'s */
13999 && oldoldop->op_type == OP_PADRANGE
14000 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
14001 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
14002 && !(oldoldop->op_flags & OPf_SPECIAL)
14005 assert(oldoldop->op_next == oldop);
14006 assert( oldop->op_type == OP_NEXTSTATE
14007 || oldop->op_type == OP_DBSTATE);
14008 assert(oldop->op_next == o);
14011 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
14013 /* Do not assume pad offsets for $c and $d are con-
14018 if ( oldoldop->op_targ + old_count == base
14019 && old_count < OPpPADRANGE_COUNTMASK - count) {
14020 base = oldoldop->op_targ;
14021 count += old_count;
14026 /* if there's any immediately following singleton
14027 * my var's; then swallow them and the associated
14029 * my ($a,$b); my $c; my $d;
14031 * my ($a,$b,$c,$d);
14034 while ( ((p = followop->op_next))
14035 && ( p->op_type == OP_PADSV
14036 || p->op_type == OP_PADAV
14037 || p->op_type == OP_PADHV)
14038 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
14039 && (p->op_private & OPpLVAL_INTRO) == intro
14040 && !(p->op_private & ~OPpLVAL_INTRO)
14042 && ( p->op_next->op_type == OP_NEXTSTATE
14043 || p->op_next->op_type == OP_DBSTATE)
14044 && count < OPpPADRANGE_COUNTMASK
14045 && base + count == p->op_targ
14048 followop = p->op_next;
14056 assert(oldoldop->op_type == OP_PADRANGE);
14057 oldoldop->op_next = followop;
14058 oldoldop->op_private = (intro | count);
14064 /* Convert the pushmark into a padrange.
14065 * To make Deparse easier, we guarantee that a padrange was
14066 * *always* formerly a pushmark */
14067 assert(o->op_type == OP_PUSHMARK);
14068 o->op_next = followop;
14069 OpTYPE_set(o, OP_PADRANGE);
14071 /* bit 7: INTRO; bit 6..0: count */
14072 o->op_private = (intro | count);
14073 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
14074 | gvoid * OPf_WANT_VOID
14075 | (defav ? OPf_SPECIAL : 0));
14083 /* Skip over state($x) in void context. */
14084 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
14085 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
14087 oldop->op_next = o->op_next;
14088 goto redo_nextstate;
14090 if (o->op_type != OP_PADAV)
14094 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
14095 OP* const pop = (o->op_type == OP_PADAV) ?
14096 o->op_next : o->op_next->op_next;
14098 if (pop && pop->op_type == OP_CONST &&
14099 ((PL_op = pop->op_next)) &&
14100 pop->op_next->op_type == OP_AELEM &&
14101 !(pop->op_next->op_private &
14102 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
14103 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
14106 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
14107 no_bareword_allowed(pop);
14108 if (o->op_type == OP_GV)
14109 op_null(o->op_next);
14110 op_null(pop->op_next);
14112 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
14113 o->op_next = pop->op_next->op_next;
14114 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
14115 o->op_private = (U8)i;
14116 if (o->op_type == OP_GV) {
14119 o->op_type = OP_AELEMFAST;
14122 o->op_type = OP_AELEMFAST_LEX;
14124 if (o->op_type != OP_GV)
14128 /* Remove $foo from the op_next chain in void context. */
14130 && ( o->op_next->op_type == OP_RV2SV
14131 || o->op_next->op_type == OP_RV2AV
14132 || o->op_next->op_type == OP_RV2HV )
14133 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14134 && !(o->op_next->op_private & OPpLVAL_INTRO))
14136 oldop->op_next = o->op_next->op_next;
14137 /* Reprocess the previous op if it is a nextstate, to
14138 allow double-nextstate optimisation. */
14140 if (oldop->op_type == OP_NEXTSTATE) {
14147 o = oldop->op_next;
14150 else if (o->op_next->op_type == OP_RV2SV) {
14151 if (!(o->op_next->op_private & OPpDEREF)) {
14152 op_null(o->op_next);
14153 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
14155 o->op_next = o->op_next->op_next;
14156 OpTYPE_set(o, OP_GVSV);
14159 else if (o->op_next->op_type == OP_READLINE
14160 && o->op_next->op_next->op_type == OP_CONCAT
14161 && (o->op_next->op_next->op_flags & OPf_STACKED))
14163 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
14164 OpTYPE_set(o, OP_RCATLINE);
14165 o->op_flags |= OPf_STACKED;
14166 op_null(o->op_next->op_next);
14167 op_null(o->op_next);
14172 #define HV_OR_SCALARHV(op) \
14173 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
14175 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
14176 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
14177 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
14178 ? cUNOPx(op)->op_first \
14182 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
14183 fop->op_private |= OPpTRUEBOOL;
14189 fop = cLOGOP->op_first;
14190 sop = OpSIBLING(fop);
14191 while (cLOGOP->op_other->op_type == OP_NULL)
14192 cLOGOP->op_other = cLOGOP->op_other->op_next;
14193 while (o->op_next && ( o->op_type == o->op_next->op_type
14194 || o->op_next->op_type == OP_NULL))
14195 o->op_next = o->op_next->op_next;
14197 /* If we're an OR and our next is an AND in void context, we'll
14198 follow its op_other on short circuit, same for reverse.
14199 We can't do this with OP_DOR since if it's true, its return
14200 value is the underlying value which must be evaluated
14204 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
14205 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
14207 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14209 o->op_next = ((LOGOP*)o->op_next)->op_other;
14211 DEFER(cLOGOP->op_other);
14214 fop = HV_OR_SCALARHV(fop);
14215 if (sop) sop = HV_OR_SCALARHV(sop);
14220 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
14221 while (nop && nop->op_next) {
14222 switch (nop->op_next->op_type) {
14227 lop = nop = nop->op_next;
14230 nop = nop->op_next;
14239 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14240 || o->op_type == OP_AND )
14241 fop->op_private |= OPpTRUEBOOL;
14242 else if (!(lop->op_flags & OPf_WANT))
14243 fop->op_private |= OPpMAYBE_TRUEBOOL;
14245 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14247 sop->op_private |= OPpTRUEBOOL;
14254 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
14255 fop->op_private |= OPpTRUEBOOL;
14256 #undef HV_OR_SCALARHV
14257 /* GERONIMO! */ /* FALLTHROUGH */
14266 case OP_ARGDEFELEM:
14267 while (cLOGOP->op_other->op_type == OP_NULL)
14268 cLOGOP->op_other = cLOGOP->op_other->op_next;
14269 DEFER(cLOGOP->op_other);
14274 while (cLOOP->op_redoop->op_type == OP_NULL)
14275 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14276 while (cLOOP->op_nextop->op_type == OP_NULL)
14277 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14278 while (cLOOP->op_lastop->op_type == OP_NULL)
14279 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14280 /* a while(1) loop doesn't have an op_next that escapes the
14281 * loop, so we have to explicitly follow the op_lastop to
14282 * process the rest of the code */
14283 DEFER(cLOOP->op_lastop);
14287 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14288 DEFER(cLOGOPo->op_other);
14292 assert(!(cPMOP->op_pmflags & PMf_ONCE));
14293 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14294 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14295 cPMOP->op_pmstashstartu.op_pmreplstart
14296 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14297 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14303 if (o->op_flags & OPf_SPECIAL) {
14304 /* first arg is a code block */
14305 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14306 OP * kid = cUNOPx(nullop)->op_first;
14308 assert(nullop->op_type == OP_NULL);
14309 assert(kid->op_type == OP_SCOPE
14310 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14311 /* since OP_SORT doesn't have a handy op_other-style
14312 * field that can point directly to the start of the code
14313 * block, store it in the otherwise-unused op_next field
14314 * of the top-level OP_NULL. This will be quicker at
14315 * run-time, and it will also allow us to remove leading
14316 * OP_NULLs by just messing with op_nexts without
14317 * altering the basic op_first/op_sibling layout. */
14318 kid = kLISTOP->op_first;
14320 (kid->op_type == OP_NULL
14321 && ( kid->op_targ == OP_NEXTSTATE
14322 || kid->op_targ == OP_DBSTATE ))
14323 || kid->op_type == OP_STUB
14324 || kid->op_type == OP_ENTER);
14325 nullop->op_next = kLISTOP->op_next;
14326 DEFER(nullop->op_next);
14329 /* check that RHS of sort is a single plain array */
14330 oright = cUNOPo->op_first;
14331 if (!oright || oright->op_type != OP_PUSHMARK)
14334 if (o->op_private & OPpSORT_INPLACE)
14337 /* reverse sort ... can be optimised. */
14338 if (!OpHAS_SIBLING(cUNOPo)) {
14339 /* Nothing follows us on the list. */
14340 OP * const reverse = o->op_next;
14342 if (reverse->op_type == OP_REVERSE &&
14343 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14344 OP * const pushmark = cUNOPx(reverse)->op_first;
14345 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14346 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14347 /* reverse -> pushmark -> sort */
14348 o->op_private |= OPpSORT_REVERSE;
14350 pushmark->op_next = oright->op_next;
14360 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14362 LISTOP *enter, *exlist;
14364 if (o->op_private & OPpSORT_INPLACE)
14367 enter = (LISTOP *) o->op_next;
14370 if (enter->op_type == OP_NULL) {
14371 enter = (LISTOP *) enter->op_next;
14375 /* for $a (...) will have OP_GV then OP_RV2GV here.
14376 for (...) just has an OP_GV. */
14377 if (enter->op_type == OP_GV) {
14378 gvop = (OP *) enter;
14379 enter = (LISTOP *) enter->op_next;
14382 if (enter->op_type == OP_RV2GV) {
14383 enter = (LISTOP *) enter->op_next;
14389 if (enter->op_type != OP_ENTERITER)
14392 iter = enter->op_next;
14393 if (!iter || iter->op_type != OP_ITER)
14396 expushmark = enter->op_first;
14397 if (!expushmark || expushmark->op_type != OP_NULL
14398 || expushmark->op_targ != OP_PUSHMARK)
14401 exlist = (LISTOP *) OpSIBLING(expushmark);
14402 if (!exlist || exlist->op_type != OP_NULL
14403 || exlist->op_targ != OP_LIST)
14406 if (exlist->op_last != o) {
14407 /* Mmm. Was expecting to point back to this op. */
14410 theirmark = exlist->op_first;
14411 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14414 if (OpSIBLING(theirmark) != o) {
14415 /* There's something between the mark and the reverse, eg
14416 for (1, reverse (...))
14421 ourmark = ((LISTOP *)o)->op_first;
14422 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14425 ourlast = ((LISTOP *)o)->op_last;
14426 if (!ourlast || ourlast->op_next != o)
14429 rv2av = OpSIBLING(ourmark);
14430 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14431 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14432 /* We're just reversing a single array. */
14433 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14434 enter->op_flags |= OPf_STACKED;
14437 /* We don't have control over who points to theirmark, so sacrifice
14439 theirmark->op_next = ourmark->op_next;
14440 theirmark->op_flags = ourmark->op_flags;
14441 ourlast->op_next = gvop ? gvop : (OP *) enter;
14444 enter->op_private |= OPpITER_REVERSED;
14445 iter->op_private |= OPpITER_REVERSED;
14449 o = oldop->op_next;
14457 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14458 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14463 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14464 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14467 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14469 sv = newRV((SV *)PL_compcv);
14473 OpTYPE_set(o, OP_CONST);
14474 o->op_flags |= OPf_SPECIAL;
14475 cSVOPo->op_sv = sv;
14480 if (OP_GIMME(o,0) == G_VOID
14481 || ( o->op_next->op_type == OP_LINESEQ
14482 && ( o->op_next->op_next->op_type == OP_LEAVESUB
14483 || ( o->op_next->op_next->op_type == OP_RETURN
14484 && !CvLVALUE(PL_compcv)))))
14486 OP *right = cBINOP->op_first;
14505 OP *left = OpSIBLING(right);
14506 if (left->op_type == OP_SUBSTR
14507 && (left->op_private & 7) < 4) {
14509 /* cut out right */
14510 op_sibling_splice(o, NULL, 1, NULL);
14511 /* and insert it as second child of OP_SUBSTR */
14512 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14514 left->op_private |= OPpSUBSTR_REPL_FIRST;
14516 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14523 int l, r, lr, lscalars, rscalars;
14525 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14526 Note that we do this now rather than in newASSIGNOP(),
14527 since only by now are aliased lexicals flagged as such
14529 See the essay "Common vars in list assignment" above for
14530 the full details of the rationale behind all the conditions
14533 PL_generation sorcery:
14534 To detect whether there are common vars, the global var
14535 PL_generation is incremented for each assign op we scan.
14536 Then we run through all the lexical variables on the LHS,
14537 of the assignment, setting a spare slot in each of them to
14538 PL_generation. Then we scan the RHS, and if any lexicals
14539 already have that value, we know we've got commonality.
14540 Also, if the generation number is already set to
14541 PERL_INT_MAX, then the variable is involved in aliasing, so
14542 we also have potential commonality in that case.
14548 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
14551 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14555 /* After looking for things which are *always* safe, this main
14556 * if/else chain selects primarily based on the type of the
14557 * LHS, gradually working its way down from the more dangerous
14558 * to the more restrictive and thus safer cases */
14560 if ( !l /* () = ....; */
14561 || !r /* .... = (); */
14562 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14563 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14564 || (lscalars < 2) /* ($x, undef) = ... */
14566 NOOP; /* always safe */
14568 else if (l & AAS_DANGEROUS) {
14569 /* always dangerous */
14570 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14571 o->op_private |= OPpASSIGN_COMMON_AGG;
14573 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14574 /* package vars are always dangerous - too many
14575 * aliasing possibilities */
14576 if (l & AAS_PKG_SCALAR)
14577 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14578 if (l & AAS_PKG_AGG)
14579 o->op_private |= OPpASSIGN_COMMON_AGG;
14581 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14582 |AAS_LEX_SCALAR|AAS_LEX_AGG))
14584 /* LHS contains only lexicals and safe ops */
14586 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14587 o->op_private |= OPpASSIGN_COMMON_AGG;
14589 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14590 if (lr & AAS_LEX_SCALAR_COMM)
14591 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14592 else if ( !(l & AAS_LEX_SCALAR)
14593 && (r & AAS_DEFAV))
14597 * as scalar-safe for performance reasons.
14598 * (it will still have been marked _AGG if necessary */
14601 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14602 o->op_private |= OPpASSIGN_COMMON_RC1;
14607 * may have to handle aggregate on LHS, but we can't
14608 * have common scalars. */
14611 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14617 Perl_cpeep_t cpeep =
14618 XopENTRYCUSTOM(o, xop_peep);
14620 cpeep(aTHX_ o, oldop);
14625 /* did we just null the current op? If so, re-process it to handle
14626 * eliding "empty" ops from the chain */
14627 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14640 Perl_peep(pTHX_ OP *o)
14646 =head1 Custom Operators
14648 =for apidoc Ao||custom_op_xop
14649 Return the XOP structure for a given custom op. This macro should be
14650 considered internal to C<OP_NAME> and the other access macros: use them instead.
14651 This macro does call a function. Prior
14652 to 5.19.6, this was implemented as a
14659 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14665 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14667 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14668 assert(o->op_type == OP_CUSTOM);
14670 /* This is wrong. It assumes a function pointer can be cast to IV,
14671 * which isn't guaranteed, but this is what the old custom OP code
14672 * did. In principle it should be safer to Copy the bytes of the
14673 * pointer into a PV: since the new interface is hidden behind
14674 * functions, this can be changed later if necessary. */
14675 /* Change custom_op_xop if this ever happens */
14676 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14679 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14681 /* assume noone will have just registered a desc */
14682 if (!he && PL_custom_op_names &&
14683 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14688 /* XXX does all this need to be shared mem? */
14689 Newxz(xop, 1, XOP);
14690 pv = SvPV(HeVAL(he), l);
14691 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14692 if (PL_custom_op_descs &&
14693 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14695 pv = SvPV(HeVAL(he), l);
14696 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14698 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14702 xop = (XOP *)&xop_null;
14704 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14708 if(field == XOPe_xop_ptr) {
14711 const U32 flags = XopFLAGS(xop);
14712 if(flags & field) {
14714 case XOPe_xop_name:
14715 any.xop_name = xop->xop_name;
14717 case XOPe_xop_desc:
14718 any.xop_desc = xop->xop_desc;
14720 case XOPe_xop_class:
14721 any.xop_class = xop->xop_class;
14723 case XOPe_xop_peep:
14724 any.xop_peep = xop->xop_peep;
14727 NOT_REACHED; /* NOTREACHED */
14732 case XOPe_xop_name:
14733 any.xop_name = XOPd_xop_name;
14735 case XOPe_xop_desc:
14736 any.xop_desc = XOPd_xop_desc;
14738 case XOPe_xop_class:
14739 any.xop_class = XOPd_xop_class;
14741 case XOPe_xop_peep:
14742 any.xop_peep = XOPd_xop_peep;
14745 NOT_REACHED; /* NOTREACHED */
14750 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14751 * op.c: In function 'Perl_custom_op_get_field':
14752 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14753 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14754 * expands to assert(0), which expands to ((0) ? (void)0 :
14755 * __assert(...)), and gcc doesn't know that __assert can never return. */
14761 =for apidoc Ao||custom_op_register
14762 Register a custom op. See L<perlguts/"Custom Operators">.
14768 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14772 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14774 /* see the comment in custom_op_xop */
14775 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14777 if (!PL_custom_ops)
14778 PL_custom_ops = newHV();
14780 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14781 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14786 =for apidoc core_prototype
14788 This function assigns the prototype of the named core function to C<sv>, or
14789 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
14790 C<NULL> if the core function has no prototype. C<code> is a code as returned
14791 by C<keyword()>. It must not be equal to 0.
14797 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14800 int i = 0, n = 0, seen_question = 0, defgv = 0;
14802 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14803 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14804 bool nullret = FALSE;
14806 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14810 if (!sv) sv = sv_newmortal();
14812 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14814 switch (code < 0 ? -code : code) {
14815 case KEY_and : case KEY_chop: case KEY_chomp:
14816 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14817 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14818 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14819 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14820 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14821 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14822 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14823 case KEY_x : case KEY_xor :
14824 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14825 case KEY_glob: retsetpvs("_;", OP_GLOB);
14826 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
14827 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
14828 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
14829 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14830 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14832 case KEY_evalbytes:
14833 name = "entereval"; break;
14841 while (i < MAXO) { /* The slow way. */
14842 if (strEQ(name, PL_op_name[i])
14843 || strEQ(name, PL_op_desc[i]))
14845 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14852 defgv = PL_opargs[i] & OA_DEFGV;
14853 oa = PL_opargs[i] >> OASHIFT;
14855 if (oa & OA_OPTIONAL && !seen_question && (
14856 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14861 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14862 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14863 /* But globs are already references (kinda) */
14864 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14868 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14869 && !scalar_mod_type(NULL, i)) {
14874 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14878 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14879 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14880 str[n-1] = '_'; defgv = 0;
14884 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14886 sv_setpvn(sv, str, n - 1);
14887 if (opnum) *opnum = i;
14892 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14895 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14898 PERL_ARGS_ASSERT_CORESUB_OP;
14902 return op_append_elem(OP_LINESEQ,
14905 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14912 o = newUNOP(OP_AVHVSWITCH,0,argop);
14913 o->op_private = opnum-OP_EACH;
14915 case OP_SELECT: /* which represents OP_SSELECT as well */
14920 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14921 newSVOP(OP_CONST, 0, newSVuv(1))
14923 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14925 coresub_op(coreargssv, 0, OP_SELECT)
14929 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14931 return op_append_elem(
14934 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14935 ? OPpOFFBYONE << 8 : 0)
14937 case OA_BASEOP_OR_UNOP:
14938 if (opnum == OP_ENTEREVAL) {
14939 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14940 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14942 else o = newUNOP(opnum,0,argop);
14943 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14946 if (is_handle_constructor(o, 1))
14947 argop->op_private |= OPpCOREARGS_DEREF1;
14948 if (scalar_mod_type(NULL, opnum))
14949 argop->op_private |= OPpCOREARGS_SCALARMOD;
14953 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14954 if (is_handle_constructor(o, 2))
14955 argop->op_private |= OPpCOREARGS_DEREF2;
14956 if (opnum == OP_SUBSTR) {
14957 o->op_private |= OPpMAYBE_LVSUB;
14966 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14967 SV * const *new_const_svp)
14969 const char *hvname;
14970 bool is_const = !!CvCONST(old_cv);
14971 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14973 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14975 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14977 /* They are 2 constant subroutines generated from
14978 the same constant. This probably means that
14979 they are really the "same" proxy subroutine
14980 instantiated in 2 places. Most likely this is
14981 when a constant is exported twice. Don't warn.
14984 (ckWARN(WARN_REDEFINE)
14986 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14987 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14988 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14989 strEQ(hvname, "autouse"))
14993 && ckWARN_d(WARN_REDEFINE)
14994 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14997 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14999 ? "Constant subroutine %"SVf" redefined"
15000 : "Subroutine %"SVf" redefined",
15005 =head1 Hook manipulation
15007 These functions provide convenient and thread-safe means of manipulating
15014 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
15016 Puts a C function into the chain of check functions for a specified op
15017 type. This is the preferred way to manipulate the L</PL_check> array.
15018 C<opcode> specifies which type of op is to be affected. C<new_checker>
15019 is a pointer to the C function that is to be added to that opcode's
15020 check chain, and C<old_checker_p> points to the storage location where a
15021 pointer to the next function in the chain will be stored. The value of
15022 C<new_pointer> is written into the L</PL_check> array, while the value
15023 previously stored there is written to C<*old_checker_p>.
15025 The function should be defined like this:
15027 static OP *new_checker(pTHX_ OP *op) { ... }
15029 It is intended to be called in this manner:
15031 new_checker(aTHX_ op)
15033 C<old_checker_p> should be defined like this:
15035 static Perl_check_t old_checker_p;
15037 L</PL_check> is global to an entire process, and a module wishing to
15038 hook op checking may find itself invoked more than once per process,
15039 typically in different threads. To handle that situation, this function
15040 is idempotent. The location C<*old_checker_p> must initially (once
15041 per process) contain a null pointer. A C variable of static duration
15042 (declared at file scope, typically also marked C<static> to give
15043 it internal linkage) will be implicitly initialised appropriately,
15044 if it does not have an explicit initialiser. This function will only
15045 actually modify the check chain if it finds C<*old_checker_p> to be null.
15046 This function is also thread safe on the small scale. It uses appropriate
15047 locking to avoid race conditions in accessing L</PL_check>.
15049 When this function is called, the function referenced by C<new_checker>
15050 must be ready to be called, except for C<*old_checker_p> being unfilled.
15051 In a threading situation, C<new_checker> may be called immediately,
15052 even before this function has returned. C<*old_checker_p> will always
15053 be appropriately set before C<new_checker> is called. If C<new_checker>
15054 decides not to do anything special with an op that it is given (which
15055 is the usual case for most uses of op check hooking), it must chain the
15056 check function referenced by C<*old_checker_p>.
15058 If you want to influence compilation of calls to a specific subroutine,
15059 then use L</cv_set_call_checker> rather than hooking checking of all
15066 Perl_wrap_op_checker(pTHX_ Optype opcode,
15067 Perl_check_t new_checker, Perl_check_t *old_checker_p)
15071 PERL_UNUSED_CONTEXT;
15072 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
15073 if (*old_checker_p) return;
15074 OP_CHECK_MUTEX_LOCK;
15075 if (!*old_checker_p) {
15076 *old_checker_p = PL_check[opcode];
15077 PL_check[opcode] = new_checker;
15079 OP_CHECK_MUTEX_UNLOCK;
15084 /* Efficient sub that returns a constant scalar value. */
15086 const_sv_xsub(pTHX_ CV* cv)
15089 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
15090 PERL_UNUSED_ARG(items);
15100 const_av_xsub(pTHX_ CV* cv)
15103 AV * const av = MUTABLE_AV(XSANY.any_ptr);
15111 if (SvRMAGICAL(av))
15112 Perl_croak(aTHX_ "Magical list constants are not supported");
15113 if (GIMME_V != G_ARRAY) {
15115 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15118 EXTEND(SP, AvFILLp(av)+1);
15119 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15120 XSRETURN(AvFILLp(av)+1);
15125 * ex: set ts=8 sts=4 sw=4 et: