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) {
856 #ifdef DEBUG_LEAKING_SCALARS
860 } while ( (o = POP_DEFERRED_OP()) );
862 Safefree(defer_stack);
865 /* S_op_clear_gv(): free a GV attached to an OP */
869 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
871 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
875 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
876 || o->op_type == OP_MULTIDEREF)
879 ? ((GV*)PAD_SVl(*ixp)) : NULL;
881 ? (GV*)(*svp) : NULL;
883 /* It's possible during global destruction that the GV is freed
884 before the optree. Whilst the SvREFCNT_inc is happy to bump from
885 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
886 will trigger an assertion failure, because the entry to sv_clear
887 checks that the scalar is not already freed. A check of for
888 !SvIS_FREED(gv) turns out to be invalid, because during global
889 destruction the reference count can be forced down to zero
890 (with SVf_BREAK set). In which case raising to 1 and then
891 dropping to 0 triggers cleanup before it should happen. I
892 *think* that this might actually be a general, systematic,
893 weakness of the whole idea of SVf_BREAK, in that code *is*
894 allowed to raise and lower references during global destruction,
895 so any *valid* code that happens to do this during global
896 destruction might well trigger premature cleanup. */
897 bool still_valid = gv && SvREFCNT(gv);
900 SvREFCNT_inc_simple_void(gv);
903 pad_swipe(*ixp, TRUE);
911 int try_downgrade = SvREFCNT(gv) == 2;
914 gv_try_downgrade(gv);
920 Perl_op_clear(pTHX_ OP *o)
925 PERL_ARGS_ASSERT_OP_CLEAR;
927 switch (o->op_type) {
928 case OP_NULL: /* Was holding old type, if any. */
931 case OP_ENTEREVAL: /* Was holding hints. */
932 case OP_ARGDEFELEM: /* Was holding signature index. */
936 if (!(o->op_flags & OPf_REF)
937 || (PL_check[o->op_type] != Perl_ck_ftst))
944 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
946 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
949 case OP_METHOD_REDIR:
950 case OP_METHOD_REDIR_SUPER:
952 if (cMETHOPx(o)->op_rclass_targ) {
953 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
954 cMETHOPx(o)->op_rclass_targ = 0;
957 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
958 cMETHOPx(o)->op_rclass_sv = NULL;
960 case OP_METHOD_NAMED:
961 case OP_METHOD_SUPER:
962 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
963 cMETHOPx(o)->op_u.op_meth_sv = NULL;
966 pad_swipe(o->op_targ, 1);
973 SvREFCNT_dec(cSVOPo->op_sv);
974 cSVOPo->op_sv = NULL;
977 Even if op_clear does a pad_free for the target of the op,
978 pad_free doesn't actually remove the sv that exists in the pad;
979 instead it lives on. This results in that it could be reused as
980 a target later on when the pad was reallocated.
983 pad_swipe(o->op_targ,1);
993 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
998 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
999 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
1001 if (cPADOPo->op_padix > 0) {
1002 pad_swipe(cPADOPo->op_padix, TRUE);
1003 cPADOPo->op_padix = 0;
1006 SvREFCNT_dec(cSVOPo->op_sv);
1007 cSVOPo->op_sv = NULL;
1011 PerlMemShared_free(cPVOPo->op_pv);
1012 cPVOPo->op_pv = NULL;
1016 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1020 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
1021 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1024 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1030 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1031 op_free(cPMOPo->op_code_list);
1032 cPMOPo->op_code_list = NULL;
1033 forget_pmop(cPMOPo);
1034 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1035 /* we use the same protection as the "SAFE" version of the PM_ macros
1036 * here since sv_clean_all might release some PMOPs
1037 * after PL_regex_padav has been cleared
1038 * and the clearing of PL_regex_padav needs to
1039 * happen before sv_clean_all
1042 if(PL_regex_pad) { /* We could be in destruction */
1043 const IV offset = (cPMOPo)->op_pmoffset;
1044 ReREFCNT_dec(PM_GETRE(cPMOPo));
1045 PL_regex_pad[offset] = &PL_sv_undef;
1046 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1050 ReREFCNT_dec(PM_GETRE(cPMOPo));
1051 PM_SETRE(cPMOPo, NULL);
1057 PerlMemShared_free(cUNOP_AUXo->op_aux);
1062 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1063 UV actions = items->uv;
1065 bool is_hash = FALSE;
1068 switch (actions & MDEREF_ACTION_MASK) {
1071 actions = (++items)->uv;
1074 case MDEREF_HV_padhv_helem:
1076 case MDEREF_AV_padav_aelem:
1077 pad_free((++items)->pad_offset);
1080 case MDEREF_HV_gvhv_helem:
1082 case MDEREF_AV_gvav_aelem:
1084 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1086 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1090 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1092 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1094 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1096 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1098 goto do_vivify_rv2xv_elem;
1100 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1102 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1103 pad_free((++items)->pad_offset);
1104 goto do_vivify_rv2xv_elem;
1106 case MDEREF_HV_pop_rv2hv_helem:
1107 case MDEREF_HV_vivify_rv2hv_helem:
1109 do_vivify_rv2xv_elem:
1110 case MDEREF_AV_pop_rv2av_aelem:
1111 case MDEREF_AV_vivify_rv2av_aelem:
1113 switch (actions & MDEREF_INDEX_MASK) {
1114 case MDEREF_INDEX_none:
1117 case MDEREF_INDEX_const:
1121 pad_swipe((++items)->pad_offset, 1);
1123 SvREFCNT_dec((++items)->sv);
1129 case MDEREF_INDEX_padsv:
1130 pad_free((++items)->pad_offset);
1132 case MDEREF_INDEX_gvsv:
1134 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1136 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1141 if (actions & MDEREF_FLAG_last)
1154 actions >>= MDEREF_SHIFT;
1157 /* start of malloc is at op_aux[-1], where the length is
1159 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1164 if (o->op_targ > 0) {
1165 pad_free(o->op_targ);
1171 S_cop_free(pTHX_ COP* cop)
1173 PERL_ARGS_ASSERT_COP_FREE;
1176 if (! specialWARN(cop->cop_warnings))
1177 PerlMemShared_free(cop->cop_warnings);
1178 cophh_free(CopHINTHASH_get(cop));
1179 if (PL_curcop == cop)
1184 S_forget_pmop(pTHX_ PMOP *const o
1187 HV * const pmstash = PmopSTASH(o);
1189 PERL_ARGS_ASSERT_FORGET_PMOP;
1191 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1192 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1194 PMOP **const array = (PMOP**) mg->mg_ptr;
1195 U32 count = mg->mg_len / sizeof(PMOP**);
1199 if (array[i] == o) {
1200 /* Found it. Move the entry at the end to overwrite it. */
1201 array[i] = array[--count];
1202 mg->mg_len = count * sizeof(PMOP**);
1203 /* Could realloc smaller at this point always, but probably
1204 not worth it. Probably worth free()ing if we're the
1207 Safefree(mg->mg_ptr);
1220 S_find_and_forget_pmops(pTHX_ OP *o)
1222 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1224 if (o->op_flags & OPf_KIDS) {
1225 OP *kid = cUNOPo->op_first;
1227 switch (kid->op_type) {
1232 forget_pmop((PMOP*)kid);
1234 find_and_forget_pmops(kid);
1235 kid = OpSIBLING(kid);
1241 =for apidoc Am|void|op_null|OP *o
1243 Neutralizes an op when it is no longer needed, but is still linked to from
1250 Perl_op_null(pTHX_ OP *o)
1254 PERL_ARGS_ASSERT_OP_NULL;
1256 if (o->op_type == OP_NULL)
1259 o->op_targ = o->op_type;
1260 OpTYPE_set(o, OP_NULL);
1264 Perl_op_refcnt_lock(pTHX)
1265 PERL_TSA_ACQUIRE(PL_op_mutex)
1270 PERL_UNUSED_CONTEXT;
1275 Perl_op_refcnt_unlock(pTHX)
1276 PERL_TSA_RELEASE(PL_op_mutex)
1281 PERL_UNUSED_CONTEXT;
1287 =for apidoc op_sibling_splice
1289 A general function for editing the structure of an existing chain of
1290 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1291 you to delete zero or more sequential nodes, replacing them with zero or
1292 more different nodes. Performs the necessary op_first/op_last
1293 housekeeping on the parent node and op_sibling manipulation on the
1294 children. The last deleted node will be marked as as the last node by
1295 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1297 Note that op_next is not manipulated, and nodes are not freed; that is the
1298 responsibility of the caller. It also won't create a new list op for an
1299 empty list etc; use higher-level functions like op_append_elem() for that.
1301 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1302 the splicing doesn't affect the first or last op in the chain.
1304 C<start> is the node preceding the first node to be spliced. Node(s)
1305 following it will be deleted, and ops will be inserted after it. If it is
1306 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1309 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1310 If -1 or greater than or equal to the number of remaining kids, all
1311 remaining kids are deleted.
1313 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1314 If C<NULL>, no nodes are inserted.
1316 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1321 action before after returns
1322 ------ ----- ----- -------
1325 splice(P, A, 2, X-Y-Z) | | B-C
1329 splice(P, NULL, 1, X-Y) | | A
1333 splice(P, NULL, 3, NULL) | | A-B-C
1337 splice(P, B, 0, X-Y) | | NULL
1341 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1342 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1348 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1352 OP *last_del = NULL;
1353 OP *last_ins = NULL;
1356 first = OpSIBLING(start);
1360 first = cLISTOPx(parent)->op_first;
1362 assert(del_count >= -1);
1364 if (del_count && first) {
1366 while (--del_count && OpHAS_SIBLING(last_del))
1367 last_del = OpSIBLING(last_del);
1368 rest = OpSIBLING(last_del);
1369 OpLASTSIB_set(last_del, NULL);
1376 while (OpHAS_SIBLING(last_ins))
1377 last_ins = OpSIBLING(last_ins);
1378 OpMAYBESIB_set(last_ins, rest, NULL);
1384 OpMAYBESIB_set(start, insert, NULL);
1389 cLISTOPx(parent)->op_first = insert;
1391 parent->op_flags |= OPf_KIDS;
1393 parent->op_flags &= ~OPf_KIDS;
1397 /* update op_last etc */
1404 /* ought to use OP_CLASS(parent) here, but that can't handle
1405 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1407 type = parent->op_type;
1408 if (type == OP_CUSTOM) {
1410 type = XopENTRYCUSTOM(parent, xop_class);
1413 if (type == OP_NULL)
1414 type = parent->op_targ;
1415 type = PL_opargs[type] & OA_CLASS_MASK;
1418 lastop = last_ins ? last_ins : start ? start : NULL;
1419 if ( type == OA_BINOP
1420 || type == OA_LISTOP
1424 cLISTOPx(parent)->op_last = lastop;
1427 OpLASTSIB_set(lastop, parent);
1429 return last_del ? first : NULL;
1432 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1436 #ifdef PERL_OP_PARENT
1439 =for apidoc op_parent
1441 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1442 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1448 Perl_op_parent(OP *o)
1450 PERL_ARGS_ASSERT_OP_PARENT;
1451 while (OpHAS_SIBLING(o))
1453 return o->op_sibparent;
1459 /* replace the sibling following start with a new UNOP, which becomes
1460 * the parent of the original sibling; e.g.
1462 * op_sibling_newUNOP(P, A, unop-args...)
1470 * where U is the new UNOP.
1472 * parent and start args are the same as for op_sibling_splice();
1473 * type and flags args are as newUNOP().
1475 * Returns the new UNOP.
1479 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1483 kid = op_sibling_splice(parent, start, 1, NULL);
1484 newop = newUNOP(type, flags, kid);
1485 op_sibling_splice(parent, start, 0, newop);
1490 /* lowest-level newLOGOP-style function - just allocates and populates
1491 * the struct. Higher-level stuff should be done by S_new_logop() /
1492 * newLOGOP(). This function exists mainly to avoid op_first assignment
1493 * being spread throughout this file.
1497 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1502 NewOp(1101, logop, 1, LOGOP);
1503 OpTYPE_set(logop, type);
1504 logop->op_first = first;
1505 logop->op_other = other;
1506 logop->op_flags = OPf_KIDS;
1507 while (kid && OpHAS_SIBLING(kid))
1508 kid = OpSIBLING(kid);
1510 OpLASTSIB_set(kid, (OP*)logop);
1515 /* Contextualizers */
1518 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1520 Applies a syntactic context to an op tree representing an expression.
1521 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1522 or C<G_VOID> to specify the context to apply. The modified op tree
1529 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1531 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1533 case G_SCALAR: return scalar(o);
1534 case G_ARRAY: return list(o);
1535 case G_VOID: return scalarvoid(o);
1537 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1544 =for apidoc Am|OP*|op_linklist|OP *o
1545 This function is the implementation of the L</LINKLIST> macro. It should
1546 not be called directly.
1552 Perl_op_linklist(pTHX_ OP *o)
1556 PERL_ARGS_ASSERT_OP_LINKLIST;
1561 /* establish postfix order */
1562 first = cUNOPo->op_first;
1565 o->op_next = LINKLIST(first);
1568 OP *sibl = OpSIBLING(kid);
1570 kid->op_next = LINKLIST(sibl);
1585 S_scalarkids(pTHX_ OP *o)
1587 if (o && o->op_flags & OPf_KIDS) {
1589 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1596 S_scalarboolean(pTHX_ OP *o)
1598 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1600 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1601 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1602 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1603 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1604 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1605 if (ckWARN(WARN_SYNTAX)) {
1606 const line_t oldline = CopLINE(PL_curcop);
1608 if (PL_parser && PL_parser->copline != NOLINE) {
1609 /* This ensures that warnings are reported at the first line
1610 of the conditional, not the last. */
1611 CopLINE_set(PL_curcop, PL_parser->copline);
1613 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1614 CopLINE_set(PL_curcop, oldline);
1621 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1624 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1625 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1627 const char funny = o->op_type == OP_PADAV
1628 || o->op_type == OP_RV2AV ? '@' : '%';
1629 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1631 if (cUNOPo->op_first->op_type != OP_GV
1632 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1634 return varname(gv, funny, 0, NULL, 0, subscript_type);
1637 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1642 S_op_varname(pTHX_ const OP *o)
1644 return S_op_varname_subscript(aTHX_ o, 1);
1648 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1649 { /* or not so pretty :-) */
1650 if (o->op_type == OP_CONST) {
1652 if (SvPOK(*retsv)) {
1654 *retsv = sv_newmortal();
1655 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1656 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1658 else if (!SvOK(*retsv))
1661 else *retpv = "...";
1665 S_scalar_slice_warning(pTHX_ const OP *o)
1669 o->op_type == OP_HSLICE ? '{' : '[';
1671 o->op_type == OP_HSLICE ? '}' : ']';
1673 SV *keysv = NULL; /* just to silence compiler warnings */
1674 const char *key = NULL;
1676 if (!(o->op_private & OPpSLICEWARNING))
1678 if (PL_parser && PL_parser->error_count)
1679 /* This warning can be nonsensical when there is a syntax error. */
1682 kid = cLISTOPo->op_first;
1683 kid = OpSIBLING(kid); /* get past pushmark */
1684 /* weed out false positives: any ops that can return lists */
1685 switch (kid->op_type) {
1711 /* Don't warn if we have a nulled list either. */
1712 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1715 assert(OpSIBLING(kid));
1716 name = S_op_varname(aTHX_ OpSIBLING(kid));
1717 if (!name) /* XS module fiddling with the op tree */
1719 S_op_pretty(aTHX_ kid, &keysv, &key);
1720 assert(SvPOK(name));
1721 sv_chop(name,SvPVX(name)+1);
1723 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1724 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1725 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1727 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1728 lbrack, key, rbrack);
1730 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1731 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1732 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1734 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1735 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1739 Perl_scalar(pTHX_ OP *o)
1743 /* assumes no premature commitment */
1744 if (!o || (PL_parser && PL_parser->error_count)
1745 || (o->op_flags & OPf_WANT)
1746 || o->op_type == OP_RETURN)
1751 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1753 switch (o->op_type) {
1755 scalar(cBINOPo->op_first);
1756 if (o->op_private & OPpREPEAT_DOLIST) {
1757 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1758 assert(kid->op_type == OP_PUSHMARK);
1759 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1760 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1761 o->op_private &=~ OPpREPEAT_DOLIST;
1768 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1778 if (o->op_flags & OPf_KIDS) {
1779 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1785 kid = cLISTOPo->op_first;
1787 kid = OpSIBLING(kid);
1790 OP *sib = OpSIBLING(kid);
1791 if (sib && kid->op_type != OP_LEAVEWHEN
1792 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1793 || ( sib->op_targ != OP_NEXTSTATE
1794 && sib->op_targ != OP_DBSTATE )))
1800 PL_curcop = &PL_compiling;
1805 kid = cLISTOPo->op_first;
1808 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1813 /* Warn about scalar context */
1814 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1815 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1818 const char *key = NULL;
1820 /* This warning can be nonsensical when there is a syntax error. */
1821 if (PL_parser && PL_parser->error_count)
1824 if (!ckWARN(WARN_SYNTAX)) break;
1826 kid = cLISTOPo->op_first;
1827 kid = OpSIBLING(kid); /* get past pushmark */
1828 assert(OpSIBLING(kid));
1829 name = S_op_varname(aTHX_ OpSIBLING(kid));
1830 if (!name) /* XS module fiddling with the op tree */
1832 S_op_pretty(aTHX_ kid, &keysv, &key);
1833 assert(SvPOK(name));
1834 sv_chop(name,SvPVX(name)+1);
1836 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1837 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1838 "%%%"SVf"%c%s%c in scalar context better written "
1840 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1841 lbrack, key, rbrack);
1843 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1844 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1845 "%%%"SVf"%c%"SVf"%c in scalar context better "
1846 "written as $%"SVf"%c%"SVf"%c",
1847 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1848 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1855 Perl_scalarvoid(pTHX_ OP *arg)
1861 SSize_t defer_stack_alloc = 0;
1862 SSize_t defer_ix = -1;
1863 OP **defer_stack = NULL;
1866 PERL_ARGS_ASSERT_SCALARVOID;
1869 SV *useless_sv = NULL;
1870 const char* useless = NULL;
1872 if (o->op_type == OP_NEXTSTATE
1873 || o->op_type == OP_DBSTATE
1874 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1875 || o->op_targ == OP_DBSTATE)))
1876 PL_curcop = (COP*)o; /* for warning below */
1878 /* assumes no premature commitment */
1879 want = o->op_flags & OPf_WANT;
1880 if ((want && want != OPf_WANT_SCALAR)
1881 || (PL_parser && PL_parser->error_count)
1882 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1887 if ((o->op_private & OPpTARGET_MY)
1888 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1890 /* newASSIGNOP has already applied scalar context, which we
1891 leave, as if this op is inside SASSIGN. */
1895 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1897 switch (o->op_type) {
1899 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1903 if (o->op_flags & OPf_STACKED)
1905 if (o->op_type == OP_REPEAT)
1906 scalar(cBINOPo->op_first);
1909 if (o->op_private == 4)
1944 case OP_GETSOCKNAME:
1945 case OP_GETPEERNAME:
1950 case OP_GETPRIORITY:
1975 useless = OP_DESC(o);
1985 case OP_AELEMFAST_LEX:
1989 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1990 /* Otherwise it's "Useless use of grep iterator" */
1991 useless = OP_DESC(o);
1995 kid = cLISTOPo->op_first;
1996 if (kid && kid->op_type == OP_PUSHRE
1998 && !(o->op_flags & OPf_STACKED)
2000 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
2002 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
2005 useless = OP_DESC(o);
2009 kid = cUNOPo->op_first;
2010 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2011 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2014 useless = "negative pattern binding (!~)";
2018 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2019 useless = "non-destructive substitution (s///r)";
2023 useless = "non-destructive transliteration (tr///r)";
2030 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2031 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2032 useless = "a variable";
2037 if (cSVOPo->op_private & OPpCONST_STRICT)
2038 no_bareword_allowed(o);
2040 if (ckWARN(WARN_VOID)) {
2042 /* don't warn on optimised away booleans, eg
2043 * use constant Foo, 5; Foo || print; */
2044 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2046 /* the constants 0 and 1 are permitted as they are
2047 conventionally used as dummies in constructs like
2048 1 while some_condition_with_side_effects; */
2049 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2051 else if (SvPOK(sv)) {
2052 SV * const dsv = newSVpvs("");
2054 = Perl_newSVpvf(aTHX_
2056 pv_pretty(dsv, SvPVX_const(sv),
2057 SvCUR(sv), 32, NULL, NULL,
2059 | PERL_PV_ESCAPE_NOCLEAR
2060 | PERL_PV_ESCAPE_UNI_DETECT));
2061 SvREFCNT_dec_NN(dsv);
2063 else if (SvOK(sv)) {
2064 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
2067 useless = "a constant (undef)";
2070 op_null(o); /* don't execute or even remember it */
2074 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2078 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2082 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2086 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2091 UNOP *refgen, *rv2cv;
2094 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2097 rv2gv = ((BINOP *)o)->op_last;
2098 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2101 refgen = (UNOP *)((BINOP *)o)->op_first;
2103 if (!refgen || (refgen->op_type != OP_REFGEN
2104 && refgen->op_type != OP_SREFGEN))
2107 exlist = (LISTOP *)refgen->op_first;
2108 if (!exlist || exlist->op_type != OP_NULL
2109 || exlist->op_targ != OP_LIST)
2112 if (exlist->op_first->op_type != OP_PUSHMARK
2113 && exlist->op_first != exlist->op_last)
2116 rv2cv = (UNOP*)exlist->op_last;
2118 if (rv2cv->op_type != OP_RV2CV)
2121 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2122 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2123 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2125 o->op_private |= OPpASSIGN_CV_TO_GV;
2126 rv2gv->op_private |= OPpDONT_INIT_GV;
2127 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2139 kid = cLOGOPo->op_first;
2140 if (kid->op_type == OP_NOT
2141 && (kid->op_flags & OPf_KIDS)) {
2142 if (o->op_type == OP_AND) {
2143 OpTYPE_set(o, OP_OR);
2145 OpTYPE_set(o, OP_AND);
2155 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2156 if (!(kid->op_flags & OPf_KIDS))
2163 if (o->op_flags & OPf_STACKED)
2170 if (!(o->op_flags & OPf_KIDS))
2181 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2182 if (!(kid->op_flags & OPf_KIDS))
2188 /* If the first kid after pushmark is something that the padrange
2189 optimisation would reject, then null the list and the pushmark.
2191 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
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
2197 || !(kid = OpSIBLING(kid))
2198 || ( kid->op_type != OP_PADSV
2199 && kid->op_type != OP_PADAV
2200 && kid->op_type != OP_PADHV)
2201 || kid->op_private & ~OPpLVAL_INTRO)
2203 op_null(cUNOPo->op_first); /* NULL the pushmark */
2204 op_null(o); /* NULL the list */
2216 /* mortalise it, in case warnings are fatal. */
2217 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2218 "Useless use of %"SVf" in void context",
2219 SVfARG(sv_2mortal(useless_sv)));
2222 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2223 "Useless use of %s in void context",
2226 } while ( (o = POP_DEFERRED_OP()) );
2228 Safefree(defer_stack);
2234 S_listkids(pTHX_ OP *o)
2236 if (o && o->op_flags & OPf_KIDS) {
2238 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2245 Perl_list(pTHX_ OP *o)
2249 /* assumes no premature commitment */
2250 if (!o || (o->op_flags & OPf_WANT)
2251 || (PL_parser && PL_parser->error_count)
2252 || o->op_type == OP_RETURN)
2257 if ((o->op_private & OPpTARGET_MY)
2258 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2260 return o; /* As if inside SASSIGN */
2263 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2265 switch (o->op_type) {
2267 list(cBINOPo->op_first);
2270 if (o->op_private & OPpREPEAT_DOLIST
2271 && !(o->op_flags & OPf_STACKED))
2273 list(cBINOPo->op_first);
2274 kid = cBINOPo->op_last;
2275 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2276 && SvIVX(kSVOP_sv) == 1)
2278 op_null(o); /* repeat */
2279 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2281 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2288 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2296 if (!(o->op_flags & OPf_KIDS))
2298 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2299 list(cBINOPo->op_first);
2300 return gen_constant_list(o);
2306 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2307 op_null(cUNOPo->op_first); /* NULL the pushmark */
2308 op_null(o); /* NULL the list */
2313 kid = cLISTOPo->op_first;
2315 kid = OpSIBLING(kid);
2318 OP *sib = OpSIBLING(kid);
2319 if (sib && kid->op_type != OP_LEAVEWHEN)
2325 PL_curcop = &PL_compiling;
2329 kid = cLISTOPo->op_first;
2336 S_scalarseq(pTHX_ OP *o)
2339 const OPCODE type = o->op_type;
2341 if (type == OP_LINESEQ || type == OP_SCOPE ||
2342 type == OP_LEAVE || type == OP_LEAVETRY)
2345 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2346 if ((sib = OpSIBLING(kid))
2347 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2348 || ( sib->op_targ != OP_NEXTSTATE
2349 && sib->op_targ != OP_DBSTATE )))
2354 PL_curcop = &PL_compiling;
2356 o->op_flags &= ~OPf_PARENS;
2357 if (PL_hints & HINT_BLOCK_SCOPE)
2358 o->op_flags |= OPf_PARENS;
2361 o = newOP(OP_STUB, 0);
2366 S_modkids(pTHX_ OP *o, I32 type)
2368 if (o && o->op_flags & OPf_KIDS) {
2370 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2371 op_lvalue(kid, type);
2377 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2378 * const fields. Also, convert CONST keys to HEK-in-SVs.
2379 * rop is the op that retrieves the hash;
2380 * key_op is the first key
2384 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2390 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2392 if (rop->op_first->op_type == OP_PADSV)
2393 /* @$hash{qw(keys here)} */
2394 rop = (UNOP*)rop->op_first;
2396 /* @{$hash}{qw(keys here)} */
2397 if (rop->op_first->op_type == OP_SCOPE
2398 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2400 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2407 lexname = NULL; /* just to silence compiler warnings */
2408 fields = NULL; /* just to silence compiler warnings */
2412 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2413 SvPAD_TYPED(lexname))
2414 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2415 && isGV(*fields) && GvHV(*fields);
2417 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2419 if (key_op->op_type != OP_CONST)
2421 svp = cSVOPx_svp(key_op);
2423 /* make sure it's not a bareword under strict subs */
2424 if (key_op->op_private & OPpCONST_BARE &&
2425 key_op->op_private & OPpCONST_STRICT)
2427 no_bareword_allowed((OP*)key_op);
2430 /* Make the CONST have a shared SV */
2431 if ( !SvIsCOW_shared_hash(sv = *svp)
2432 && SvTYPE(sv) < SVt_PVMG
2437 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2438 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2439 SvREFCNT_dec_NN(sv);
2444 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2446 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2447 "in variable %"PNf" of type %"HEKf,
2448 SVfARG(*svp), PNfARG(lexname),
2449 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2456 =for apidoc finalize_optree
2458 This function finalizes the optree. Should be called directly after
2459 the complete optree is built. It does some additional
2460 checking which can't be done in the normal C<ck_>xxx functions and makes
2461 the tree thread-safe.
2466 Perl_finalize_optree(pTHX_ OP* o)
2468 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2471 SAVEVPTR(PL_curcop);
2479 /* Relocate sv to the pad for thread safety.
2480 * Despite being a "constant", the SV is written to,
2481 * for reference counts, sv_upgrade() etc. */
2482 PERL_STATIC_INLINE void
2483 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2486 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2488 ix = pad_alloc(OP_CONST, SVf_READONLY);
2489 SvREFCNT_dec(PAD_SVl(ix));
2490 PAD_SETSV(ix, *svp);
2491 /* XXX I don't know how this isn't readonly already. */
2492 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2500 S_finalize_op(pTHX_ OP* o)
2502 PERL_ARGS_ASSERT_FINALIZE_OP;
2505 switch (o->op_type) {
2508 PL_curcop = ((COP*)o); /* for warnings */
2511 if (OpHAS_SIBLING(o)) {
2512 OP *sib = OpSIBLING(o);
2513 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2514 && ckWARN(WARN_EXEC)
2515 && OpHAS_SIBLING(sib))
2517 const OPCODE type = OpSIBLING(sib)->op_type;
2518 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2519 const line_t oldline = CopLINE(PL_curcop);
2520 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2521 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2522 "Statement unlikely to be reached");
2523 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2524 "\t(Maybe you meant system() when you said exec()?)\n");
2525 CopLINE_set(PL_curcop, oldline);
2532 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2533 GV * const gv = cGVOPo_gv;
2534 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2535 /* XXX could check prototype here instead of just carping */
2536 SV * const sv = sv_newmortal();
2537 gv_efullname3(sv, gv, NULL);
2538 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2539 "%"SVf"() called too early to check prototype",
2546 if (cSVOPo->op_private & OPpCONST_STRICT)
2547 no_bareword_allowed(o);
2551 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2556 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2557 case OP_METHOD_NAMED:
2558 case OP_METHOD_SUPER:
2559 case OP_METHOD_REDIR:
2560 case OP_METHOD_REDIR_SUPER:
2561 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2570 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2573 rop = (UNOP*)((BINOP*)o)->op_first;
2578 S_scalar_slice_warning(aTHX_ o);
2582 kid = OpSIBLING(cLISTOPo->op_first);
2583 if (/* I bet there's always a pushmark... */
2584 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2585 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2590 key_op = (SVOP*)(kid->op_type == OP_CONST
2592 : OpSIBLING(kLISTOP->op_first));
2594 rop = (UNOP*)((LISTOP*)o)->op_last;
2597 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2599 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2603 S_scalar_slice_warning(aTHX_ o);
2607 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2608 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2615 if (o->op_flags & OPf_KIDS) {
2619 /* check that op_last points to the last sibling, and that
2620 * the last op_sibling/op_sibparent field points back to the
2621 * parent, and that the only ops with KIDS are those which are
2622 * entitled to them */
2623 U32 type = o->op_type;
2627 if (type == OP_NULL) {
2629 /* ck_glob creates a null UNOP with ex-type GLOB
2630 * (which is a list op. So pretend it wasn't a listop */
2631 if (type == OP_GLOB)
2634 family = PL_opargs[type] & OA_CLASS_MASK;
2636 has_last = ( family == OA_BINOP
2637 || family == OA_LISTOP
2638 || family == OA_PMOP
2639 || family == OA_LOOP
2641 assert( has_last /* has op_first and op_last, or ...
2642 ... has (or may have) op_first: */
2643 || family == OA_UNOP
2644 || family == OA_UNOP_AUX
2645 || family == OA_LOGOP
2646 || family == OA_BASEOP_OR_UNOP
2647 || family == OA_FILESTATOP
2648 || family == OA_LOOPEXOP
2649 || family == OA_METHOP
2650 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2651 || type == OP_SASSIGN
2652 || type == OP_CUSTOM
2653 || type == OP_NULL /* new_logop does this */
2656 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2657 # ifdef PERL_OP_PARENT
2658 if (!OpHAS_SIBLING(kid)) {
2660 assert(kid == cLISTOPo->op_last);
2661 assert(kid->op_sibparent == o);
2664 if (has_last && !OpHAS_SIBLING(kid))
2665 assert(kid == cLISTOPo->op_last);
2670 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2676 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2678 Propagate lvalue ("modifiable") context to an op and its children.
2679 C<type> represents the context type, roughly based on the type of op that
2680 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2681 because it has no op type of its own (it is signalled by a flag on
2684 This function detects things that can't be modified, such as C<$x+1>, and
2685 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2686 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2688 It also flags things that need to behave specially in an lvalue context,
2689 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2695 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2698 PadnameLVALUE_on(pn);
2699 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2701 /* RT #127786: cv can be NULL due to an eval within the DB package
2702 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2703 * unless they contain an eval, but calling eval within DB
2704 * pretends the eval was done in the caller's scope.
2708 assert(CvPADLIST(cv));
2710 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2711 assert(PadnameLEN(pn));
2712 PadnameLVALUE_on(pn);
2717 S_vivifies(const OPCODE type)
2720 case OP_RV2AV: case OP_ASLICE:
2721 case OP_RV2HV: case OP_KVASLICE:
2722 case OP_RV2SV: case OP_HSLICE:
2723 case OP_AELEMFAST: case OP_KVHSLICE:
2732 S_lvref(pTHX_ OP *o, I32 type)
2736 switch (o->op_type) {
2738 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2739 kid = OpSIBLING(kid))
2740 S_lvref(aTHX_ kid, type);
2745 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2746 o->op_flags |= OPf_STACKED;
2747 if (o->op_flags & OPf_PARENS) {
2748 if (o->op_private & OPpLVAL_INTRO) {
2749 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2750 "localized parenthesized array in list assignment"));
2754 OpTYPE_set(o, OP_LVAVREF);
2755 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2756 o->op_flags |= OPf_MOD|OPf_REF;
2759 o->op_private |= OPpLVREF_AV;
2762 kid = cUNOPo->op_first;
2763 if (kid->op_type == OP_NULL)
2764 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2766 o->op_private = OPpLVREF_CV;
2767 if (kid->op_type == OP_GV)
2768 o->op_flags |= OPf_STACKED;
2769 else if (kid->op_type == OP_PADCV) {
2770 o->op_targ = kid->op_targ;
2772 op_free(cUNOPo->op_first);
2773 cUNOPo->op_first = NULL;
2774 o->op_flags &=~ OPf_KIDS;
2779 if (o->op_flags & OPf_PARENS) {
2781 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2782 "parenthesized hash in list assignment"));
2785 o->op_private |= OPpLVREF_HV;
2789 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2790 o->op_flags |= OPf_STACKED;
2793 if (o->op_flags & OPf_PARENS) goto parenhash;
2794 o->op_private |= OPpLVREF_HV;
2797 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2800 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2801 if (o->op_flags & OPf_PARENS) goto slurpy;
2802 o->op_private |= OPpLVREF_AV;
2806 o->op_private |= OPpLVREF_ELEM;
2807 o->op_flags |= OPf_STACKED;
2811 OpTYPE_set(o, OP_LVREFSLICE);
2812 o->op_private &= OPpLVAL_INTRO;
2815 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2817 else if (!(o->op_flags & OPf_KIDS))
2819 if (o->op_targ != OP_LIST) {
2820 S_lvref(aTHX_ cBINOPo->op_first, type);
2825 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2826 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2827 S_lvref(aTHX_ kid, type);
2831 if (o->op_flags & OPf_PARENS)
2836 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2837 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2838 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2843 OpTYPE_set(o, OP_LVREF);
2845 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2846 if (type == OP_ENTERLOOP)
2847 o->op_private |= OPpLVREF_ITER;
2850 PERL_STATIC_INLINE bool
2851 S_potential_mod_type(I32 type)
2853 /* Types that only potentially result in modification. */
2854 return type == OP_GREPSTART || type == OP_ENTERSUB
2855 || type == OP_REFGEN || type == OP_LEAVESUBLV;
2859 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2863 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2866 if (!o || (PL_parser && PL_parser->error_count))
2869 if ((o->op_private & OPpTARGET_MY)
2870 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2875 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2877 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2879 switch (o->op_type) {
2884 if ((o->op_flags & OPf_PARENS))
2888 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2889 !(o->op_flags & OPf_STACKED)) {
2890 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
2891 assert(cUNOPo->op_first->op_type == OP_NULL);
2892 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2895 else { /* lvalue subroutine call */
2896 o->op_private |= OPpLVAL_INTRO;
2897 PL_modcount = RETURN_UNLIMITED_NUMBER;
2898 if (S_potential_mod_type(type)) {
2899 o->op_private |= OPpENTERSUB_INARGS;
2902 else { /* Compile-time error message: */
2903 OP *kid = cUNOPo->op_first;
2908 if (kid->op_type != OP_PUSHMARK) {
2909 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2911 "panic: unexpected lvalue entersub "
2912 "args: type/targ %ld:%"UVuf,
2913 (long)kid->op_type, (UV)kid->op_targ);
2914 kid = kLISTOP->op_first;
2916 while (OpHAS_SIBLING(kid))
2917 kid = OpSIBLING(kid);
2918 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2919 break; /* Postpone until runtime */
2922 kid = kUNOP->op_first;
2923 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2924 kid = kUNOP->op_first;
2925 if (kid->op_type == OP_NULL)
2927 "Unexpected constant lvalue entersub "
2928 "entry via type/targ %ld:%"UVuf,
2929 (long)kid->op_type, (UV)kid->op_targ);
2930 if (kid->op_type != OP_GV) {
2937 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2938 ? MUTABLE_CV(SvRV(gv))
2944 if (flags & OP_LVALUE_NO_CROAK)
2947 namesv = cv_name(cv, NULL, 0);
2948 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2949 "subroutine call of &%"SVf" in %s",
2950 SVfARG(namesv), PL_op_desc[type]),
2958 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2959 /* grep, foreach, subcalls, refgen */
2960 if (S_potential_mod_type(type))
2962 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2963 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2966 type ? PL_op_desc[type] : "local"));
2979 case OP_RIGHT_SHIFT:
2988 if (!(o->op_flags & OPf_STACKED))
2994 if (o->op_flags & OPf_STACKED) {
2998 if (!(o->op_private & OPpREPEAT_DOLIST))
3001 const I32 mods = PL_modcount;
3002 modkids(cBINOPo->op_first, type);
3003 if (type != OP_AASSIGN)
3005 kid = cBINOPo->op_last;
3006 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3007 const IV iv = SvIV(kSVOP_sv);
3008 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3010 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3013 PL_modcount = RETURN_UNLIMITED_NUMBER;
3019 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3020 op_lvalue(kid, type);
3025 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3026 PL_modcount = RETURN_UNLIMITED_NUMBER;
3027 return o; /* Treat \(@foo) like ordinary list. */
3031 if (scalar_mod_type(o, type))
3033 ref(cUNOPo->op_first, o->op_type);
3040 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
3041 if (type == OP_LEAVESUBLV && (
3042 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3043 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3045 o->op_private |= OPpMAYBE_LVSUB;
3049 PL_modcount = RETURN_UNLIMITED_NUMBER;
3054 if (type == OP_LEAVESUBLV)
3055 o->op_private |= OPpMAYBE_LVSUB;
3058 if (type == OP_LEAVESUBLV
3059 && (o->op_private & 3) + OP_EACH == OP_KEYS)
3060 o->op_private |= OPpMAYBE_LVSUB;
3063 PL_hints |= HINT_BLOCK_SCOPE;
3064 if (type == OP_LEAVESUBLV)
3065 o->op_private |= OPpMAYBE_LVSUB;
3069 ref(cUNOPo->op_first, o->op_type);
3073 PL_hints |= HINT_BLOCK_SCOPE;
3083 case OP_AELEMFAST_LEX:
3090 PL_modcount = RETURN_UNLIMITED_NUMBER;
3091 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3092 return o; /* Treat \(@foo) like ordinary list. */
3093 if (scalar_mod_type(o, type))
3095 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3096 && type == OP_LEAVESUBLV)
3097 o->op_private |= OPpMAYBE_LVSUB;
3101 if (!type) /* local() */
3102 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3103 PNfARG(PAD_COMPNAME(o->op_targ)));
3104 if (!(o->op_private & OPpLVAL_INTRO)
3105 || ( type != OP_SASSIGN && type != OP_AASSIGN
3106 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3107 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3115 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3119 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3125 if (type == OP_LEAVESUBLV)
3126 o->op_private |= OPpMAYBE_LVSUB;
3127 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3128 /* substr and vec */
3129 /* If this op is in merely potential (non-fatal) modifiable
3130 context, then apply OP_ENTERSUB context to
3131 the kid op (to avoid croaking). Other-
3132 wise pass this op’s own type so the correct op is mentioned
3133 in error messages. */
3134 op_lvalue(OpSIBLING(cBINOPo->op_first),
3135 S_potential_mod_type(type)
3143 ref(cBINOPo->op_first, o->op_type);
3144 if (type == OP_ENTERSUB &&
3145 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3146 o->op_private |= OPpLVAL_DEFER;
3147 if (type == OP_LEAVESUBLV)
3148 o->op_private |= OPpMAYBE_LVSUB;
3155 o->op_private |= OPpLVALUE;
3161 if (o->op_flags & OPf_KIDS)
3162 op_lvalue(cLISTOPo->op_last, type);
3167 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3169 else if (!(o->op_flags & OPf_KIDS))
3171 if (o->op_targ != OP_LIST) {
3172 op_lvalue(cBINOPo->op_first, type);
3178 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3179 /* elements might be in void context because the list is
3180 in scalar context or because they are attribute sub calls */
3181 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3182 op_lvalue(kid, type);
3190 if (type == OP_LEAVESUBLV
3191 || !S_vivifies(cLOGOPo->op_first->op_type))
3192 op_lvalue(cLOGOPo->op_first, type);
3193 if (type == OP_LEAVESUBLV
3194 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3195 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3199 if (type == OP_NULL) { /* local */
3201 if (!FEATURE_MYREF_IS_ENABLED)
3202 Perl_croak(aTHX_ "The experimental declared_refs "
3203 "feature is not enabled");
3204 Perl_ck_warner_d(aTHX_
3205 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3206 "Declaring references is experimental");
3207 op_lvalue(cUNOPo->op_first, OP_NULL);
3210 if (type != OP_AASSIGN && type != OP_SASSIGN
3211 && type != OP_ENTERLOOP)
3213 /* Don’t bother applying lvalue context to the ex-list. */
3214 kid = cUNOPx(cUNOPo->op_first)->op_first;
3215 assert (!OpHAS_SIBLING(kid));
3218 if (type == OP_NULL) /* local */
3220 if (type != OP_AASSIGN) goto nomod;
3221 kid = cUNOPo->op_first;
3224 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3225 S_lvref(aTHX_ kid, type);
3226 if (!PL_parser || PL_parser->error_count == ec) {
3227 if (!FEATURE_REFALIASING_IS_ENABLED)
3229 "Experimental aliasing via reference not enabled");
3230 Perl_ck_warner_d(aTHX_
3231 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3232 "Aliasing via reference is experimental");
3235 if (o->op_type == OP_REFGEN)
3236 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3241 kid = cLISTOPo->op_first;
3242 if (kid && kid->op_type == OP_PUSHRE &&
3244 || o->op_flags & OPf_STACKED
3246 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3248 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3251 /* This is actually @array = split. */
3252 PL_modcount = RETURN_UNLIMITED_NUMBER;
3258 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3262 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3263 their argument is a filehandle; thus \stat(".") should not set
3265 if (type == OP_REFGEN &&
3266 PL_check[o->op_type] == Perl_ck_ftst)
3269 if (type != OP_LEAVESUBLV)
3270 o->op_flags |= OPf_MOD;
3272 if (type == OP_AASSIGN || type == OP_SASSIGN)
3273 o->op_flags |= OPf_SPECIAL|OPf_REF;
3274 else if (!type) { /* local() */
3277 o->op_private |= OPpLVAL_INTRO;
3278 o->op_flags &= ~OPf_SPECIAL;
3279 PL_hints |= HINT_BLOCK_SCOPE;
3284 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3285 "Useless localization of %s", OP_DESC(o));
3288 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3289 && type != OP_LEAVESUBLV)
3290 o->op_flags |= OPf_REF;
3295 S_scalar_mod_type(const OP *o, I32 type)
3300 if (o && o->op_type == OP_RV2GV)
3324 case OP_RIGHT_SHIFT:
3353 S_is_handle_constructor(const OP *o, I32 numargs)
3355 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3357 switch (o->op_type) {
3365 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3378 S_refkids(pTHX_ OP *o, I32 type)
3380 if (o && o->op_flags & OPf_KIDS) {
3382 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3389 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3394 PERL_ARGS_ASSERT_DOREF;
3396 if (PL_parser && PL_parser->error_count)
3399 switch (o->op_type) {
3401 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3402 !(o->op_flags & OPf_STACKED)) {
3403 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3404 assert(cUNOPo->op_first->op_type == OP_NULL);
3405 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3406 o->op_flags |= OPf_SPECIAL;
3408 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3409 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3410 : type == OP_RV2HV ? OPpDEREF_HV
3412 o->op_flags |= OPf_MOD;
3418 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3419 doref(kid, type, set_op_ref);
3422 if (type == OP_DEFINED)
3423 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3424 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3427 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3428 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3429 : type == OP_RV2HV ? OPpDEREF_HV
3431 o->op_flags |= OPf_MOD;
3438 o->op_flags |= OPf_REF;
3441 if (type == OP_DEFINED)
3442 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3443 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3449 o->op_flags |= OPf_REF;
3454 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3456 doref(cBINOPo->op_first, type, set_op_ref);
3460 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3461 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3462 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3463 : type == OP_RV2HV ? OPpDEREF_HV
3465 o->op_flags |= OPf_MOD;
3475 if (!(o->op_flags & OPf_KIDS))
3477 doref(cLISTOPo->op_last, type, set_op_ref);
3487 S_dup_attrlist(pTHX_ OP *o)
3491 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3493 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3494 * where the first kid is OP_PUSHMARK and the remaining ones
3495 * are OP_CONST. We need to push the OP_CONST values.
3497 if (o->op_type == OP_CONST)
3498 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3500 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3502 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3503 if (o->op_type == OP_CONST)
3504 rop = op_append_elem(OP_LIST, rop,
3505 newSVOP(OP_CONST, o->op_flags,
3506 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3513 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3515 PERL_ARGS_ASSERT_APPLY_ATTRS;
3517 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3519 /* fake up C<use attributes $pkg,$rv,@attrs> */
3521 #define ATTRSMODULE "attributes"
3522 #define ATTRSMODULE_PM "attributes.pm"
3525 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3526 newSVpvs(ATTRSMODULE),
3528 op_prepend_elem(OP_LIST,
3529 newSVOP(OP_CONST, 0, stashsv),
3530 op_prepend_elem(OP_LIST,
3531 newSVOP(OP_CONST, 0,
3533 dup_attrlist(attrs))));
3538 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3540 OP *pack, *imop, *arg;
3541 SV *meth, *stashsv, **svp;
3543 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3548 assert(target->op_type == OP_PADSV ||
3549 target->op_type == OP_PADHV ||
3550 target->op_type == OP_PADAV);
3552 /* Ensure that attributes.pm is loaded. */
3553 /* Don't force the C<use> if we don't need it. */
3554 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3555 if (svp && *svp != &PL_sv_undef)
3556 NOOP; /* already in %INC */
3558 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3559 newSVpvs(ATTRSMODULE), NULL);
3561 /* Need package name for method call. */
3562 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3564 /* Build up the real arg-list. */
3565 stashsv = newSVhek(HvNAME_HEK(stash));
3567 arg = newOP(OP_PADSV, 0);
3568 arg->op_targ = target->op_targ;
3569 arg = op_prepend_elem(OP_LIST,
3570 newSVOP(OP_CONST, 0, stashsv),
3571 op_prepend_elem(OP_LIST,
3572 newUNOP(OP_REFGEN, 0,
3574 dup_attrlist(attrs)));
3576 /* Fake up a method call to import */
3577 meth = newSVpvs_share("import");
3578 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3579 op_append_elem(OP_LIST,
3580 op_prepend_elem(OP_LIST, pack, arg),
3581 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3583 /* Combine the ops. */
3584 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3588 =notfor apidoc apply_attrs_string
3590 Attempts to apply a list of attributes specified by the C<attrstr> and
3591 C<len> arguments to the subroutine identified by the C<cv> argument which
3592 is expected to be associated with the package identified by the C<stashpv>
3593 argument (see L<attributes>). It gets this wrong, though, in that it
3594 does not correctly identify the boundaries of the individual attribute
3595 specifications within C<attrstr>. This is not really intended for the
3596 public API, but has to be listed here for systems such as AIX which
3597 need an explicit export list for symbols. (It's called from XS code
3598 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3599 to respect attribute syntax properly would be welcome.
3605 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3606 const char *attrstr, STRLEN len)
3610 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3613 len = strlen(attrstr);
3617 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3619 const char * const sstr = attrstr;
3620 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3621 attrs = op_append_elem(OP_LIST, attrs,
3622 newSVOP(OP_CONST, 0,
3623 newSVpvn(sstr, attrstr-sstr)));
3627 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3628 newSVpvs(ATTRSMODULE),
3629 NULL, op_prepend_elem(OP_LIST,
3630 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3631 op_prepend_elem(OP_LIST,
3632 newSVOP(OP_CONST, 0,
3633 newRV(MUTABLE_SV(cv))),
3638 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3640 OP *new_proto = NULL;
3645 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3651 if (o->op_type == OP_CONST) {
3652 pv = SvPV(cSVOPo_sv, pvlen);
3653 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3654 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3655 SV ** const tmpo = cSVOPx_svp(o);
3656 SvREFCNT_dec(cSVOPo_sv);
3661 } else if (o->op_type == OP_LIST) {
3663 assert(o->op_flags & OPf_KIDS);
3664 lasto = cLISTOPo->op_first;
3665 assert(lasto->op_type == OP_PUSHMARK);
3666 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3667 if (o->op_type == OP_CONST) {
3668 pv = SvPV(cSVOPo_sv, pvlen);
3669 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3670 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3671 SV ** const tmpo = cSVOPx_svp(o);
3672 SvREFCNT_dec(cSVOPo_sv);
3674 if (new_proto && ckWARN(WARN_MISC)) {
3676 const char * newp = SvPV(cSVOPo_sv, new_len);
3677 Perl_warner(aTHX_ packWARN(WARN_MISC),
3678 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3679 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3685 /* excise new_proto from the list */
3686 op_sibling_splice(*attrs, lasto, 1, NULL);
3693 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3694 would get pulled in with no real need */
3695 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3704 svname = sv_newmortal();
3705 gv_efullname3(svname, name, NULL);
3707 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3708 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3710 svname = (SV *)name;
3711 if (ckWARN(WARN_ILLEGALPROTO))
3712 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3713 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3714 STRLEN old_len, new_len;
3715 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3716 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3718 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3719 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3721 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3722 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3732 S_cant_declare(pTHX_ OP *o)
3734 if (o->op_type == OP_NULL
3735 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3736 o = cUNOPo->op_first;
3737 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3738 o->op_type == OP_NULL
3739 && o->op_flags & OPf_SPECIAL
3742 PL_parser->in_my == KEY_our ? "our" :
3743 PL_parser->in_my == KEY_state ? "state" :
3748 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3751 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3753 PERL_ARGS_ASSERT_MY_KID;
3755 if (!o || (PL_parser && PL_parser->error_count))
3760 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3762 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3763 my_kid(kid, attrs, imopsp);
3765 } else if (type == OP_UNDEF || type == OP_STUB) {
3767 } else if (type == OP_RV2SV || /* "our" declaration */
3770 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3771 S_cant_declare(aTHX_ o);
3773 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3775 PL_parser->in_my = FALSE;
3776 PL_parser->in_my_stash = NULL;
3777 apply_attrs(GvSTASH(gv),
3778 (type == OP_RV2SV ? GvSV(gv) :
3779 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3780 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3783 o->op_private |= OPpOUR_INTRO;
3786 else if (type == OP_REFGEN || type == OP_SREFGEN) {
3787 if (!FEATURE_MYREF_IS_ENABLED)
3788 Perl_croak(aTHX_ "The experimental declared_refs "
3789 "feature is not enabled");
3790 Perl_ck_warner_d(aTHX_
3791 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3792 "Declaring references is experimental");
3793 /* Kid is a nulled OP_LIST, handled above. */
3794 my_kid(cUNOPo->op_first, attrs, imopsp);
3797 else if (type != OP_PADSV &&
3800 type != OP_PUSHMARK)
3802 S_cant_declare(aTHX_ o);
3805 else if (attrs && type != OP_PUSHMARK) {
3809 PL_parser->in_my = FALSE;
3810 PL_parser->in_my_stash = NULL;
3812 /* check for C<my Dog $spot> when deciding package */
3813 stash = PAD_COMPNAME_TYPE(o->op_targ);
3815 stash = PL_curstash;
3816 apply_attrs_my(stash, o, attrs, imopsp);
3818 o->op_flags |= OPf_MOD;
3819 o->op_private |= OPpLVAL_INTRO;
3821 o->op_private |= OPpPAD_STATE;
3826 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3829 int maybe_scalar = 0;
3831 PERL_ARGS_ASSERT_MY_ATTRS;
3833 /* [perl #17376]: this appears to be premature, and results in code such as
3834 C< our(%x); > executing in list mode rather than void mode */
3836 if (o->op_flags & OPf_PARENS)
3846 o = my_kid(o, attrs, &rops);
3848 if (maybe_scalar && o->op_type == OP_PADSV) {
3849 o = scalar(op_append_list(OP_LIST, rops, o));
3850 o->op_private |= OPpLVAL_INTRO;
3853 /* The listop in rops might have a pushmark at the beginning,
3854 which will mess up list assignment. */
3855 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3856 if (rops->op_type == OP_LIST &&
3857 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3859 OP * const pushmark = lrops->op_first;
3860 /* excise pushmark */
3861 op_sibling_splice(rops, NULL, 1, NULL);
3864 o = op_append_list(OP_LIST, o, rops);
3867 PL_parser->in_my = FALSE;
3868 PL_parser->in_my_stash = NULL;
3873 Perl_sawparens(pTHX_ OP *o)
3875 PERL_UNUSED_CONTEXT;
3877 o->op_flags |= OPf_PARENS;
3882 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3886 const OPCODE ltype = left->op_type;
3887 const OPCODE rtype = right->op_type;
3889 PERL_ARGS_ASSERT_BIND_MATCH;
3891 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3892 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3894 const char * const desc
3896 rtype == OP_SUBST || rtype == OP_TRANS
3897 || rtype == OP_TRANSR
3899 ? (int)rtype : OP_MATCH];
3900 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3902 S_op_varname(aTHX_ left);
3904 Perl_warner(aTHX_ packWARN(WARN_MISC),
3905 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3906 desc, SVfARG(name), SVfARG(name));
3908 const char * const sample = (isary
3909 ? "@array" : "%hash");
3910 Perl_warner(aTHX_ packWARN(WARN_MISC),
3911 "Applying %s to %s will act on scalar(%s)",
3912 desc, sample, sample);
3916 if (rtype == OP_CONST &&
3917 cSVOPx(right)->op_private & OPpCONST_BARE &&
3918 cSVOPx(right)->op_private & OPpCONST_STRICT)
3920 no_bareword_allowed(right);
3923 /* !~ doesn't make sense with /r, so error on it for now */
3924 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3926 /* diag_listed_as: Using !~ with %s doesn't make sense */
3927 yyerror("Using !~ with s///r doesn't make sense");
3928 if (rtype == OP_TRANSR && type == OP_NOT)
3929 /* diag_listed_as: Using !~ with %s doesn't make sense */
3930 yyerror("Using !~ with tr///r doesn't make sense");
3932 ismatchop = (rtype == OP_MATCH ||
3933 rtype == OP_SUBST ||
3934 rtype == OP_TRANS || rtype == OP_TRANSR)
3935 && !(right->op_flags & OPf_SPECIAL);
3936 if (ismatchop && right->op_private & OPpTARGET_MY) {
3938 right->op_private &= ~OPpTARGET_MY;
3940 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3941 if (left->op_type == OP_PADSV
3942 && !(left->op_private & OPpLVAL_INTRO))
3944 right->op_targ = left->op_targ;
3949 right->op_flags |= OPf_STACKED;
3950 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3951 ! (rtype == OP_TRANS &&
3952 right->op_private & OPpTRANS_IDENTICAL) &&
3953 ! (rtype == OP_SUBST &&
3954 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3955 left = op_lvalue(left, rtype);
3956 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3957 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3959 o = op_prepend_elem(rtype, scalar(left), right);
3962 return newUNOP(OP_NOT, 0, scalar(o));
3966 return bind_match(type, left,
3967 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3971 Perl_invert(pTHX_ OP *o)
3975 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3979 =for apidoc Amx|OP *|op_scope|OP *o
3981 Wraps up an op tree with some additional ops so that at runtime a dynamic
3982 scope will be created. The original ops run in the new dynamic scope,
3983 and then, provided that they exit normally, the scope will be unwound.
3984 The additional ops used to create and unwind the dynamic scope will
3985 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3986 instead if the ops are simple enough to not need the full dynamic scope
3993 Perl_op_scope(pTHX_ OP *o)
3997 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3998 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3999 OpTYPE_set(o, OP_LEAVE);
4001 else if (o->op_type == OP_LINESEQ) {
4003 OpTYPE_set(o, OP_SCOPE);
4004 kid = ((LISTOP*)o)->op_first;
4005 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4008 /* The following deals with things like 'do {1 for 1}' */
4009 kid = OpSIBLING(kid);
4011 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4016 o = newLISTOP(OP_SCOPE, 0, o, NULL);
4022 Perl_op_unscope(pTHX_ OP *o)
4024 if (o && o->op_type == OP_LINESEQ) {
4025 OP *kid = cLISTOPo->op_first;
4026 for(; kid; kid = OpSIBLING(kid))
4027 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4034 =for apidoc Am|int|block_start|int full
4036 Handles compile-time scope entry.
4037 Arranges for hints to be restored on block
4038 exit and also handles pad sequence numbers to make lexical variables scope
4039 right. Returns a savestack index for use with C<block_end>.
4045 Perl_block_start(pTHX_ int full)
4047 const int retval = PL_savestack_ix;
4049 PL_compiling.cop_seq = PL_cop_seqmax;
4051 pad_block_start(full);
4053 PL_hints &= ~HINT_BLOCK_SCOPE;
4054 SAVECOMPILEWARNINGS();
4055 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4056 SAVEI32(PL_compiling.cop_seq);
4057 PL_compiling.cop_seq = 0;
4059 CALL_BLOCK_HOOKS(bhk_start, full);
4065 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4067 Handles compile-time scope exit. C<floor>
4068 is the savestack index returned by
4069 C<block_start>, and C<seq> is the body of the block. Returns the block,
4076 Perl_block_end(pTHX_ I32 floor, OP *seq)
4078 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4079 OP* retval = scalarseq(seq);
4082 /* XXX Is the null PL_parser check necessary here? */
4083 assert(PL_parser); /* Let’s find out under debugging builds. */
4084 if (PL_parser && PL_parser->parsed_sub) {
4085 o = newSTATEOP(0, NULL, NULL);
4087 retval = op_append_elem(OP_LINESEQ, retval, o);
4090 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4094 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4098 /* pad_leavemy has created a sequence of introcv ops for all my
4099 subs declared in the block. We have to replicate that list with
4100 clonecv ops, to deal with this situation:
4105 sub s1 { state sub foo { \&s2 } }
4108 Originally, I was going to have introcv clone the CV and turn
4109 off the stale flag. Since &s1 is declared before &s2, the
4110 introcv op for &s1 is executed (on sub entry) before the one for
4111 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
4112 cloned, since it is a state sub) closes over &s2 and expects
4113 to see it in its outer CV’s pad. If the introcv op clones &s1,
4114 then &s2 is still marked stale. Since &s1 is not active, and
4115 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4116 ble will not stay shared’ warning. Because it is the same stub
4117 that will be used when the introcv op for &s2 is executed, clos-
4118 ing over it is safe. Hence, we have to turn off the stale flag
4119 on all lexical subs in the block before we clone any of them.
4120 Hence, having introcv clone the sub cannot work. So we create a
4121 list of ops like this:
4145 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4146 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4147 for (;; kid = OpSIBLING(kid)) {
4148 OP *newkid = newOP(OP_CLONECV, 0);
4149 newkid->op_targ = kid->op_targ;
4150 o = op_append_elem(OP_LINESEQ, o, newkid);
4151 if (kid == last) break;
4153 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4156 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4162 =head1 Compile-time scope hooks
4164 =for apidoc Aox||blockhook_register
4166 Register a set of hooks to be called when the Perl lexical scope changes
4167 at compile time. See L<perlguts/"Compile-time scope hooks">.
4173 Perl_blockhook_register(pTHX_ BHK *hk)
4175 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4177 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4181 Perl_newPROG(pTHX_ OP *o)
4183 PERL_ARGS_ASSERT_NEWPROG;
4190 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4191 ((PL_in_eval & EVAL_KEEPERR)
4192 ? OPf_SPECIAL : 0), o);
4195 assert(CxTYPE(cx) == CXt_EVAL);
4197 if ((cx->blk_gimme & G_WANT) == G_VOID)
4198 scalarvoid(PL_eval_root);
4199 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4202 scalar(PL_eval_root);
4204 PL_eval_start = op_linklist(PL_eval_root);
4205 PL_eval_root->op_private |= OPpREFCOUNTED;
4206 OpREFCNT_set(PL_eval_root, 1);
4207 PL_eval_root->op_next = 0;
4208 i = PL_savestack_ix;
4211 CALL_PEEP(PL_eval_start);
4212 finalize_optree(PL_eval_root);
4213 S_prune_chain_head(&PL_eval_start);
4215 PL_savestack_ix = i;
4218 if (o->op_type == OP_STUB) {
4219 /* This block is entered if nothing is compiled for the main
4220 program. This will be the case for an genuinely empty main
4221 program, or one which only has BEGIN blocks etc, so already
4224 Historically (5.000) the guard above was !o. However, commit
4225 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4226 c71fccf11fde0068, changed perly.y so that newPROG() is now
4227 called with the output of block_end(), which returns a new
4228 OP_STUB for the case of an empty optree. ByteLoader (and
4229 maybe other things) also take this path, because they set up
4230 PL_main_start and PL_main_root directly, without generating an
4233 If the parsing the main program aborts (due to parse errors,
4234 or due to BEGIN or similar calling exit), then newPROG()
4235 isn't even called, and hence this code path and its cleanups
4236 are skipped. This shouldn't make a make a difference:
4237 * a non-zero return from perl_parse is a failure, and
4238 perl_destruct() should be called immediately.
4239 * however, if exit(0) is called during the parse, then
4240 perl_parse() returns 0, and perl_run() is called. As
4241 PL_main_start will be NULL, perl_run() will return
4242 promptly, and the exit code will remain 0.
4245 PL_comppad_name = 0;
4247 S_op_destroy(aTHX_ o);
4250 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4251 PL_curcop = &PL_compiling;
4252 PL_main_start = LINKLIST(PL_main_root);
4253 PL_main_root->op_private |= OPpREFCOUNTED;
4254 OpREFCNT_set(PL_main_root, 1);
4255 PL_main_root->op_next = 0;
4256 CALL_PEEP(PL_main_start);
4257 finalize_optree(PL_main_root);
4258 S_prune_chain_head(&PL_main_start);
4259 cv_forget_slab(PL_compcv);
4262 /* Register with debugger */
4264 CV * const cv = get_cvs("DB::postponed", 0);
4268 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4270 call_sv(MUTABLE_SV(cv), G_DISCARD);
4277 Perl_localize(pTHX_ OP *o, I32 lex)
4279 PERL_ARGS_ASSERT_LOCALIZE;
4281 if (o->op_flags & OPf_PARENS)
4282 /* [perl #17376]: this appears to be premature, and results in code such as
4283 C< our(%x); > executing in list mode rather than void mode */
4290 if ( PL_parser->bufptr > PL_parser->oldbufptr
4291 && PL_parser->bufptr[-1] == ','
4292 && ckWARN(WARN_PARENTHESIS))
4294 char *s = PL_parser->bufptr;
4297 /* some heuristics to detect a potential error */
4298 while (*s && (strchr(", \t\n", *s)))
4302 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4304 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4307 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4309 while (*s && (strchr(", \t\n", *s)))
4315 if (sigil && (*s == ';' || *s == '=')) {
4316 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4317 "Parentheses missing around \"%s\" list",
4319 ? (PL_parser->in_my == KEY_our
4321 : PL_parser->in_my == KEY_state
4331 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4332 PL_parser->in_my = FALSE;
4333 PL_parser->in_my_stash = NULL;
4338 Perl_jmaybe(pTHX_ OP *o)
4340 PERL_ARGS_ASSERT_JMAYBE;
4342 if (o->op_type == OP_LIST) {
4344 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4345 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4350 PERL_STATIC_INLINE OP *
4351 S_op_std_init(pTHX_ OP *o)
4353 I32 type = o->op_type;
4355 PERL_ARGS_ASSERT_OP_STD_INIT;
4357 if (PL_opargs[type] & OA_RETSCALAR)
4359 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4360 o->op_targ = pad_alloc(type, SVs_PADTMP);
4365 PERL_STATIC_INLINE OP *
4366 S_op_integerize(pTHX_ OP *o)
4368 I32 type = o->op_type;
4370 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4372 /* integerize op. */
4373 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4376 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4379 if (type == OP_NEGATE)
4380 /* XXX might want a ck_negate() for this */
4381 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4387 S_fold_constants(pTHX_ OP *o)
4392 VOL I32 type = o->op_type;
4397 SV * const oldwarnhook = PL_warnhook;
4398 SV * const olddiehook = PL_diehook;
4400 U8 oldwarn = PL_dowarn;
4404 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4406 if (!(PL_opargs[type] & OA_FOLDCONST))
4415 #ifdef USE_LOCALE_CTYPE
4416 if (IN_LC_COMPILETIME(LC_CTYPE))
4425 #ifdef USE_LOCALE_COLLATE
4426 if (IN_LC_COMPILETIME(LC_COLLATE))
4431 /* XXX what about the numeric ops? */
4432 #ifdef USE_LOCALE_NUMERIC
4433 if (IN_LC_COMPILETIME(LC_NUMERIC))
4438 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4439 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4442 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4443 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4445 const char *s = SvPVX_const(sv);
4446 while (s < SvEND(sv)) {
4447 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4454 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4457 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4458 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4462 if (PL_parser && PL_parser->error_count)
4463 goto nope; /* Don't try to run w/ errors */
4465 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4466 switch (curop->op_type) {
4468 if ( (curop->op_private & OPpCONST_BARE)
4469 && (curop->op_private & OPpCONST_STRICT)) {
4470 no_bareword_allowed(curop);
4478 /* Foldable; move to next op in list */
4482 /* No other op types are considered foldable */
4487 curop = LINKLIST(o);
4488 old_next = o->op_next;
4492 old_cxix = cxstack_ix;
4493 create_eval_scope(NULL, G_FAKINGEVAL);
4495 /* Verify that we don't need to save it: */
4496 assert(PL_curcop == &PL_compiling);
4497 StructCopy(&PL_compiling, ¬_compiling, COP);
4498 PL_curcop = ¬_compiling;
4499 /* The above ensures that we run with all the correct hints of the
4500 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4501 assert(IN_PERL_RUNTIME);
4502 PL_warnhook = PERL_WARNHOOK_FATAL;
4506 /* Effective $^W=1. */
4507 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4508 PL_dowarn |= G_WARN_ON;
4513 sv = *(PL_stack_sp--);
4514 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4515 pad_swipe(o->op_targ, FALSE);
4517 else if (SvTEMP(sv)) { /* grab mortal temp? */
4518 SvREFCNT_inc_simple_void(sv);
4521 else { assert(SvIMMORTAL(sv)); }
4524 /* Something tried to die. Abandon constant folding. */
4525 /* Pretend the error never happened. */
4527 o->op_next = old_next;
4531 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4532 PL_warnhook = oldwarnhook;
4533 PL_diehook = olddiehook;
4534 /* XXX note that this croak may fail as we've already blown away
4535 * the stack - eg any nested evals */
4536 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4539 PL_dowarn = oldwarn;
4540 PL_warnhook = oldwarnhook;
4541 PL_diehook = olddiehook;
4542 PL_curcop = &PL_compiling;
4544 /* if we croaked, depending on how we croaked the eval scope
4545 * may or may not have already been popped */
4546 if (cxstack_ix > old_cxix) {
4547 assert(cxstack_ix == old_cxix + 1);
4548 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4549 delete_eval_scope();
4554 /* OP_STRINGIFY and constant folding are used to implement qq.
4555 Here the constant folding is an implementation detail that we
4556 want to hide. If the stringify op is itself already marked
4557 folded, however, then it is actually a folded join. */
4558 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4563 else if (!SvIMMORTAL(sv)) {
4567 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4568 if (!is_stringify) newop->op_folded = 1;
4576 S_gen_constant_list(pTHX_ OP *o)
4580 const SSize_t oldtmps_floor = PL_tmps_floor;
4585 if (PL_parser && PL_parser->error_count)
4586 return o; /* Don't attempt to run with errors */
4588 curop = LINKLIST(o);
4591 S_prune_chain_head(&curop);
4593 Perl_pp_pushmark(aTHX);
4596 assert (!(curop->op_flags & OPf_SPECIAL));
4597 assert(curop->op_type == OP_RANGE);
4598 Perl_pp_anonlist(aTHX);
4599 PL_tmps_floor = oldtmps_floor;
4601 OpTYPE_set(o, OP_RV2AV);
4602 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4603 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4604 o->op_opt = 0; /* needs to be revisited in rpeep() */
4605 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4607 /* replace subtree with an OP_CONST */
4608 curop = ((UNOP*)o)->op_first;
4609 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4612 if (AvFILLp(av) != -1)
4613 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4616 SvREADONLY_on(*svp);
4623 =head1 Optree Manipulation Functions
4626 /* List constructors */
4629 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4631 Append an item to the list of ops contained directly within a list-type
4632 op, returning the lengthened list. C<first> is the list-type op,
4633 and C<last> is the op to append to the list. C<optype> specifies the
4634 intended opcode for the list. If C<first> is not already a list of the
4635 right type, it will be upgraded into one. If either C<first> or C<last>
4636 is null, the other is returned unchanged.
4642 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4650 if (first->op_type != (unsigned)type
4651 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4653 return newLISTOP(type, 0, first, last);
4656 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4657 first->op_flags |= OPf_KIDS;
4662 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4664 Concatenate the lists of ops contained directly within two list-type ops,
4665 returning the combined list. C<first> and C<last> are the list-type ops
4666 to concatenate. C<optype> specifies the intended opcode for the list.
4667 If either C<first> or C<last> is not already a list of the right type,
4668 it will be upgraded into one. If either C<first> or C<last> is null,
4669 the other is returned unchanged.
4675 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4683 if (first->op_type != (unsigned)type)
4684 return op_prepend_elem(type, first, last);
4686 if (last->op_type != (unsigned)type)
4687 return op_append_elem(type, first, last);
4689 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4690 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4691 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4692 first->op_flags |= (last->op_flags & OPf_KIDS);
4694 S_op_destroy(aTHX_ last);
4700 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4702 Prepend an item to the list of ops contained directly within a list-type
4703 op, returning the lengthened list. C<first> is the op to prepend to the
4704 list, and C<last> is the list-type op. C<optype> specifies the intended
4705 opcode for the list. If C<last> is not already a list of the right type,
4706 it will be upgraded into one. If either C<first> or C<last> is null,
4707 the other is returned unchanged.
4713 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4721 if (last->op_type == (unsigned)type) {
4722 if (type == OP_LIST) { /* already a PUSHMARK there */
4723 /* insert 'first' after pushmark */
4724 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4725 if (!(first->op_flags & OPf_PARENS))
4726 last->op_flags &= ~OPf_PARENS;
4729 op_sibling_splice(last, NULL, 0, first);
4730 last->op_flags |= OPf_KIDS;
4734 return newLISTOP(type, 0, first, last);
4738 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4740 Converts C<o> into a list op if it is not one already, and then converts it
4741 into the specified C<type>, calling its check function, allocating a target if
4742 it needs one, and folding constants.
4744 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4745 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4746 C<op_convert_list> to make it the right type.
4752 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4755 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4756 if (!o || o->op_type != OP_LIST)
4757 o = force_list(o, 0);
4760 o->op_flags &= ~OPf_WANT;
4761 o->op_private &= ~OPpLVAL_INTRO;
4764 if (!(PL_opargs[type] & OA_MARK))
4765 op_null(cLISTOPo->op_first);
4767 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4768 if (kid2 && kid2->op_type == OP_COREARGS) {
4769 op_null(cLISTOPo->op_first);
4770 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4774 OpTYPE_set(o, type);
4775 o->op_flags |= flags;
4776 if (flags & OPf_FOLDED)
4779 o = CHECKOP(type, o);
4780 if (o->op_type != (unsigned)type)
4783 return fold_constants(op_integerize(op_std_init(o)));
4790 =head1 Optree construction
4792 =for apidoc Am|OP *|newNULLLIST
4794 Constructs, checks, and returns a new C<stub> op, which represents an
4795 empty list expression.
4801 Perl_newNULLLIST(pTHX)
4803 return newOP(OP_STUB, 0);
4806 /* promote o and any siblings to be a list if its not already; i.e.
4814 * pushmark - o - A - B
4816 * If nullit it true, the list op is nulled.
4820 S_force_list(pTHX_ OP *o, bool nullit)
4822 if (!o || o->op_type != OP_LIST) {
4825 /* manually detach any siblings then add them back later */
4826 rest = OpSIBLING(o);
4827 OpLASTSIB_set(o, NULL);
4829 o = newLISTOP(OP_LIST, 0, o, NULL);
4831 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4839 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4841 Constructs, checks, and returns an op of any list type. C<type> is
4842 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4843 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
4844 supply up to two ops to be direct children of the list op; they are
4845 consumed by this function and become part of the constructed op tree.
4847 For most list operators, the check function expects all the kid ops to be
4848 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4849 appropriate. What you want to do in that case is create an op of type
4850 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4851 See L</op_convert_list> for more information.
4858 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4863 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4864 || type == OP_CUSTOM);
4866 NewOp(1101, listop, 1, LISTOP);
4868 OpTYPE_set(listop, type);
4871 listop->op_flags = (U8)flags;
4875 else if (!first && last)
4878 OpMORESIB_set(first, last);
4879 listop->op_first = first;
4880 listop->op_last = last;
4881 if (type == OP_LIST) {
4882 OP* const pushop = newOP(OP_PUSHMARK, 0);
4883 OpMORESIB_set(pushop, first);
4884 listop->op_first = pushop;
4885 listop->op_flags |= OPf_KIDS;
4887 listop->op_last = pushop;
4889 if (listop->op_last)
4890 OpLASTSIB_set(listop->op_last, (OP*)listop);
4892 return CHECKOP(type, listop);
4896 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4898 Constructs, checks, and returns an op of any base type (any type that
4899 has no extra fields). C<type> is the opcode. C<flags> gives the
4900 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4907 Perl_newOP(pTHX_ I32 type, I32 flags)
4912 if (type == -OP_ENTEREVAL) {
4913 type = OP_ENTEREVAL;
4914 flags |= OPpEVAL_BYTES<<8;
4917 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4918 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4919 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4920 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4922 NewOp(1101, o, 1, OP);
4923 OpTYPE_set(o, type);
4924 o->op_flags = (U8)flags;
4927 o->op_private = (U8)(0 | (flags >> 8));
4928 if (PL_opargs[type] & OA_RETSCALAR)
4930 if (PL_opargs[type] & OA_TARGET)
4931 o->op_targ = pad_alloc(type, SVs_PADTMP);
4932 return CHECKOP(type, o);
4936 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4938 Constructs, checks, and returns an op of any unary type. C<type> is
4939 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4940 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4941 bits, the eight bits of C<op_private>, except that the bit with value 1
4942 is automatically set. C<first> supplies an optional op to be the direct
4943 child of the unary op; it is consumed by this function and become part
4944 of the constructed op tree.
4950 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4955 if (type == -OP_ENTEREVAL) {
4956 type = OP_ENTEREVAL;
4957 flags |= OPpEVAL_BYTES<<8;
4960 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4961 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4962 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4963 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4964 || type == OP_SASSIGN
4965 || type == OP_ENTERTRY
4966 || type == OP_CUSTOM
4967 || type == OP_NULL );
4970 first = newOP(OP_STUB, 0);
4971 if (PL_opargs[type] & OA_MARK)
4972 first = force_list(first, 1);
4974 NewOp(1101, unop, 1, UNOP);
4975 OpTYPE_set(unop, type);
4976 unop->op_first = first;
4977 unop->op_flags = (U8)(flags | OPf_KIDS);
4978 unop->op_private = (U8)(1 | (flags >> 8));
4980 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4981 OpLASTSIB_set(first, (OP*)unop);
4983 unop = (UNOP*) CHECKOP(type, unop);
4987 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4991 =for apidoc newUNOP_AUX
4993 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4994 initialised to C<aux>
5000 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5005 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5006 || type == OP_CUSTOM);
5008 NewOp(1101, unop, 1, UNOP_AUX);
5009 unop->op_type = (OPCODE)type;
5010 unop->op_ppaddr = PL_ppaddr[type];
5011 unop->op_first = first;
5012 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5013 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5016 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5017 OpLASTSIB_set(first, (OP*)unop);
5019 unop = (UNOP_AUX*) CHECKOP(type, unop);
5021 return op_std_init((OP *) unop);
5025 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
5027 Constructs, checks, and returns an op of method type with a method name
5028 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
5029 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5030 and, shifted up eight bits, the eight bits of C<op_private>, except that
5031 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
5032 op which evaluates method name; it is consumed by this function and
5033 become part of the constructed op tree.
5034 Supported optypes: C<OP_METHOD>.
5040 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5044 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5045 || type == OP_CUSTOM);
5047 NewOp(1101, methop, 1, METHOP);
5049 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
5050 methop->op_flags = (U8)(flags | OPf_KIDS);
5051 methop->op_u.op_first = dynamic_meth;
5052 methop->op_private = (U8)(1 | (flags >> 8));
5054 if (!OpHAS_SIBLING(dynamic_meth))
5055 OpLASTSIB_set(dynamic_meth, (OP*)methop);
5059 methop->op_flags = (U8)(flags & ~OPf_KIDS);
5060 methop->op_u.op_meth_sv = const_meth;
5061 methop->op_private = (U8)(0 | (flags >> 8));
5062 methop->op_next = (OP*)methop;
5066 methop->op_rclass_targ = 0;
5068 methop->op_rclass_sv = NULL;
5071 OpTYPE_set(methop, type);
5072 return CHECKOP(type, methop);
5076 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5077 PERL_ARGS_ASSERT_NEWMETHOP;
5078 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5082 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
5084 Constructs, checks, and returns an op of method type with a constant
5085 method name. C<type> is the opcode. C<flags> gives the eight bits of
5086 C<op_flags>, and, shifted up eight bits, the eight bits of
5087 C<op_private>. C<const_meth> supplies a constant method name;
5088 it must be a shared COW string.
5089 Supported optypes: C<OP_METHOD_NAMED>.
5095 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5096 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5097 return newMETHOP_internal(type, flags, NULL, const_meth);
5101 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
5103 Constructs, checks, and returns an op of any binary type. C<type>
5104 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
5105 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5106 the eight bits of C<op_private>, except that the bit with value 1 or
5107 2 is automatically set as required. C<first> and C<last> supply up to
5108 two ops to be the direct children of the binary op; they are consumed
5109 by this function and become part of the constructed op tree.
5115 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5120 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5121 || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
5123 NewOp(1101, binop, 1, BINOP);
5126 first = newOP(OP_NULL, 0);
5128 OpTYPE_set(binop, type);
5129 binop->op_first = first;
5130 binop->op_flags = (U8)(flags | OPf_KIDS);
5133 binop->op_private = (U8)(1 | (flags >> 8));
5136 binop->op_private = (U8)(2 | (flags >> 8));
5137 OpMORESIB_set(first, last);
5140 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5141 OpLASTSIB_set(last, (OP*)binop);
5143 binop->op_last = OpSIBLING(binop->op_first);
5145 OpLASTSIB_set(binop->op_last, (OP*)binop);
5147 binop = (BINOP*)CHECKOP(type, binop);
5148 if (binop->op_next || binop->op_type != (OPCODE)type)
5151 return fold_constants(op_integerize(op_std_init((OP *)binop)));
5154 static int uvcompare(const void *a, const void *b)
5155 __attribute__nonnull__(1)
5156 __attribute__nonnull__(2)
5157 __attribute__pure__;
5158 static int uvcompare(const void *a, const void *b)
5160 if (*((const UV *)a) < (*(const UV *)b))
5162 if (*((const UV *)a) > (*(const UV *)b))
5164 if (*((const UV *)a+1) < (*(const UV *)b+1))
5166 if (*((const UV *)a+1) > (*(const UV *)b+1))
5172 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5174 SV * const tstr = ((SVOP*)expr)->op_sv;
5176 ((SVOP*)repl)->op_sv;
5179 const U8 *t = (U8*)SvPV_const(tstr, tlen);
5180 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5186 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5187 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5188 I32 del = o->op_private & OPpTRANS_DELETE;
5191 PERL_ARGS_ASSERT_PMTRANS;
5193 PL_hints |= HINT_BLOCK_SCOPE;
5196 o->op_private |= OPpTRANS_FROM_UTF;
5199 o->op_private |= OPpTRANS_TO_UTF;
5201 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5202 SV* const listsv = newSVpvs("# comment\n");
5204 const U8* tend = t + tlen;
5205 const U8* rend = r + rlen;
5221 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5222 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5225 const U32 flags = UTF8_ALLOW_DEFAULT;
5229 t = tsave = bytes_to_utf8(t, &len);
5232 if (!to_utf && rlen) {
5234 r = rsave = bytes_to_utf8(r, &len);
5238 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5239 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5243 U8 tmpbuf[UTF8_MAXBYTES+1];
5246 Newx(cp, 2*tlen, UV);
5248 transv = newSVpvs("");
5250 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5252 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5254 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5258 cp[2*i+1] = cp[2*i];
5262 qsort(cp, i, 2*sizeof(UV), uvcompare);
5263 for (j = 0; j < i; j++) {
5265 diff = val - nextmin;
5267 t = uvchr_to_utf8(tmpbuf,nextmin);
5268 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5270 U8 range_mark = ILLEGAL_UTF8_BYTE;
5271 t = uvchr_to_utf8(tmpbuf, val - 1);
5272 sv_catpvn(transv, (char *)&range_mark, 1);
5273 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5280 t = uvchr_to_utf8(tmpbuf,nextmin);
5281 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5283 U8 range_mark = ILLEGAL_UTF8_BYTE;
5284 sv_catpvn(transv, (char *)&range_mark, 1);
5286 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5287 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5288 t = (const U8*)SvPVX_const(transv);
5289 tlen = SvCUR(transv);
5293 else if (!rlen && !del) {
5294 r = t; rlen = tlen; rend = tend;
5297 if ((!rlen && !del) || t == r ||
5298 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5300 o->op_private |= OPpTRANS_IDENTICAL;
5304 while (t < tend || tfirst <= tlast) {
5305 /* see if we need more "t" chars */
5306 if (tfirst > tlast) {
5307 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5309 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5311 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5318 /* now see if we need more "r" chars */
5319 if (rfirst > rlast) {
5321 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5323 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5325 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5334 rfirst = rlast = 0xffffffff;
5338 /* now see which range will peter out first, if either. */
5339 tdiff = tlast - tfirst;
5340 rdiff = rlast - rfirst;
5341 tcount += tdiff + 1;
5342 rcount += rdiff + 1;
5349 if (rfirst == 0xffffffff) {
5350 diff = tdiff; /* oops, pretend rdiff is infinite */
5352 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5353 (long)tfirst, (long)tlast);
5355 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5359 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5360 (long)tfirst, (long)(tfirst + diff),
5363 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5364 (long)tfirst, (long)rfirst);
5366 if (rfirst + diff > max)
5367 max = rfirst + diff;
5369 grows = (tfirst < rfirst &&
5370 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5382 else if (max > 0xff)
5387 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5389 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5390 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5391 PAD_SETSV(cPADOPo->op_padix, swash);
5393 SvREADONLY_on(swash);
5395 cSVOPo->op_sv = swash;
5397 SvREFCNT_dec(listsv);
5398 SvREFCNT_dec(transv);
5400 if (!del && havefinal && rlen)
5401 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5402 newSVuv((UV)final), 0);
5411 else if (rlast == 0xffffffff)
5417 tbl = (short*)PerlMemShared_calloc(
5418 (o->op_private & OPpTRANS_COMPLEMENT) &&
5419 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5421 cPVOPo->op_pv = (char*)tbl;
5423 for (i = 0; i < (I32)tlen; i++)
5425 for (i = 0, j = 0; i < 256; i++) {
5427 if (j >= (I32)rlen) {
5436 if (i < 128 && r[j] >= 128)
5446 o->op_private |= OPpTRANS_IDENTICAL;
5448 else if (j >= (I32)rlen)
5453 PerlMemShared_realloc(tbl,
5454 (0x101+rlen-j) * sizeof(short));
5455 cPVOPo->op_pv = (char*)tbl;
5457 tbl[0x100] = (short)(rlen - j);
5458 for (i=0; i < (I32)rlen - j; i++)
5459 tbl[0x101+i] = r[j+i];
5463 if (!rlen && !del) {
5466 o->op_private |= OPpTRANS_IDENTICAL;
5468 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5469 o->op_private |= OPpTRANS_IDENTICAL;
5471 for (i = 0; i < 256; i++)
5473 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5474 if (j >= (I32)rlen) {
5476 if (tbl[t[i]] == -1)
5482 if (tbl[t[i]] == -1) {
5483 if (t[i] < 128 && r[j] >= 128)
5491 if(del && rlen == tlen) {
5492 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5493 } else if(rlen > tlen && !complement) {
5494 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5498 o->op_private |= OPpTRANS_GROWS;
5506 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5508 Constructs, checks, and returns an op of any pattern matching type.
5509 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
5510 and, shifted up eight bits, the eight bits of C<op_private>.
5516 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5521 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5522 || type == OP_CUSTOM);
5524 NewOp(1101, pmop, 1, PMOP);
5525 OpTYPE_set(pmop, type);
5526 pmop->op_flags = (U8)flags;
5527 pmop->op_private = (U8)(0 | (flags >> 8));
5528 if (PL_opargs[type] & OA_RETSCALAR)
5531 if (PL_hints & HINT_RE_TAINT)
5532 pmop->op_pmflags |= PMf_RETAINT;
5533 #ifdef USE_LOCALE_CTYPE
5534 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5535 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5540 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5542 if (PL_hints & HINT_RE_FLAGS) {
5543 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5544 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5546 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5547 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5548 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5550 if (reflags && SvOK(reflags)) {
5551 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5557 assert(SvPOK(PL_regex_pad[0]));
5558 if (SvCUR(PL_regex_pad[0])) {
5559 /* Pop off the "packed" IV from the end. */
5560 SV *const repointer_list = PL_regex_pad[0];
5561 const char *p = SvEND(repointer_list) - sizeof(IV);
5562 const IV offset = *((IV*)p);
5564 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5566 SvEND_set(repointer_list, p);
5568 pmop->op_pmoffset = offset;
5569 /* This slot should be free, so assert this: */
5570 assert(PL_regex_pad[offset] == &PL_sv_undef);
5572 SV * const repointer = &PL_sv_undef;
5573 av_push(PL_regex_padav, repointer);
5574 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5575 PL_regex_pad = AvARRAY(PL_regex_padav);
5579 return CHECKOP(type, pmop);
5587 /* Any pad names in scope are potentially lvalues. */
5588 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5589 PADNAME *pn = PAD_COMPNAME_SV(i);
5590 if (!pn || !PadnameLEN(pn))
5592 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5593 S_mark_padname_lvalue(aTHX_ pn);
5597 /* Given some sort of match op o, and an expression expr containing a
5598 * pattern, either compile expr into a regex and attach it to o (if it's
5599 * constant), or convert expr into a runtime regcomp op sequence (if it's
5602 * isreg indicates that the pattern is part of a regex construct, eg
5603 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5604 * split "pattern", which aren't. In the former case, expr will be a list
5605 * if the pattern contains more than one term (eg /a$b/).
5607 * When the pattern has been compiled within a new anon CV (for
5608 * qr/(?{...})/ ), then floor indicates the savestack level just before
5609 * the new sub was created
5613 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5617 I32 repl_has_vars = 0;
5618 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5619 bool is_compiletime;
5622 PERL_ARGS_ASSERT_PMRUNTIME;
5625 return pmtrans(o, expr, repl);
5628 /* find whether we have any runtime or code elements;
5629 * at the same time, temporarily set the op_next of each DO block;
5630 * then when we LINKLIST, this will cause the DO blocks to be excluded
5631 * from the op_next chain (and from having LINKLIST recursively
5632 * applied to them). We fix up the DOs specially later */
5636 if (expr->op_type == OP_LIST) {
5638 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5639 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5641 assert(!o->op_next);
5642 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5643 assert(PL_parser && PL_parser->error_count);
5644 /* This can happen with qr/ (?{(^{})/. Just fake up
5645 the op we were expecting to see, to avoid crashing
5647 op_sibling_splice(expr, o, 0,
5648 newSVOP(OP_CONST, 0, &PL_sv_no));
5650 o->op_next = OpSIBLING(o);
5652 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5656 else if (expr->op_type != OP_CONST)
5661 /* fix up DO blocks; treat each one as a separate little sub;
5662 * also, mark any arrays as LIST/REF */
5664 if (expr->op_type == OP_LIST) {
5666 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5668 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5669 assert( !(o->op_flags & OPf_WANT));
5670 /* push the array rather than its contents. The regex
5671 * engine will retrieve and join the elements later */
5672 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5676 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5678 o->op_next = NULL; /* undo temporary hack from above */
5681 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5682 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5684 assert(leaveop->op_first->op_type == OP_ENTER);
5685 assert(OpHAS_SIBLING(leaveop->op_first));
5686 o->op_next = OpSIBLING(leaveop->op_first);
5688 assert(leaveop->op_flags & OPf_KIDS);
5689 assert(leaveop->op_last->op_next == (OP*)leaveop);
5690 leaveop->op_next = NULL; /* stop on last op */
5691 op_null((OP*)leaveop);
5695 OP *scope = cLISTOPo->op_first;
5696 assert(scope->op_type == OP_SCOPE);
5697 assert(scope->op_flags & OPf_KIDS);
5698 scope->op_next = NULL; /* stop on last op */
5701 /* have to peep the DOs individually as we've removed it from
5702 * the op_next chain */
5704 S_prune_chain_head(&(o->op_next));
5706 /* runtime finalizes as part of finalizing whole tree */
5710 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5711 assert( !(expr->op_flags & OPf_WANT));
5712 /* push the array rather than its contents. The regex
5713 * engine will retrieve and join the elements later */
5714 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5717 PL_hints |= HINT_BLOCK_SCOPE;
5719 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5721 if (is_compiletime) {
5722 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5723 regexp_engine const *eng = current_re_engine();
5725 if (o->op_flags & OPf_SPECIAL)
5726 rx_flags |= RXf_SPLIT;
5728 if (!has_code || !eng->op_comp) {
5729 /* compile-time simple constant pattern */
5731 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5732 /* whoops! we guessed that a qr// had a code block, but we
5733 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5734 * that isn't required now. Note that we have to be pretty
5735 * confident that nothing used that CV's pad while the
5736 * regex was parsed, except maybe op targets for \Q etc.
5737 * If there were any op targets, though, they should have
5738 * been stolen by constant folding.
5742 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5743 while (++i <= AvFILLp(PL_comppad)) {
5744 assert(!PL_curpad[i]);
5747 /* But we know that one op is using this CV's slab. */
5748 cv_forget_slab(PL_compcv);
5750 pm->op_pmflags &= ~PMf_HAS_CV;
5755 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5756 rx_flags, pm->op_pmflags)
5757 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5758 rx_flags, pm->op_pmflags)
5763 /* compile-time pattern that includes literal code blocks */
5764 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5767 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5770 if (pm->op_pmflags & PMf_HAS_CV) {
5772 /* this QR op (and the anon sub we embed it in) is never
5773 * actually executed. It's just a placeholder where we can
5774 * squirrel away expr in op_code_list without the peephole
5775 * optimiser etc processing it for a second time */
5776 OP *qr = newPMOP(OP_QR, 0);
5777 ((PMOP*)qr)->op_code_list = expr;
5779 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5780 SvREFCNT_inc_simple_void(PL_compcv);
5781 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5782 ReANY(re)->qr_anoncv = cv;
5784 /* attach the anon CV to the pad so that
5785 * pad_fixup_inner_anons() can find it */
5786 (void)pad_add_anon(cv, o->op_type);
5787 SvREFCNT_inc_simple_void(cv);
5790 pm->op_code_list = expr;
5795 /* runtime pattern: build chain of regcomp etc ops */
5797 PADOFFSET cv_targ = 0;
5799 reglist = isreg && expr->op_type == OP_LIST;
5804 pm->op_code_list = expr;
5805 /* don't free op_code_list; its ops are embedded elsewhere too */
5806 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5809 if (o->op_flags & OPf_SPECIAL)
5810 pm->op_pmflags |= PMf_SPLIT;
5812 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5813 * to allow its op_next to be pointed past the regcomp and
5814 * preceding stacking ops;
5815 * OP_REGCRESET is there to reset taint before executing the
5817 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5818 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5820 if (pm->op_pmflags & PMf_HAS_CV) {
5821 /* we have a runtime qr with literal code. This means
5822 * that the qr// has been wrapped in a new CV, which
5823 * means that runtime consts, vars etc will have been compiled
5824 * against a new pad. So... we need to execute those ops
5825 * within the environment of the new CV. So wrap them in a call
5826 * to a new anon sub. i.e. for
5830 * we build an anon sub that looks like
5832 * sub { "a", $b, '(?{...})' }
5834 * and call it, passing the returned list to regcomp.
5835 * Or to put it another way, the list of ops that get executed
5839 * ------ -------------------
5840 * pushmark (for regcomp)
5841 * pushmark (for entersub)
5845 * regcreset regcreset
5847 * const("a") const("a")
5849 * const("(?{...})") const("(?{...})")
5854 SvREFCNT_inc_simple_void(PL_compcv);
5855 CvLVALUE_on(PL_compcv);
5856 /* these lines are just an unrolled newANONATTRSUB */
5857 expr = newSVOP(OP_ANONCODE, 0,
5858 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5859 cv_targ = expr->op_targ;
5860 expr = newUNOP(OP_REFGEN, 0, expr);
5862 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5865 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
5866 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5867 | (reglist ? OPf_STACKED : 0);
5868 rcop->op_targ = cv_targ;
5870 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5871 if (PL_hints & HINT_RE_EVAL)
5872 S_set_haseval(aTHX);
5874 /* establish postfix order */
5875 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5877 rcop->op_next = expr;
5878 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5881 rcop->op_next = LINKLIST(expr);
5882 expr->op_next = (OP*)rcop;
5885 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5891 /* If we are looking at s//.../e with a single statement, get past
5892 the implicit do{}. */
5893 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5894 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5895 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5898 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5899 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5900 && !OpHAS_SIBLING(sib))
5903 if (curop->op_type == OP_CONST)
5905 else if (( (curop->op_type == OP_RV2SV ||
5906 curop->op_type == OP_RV2AV ||
5907 curop->op_type == OP_RV2HV ||
5908 curop->op_type == OP_RV2GV)
5909 && cUNOPx(curop)->op_first
5910 && cUNOPx(curop)->op_first->op_type == OP_GV )
5911 || curop->op_type == OP_PADSV
5912 || curop->op_type == OP_PADAV
5913 || curop->op_type == OP_PADHV
5914 || curop->op_type == OP_PADANY) {
5922 || !RX_PRELEN(PM_GETRE(pm))
5923 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5925 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5926 op_prepend_elem(o->op_type, scalar(repl), o);
5929 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
5930 rcop->op_private = 1;
5932 /* establish postfix order */
5933 rcop->op_next = LINKLIST(repl);
5934 repl->op_next = (OP*)rcop;
5936 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5937 assert(!(pm->op_pmflags & PMf_ONCE));
5938 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5947 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5949 Constructs, checks, and returns an op of any type that involves an
5950 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
5951 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
5952 takes ownership of one reference to it.
5958 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5963 PERL_ARGS_ASSERT_NEWSVOP;
5965 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5966 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5967 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5968 || type == OP_CUSTOM);
5970 NewOp(1101, svop, 1, SVOP);
5971 OpTYPE_set(svop, type);
5973 svop->op_next = (OP*)svop;
5974 svop->op_flags = (U8)flags;
5975 svop->op_private = (U8)(0 | (flags >> 8));
5976 if (PL_opargs[type] & OA_RETSCALAR)
5978 if (PL_opargs[type] & OA_TARGET)
5979 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5980 return CHECKOP(type, svop);
5984 =for apidoc Am|OP *|newDEFSVOP|
5986 Constructs and returns an op to access C<$_>.
5992 Perl_newDEFSVOP(pTHX)
5994 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
6000 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
6002 Constructs, checks, and returns an op of any type that involves a
6003 reference to a pad element. C<type> is the opcode. C<flags> gives the
6004 eight bits of C<op_flags>. A pad slot is automatically allocated, and
6005 is populated with C<sv>; this function takes ownership of one reference
6008 This function only exists if Perl has been compiled to use ithreads.
6014 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
6019 PERL_ARGS_ASSERT_NEWPADOP;
6021 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
6022 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6023 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6024 || type == OP_CUSTOM);
6026 NewOp(1101, padop, 1, PADOP);
6027 OpTYPE_set(padop, type);
6029 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
6030 SvREFCNT_dec(PAD_SVl(padop->op_padix));
6031 PAD_SETSV(padop->op_padix, sv);
6033 padop->op_next = (OP*)padop;
6034 padop->op_flags = (U8)flags;
6035 if (PL_opargs[type] & OA_RETSCALAR)
6037 if (PL_opargs[type] & OA_TARGET)
6038 padop->op_targ = pad_alloc(type, SVs_PADTMP);
6039 return CHECKOP(type, padop);
6042 #endif /* USE_ITHREADS */
6045 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
6047 Constructs, checks, and returns an op of any type that involves an
6048 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
6049 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
6050 reference; calling this function does not transfer ownership of any
6057 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
6059 PERL_ARGS_ASSERT_NEWGVOP;
6062 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6064 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6069 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
6071 Constructs, checks, and returns an op of any type that involves an
6072 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
6073 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
6074 must have been allocated using C<PerlMemShared_malloc>; the memory will
6075 be freed when the op is destroyed.
6081 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
6084 const bool utf8 = cBOOL(flags & SVf_UTF8);
6089 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6090 || type == OP_RUNCV || type == OP_CUSTOM
6091 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6093 NewOp(1101, pvop, 1, PVOP);
6094 OpTYPE_set(pvop, type);
6096 pvop->op_next = (OP*)pvop;
6097 pvop->op_flags = (U8)flags;
6098 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
6099 if (PL_opargs[type] & OA_RETSCALAR)
6101 if (PL_opargs[type] & OA_TARGET)
6102 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
6103 return CHECKOP(type, pvop);
6107 Perl_package(pTHX_ OP *o)
6109 SV *const sv = cSVOPo->op_sv;
6111 PERL_ARGS_ASSERT_PACKAGE;
6113 SAVEGENERICSV(PL_curstash);
6114 save_item(PL_curstname);
6116 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
6118 sv_setsv(PL_curstname, sv);
6120 PL_hints |= HINT_BLOCK_SCOPE;
6121 PL_parser->copline = NOLINE;
6127 Perl_package_version( pTHX_ OP *v )
6129 U32 savehints = PL_hints;
6130 PERL_ARGS_ASSERT_PACKAGE_VERSION;
6131 PL_hints &= ~HINT_STRICT_VARS;
6132 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6133 PL_hints = savehints;
6138 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6143 SV *use_version = NULL;
6145 PERL_ARGS_ASSERT_UTILIZE;
6147 if (idop->op_type != OP_CONST)
6148 Perl_croak(aTHX_ "Module name must be constant");
6153 SV * const vesv = ((SVOP*)version)->op_sv;
6155 if (!arg && !SvNIOKp(vesv)) {
6162 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6163 Perl_croak(aTHX_ "Version number must be a constant number");
6165 /* Make copy of idop so we don't free it twice */
6166 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6168 /* Fake up a method call to VERSION */
6169 meth = newSVpvs_share("VERSION");
6170 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6171 op_append_elem(OP_LIST,
6172 op_prepend_elem(OP_LIST, pack, version),
6173 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6177 /* Fake up an import/unimport */
6178 if (arg && arg->op_type == OP_STUB) {
6179 imop = arg; /* no import on explicit () */
6181 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6182 imop = NULL; /* use 5.0; */
6184 use_version = ((SVOP*)idop)->op_sv;
6186 idop->op_private |= OPpCONST_NOVER;
6191 /* Make copy of idop so we don't free it twice */
6192 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6194 /* Fake up a method call to import/unimport */
6196 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6197 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6198 op_append_elem(OP_LIST,
6199 op_prepend_elem(OP_LIST, pack, arg),
6200 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6204 /* Fake up the BEGIN {}, which does its thing immediately. */
6206 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6209 op_append_elem(OP_LINESEQ,
6210 op_append_elem(OP_LINESEQ,
6211 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6212 newSTATEOP(0, NULL, veop)),
6213 newSTATEOP(0, NULL, imop) ));
6217 * feature bundle that corresponds to the required version. */
6218 use_version = sv_2mortal(new_version(use_version));
6219 S_enable_feature_bundle(aTHX_ use_version);
6221 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6222 if (vcmp(use_version,
6223 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6224 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6225 PL_hints |= HINT_STRICT_REFS;
6226 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6227 PL_hints |= HINT_STRICT_SUBS;
6228 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6229 PL_hints |= HINT_STRICT_VARS;
6231 /* otherwise they are off */
6233 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6234 PL_hints &= ~HINT_STRICT_REFS;
6235 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6236 PL_hints &= ~HINT_STRICT_SUBS;
6237 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6238 PL_hints &= ~HINT_STRICT_VARS;
6242 /* The "did you use incorrect case?" warning used to be here.
6243 * The problem is that on case-insensitive filesystems one
6244 * might get false positives for "use" (and "require"):
6245 * "use Strict" or "require CARP" will work. This causes
6246 * portability problems for the script: in case-strict
6247 * filesystems the script will stop working.
6249 * The "incorrect case" warning checked whether "use Foo"
6250 * imported "Foo" to your namespace, but that is wrong, too:
6251 * there is no requirement nor promise in the language that
6252 * a Foo.pm should or would contain anything in package "Foo".
6254 * There is very little Configure-wise that can be done, either:
6255 * the case-sensitivity of the build filesystem of Perl does not
6256 * help in guessing the case-sensitivity of the runtime environment.
6259 PL_hints |= HINT_BLOCK_SCOPE;
6260 PL_parser->copline = NOLINE;
6261 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6265 =head1 Embedding Functions
6267 =for apidoc load_module
6269 Loads the module whose name is pointed to by the string part of name.
6270 Note that the actual module name, not its filename, should be given.
6271 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
6272 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6273 (or 0 for no flags). ver, if specified
6274 and not NULL, provides version semantics
6275 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
6276 arguments can be used to specify arguments to the module's C<import()>
6277 method, similar to C<use Foo::Bar VERSION LIST>. They must be
6278 terminated with a final C<NULL> pointer. Note that this list can only
6279 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6280 Otherwise at least a single C<NULL> pointer to designate the default
6281 import list is required.
6283 The reference count for each specified C<SV*> parameter is decremented.
6288 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6292 PERL_ARGS_ASSERT_LOAD_MODULE;
6294 va_start(args, ver);
6295 vload_module(flags, name, ver, &args);
6299 #ifdef PERL_IMPLICIT_CONTEXT
6301 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6305 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6306 va_start(args, ver);
6307 vload_module(flags, name, ver, &args);
6313 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6316 OP * const modname = newSVOP(OP_CONST, 0, name);
6318 PERL_ARGS_ASSERT_VLOAD_MODULE;
6320 modname->op_private |= OPpCONST_BARE;
6322 veop = newSVOP(OP_CONST, 0, ver);
6326 if (flags & PERL_LOADMOD_NOIMPORT) {
6327 imop = sawparens(newNULLLIST());
6329 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6330 imop = va_arg(*args, OP*);
6335 sv = va_arg(*args, SV*);
6337 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6338 sv = va_arg(*args, SV*);
6342 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6343 * that it has a PL_parser to play with while doing that, and also
6344 * that it doesn't mess with any existing parser, by creating a tmp
6345 * new parser with lex_start(). This won't actually be used for much,
6346 * since pp_require() will create another parser for the real work.
6347 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6350 SAVEVPTR(PL_curcop);
6351 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6352 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6353 veop, modname, imop);
6357 PERL_STATIC_INLINE OP *
6358 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6360 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6361 newLISTOP(OP_LIST, 0, arg,
6362 newUNOP(OP_RV2CV, 0,
6363 newGVOP(OP_GV, 0, gv))));
6367 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6372 PERL_ARGS_ASSERT_DOFILE;
6374 if (!force_builtin && (gv = gv_override("do", 2))) {
6375 doop = S_new_entersubop(aTHX_ gv, term);
6378 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6384 =head1 Optree construction
6386 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6388 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
6389 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6390 be set automatically, and, shifted up eight bits, the eight bits of
6391 C<op_private>, except that the bit with value 1 or 2 is automatically
6392 set as required. C<listval> and C<subscript> supply the parameters of
6393 the slice; they are consumed by this function and become part of the
6394 constructed op tree.
6400 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6402 return newBINOP(OP_LSLICE, flags,
6403 list(force_list(subscript, 1)),
6404 list(force_list(listval, 1)) );
6407 #define ASSIGN_LIST 1
6408 #define ASSIGN_REF 2
6411 S_assignment_type(pTHX_ const OP *o)
6420 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6421 o = cUNOPo->op_first;
6423 flags = o->op_flags;
6425 if (type == OP_COND_EXPR) {
6426 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6427 const I32 t = assignment_type(sib);
6428 const I32 f = assignment_type(OpSIBLING(sib));
6430 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6432 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6433 yyerror("Assignment to both a list and a scalar");
6437 if (type == OP_SREFGEN)
6439 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6440 type = kid->op_type;
6441 flags |= kid->op_flags;
6442 if (!(flags & OPf_PARENS)
6443 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6444 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6450 if (type == OP_LIST &&
6451 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6452 o->op_private & OPpLVAL_INTRO)
6455 if (type == OP_LIST || flags & OPf_PARENS ||
6456 type == OP_RV2AV || type == OP_RV2HV ||
6457 type == OP_ASLICE || type == OP_HSLICE ||
6458 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6461 if (type == OP_PADAV || type == OP_PADHV)
6464 if (type == OP_RV2SV)
6472 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6474 Constructs, checks, and returns an assignment op. C<left> and C<right>
6475 supply the parameters of the assignment; they are consumed by this
6476 function and become part of the constructed op tree.
6478 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6479 a suitable conditional optree is constructed. If C<optype> is the opcode
6480 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6481 performs the binary operation and assigns the result to the left argument.
6482 Either way, if C<optype> is non-zero then C<flags> has no effect.
6484 If C<optype> is zero, then a plain scalar or list assignment is
6485 constructed. Which type of assignment it is is automatically determined.
6486 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6487 will be set automatically, and, shifted up eight bits, the eight bits
6488 of C<op_private>, except that the bit with value 1 or 2 is automatically
6495 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6501 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6502 return newLOGOP(optype, 0,
6503 op_lvalue(scalar(left), optype),
6504 newUNOP(OP_SASSIGN, 0, scalar(right)));
6507 return newBINOP(optype, OPf_STACKED,
6508 op_lvalue(scalar(left), optype), scalar(right));
6512 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6513 static const char no_list_state[] = "Initialization of state variables"
6514 " in list context currently forbidden";
6517 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6518 left->op_private &= ~ OPpSLICEWARNING;
6521 left = op_lvalue(left, OP_AASSIGN);
6522 curop = list(force_list(left, 1));
6523 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6524 o->op_private = (U8)(0 | (flags >> 8));
6526 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6528 OP* lop = ((LISTOP*)left)->op_first;
6530 if ((lop->op_type == OP_PADSV ||
6531 lop->op_type == OP_PADAV ||
6532 lop->op_type == OP_PADHV ||
6533 lop->op_type == OP_PADANY)
6534 && (lop->op_private & OPpPAD_STATE)
6536 yyerror(no_list_state);
6537 lop = OpSIBLING(lop);
6540 else if ( (left->op_private & OPpLVAL_INTRO)
6541 && (left->op_private & OPpPAD_STATE)
6542 && ( left->op_type == OP_PADSV
6543 || left->op_type == OP_PADAV
6544 || left->op_type == OP_PADHV
6545 || left->op_type == OP_PADANY)
6547 /* All single variable list context state assignments, hence
6557 yyerror(no_list_state);
6560 if (right && right->op_type == OP_SPLIT
6561 && !(right->op_flags & OPf_STACKED)) {
6562 OP* tmpop = ((LISTOP*)right)->op_first;
6563 PMOP * const pm = (PMOP*)tmpop;
6564 assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6567 !pm->op_pmreplrootu.op_pmtargetoff
6569 !pm->op_pmreplrootu.op_pmtargetgv
6573 if (!(left->op_private & OPpLVAL_INTRO) &&
6574 ( (left->op_type == OP_RV2AV &&
6575 (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6576 || left->op_type == OP_PADAV )
6578 if (tmpop != (OP *)pm) {
6580 pm->op_pmreplrootu.op_pmtargetoff
6581 = cPADOPx(tmpop)->op_padix;
6582 cPADOPx(tmpop)->op_padix = 0; /* steal it */
6584 pm->op_pmreplrootu.op_pmtargetgv
6585 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6586 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
6588 right->op_private |=
6589 left->op_private & OPpOUR_INTRO;
6592 pm->op_targ = left->op_targ;
6593 left->op_targ = 0; /* filch it */
6596 tmpop = cUNOPo->op_first; /* to list (nulled) */
6597 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6598 /* detach rest of siblings from o subtree,
6599 * and free subtree */
6600 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6601 op_free(o); /* blow off assign */
6602 right->op_flags &= ~OPf_WANT;
6603 /* "I don't know and I don't care." */
6606 else if (left->op_type == OP_RV2AV
6607 || left->op_type == OP_PADAV)
6609 /* Detach the array. */
6613 op_sibling_splice(cBINOPo->op_last,
6614 cUNOPx(cBINOPo->op_last)
6615 ->op_first, 1, NULL);
6616 assert(ary == left);
6617 /* Attach it to the split. */
6618 op_sibling_splice(right, cLISTOPx(right)->op_last,
6620 right->op_flags |= OPf_STACKED;
6621 /* Detach split and expunge aassign as above. */
6624 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6625 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6628 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6629 SV * const sv = *svp;
6630 if (SvIOK(sv) && SvIVX(sv) == 0)
6632 if (right->op_private & OPpSPLIT_IMPLIM) {
6633 /* our own SV, created in ck_split */
6635 sv_setiv(sv, PL_modcount+1);
6638 /* SV may belong to someone else */
6640 *svp = newSViv(PL_modcount+1);
6648 if (assign_type == ASSIGN_REF)
6649 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6651 right = newOP(OP_UNDEF, 0);
6652 if (right->op_type == OP_READLINE) {
6653 right->op_flags |= OPf_STACKED;
6654 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6658 o = newBINOP(OP_SASSIGN, flags,
6659 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6665 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6667 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6668 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6669 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6670 If C<label> is non-null, it supplies the name of a label to attach to
6671 the state op; this function takes ownership of the memory pointed at by
6672 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
6675 If C<o> is null, the state op is returned. Otherwise the state op is
6676 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
6677 is consumed by this function and becomes part of the returned op tree.
6683 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6686 const U32 seq = intro_my();
6687 const U32 utf8 = flags & SVf_UTF8;
6690 PL_parser->parsed_sub = 0;
6694 NewOp(1101, cop, 1, COP);
6695 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6696 OpTYPE_set(cop, OP_DBSTATE);
6699 OpTYPE_set(cop, OP_NEXTSTATE);
6701 cop->op_flags = (U8)flags;
6702 CopHINTS_set(cop, PL_hints);
6704 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6706 cop->op_next = (OP*)cop;
6709 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6710 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6712 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6714 PL_hints |= HINT_BLOCK_SCOPE;
6715 /* It seems that we need to defer freeing this pointer, as other parts
6716 of the grammar end up wanting to copy it after this op has been
6721 if (PL_parser->preambling != NOLINE) {
6722 CopLINE_set(cop, PL_parser->preambling);
6723 PL_parser->copline = NOLINE;
6725 else if (PL_parser->copline == NOLINE)
6726 CopLINE_set(cop, CopLINE(PL_curcop));
6728 CopLINE_set(cop, PL_parser->copline);
6729 PL_parser->copline = NOLINE;
6732 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6734 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6736 CopSTASH_set(cop, PL_curstash);
6738 if (cop->op_type == OP_DBSTATE) {
6739 /* this line can have a breakpoint - store the cop in IV */
6740 AV *av = CopFILEAVx(PL_curcop);
6742 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6743 if (svp && *svp != &PL_sv_undef ) {
6744 (void)SvIOK_on(*svp);
6745 SvIV_set(*svp, PTR2IV(cop));
6750 if (flags & OPf_SPECIAL)
6752 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6756 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6758 Constructs, checks, and returns a logical (flow control) op. C<type>
6759 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6760 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6761 the eight bits of C<op_private>, except that the bit with value 1 is
6762 automatically set. C<first> supplies the expression controlling the
6763 flow, and C<other> supplies the side (alternate) chain of ops; they are
6764 consumed by this function and become part of the constructed op tree.
6770 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6772 PERL_ARGS_ASSERT_NEWLOGOP;
6774 return new_logop(type, flags, &first, &other);
6778 S_search_const(pTHX_ OP *o)
6780 PERL_ARGS_ASSERT_SEARCH_CONST;
6782 switch (o->op_type) {
6786 if (o->op_flags & OPf_KIDS)
6787 return search_const(cUNOPo->op_first);
6794 if (!(o->op_flags & OPf_KIDS))
6796 kid = cLISTOPo->op_first;
6798 switch (kid->op_type) {
6802 kid = OpSIBLING(kid);
6805 if (kid != cLISTOPo->op_last)
6811 kid = cLISTOPo->op_last;
6813 return search_const(kid);
6821 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6829 int prepend_not = 0;
6831 PERL_ARGS_ASSERT_NEW_LOGOP;
6836 /* [perl #59802]: Warn about things like "return $a or $b", which
6837 is parsed as "(return $a) or $b" rather than "return ($a or
6838 $b)". NB: This also applies to xor, which is why we do it
6841 switch (first->op_type) {
6845 /* XXX: Perhaps we should emit a stronger warning for these.
6846 Even with the high-precedence operator they don't seem to do
6849 But until we do, fall through here.
6855 /* XXX: Currently we allow people to "shoot themselves in the
6856 foot" by explicitly writing "(return $a) or $b".
6858 Warn unless we are looking at the result from folding or if
6859 the programmer explicitly grouped the operators like this.
6860 The former can occur with e.g.
6862 use constant FEATURE => ( $] >= ... );
6863 sub { not FEATURE and return or do_stuff(); }
6865 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6866 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6867 "Possible precedence issue with control flow operator");
6868 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6874 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6875 return newBINOP(type, flags, scalar(first), scalar(other));
6877 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6878 || type == OP_CUSTOM);
6880 scalarboolean(first);
6882 /* search for a constant op that could let us fold the test */
6883 if ((cstop = search_const(first))) {
6884 if (cstop->op_private & OPpCONST_STRICT)
6885 no_bareword_allowed(cstop);
6886 else if ((cstop->op_private & OPpCONST_BARE))
6887 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6888 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6889 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6890 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6891 /* Elide the (constant) lhs, since it can't affect the outcome */
6893 if (other->op_type == OP_CONST)
6894 other->op_private |= OPpCONST_SHORTCIRCUIT;
6896 if (other->op_type == OP_LEAVE)
6897 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6898 else if (other->op_type == OP_MATCH
6899 || other->op_type == OP_SUBST
6900 || other->op_type == OP_TRANSR
6901 || other->op_type == OP_TRANS)
6902 /* Mark the op as being unbindable with =~ */
6903 other->op_flags |= OPf_SPECIAL;
6905 other->op_folded = 1;
6909 /* Elide the rhs, since the outcome is entirely determined by
6910 * the (constant) lhs */
6912 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6913 const OP *o2 = other;
6914 if ( ! (o2->op_type == OP_LIST
6915 && (( o2 = cUNOPx(o2)->op_first))
6916 && o2->op_type == OP_PUSHMARK
6917 && (( o2 = OpSIBLING(o2))) )
6920 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6921 || o2->op_type == OP_PADHV)
6922 && o2->op_private & OPpLVAL_INTRO
6923 && !(o2->op_private & OPpPAD_STATE))
6925 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6926 "Deprecated use of my() in false conditional");
6930 if (cstop->op_type == OP_CONST)
6931 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6936 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6937 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6939 const OP * const k1 = ((UNOP*)first)->op_first;
6940 const OP * const k2 = OpSIBLING(k1);
6942 switch (first->op_type)
6945 if (k2 && k2->op_type == OP_READLINE
6946 && (k2->op_flags & OPf_STACKED)
6947 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6949 warnop = k2->op_type;
6954 if (k1->op_type == OP_READDIR
6955 || k1->op_type == OP_GLOB
6956 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6957 || k1->op_type == OP_EACH
6958 || k1->op_type == OP_AEACH)
6960 warnop = ((k1->op_type == OP_NULL)
6961 ? (OPCODE)k1->op_targ : k1->op_type);
6966 const line_t oldline = CopLINE(PL_curcop);
6967 /* This ensures that warnings are reported at the first line
6968 of the construction, not the last. */
6969 CopLINE_set(PL_curcop, PL_parser->copline);
6970 Perl_warner(aTHX_ packWARN(WARN_MISC),
6971 "Value of %s%s can be \"0\"; test with defined()",
6973 ((warnop == OP_READLINE || warnop == OP_GLOB)
6974 ? " construct" : "() operator"));
6975 CopLINE_set(PL_curcop, oldline);
6979 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6980 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6982 /* optimize AND and OR ops that have NOTs as children */
6983 if (first->op_type == OP_NOT
6984 && (first->op_flags & OPf_KIDS)
6985 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6986 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6988 if (type == OP_AND || type == OP_OR) {
6994 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6996 prepend_not = 1; /* prepend a NOT op later */
7001 logop = alloc_LOGOP(type, first, LINKLIST(other));
7002 logop->op_flags |= (U8)flags;
7003 logop->op_private = (U8)(1 | (flags >> 8));
7005 /* establish postfix order */
7006 logop->op_next = LINKLIST(first);
7007 first->op_next = (OP*)logop;
7008 assert(!OpHAS_SIBLING(first));
7009 op_sibling_splice((OP*)logop, first, 0, other);
7011 CHECKOP(type,logop);
7013 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7014 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7022 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7024 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7025 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7026 will be set automatically, and, shifted up eight bits, the eight bits of
7027 C<op_private>, except that the bit with value 1 is automatically set.
7028 C<first> supplies the expression selecting between the two branches,
7029 and C<trueop> and C<falseop> supply the branches; they are consumed by
7030 this function and become part of the constructed op tree.
7036 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7044 PERL_ARGS_ASSERT_NEWCONDOP;
7047 return newLOGOP(OP_AND, 0, first, trueop);
7049 return newLOGOP(OP_OR, 0, first, falseop);
7051 scalarboolean(first);
7052 if ((cstop = search_const(first))) {
7053 /* Left or right arm of the conditional? */
7054 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7055 OP *live = left ? trueop : falseop;
7056 OP *const dead = left ? falseop : trueop;
7057 if (cstop->op_private & OPpCONST_BARE &&
7058 cstop->op_private & OPpCONST_STRICT) {
7059 no_bareword_allowed(cstop);
7063 if (live->op_type == OP_LEAVE)
7064 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7065 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7066 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7067 /* Mark the op as being unbindable with =~ */
7068 live->op_flags |= OPf_SPECIAL;
7069 live->op_folded = 1;
7072 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
7073 logop->op_flags |= (U8)flags;
7074 logop->op_private = (U8)(1 | (flags >> 8));
7075 logop->op_next = LINKLIST(falseop);
7077 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7080 /* establish postfix order */
7081 start = LINKLIST(first);
7082 first->op_next = (OP*)logop;
7084 /* make first, trueop, falseop siblings */
7085 op_sibling_splice((OP*)logop, first, 0, trueop);
7086 op_sibling_splice((OP*)logop, trueop, 0, falseop);
7088 o = newUNOP(OP_NULL, 0, (OP*)logop);
7090 trueop->op_next = falseop->op_next = o;
7097 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7099 Constructs and returns a C<range> op, with subordinate C<flip> and
7100 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
7101 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7102 for both the C<flip> and C<range> ops, except that the bit with value
7103 1 is automatically set. C<left> and C<right> supply the expressions
7104 controlling the endpoints of the range; they are consumed by this function
7105 and become part of the constructed op tree.
7111 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7119 PERL_ARGS_ASSERT_NEWRANGE;
7121 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
7122 range->op_flags = OPf_KIDS;
7123 leftstart = LINKLIST(left);
7124 range->op_private = (U8)(1 | (flags >> 8));
7126 /* make left and right siblings */
7127 op_sibling_splice((OP*)range, left, 0, right);
7129 range->op_next = (OP*)range;
7130 flip = newUNOP(OP_FLIP, flags, (OP*)range);
7131 flop = newUNOP(OP_FLOP, 0, flip);
7132 o = newUNOP(OP_NULL, 0, flop);
7134 range->op_next = leftstart;
7136 left->op_next = flip;
7137 right->op_next = flop;
7140 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7141 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7143 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7144 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7145 SvPADTMP_on(PAD_SV(flip->op_targ));
7147 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7148 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7150 /* check barewords before they might be optimized aways */
7151 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7152 no_bareword_allowed(left);
7153 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7154 no_bareword_allowed(right);
7157 if (!flip->op_private || !flop->op_private)
7158 LINKLIST(o); /* blow off optimizer unless constant */
7164 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7166 Constructs, checks, and returns an op tree expressing a loop. This is
7167 only a loop in the control flow through the op tree; it does not have
7168 the heavyweight loop structure that allows exiting the loop by C<last>
7169 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
7170 top-level op, except that some bits will be set automatically as required.
7171 C<expr> supplies the expression controlling loop iteration, and C<block>
7172 supplies the body of the loop; they are consumed by this function and
7173 become part of the constructed op tree. C<debuggable> is currently
7174 unused and should always be 1.
7180 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7184 const bool once = block && block->op_flags & OPf_SPECIAL &&
7185 block->op_type == OP_NULL;
7187 PERL_UNUSED_ARG(debuggable);
7191 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7192 || ( expr->op_type == OP_NOT
7193 && cUNOPx(expr)->op_first->op_type == OP_CONST
7194 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7197 /* Return the block now, so that S_new_logop does not try to
7199 return block; /* do {} while 0 does once */
7200 if (expr->op_type == OP_READLINE
7201 || expr->op_type == OP_READDIR
7202 || expr->op_type == OP_GLOB
7203 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7204 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7205 expr = newUNOP(OP_DEFINED, 0,
7206 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7207 } else if (expr->op_flags & OPf_KIDS) {
7208 const OP * const k1 = ((UNOP*)expr)->op_first;
7209 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7210 switch (expr->op_type) {
7212 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7213 && (k2->op_flags & OPf_STACKED)
7214 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7215 expr = newUNOP(OP_DEFINED, 0, expr);
7219 if (k1 && (k1->op_type == OP_READDIR
7220 || k1->op_type == OP_GLOB
7221 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7222 || k1->op_type == OP_EACH
7223 || k1->op_type == OP_AEACH))
7224 expr = newUNOP(OP_DEFINED, 0, expr);
7230 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7231 * op, in listop. This is wrong. [perl #27024] */
7233 block = newOP(OP_NULL, 0);
7234 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7235 o = new_logop(OP_AND, 0, &expr, &listop);
7242 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7244 if (once && o != listop)
7246 assert(cUNOPo->op_first->op_type == OP_AND
7247 || cUNOPo->op_first->op_type == OP_OR);
7248 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7252 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7254 o->op_flags |= flags;
7256 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7261 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7263 Constructs, checks, and returns an op tree expressing a C<while> loop.
7264 This is a heavyweight loop, with structure that allows exiting the loop
7265 by C<last> and suchlike.
7267 C<loop> is an optional preconstructed C<enterloop> op to use in the
7268 loop; if it is null then a suitable op will be constructed automatically.
7269 C<expr> supplies the loop's controlling expression. C<block> supplies the
7270 main body of the loop, and C<cont> optionally supplies a C<continue> block
7271 that operates as a second half of the body. All of these optree inputs
7272 are consumed by this function and become part of the constructed op tree.
7274 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7275 op and, shifted up eight bits, the eight bits of C<op_private> for
7276 the C<leaveloop> op, except that (in both cases) some bits will be set
7277 automatically. C<debuggable> is currently unused and should always be 1.
7278 C<has_my> can be supplied as true to force the
7279 loop body to be enclosed in its own scope.
7285 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7286 OP *expr, OP *block, OP *cont, I32 has_my)
7295 PERL_UNUSED_ARG(debuggable);
7298 if (expr->op_type == OP_READLINE
7299 || expr->op_type == OP_READDIR
7300 || expr->op_type == OP_GLOB
7301 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7302 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7303 expr = newUNOP(OP_DEFINED, 0,
7304 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7305 } else if (expr->op_flags & OPf_KIDS) {
7306 const OP * const k1 = ((UNOP*)expr)->op_first;
7307 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7308 switch (expr->op_type) {
7310 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7311 && (k2->op_flags & OPf_STACKED)
7312 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7313 expr = newUNOP(OP_DEFINED, 0, expr);
7317 if (k1 && (k1->op_type == OP_READDIR
7318 || k1->op_type == OP_GLOB
7319 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7320 || k1->op_type == OP_EACH
7321 || k1->op_type == OP_AEACH))
7322 expr = newUNOP(OP_DEFINED, 0, expr);
7329 block = newOP(OP_NULL, 0);
7330 else if (cont || has_my) {
7331 block = op_scope(block);
7335 next = LINKLIST(cont);
7338 OP * const unstack = newOP(OP_UNSTACK, 0);
7341 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7345 listop = op_append_list(OP_LINESEQ, block, cont);
7347 redo = LINKLIST(listop);
7351 o = new_logop(OP_AND, 0, &expr, &listop);
7352 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7354 return expr; /* listop already freed by new_logop */
7357 ((LISTOP*)listop)->op_last->op_next =
7358 (o == listop ? redo : LINKLIST(o));
7364 NewOp(1101,loop,1,LOOP);
7365 OpTYPE_set(loop, OP_ENTERLOOP);
7366 loop->op_private = 0;
7367 loop->op_next = (OP*)loop;
7370 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7372 loop->op_redoop = redo;
7373 loop->op_lastop = o;
7374 o->op_private |= loopflags;
7377 loop->op_nextop = next;
7379 loop->op_nextop = o;
7381 o->op_flags |= flags;
7382 o->op_private |= (flags >> 8);
7387 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7389 Constructs, checks, and returns an op tree expressing a C<foreach>
7390 loop (iteration through a list of values). This is a heavyweight loop,
7391 with structure that allows exiting the loop by C<last> and suchlike.
7393 C<sv> optionally supplies the variable that will be aliased to each
7394 item in turn; if null, it defaults to C<$_>.
7395 C<expr> supplies the list of values to iterate over. C<block> supplies
7396 the main body of the loop, and C<cont> optionally supplies a C<continue>
7397 block that operates as a second half of the body. All of these optree
7398 inputs are consumed by this function and become part of the constructed
7401 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7402 op and, shifted up eight bits, the eight bits of C<op_private> for
7403 the C<leaveloop> op, except that (in both cases) some bits will be set
7410 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7415 PADOFFSET padoff = 0;
7419 PERL_ARGS_ASSERT_NEWFOROP;
7422 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7423 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7424 OpTYPE_set(sv, OP_RV2GV);
7426 /* The op_type check is needed to prevent a possible segfault
7427 * if the loop variable is undeclared and 'strict vars' is in
7428 * effect. This is illegal but is nonetheless parsed, so we
7429 * may reach this point with an OP_CONST where we're expecting
7432 if (cUNOPx(sv)->op_first->op_type == OP_GV
7433 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7434 iterpflags |= OPpITER_DEF;
7436 else if (sv->op_type == OP_PADSV) { /* private variable */
7437 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7438 padoff = sv->op_targ;
7442 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7444 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7447 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7449 PADNAME * const pn = PAD_COMPNAME(padoff);
7450 const char * const name = PadnamePV(pn);
7452 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7453 iterpflags |= OPpITER_DEF;
7457 sv = newGVOP(OP_GV, 0, PL_defgv);
7458 iterpflags |= OPpITER_DEF;
7461 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7462 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7463 iterflags |= OPf_STACKED;
7465 else if (expr->op_type == OP_NULL &&
7466 (expr->op_flags & OPf_KIDS) &&
7467 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7469 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7470 * set the STACKED flag to indicate that these values are to be
7471 * treated as min/max values by 'pp_enteriter'.
7473 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7474 LOGOP* const range = (LOGOP*) flip->op_first;
7475 OP* const left = range->op_first;
7476 OP* const right = OpSIBLING(left);
7479 range->op_flags &= ~OPf_KIDS;
7480 /* detach range's children */
7481 op_sibling_splice((OP*)range, NULL, -1, NULL);
7483 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7484 listop->op_first->op_next = range->op_next;
7485 left->op_next = range->op_other;
7486 right->op_next = (OP*)listop;
7487 listop->op_next = listop->op_first;
7490 expr = (OP*)(listop);
7492 iterflags |= OPf_STACKED;
7495 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7498 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7499 op_append_elem(OP_LIST, list(expr),
7501 assert(!loop->op_next);
7502 /* for my $x () sets OPpLVAL_INTRO;
7503 * for our $x () sets OPpOUR_INTRO */
7504 loop->op_private = (U8)iterpflags;
7505 if (loop->op_slabbed
7506 && DIFF(loop, OpSLOT(loop)->opslot_next)
7507 < SIZE_TO_PSIZE(sizeof(LOOP)))
7510 NewOp(1234,tmp,1,LOOP);
7511 Copy(loop,tmp,1,LISTOP);
7512 #ifdef PERL_OP_PARENT
7513 assert(loop->op_last->op_sibparent == (OP*)loop);
7514 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7516 S_op_destroy(aTHX_ (OP*)loop);
7519 else if (!loop->op_slabbed)
7521 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7522 #ifdef PERL_OP_PARENT
7523 OpLASTSIB_set(loop->op_last, (OP*)loop);
7526 loop->op_targ = padoff;
7527 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7532 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7534 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7535 or C<last>). C<type> is the opcode. C<label> supplies the parameter
7536 determining the target of the op; it is consumed by this function and
7537 becomes part of the constructed op tree.
7543 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7547 PERL_ARGS_ASSERT_NEWLOOPEX;
7549 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7550 || type == OP_CUSTOM);
7552 if (type != OP_GOTO) {
7553 /* "last()" means "last" */
7554 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7555 o = newOP(type, OPf_SPECIAL);
7559 /* Check whether it's going to be a goto &function */
7560 if (label->op_type == OP_ENTERSUB
7561 && !(label->op_flags & OPf_STACKED))
7562 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7565 /* Check for a constant argument */
7566 if (label->op_type == OP_CONST) {
7567 SV * const sv = ((SVOP *)label)->op_sv;
7569 const char *s = SvPV_const(sv,l);
7570 if (l == strlen(s)) {
7572 SvUTF8(((SVOP*)label)->op_sv),
7574 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7578 /* If we have already created an op, we do not need the label. */
7581 else o = newUNOP(type, OPf_STACKED, label);
7583 PL_hints |= HINT_BLOCK_SCOPE;
7587 /* if the condition is a literal array or hash
7588 (or @{ ... } etc), make a reference to it.
7591 S_ref_array_or_hash(pTHX_ OP *cond)
7594 && (cond->op_type == OP_RV2AV
7595 || cond->op_type == OP_PADAV
7596 || cond->op_type == OP_RV2HV
7597 || cond->op_type == OP_PADHV))
7599 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7602 && (cond->op_type == OP_ASLICE
7603 || cond->op_type == OP_KVASLICE
7604 || cond->op_type == OP_HSLICE
7605 || cond->op_type == OP_KVHSLICE)) {
7607 /* anonlist now needs a list from this op, was previously used in
7609 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7610 cond->op_flags |= OPf_WANT_LIST;
7612 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7619 /* These construct the optree fragments representing given()
7622 entergiven and enterwhen are LOGOPs; the op_other pointer
7623 points up to the associated leave op. We need this so we
7624 can put it in the context and make break/continue work.
7625 (Also, of course, pp_enterwhen will jump straight to
7626 op_other if the match fails.)
7630 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7631 I32 enter_opcode, I32 leave_opcode,
7632 PADOFFSET entertarg)
7638 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7639 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7641 enterop = alloc_LOGOP(enter_opcode, block, NULL);
7642 enterop->op_targ = 0;
7643 enterop->op_private = 0;
7645 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7648 /* prepend cond if we have one */
7649 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7651 o->op_next = LINKLIST(cond);
7652 cond->op_next = (OP *) enterop;
7655 /* This is a default {} block */
7656 enterop->op_flags |= OPf_SPECIAL;
7657 o ->op_flags |= OPf_SPECIAL;
7659 o->op_next = (OP *) enterop;
7662 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7663 entergiven and enterwhen both
7666 enterop->op_next = LINKLIST(block);
7667 block->op_next = enterop->op_other = o;
7672 /* Does this look like a boolean operation? For these purposes
7673 a boolean operation is:
7674 - a subroutine call [*]
7675 - a logical connective
7676 - a comparison operator
7677 - a filetest operator, with the exception of -s -M -A -C
7678 - defined(), exists() or eof()
7679 - /$re/ or $foo =~ /$re/
7681 [*] possibly surprising
7684 S_looks_like_bool(pTHX_ const OP *o)
7686 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7688 switch(o->op_type) {
7691 return looks_like_bool(cLOGOPo->op_first);
7695 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7698 looks_like_bool(cLOGOPo->op_first)
7699 && looks_like_bool(sibl));
7705 o->op_flags & OPf_KIDS
7706 && looks_like_bool(cUNOPo->op_first));
7710 case OP_NOT: case OP_XOR:
7712 case OP_EQ: case OP_NE: case OP_LT:
7713 case OP_GT: case OP_LE: case OP_GE:
7715 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7716 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7718 case OP_SEQ: case OP_SNE: case OP_SLT:
7719 case OP_SGT: case OP_SLE: case OP_SGE:
7723 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7724 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7725 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7726 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7727 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7728 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7729 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7730 case OP_FTTEXT: case OP_FTBINARY:
7732 case OP_DEFINED: case OP_EXISTS:
7733 case OP_MATCH: case OP_EOF:
7740 /* Detect comparisons that have been optimized away */
7741 if (cSVOPo->op_sv == &PL_sv_yes
7742 || cSVOPo->op_sv == &PL_sv_no)
7755 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7757 Constructs, checks, and returns an op tree expressing a C<given> block.
7758 C<cond> supplies the expression that will be locally assigned to a lexical
7759 variable, and C<block> supplies the body of the C<given> construct; they
7760 are consumed by this function and become part of the constructed op tree.
7761 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7767 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7769 PERL_ARGS_ASSERT_NEWGIVENOP;
7770 PERL_UNUSED_ARG(defsv_off);
7773 return newGIVWHENOP(
7774 ref_array_or_hash(cond),
7776 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7781 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7783 Constructs, checks, and returns an op tree expressing a C<when> block.
7784 C<cond> supplies the test expression, and C<block> supplies the block
7785 that will be executed if the test evaluates to true; they are consumed
7786 by this function and become part of the constructed op tree. C<cond>
7787 will be interpreted DWIMically, often as a comparison against C<$_>,
7788 and may be null to generate a C<default> block.
7794 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7796 const bool cond_llb = (!cond || looks_like_bool(cond));
7799 PERL_ARGS_ASSERT_NEWWHENOP;
7804 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7806 scalar(ref_array_or_hash(cond)));
7809 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7812 /* must not conflict with SVf_UTF8 */
7813 #define CV_CKPROTO_CURSTASH 0x1
7816 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7817 const STRLEN len, const U32 flags)
7819 SV *name = NULL, *msg;
7820 const char * cvp = SvROK(cv)
7821 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7822 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7825 STRLEN clen = CvPROTOLEN(cv), plen = len;
7827 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7829 if (p == NULL && cvp == NULL)
7832 if (!ckWARN_d(WARN_PROTOTYPE))
7836 p = S_strip_spaces(aTHX_ p, &plen);
7837 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7838 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7839 if (plen == clen && memEQ(cvp, p, plen))
7842 if (flags & SVf_UTF8) {
7843 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7847 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7853 msg = sv_newmortal();
7858 gv_efullname3(name = sv_newmortal(), gv, NULL);
7859 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7860 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7861 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7862 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7863 sv_catpvs(name, "::");
7865 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7866 assert (CvNAMED(SvRV_const(gv)));
7867 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7869 else sv_catsv(name, (SV *)gv);
7871 else name = (SV *)gv;
7873 sv_setpvs(msg, "Prototype mismatch:");
7875 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7877 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7878 UTF8fARG(SvUTF8(cv),clen,cvp)
7881 sv_catpvs(msg, ": none");
7882 sv_catpvs(msg, " vs ");
7884 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7886 sv_catpvs(msg, "none");
7887 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7890 static void const_sv_xsub(pTHX_ CV* cv);
7891 static void const_av_xsub(pTHX_ CV* cv);
7895 =head1 Optree Manipulation Functions
7897 =for apidoc cv_const_sv
7899 If C<cv> is a constant sub eligible for inlining, returns the constant
7900 value returned by the sub. Otherwise, returns C<NULL>.
7902 Constant subs can be created with C<newCONSTSUB> or as described in
7903 L<perlsub/"Constant Functions">.
7908 Perl_cv_const_sv(const CV *const cv)
7913 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7915 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7916 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7921 Perl_cv_const_sv_or_av(const CV * const cv)
7925 if (SvROK(cv)) return SvRV((SV *)cv);
7926 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7927 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7930 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7931 * Can be called in 2 ways:
7934 * look for a single OP_CONST with attached value: return the value
7936 * allow_lex && !CvCONST(cv);
7938 * examine the clone prototype, and if contains only a single
7939 * OP_CONST, return the value; or if it contains a single PADSV ref-
7940 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7941 * a candidate for "constizing" at clone time, and return NULL.
7945 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7953 for (; o; o = o->op_next) {
7954 const OPCODE type = o->op_type;
7956 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7958 || type == OP_PUSHMARK)
7960 if (type == OP_DBSTATE)
7962 if (type == OP_LEAVESUB)
7966 if (type == OP_CONST && cSVOPo->op_sv)
7968 else if (type == OP_UNDEF && !o->op_private) {
7972 else if (allow_lex && type == OP_PADSV) {
7973 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7975 sv = &PL_sv_undef; /* an arbitrary non-null value */
7993 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7994 PADNAME * const name, SV ** const const_svp)
8001 if (CvFLAGS(PL_compcv)) {
8002 /* might have had built-in attrs applied */
8003 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
8004 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8005 && ckWARN(WARN_MISC))
8007 /* protect against fatal warnings leaking compcv */
8008 SAVEFREESV(PL_compcv);
8009 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8010 SvREFCNT_inc_simple_void_NN(PL_compcv);
8013 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8014 & ~(CVf_LVALUE * pureperl));
8019 /* redundant check for speed: */
8020 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8021 const line_t oldline = CopLINE(PL_curcop);
8024 : sv_2mortal(newSVpvn_utf8(
8025 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8027 if (PL_parser && PL_parser->copline != NOLINE)
8028 /* This ensures that warnings are reported at the first
8029 line of a redefinition, not the last. */
8030 CopLINE_set(PL_curcop, PL_parser->copline);
8031 /* protect against fatal warnings leaking compcv */
8032 SAVEFREESV(PL_compcv);
8033 report_redefined_cv(namesv, cv, const_svp);
8034 SvREFCNT_inc_simple_void_NN(PL_compcv);
8035 CopLINE_set(PL_curcop, oldline);
8042 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8047 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8050 CV *compcv = PL_compcv;
8053 PADOFFSET pax = o->op_targ;
8054 CV *outcv = CvOUTSIDE(PL_compcv);
8057 bool reusable = FALSE;
8059 #ifdef PERL_DEBUG_READONLY_OPS
8060 OPSLAB *slab = NULL;
8063 PERL_ARGS_ASSERT_NEWMYSUB;
8065 /* Find the pad slot for storing the new sub.
8066 We cannot use PL_comppad, as it is the pad owned by the new sub. We
8067 need to look in CvOUTSIDE and find the pad belonging to the enclos-
8068 ing sub. And then we need to dig deeper if this is a lexical from
8070 my sub foo; sub { sub foo { } }
8073 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8074 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8075 pax = PARENT_PAD_INDEX(name);
8076 outcv = CvOUTSIDE(outcv);
8081 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8082 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8083 spot = (CV **)svspot;
8085 if (!(PL_parser && PL_parser->error_count))
8086 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8089 assert(proto->op_type == OP_CONST);
8090 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8091 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8101 if (PL_parser && PL_parser->error_count) {
8103 SvREFCNT_dec(PL_compcv);
8108 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8110 svspot = (SV **)(spot = &clonee);
8112 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8115 assert (SvTYPE(*spot) == SVt_PVCV);
8117 hek = CvNAME_HEK(*spot);
8121 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8122 CvNAME_HEK_set(*spot, hek =
8125 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8129 CvLEXICAL_on(*spot);
8131 cv = PadnamePROTOCV(name);
8132 svspot = (SV **)(spot = &PadnamePROTOCV(name));
8136 /* This makes sub {}; work as expected. */
8137 if (block->op_type == OP_STUB) {
8138 const line_t l = PL_parser->copline;
8140 block = newSTATEOP(0, NULL, 0);
8141 PL_parser->copline = l;
8143 block = CvLVALUE(compcv)
8144 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8145 ? newUNOP(OP_LEAVESUBLV, 0,
8146 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8147 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8148 start = LINKLIST(block);
8150 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8151 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8159 const bool exists = CvROOT(cv) || CvXSUB(cv);
8161 /* if the subroutine doesn't exist and wasn't pre-declared
8162 * with a prototype, assume it will be AUTOLOADed,
8163 * skipping the prototype check
8165 if (exists || SvPOK(cv))
8166 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8168 /* already defined? */
8170 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8173 if (attrs) goto attrs;
8174 /* just a "sub foo;" when &foo is already defined */
8179 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8185 SvREFCNT_inc_simple_void_NN(const_sv);
8186 SvFLAGS(const_sv) |= SVs_PADTMP;
8188 assert(!CvROOT(cv) && !CvCONST(cv));
8192 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8193 CvFILE_set_from_cop(cv, PL_curcop);
8194 CvSTASH_set(cv, PL_curstash);
8197 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8198 CvXSUBANY(cv).any_ptr = const_sv;
8199 CvXSUB(cv) = const_sv_xsub;
8203 CvFLAGS(cv) |= CvMETHOD(compcv);
8205 SvREFCNT_dec(compcv);
8209 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8210 determine whether this sub definition is in the same scope as its
8211 declaration. If this sub definition is inside an inner named pack-
8212 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8213 the package sub. So check PadnameOUTER(name) too.
8215 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8216 assert(!CvWEAKOUTSIDE(compcv));
8217 SvREFCNT_dec(CvOUTSIDE(compcv));
8218 CvWEAKOUTSIDE_on(compcv);
8220 /* XXX else do we have a circular reference? */
8221 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8222 /* transfer PL_compcv to cv */
8225 cv_flags_t preserved_flags =
8226 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8227 PADLIST *const temp_padl = CvPADLIST(cv);
8228 CV *const temp_cv = CvOUTSIDE(cv);
8229 const cv_flags_t other_flags =
8230 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8231 OP * const cvstart = CvSTART(cv);
8235 CvFLAGS(compcv) | preserved_flags;
8236 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8237 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8238 CvPADLIST_set(cv, CvPADLIST(compcv));
8239 CvOUTSIDE(compcv) = temp_cv;
8240 CvPADLIST_set(compcv, temp_padl);
8241 CvSTART(cv) = CvSTART(compcv);
8242 CvSTART(compcv) = cvstart;
8243 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8244 CvFLAGS(compcv) |= other_flags;
8246 if (CvFILE(cv) && CvDYNFILE(cv)) {
8247 Safefree(CvFILE(cv));
8250 /* inner references to compcv must be fixed up ... */
8251 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8252 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8253 ++PL_sub_generation;
8256 /* Might have had built-in attributes applied -- propagate them. */
8257 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8259 /* ... before we throw it away */
8260 SvREFCNT_dec(compcv);
8261 PL_compcv = compcv = cv;
8269 if (!CvNAME_HEK(cv)) {
8270 if (hek) (void)share_hek_hek(hek);
8274 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8275 hek = share_hek(PadnamePV(name)+1,
8276 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8279 CvNAME_HEK_set(cv, hek);
8281 if (const_sv) goto clone;
8283 CvFILE_set_from_cop(cv, PL_curcop);
8284 CvSTASH_set(cv, PL_curstash);
8287 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8288 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8294 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8295 the debugger could be able to set a breakpoint in, so signal to
8296 pp_entereval that it should not throw away any saved lines at scope
8299 PL_breakable_sub_gen++;
8301 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8302 OpREFCNT_set(CvROOT(cv), 1);
8303 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8304 itself has a refcount. */
8306 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8307 #ifdef PERL_DEBUG_READONLY_OPS
8308 slab = (OPSLAB *)CvSTART(cv);
8310 CvSTART(cv) = start;
8312 finalize_optree(CvROOT(cv));
8313 S_prune_chain_head(&CvSTART(cv));
8315 /* now that optimizer has done its work, adjust pad values */
8317 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8321 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8322 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8326 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8327 SV * const tmpstr = sv_newmortal();
8328 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8329 GV_ADDMULTI, SVt_PVHV);
8331 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8334 (long)CopLINE(PL_curcop));
8335 if (HvNAME_HEK(PL_curstash)) {
8336 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8337 sv_catpvs(tmpstr, "::");
8339 else sv_setpvs(tmpstr, "__ANON__::");
8340 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8341 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8342 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8343 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8344 hv = GvHVn(db_postponed);
8345 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8346 CV * const pcv = GvCV(db_postponed);
8352 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8360 assert(CvDEPTH(outcv));
8362 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8363 if (reusable) cv_clone_into(clonee, *spot);
8364 else *spot = cv_clone(clonee);
8365 SvREFCNT_dec_NN(clonee);
8368 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8369 PADOFFSET depth = CvDEPTH(outcv);
8372 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8374 *svspot = SvREFCNT_inc_simple_NN(cv);
8375 SvREFCNT_dec(oldcv);
8381 PL_parser->copline = NOLINE;
8383 #ifdef PERL_DEBUG_READONLY_OPS
8393 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8394 OP *block, bool o_is_gv)
8398 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8402 const bool ec = PL_parser && PL_parser->error_count;
8403 /* If the subroutine has no body, no attributes, and no builtin attributes
8404 then it's just a sub declaration, and we may be able to get away with
8405 storing with a placeholder scalar in the symbol table, rather than a
8406 full CV. If anything is present then it will take a full CV to
8408 const I32 gv_fetch_flags
8409 = ec ? GV_NOADD_NOINIT :
8410 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8411 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8413 const char * const name =
8414 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8416 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8417 bool evanescent = FALSE;
8419 #ifdef PERL_DEBUG_READONLY_OPS
8420 OPSLAB *slab = NULL;
8428 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8429 hek and CvSTASH pointer together can imply the GV. If the name
8430 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8431 CvSTASH, so forego the optimisation if we find any.
8432 Also, we may be called from load_module at run time, so
8433 PL_curstash (which sets CvSTASH) may not point to the stash the
8434 sub is stored in. */
8436 ec ? GV_NOADD_NOINIT
8437 : PL_curstash != CopSTASH(PL_curcop)
8438 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8440 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8441 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8443 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8444 SV * const sv = sv_newmortal();
8445 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8446 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8447 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8448 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8450 } else if (PL_curstash) {
8451 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8454 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8459 move_proto_attr(&proto, &attrs, gv);
8462 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8467 assert(proto->op_type == OP_CONST);
8468 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8469 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8483 if (name) SvREFCNT_dec(PL_compcv);
8484 else cv = PL_compcv;
8486 if (name && block) {
8487 const char *s = strrchr(name, ':');
8489 if (strEQ(s, "BEGIN")) {
8490 if (PL_in_eval & EVAL_KEEPERR)
8491 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8493 SV * const errsv = ERRSV;
8494 /* force display of errors found but not reported */
8495 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8496 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8503 if (!block && SvTYPE(gv) != SVt_PVGV) {
8504 /* If we are not defining a new sub and the existing one is not a
8506 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8507 /* We are applying attributes to an existing sub, so we need it
8508 upgraded if it is a constant. */
8509 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8510 gv_init_pvn(gv, PL_curstash, name, namlen,
8511 SVf_UTF8 * name_is_utf8);
8513 else { /* Maybe prototype now, and had at maximum
8514 a prototype or const/sub ref before. */
8515 if (SvTYPE(gv) > SVt_NULL) {
8516 cv_ckproto_len_flags((const CV *)gv,
8517 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8522 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8523 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8526 sv_setiv(MUTABLE_SV(gv), -1);
8529 SvREFCNT_dec(PL_compcv);
8530 cv = PL_compcv = NULL;
8535 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8539 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8545 /* This makes sub {}; work as expected. */
8546 if (block->op_type == OP_STUB) {
8547 const line_t l = PL_parser->copline;
8549 block = newSTATEOP(0, NULL, 0);
8550 PL_parser->copline = l;
8552 block = CvLVALUE(PL_compcv)
8553 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8554 && (!isGV(gv) || !GvASSUMECV(gv)))
8555 ? newUNOP(OP_LEAVESUBLV, 0,
8556 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8557 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8558 start = LINKLIST(block);
8560 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8562 S_op_const_sv(aTHX_ start, PL_compcv,
8563 cBOOL(CvCLONE(PL_compcv)));
8570 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8571 cv_ckproto_len_flags((const CV *)gv,
8572 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8573 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8575 /* All the other code for sub redefinition warnings expects the
8576 clobbered sub to be a CV. Instead of making all those code
8577 paths more complex, just inline the RV version here. */
8578 const line_t oldline = CopLINE(PL_curcop);
8579 assert(IN_PERL_COMPILETIME);
8580 if (PL_parser && PL_parser->copline != NOLINE)
8581 /* This ensures that warnings are reported at the first
8582 line of a redefinition, not the last. */
8583 CopLINE_set(PL_curcop, PL_parser->copline);
8584 /* protect against fatal warnings leaking compcv */
8585 SAVEFREESV(PL_compcv);
8587 if (ckWARN(WARN_REDEFINE)
8588 || ( ckWARN_d(WARN_REDEFINE)
8589 && ( !const_sv || SvRV(gv) == const_sv
8590 || sv_cmp(SvRV(gv), const_sv) ))) {
8592 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8593 "Constant subroutine %"SVf" redefined",
8594 SVfARG(cSVOPo->op_sv));
8597 SvREFCNT_inc_simple_void_NN(PL_compcv);
8598 CopLINE_set(PL_curcop, oldline);
8599 SvREFCNT_dec(SvRV(gv));
8604 const bool exists = CvROOT(cv) || CvXSUB(cv);
8606 /* if the subroutine doesn't exist and wasn't pre-declared
8607 * with a prototype, assume it will be AUTOLOADed,
8608 * skipping the prototype check
8610 if (exists || SvPOK(cv))
8611 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8612 /* already defined (or promised)? */
8613 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8614 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8617 if (attrs) goto attrs;
8618 /* just a "sub foo;" when &foo is already defined */
8619 SAVEFREESV(PL_compcv);
8625 SvREFCNT_inc_simple_void_NN(const_sv);
8626 SvFLAGS(const_sv) |= SVs_PADTMP;
8628 assert(!CvROOT(cv) && !CvCONST(cv));
8630 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8631 CvXSUBANY(cv).any_ptr = const_sv;
8632 CvXSUB(cv) = const_sv_xsub;
8636 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8639 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8640 if (name && isGV(gv))
8642 cv = newCONSTSUB_flags(
8643 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8646 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8650 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8651 prepare_SV_for_RV((SV *)gv);
8655 SvRV_set(gv, const_sv);
8659 SvREFCNT_dec(PL_compcv);
8663 if (cv) { /* must reuse cv if autoloaded */
8664 /* transfer PL_compcv to cv */
8667 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8668 PADLIST *const temp_av = CvPADLIST(cv);
8669 CV *const temp_cv = CvOUTSIDE(cv);
8670 const cv_flags_t other_flags =
8671 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8672 OP * const cvstart = CvSTART(cv);
8676 assert(!CvCVGV_RC(cv));
8677 assert(CvGV(cv) == gv);
8682 PERL_HASH(hash, name, namlen);
8692 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8694 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8695 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8696 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8697 CvOUTSIDE(PL_compcv) = temp_cv;
8698 CvPADLIST_set(PL_compcv, temp_av);
8699 CvSTART(cv) = CvSTART(PL_compcv);
8700 CvSTART(PL_compcv) = cvstart;
8701 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8702 CvFLAGS(PL_compcv) |= other_flags;
8704 if (CvFILE(cv) && CvDYNFILE(cv)) {
8705 Safefree(CvFILE(cv));
8707 CvFILE_set_from_cop(cv, PL_curcop);
8708 CvSTASH_set(cv, PL_curstash);
8710 /* inner references to PL_compcv must be fixed up ... */
8711 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8712 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8713 ++PL_sub_generation;
8716 /* Might have had built-in attributes applied -- propagate them. */
8717 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8719 /* ... before we throw it away */
8720 SvREFCNT_dec(PL_compcv);
8725 if (name && isGV(gv)) {
8728 if (HvENAME_HEK(GvSTASH(gv)))
8729 /* sub Foo::bar { (shift)+1 } */
8730 gv_method_changed(gv);
8734 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8735 prepare_SV_for_RV((SV *)gv);
8739 SvRV_set(gv, (SV *)cv);
8743 if (isGV(gv)) CvGV_set(cv, gv);
8747 PERL_HASH(hash, name, namlen);
8748 CvNAME_HEK_set(cv, share_hek(name,
8754 CvFILE_set_from_cop(cv, PL_curcop);
8755 CvSTASH_set(cv, PL_curstash);
8759 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8760 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8766 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8767 the debugger could be able to set a breakpoint in, so signal to
8768 pp_entereval that it should not throw away any saved lines at scope
8771 PL_breakable_sub_gen++;
8773 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8774 OpREFCNT_set(CvROOT(cv), 1);
8775 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8776 itself has a refcount. */
8778 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8779 #ifdef PERL_DEBUG_READONLY_OPS
8780 slab = (OPSLAB *)CvSTART(cv);
8782 CvSTART(cv) = start;
8784 finalize_optree(CvROOT(cv));
8785 S_prune_chain_head(&CvSTART(cv));
8787 /* now that optimizer has done its work, adjust pad values */
8789 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8793 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8794 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8797 if (!name) SAVEFREESV(cv);
8798 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8799 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8802 if (block && has_name) {
8803 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8804 SV * const tmpstr = cv_name(cv,NULL,0);
8805 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8806 GV_ADDMULTI, SVt_PVHV);
8808 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8811 (long)CopLINE(PL_curcop));
8812 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8813 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8814 hv = GvHVn(db_postponed);
8815 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8816 CV * const pcv = GvCV(db_postponed);
8822 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8828 if (PL_parser && PL_parser->error_count)
8829 clear_special_blocks(name, gv, cv);
8832 process_special_blocks(floor, name, gv, cv);
8838 PL_parser->copline = NOLINE;
8841 #ifdef PERL_DEBUG_READONLY_OPS
8845 if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8846 pad_add_weakref(cv);
8852 S_clear_special_blocks(pTHX_ const char *const fullname,
8853 GV *const gv, CV *const cv) {
8857 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8859 colon = strrchr(fullname,':');
8860 name = colon ? colon + 1 : fullname;
8862 if ((*name == 'B' && strEQ(name, "BEGIN"))
8863 || (*name == 'E' && strEQ(name, "END"))
8864 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8865 || (*name == 'C' && strEQ(name, "CHECK"))
8866 || (*name == 'I' && strEQ(name, "INIT"))) {
8872 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8876 /* Returns true if the sub has been freed. */
8878 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8882 const char *const colon = strrchr(fullname,':');
8883 const char *const name = colon ? colon + 1 : fullname;
8885 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8888 if (strEQ(name, "BEGIN")) {
8889 const I32 oldscope = PL_scopestack_ix;
8892 if (floor) LEAVE_SCOPE(floor);
8894 PUSHSTACKi(PERLSI_REQUIRE);
8895 SAVECOPFILE(&PL_compiling);
8896 SAVECOPLINE(&PL_compiling);
8897 SAVEVPTR(PL_curcop);
8899 DEBUG_x( dump_sub(gv) );
8900 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8901 GvCV_set(gv,0); /* cv has been hijacked */
8902 call_list(oldscope, PL_beginav);
8906 return !PL_savebegin;
8912 if strEQ(name, "END") {
8913 DEBUG_x( dump_sub(gv) );
8914 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8917 } else if (*name == 'U') {
8918 if (strEQ(name, "UNITCHECK")) {
8919 /* It's never too late to run a unitcheck block */
8920 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8924 } else if (*name == 'C') {
8925 if (strEQ(name, "CHECK")) {
8927 /* diag_listed_as: Too late to run %s block */
8928 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8929 "Too late to run CHECK block");
8930 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8934 } else if (*name == 'I') {
8935 if (strEQ(name, "INIT")) {
8937 /* diag_listed_as: Too late to run %s block */
8938 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8939 "Too late to run INIT block");
8940 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8946 DEBUG_x( dump_sub(gv) );
8948 GvCV_set(gv,0); /* cv has been hijacked */
8954 =for apidoc newCONSTSUB
8956 See L</newCONSTSUB_flags>.
8962 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8964 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8968 =for apidoc newCONSTSUB_flags
8970 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
8971 eligible for inlining at compile-time.
8973 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
8975 The newly created subroutine takes ownership of a reference to the passed in
8978 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
8979 which won't be called if used as a destructor, but will suppress the overhead
8980 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8987 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8991 const char *const file = CopFILE(PL_curcop);
8995 if (IN_PERL_RUNTIME) {
8996 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8997 * an op shared between threads. Use a non-shared COP for our
8999 SAVEVPTR(PL_curcop);
9000 SAVECOMPILEWARNINGS();
9001 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9002 PL_curcop = &PL_compiling;
9004 SAVECOPLINE(PL_curcop);
9005 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
9008 PL_hints &= ~HINT_BLOCK_SCOPE;
9011 SAVEGENERICSV(PL_curstash);
9012 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9015 /* Protect sv against leakage caused by fatal warnings. */
9016 if (sv) SAVEFREESV(sv);
9018 /* file becomes the CvFILE. For an XS, it's usually static storage,
9019 and so doesn't get free()d. (It's expected to be from the C pre-
9020 processor __FILE__ directive). But we need a dynamically allocated one,
9021 and we need it to get freed. */
9022 cv = newXS_len_flags(name, len,
9023 sv && SvTYPE(sv) == SVt_PVAV
9026 file ? file : "", "",
9027 &sv, XS_DYNAMIC_FILENAME | flags);
9028 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9037 =for apidoc U||newXS
9039 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
9040 static storage, as it is used directly as CvFILE(), without a copy being made.
9046 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9048 PERL_ARGS_ASSERT_NEWXS;
9049 return newXS_len_flags(
9050 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9055 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9056 const char *const filename, const char *const proto,
9059 PERL_ARGS_ASSERT_NEWXS_FLAGS;
9060 return newXS_len_flags(
9061 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9066 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9068 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9069 return newXS_len_flags(
9070 name, strlen(name), subaddr, NULL, NULL, NULL, 0
9075 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9076 XSUBADDR_t subaddr, const char *const filename,
9077 const char *const proto, SV **const_svp,
9081 bool interleave = FALSE;
9083 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9086 GV * const gv = gv_fetchpvn(
9087 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9088 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9089 sizeof("__ANON__::__ANON__") - 1,
9090 GV_ADDMULTI | flags, SVt_PVCV);
9092 if ((cv = (name ? GvCV(gv) : NULL))) {
9094 /* just a cached method */
9098 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9099 /* already defined (or promised) */
9100 /* Redundant check that allows us to avoid creating an SV
9101 most of the time: */
9102 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9103 report_redefined_cv(newSVpvn_flags(
9104 name,len,(flags&SVf_UTF8)|SVs_TEMP
9115 if (cv) /* must reuse cv if autoloaded */
9118 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9122 if (HvENAME_HEK(GvSTASH(gv)))
9123 gv_method_changed(gv); /* newXS */
9129 /* XSUBs can't be perl lang/perl5db.pl debugged
9130 if (PERLDB_LINE_OR_SAVESRC)
9131 (void)gv_fetchfile(filename); */
9132 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9133 if (flags & XS_DYNAMIC_FILENAME) {
9135 CvFILE(cv) = savepv(filename);
9137 /* NOTE: not copied, as it is expected to be an external constant string */
9138 CvFILE(cv) = (char *)filename;
9141 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9142 CvFILE(cv) = (char*)PL_xsubfilename;
9145 CvXSUB(cv) = subaddr;
9146 #ifndef PERL_IMPLICIT_CONTEXT
9147 CvHSCXT(cv) = &PL_stack_sp;
9153 process_special_blocks(0, name, gv, cv);
9156 } /* <- not a conditional branch */
9159 sv_setpv(MUTABLE_SV(cv), proto);
9160 if (interleave) LEAVE;
9165 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9167 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9169 PERL_ARGS_ASSERT_NEWSTUB;
9173 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
9174 gv_method_changed(gv);
9176 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9181 CvFILE_set_from_cop(cv, PL_curcop);
9182 CvSTASH_set(cv, PL_curstash);
9188 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9194 if (PL_parser && PL_parser->error_count) {
9200 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9201 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9204 if ((cv = GvFORM(gv))) {
9205 if (ckWARN(WARN_REDEFINE)) {
9206 const line_t oldline = CopLINE(PL_curcop);
9207 if (PL_parser && PL_parser->copline != NOLINE)
9208 CopLINE_set(PL_curcop, PL_parser->copline);
9210 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9211 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9213 /* diag_listed_as: Format %s redefined */
9214 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9215 "Format STDOUT redefined");
9217 CopLINE_set(PL_curcop, oldline);
9222 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9224 CvFILE_set_from_cop(cv, PL_curcop);
9227 pad_tidy(padtidy_FORMAT);
9228 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9229 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9230 OpREFCNT_set(CvROOT(cv), 1);
9231 CvSTART(cv) = LINKLIST(CvROOT(cv));
9232 CvROOT(cv)->op_next = 0;
9233 CALL_PEEP(CvSTART(cv));
9234 finalize_optree(CvROOT(cv));
9235 S_prune_chain_head(&CvSTART(cv));
9241 PL_parser->copline = NOLINE;
9243 PL_compiling.cop_seq = 0;
9247 Perl_newANONLIST(pTHX_ OP *o)
9249 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9253 Perl_newANONHASH(pTHX_ OP *o)
9255 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9259 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9261 return newANONATTRSUB(floor, proto, NULL, block);
9265 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9267 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9269 newSVOP(OP_ANONCODE, 0,
9271 if (CvANONCONST(cv))
9272 anoncode = newUNOP(OP_ANONCONST, 0,
9273 op_convert_list(OP_ENTERSUB,
9274 OPf_STACKED|OPf_WANT_SCALAR,
9276 return newUNOP(OP_REFGEN, 0, anoncode);
9280 Perl_oopsAV(pTHX_ OP *o)
9284 PERL_ARGS_ASSERT_OOPSAV;
9286 switch (o->op_type) {
9289 OpTYPE_set(o, OP_PADAV);
9290 return ref(o, OP_RV2AV);
9294 OpTYPE_set(o, OP_RV2AV);
9299 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9306 Perl_oopsHV(pTHX_ OP *o)
9310 PERL_ARGS_ASSERT_OOPSHV;
9312 switch (o->op_type) {
9315 OpTYPE_set(o, OP_PADHV);
9316 return ref(o, OP_RV2HV);
9320 OpTYPE_set(o, OP_RV2HV);
9325 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9332 Perl_newAVREF(pTHX_ OP *o)
9336 PERL_ARGS_ASSERT_NEWAVREF;
9338 if (o->op_type == OP_PADANY) {
9339 OpTYPE_set(o, OP_PADAV);
9342 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9343 Perl_croak(aTHX_ "Can't use an array as a reference");
9345 return newUNOP(OP_RV2AV, 0, scalar(o));
9349 Perl_newGVREF(pTHX_ I32 type, OP *o)
9351 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9352 return newUNOP(OP_NULL, 0, o);
9353 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9357 Perl_newHVREF(pTHX_ OP *o)
9361 PERL_ARGS_ASSERT_NEWHVREF;
9363 if (o->op_type == OP_PADANY) {
9364 OpTYPE_set(o, OP_PADHV);
9367 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9368 Perl_croak(aTHX_ "Can't use a hash as a reference");
9370 return newUNOP(OP_RV2HV, 0, scalar(o));
9374 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9376 if (o->op_type == OP_PADANY) {
9378 OpTYPE_set(o, OP_PADCV);
9380 return newUNOP(OP_RV2CV, flags, scalar(o));
9384 Perl_newSVREF(pTHX_ OP *o)
9388 PERL_ARGS_ASSERT_NEWSVREF;
9390 if (o->op_type == OP_PADANY) {
9391 OpTYPE_set(o, OP_PADSV);
9395 return newUNOP(OP_RV2SV, 0, scalar(o));
9398 /* Check routines. See the comments at the top of this file for details
9399 * on when these are called */
9402 Perl_ck_anoncode(pTHX_ OP *o)
9404 PERL_ARGS_ASSERT_CK_ANONCODE;
9406 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9407 cSVOPo->op_sv = NULL;
9412 S_io_hints(pTHX_ OP *o)
9414 #if O_BINARY != 0 || O_TEXT != 0
9416 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9418 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9421 const char *d = SvPV_const(*svp, len);
9422 const I32 mode = mode_from_discipline(d, len);
9423 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9425 if (mode & O_BINARY)
9426 o->op_private |= OPpOPEN_IN_RAW;
9430 o->op_private |= OPpOPEN_IN_CRLF;
9434 svp = hv_fetchs(table, "open_OUT", FALSE);
9437 const char *d = SvPV_const(*svp, len);
9438 const I32 mode = mode_from_discipline(d, len);
9439 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9441 if (mode & O_BINARY)
9442 o->op_private |= OPpOPEN_OUT_RAW;
9446 o->op_private |= OPpOPEN_OUT_CRLF;
9451 PERL_UNUSED_CONTEXT;
9457 Perl_ck_backtick(pTHX_ OP *o)
9462 PERL_ARGS_ASSERT_CK_BACKTICK;
9463 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9464 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9465 && (gv = gv_override("readpipe",8)))
9467 /* detach rest of siblings from o and its first child */
9468 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9469 newop = S_new_entersubop(aTHX_ gv, sibl);
9471 else if (!(o->op_flags & OPf_KIDS))
9472 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9477 S_io_hints(aTHX_ o);
9482 Perl_ck_bitop(pTHX_ OP *o)
9484 PERL_ARGS_ASSERT_CK_BITOP;
9486 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9488 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9489 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9490 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9491 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9492 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9493 "The bitwise feature is experimental");
9494 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9495 && OP_IS_INFIX_BIT(o->op_type))
9497 const OP * const left = cBINOPo->op_first;
9498 const OP * const right = OpSIBLING(left);
9499 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9500 (left->op_flags & OPf_PARENS) == 0) ||
9501 (OP_IS_NUMCOMPARE(right->op_type) &&
9502 (right->op_flags & OPf_PARENS) == 0))
9503 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9504 "Possible precedence problem on bitwise %s operator",
9505 o->op_type == OP_BIT_OR
9506 ||o->op_type == OP_NBIT_OR ? "|"
9507 : o->op_type == OP_BIT_AND
9508 ||o->op_type == OP_NBIT_AND ? "&"
9509 : o->op_type == OP_BIT_XOR
9510 ||o->op_type == OP_NBIT_XOR ? "^"
9511 : o->op_type == OP_SBIT_OR ? "|."
9512 : o->op_type == OP_SBIT_AND ? "&." : "^."
9518 PERL_STATIC_INLINE bool
9519 is_dollar_bracket(pTHX_ const OP * const o)
9522 PERL_UNUSED_CONTEXT;
9523 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9524 && (kid = cUNOPx(o)->op_first)
9525 && kid->op_type == OP_GV
9526 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9530 Perl_ck_cmp(pTHX_ OP *o)
9532 PERL_ARGS_ASSERT_CK_CMP;
9533 if (ckWARN(WARN_SYNTAX)) {
9534 const OP *kid = cUNOPo->op_first;
9537 ( is_dollar_bracket(aTHX_ kid)
9538 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9540 || ( kid->op_type == OP_CONST
9541 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9545 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9546 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9552 Perl_ck_concat(pTHX_ OP *o)
9554 const OP * const kid = cUNOPo->op_first;
9556 PERL_ARGS_ASSERT_CK_CONCAT;
9557 PERL_UNUSED_CONTEXT;
9559 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9560 !(kUNOP->op_first->op_flags & OPf_MOD))
9561 o->op_flags |= OPf_STACKED;
9566 Perl_ck_spair(pTHX_ OP *o)
9570 PERL_ARGS_ASSERT_CK_SPAIR;
9572 if (o->op_flags & OPf_KIDS) {
9576 const OPCODE type = o->op_type;
9577 o = modkids(ck_fun(o), type);
9578 kid = cUNOPo->op_first;
9579 kidkid = kUNOP->op_first;
9580 newop = OpSIBLING(kidkid);
9582 const OPCODE type = newop->op_type;
9583 if (OpHAS_SIBLING(newop))
9585 if (o->op_type == OP_REFGEN
9586 && ( type == OP_RV2CV
9587 || ( !(newop->op_flags & OPf_PARENS)
9588 && ( type == OP_RV2AV || type == OP_PADAV
9589 || type == OP_RV2HV || type == OP_PADHV))))
9590 NOOP; /* OK (allow srefgen for \@a and \%h) */
9591 else if (OP_GIMME(newop,0) != G_SCALAR)
9594 /* excise first sibling */
9595 op_sibling_splice(kid, NULL, 1, NULL);
9598 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9599 * and OP_CHOMP into OP_SCHOMP */
9600 o->op_ppaddr = PL_ppaddr[++o->op_type];
9605 Perl_ck_delete(pTHX_ OP *o)
9607 PERL_ARGS_ASSERT_CK_DELETE;
9611 if (o->op_flags & OPf_KIDS) {
9612 OP * const kid = cUNOPo->op_first;
9613 switch (kid->op_type) {
9615 o->op_flags |= OPf_SPECIAL;
9618 o->op_private |= OPpSLICE;
9621 o->op_flags |= OPf_SPECIAL;
9626 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9627 " use array slice");
9629 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9632 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9633 "element or slice");
9635 if (kid->op_private & OPpLVAL_INTRO)
9636 o->op_private |= OPpLVAL_INTRO;
9643 Perl_ck_eof(pTHX_ OP *o)
9645 PERL_ARGS_ASSERT_CK_EOF;
9647 if (o->op_flags & OPf_KIDS) {
9649 if (cLISTOPo->op_first->op_type == OP_STUB) {
9651 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9656 kid = cLISTOPo->op_first;
9657 if (kid->op_type == OP_RV2GV)
9658 kid->op_private |= OPpALLOW_FAKE;
9664 Perl_ck_eval(pTHX_ OP *o)
9668 PERL_ARGS_ASSERT_CK_EVAL;
9670 PL_hints |= HINT_BLOCK_SCOPE;
9671 if (o->op_flags & OPf_KIDS) {
9672 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9675 if (o->op_type == OP_ENTERTRY) {
9678 /* cut whole sibling chain free from o */
9679 op_sibling_splice(o, NULL, -1, NULL);
9682 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
9684 /* establish postfix order */
9685 enter->op_next = (OP*)enter;
9687 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9688 OpTYPE_set(o, OP_LEAVETRY);
9689 enter->op_other = o;
9694 S_set_haseval(aTHX);
9698 const U8 priv = o->op_private;
9700 /* the newUNOP will recursively call ck_eval(), which will handle
9701 * all the stuff at the end of this function, like adding
9704 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9706 o->op_targ = (PADOFFSET)PL_hints;
9707 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9708 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9709 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9710 /* Store a copy of %^H that pp_entereval can pick up. */
9711 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9712 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9713 /* append hhop to only child */
9714 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9716 o->op_private |= OPpEVAL_HAS_HH;
9718 if (!(o->op_private & OPpEVAL_BYTES)
9719 && FEATURE_UNIEVAL_IS_ENABLED)
9720 o->op_private |= OPpEVAL_UNICODE;
9725 Perl_ck_exec(pTHX_ OP *o)
9727 PERL_ARGS_ASSERT_CK_EXEC;
9729 if (o->op_flags & OPf_STACKED) {
9732 kid = OpSIBLING(cUNOPo->op_first);
9733 if (kid->op_type == OP_RV2GV)
9742 Perl_ck_exists(pTHX_ OP *o)
9744 PERL_ARGS_ASSERT_CK_EXISTS;
9747 if (o->op_flags & OPf_KIDS) {
9748 OP * const kid = cUNOPo->op_first;
9749 if (kid->op_type == OP_ENTERSUB) {
9750 (void) ref(kid, o->op_type);
9751 if (kid->op_type != OP_RV2CV
9752 && !(PL_parser && PL_parser->error_count))
9754 "exists argument is not a subroutine name");
9755 o->op_private |= OPpEXISTS_SUB;
9757 else if (kid->op_type == OP_AELEM)
9758 o->op_flags |= OPf_SPECIAL;
9759 else if (kid->op_type != OP_HELEM)
9760 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9761 "element or a subroutine");
9768 Perl_ck_rvconst(pTHX_ OP *o)
9771 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9773 PERL_ARGS_ASSERT_CK_RVCONST;
9775 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9777 if (kid->op_type == OP_CONST) {
9780 SV * const kidsv = kid->op_sv;
9782 /* Is it a constant from cv_const_sv()? */
9783 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9786 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9787 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9788 const char *badthing;
9789 switch (o->op_type) {
9791 badthing = "a SCALAR";
9794 badthing = "an ARRAY";
9797 badthing = "a HASH";
9805 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9806 SVfARG(kidsv), badthing);
9809 * This is a little tricky. We only want to add the symbol if we
9810 * didn't add it in the lexer. Otherwise we get duplicate strict
9811 * warnings. But if we didn't add it in the lexer, we must at
9812 * least pretend like we wanted to add it even if it existed before,
9813 * or we get possible typo warnings. OPpCONST_ENTERED says
9814 * whether the lexer already added THIS instance of this symbol.
9816 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9817 gv = gv_fetchsv(kidsv,
9818 o->op_type == OP_RV2CV
9819 && o->op_private & OPpMAY_RETURN_CONSTANT
9821 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9824 : o->op_type == OP_RV2SV
9826 : o->op_type == OP_RV2AV
9828 : o->op_type == OP_RV2HV
9835 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9836 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9837 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9839 OpTYPE_set(kid, OP_GV);
9840 SvREFCNT_dec(kid->op_sv);
9842 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9843 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9844 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9845 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9846 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9848 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9850 kid->op_private = 0;
9851 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9859 Perl_ck_ftst(pTHX_ OP *o)
9862 const I32 type = o->op_type;
9864 PERL_ARGS_ASSERT_CK_FTST;
9866 if (o->op_flags & OPf_REF) {
9869 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9870 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9871 const OPCODE kidtype = kid->op_type;
9873 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9874 && !kid->op_folded) {
9875 OP * const newop = newGVOP(type, OPf_REF,
9876 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9881 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
9882 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
9884 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9885 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
9886 array_passed_to_stat, name);
9889 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9890 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
9894 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9895 o->op_private |= OPpFT_ACCESS;
9896 if (type != OP_STAT && type != OP_LSTAT
9897 && PL_check[kidtype] == Perl_ck_ftst
9898 && kidtype != OP_STAT && kidtype != OP_LSTAT
9900 o->op_private |= OPpFT_STACKED;
9901 kid->op_private |= OPpFT_STACKING;
9902 if (kidtype == OP_FTTTY && (
9903 !(kid->op_private & OPpFT_STACKED)
9904 || kid->op_private & OPpFT_AFTER_t
9906 o->op_private |= OPpFT_AFTER_t;
9911 if (type == OP_FTTTY)
9912 o = newGVOP(type, OPf_REF, PL_stdingv);
9914 o = newUNOP(type, 0, newDEFSVOP());
9920 Perl_ck_fun(pTHX_ OP *o)
9922 const int type = o->op_type;
9923 I32 oa = PL_opargs[type] >> OASHIFT;
9925 PERL_ARGS_ASSERT_CK_FUN;
9927 if (o->op_flags & OPf_STACKED) {
9928 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9931 return no_fh_allowed(o);
9934 if (o->op_flags & OPf_KIDS) {
9935 OP *prev_kid = NULL;
9936 OP *kid = cLISTOPo->op_first;
9938 bool seen_optional = FALSE;
9940 if (kid->op_type == OP_PUSHMARK ||
9941 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9944 kid = OpSIBLING(kid);
9946 if (kid && kid->op_type == OP_COREARGS) {
9947 bool optional = FALSE;
9950 if (oa & OA_OPTIONAL) optional = TRUE;
9953 if (optional) o->op_private |= numargs;
9958 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9959 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9961 /* append kid to chain */
9962 op_sibling_splice(o, prev_kid, 0, kid);
9964 seen_optional = TRUE;
9971 /* list seen where single (scalar) arg expected? */
9972 if (numargs == 1 && !(oa >> 4)
9973 && kid->op_type == OP_LIST && type != OP_SCALAR)
9975 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9977 if (type != OP_DELETE) scalar(kid);
9988 if ((type == OP_PUSH || type == OP_UNSHIFT)
9989 && !OpHAS_SIBLING(kid))
9990 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9991 "Useless use of %s with no values",
9994 if (kid->op_type == OP_CONST
9995 && ( !SvROK(cSVOPx_sv(kid))
9996 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9998 bad_type_pv(numargs, "array", o, kid);
9999 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
10000 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
10001 PL_op_desc[type]), 0);
10004 op_lvalue(kid, type);
10008 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
10009 bad_type_pv(numargs, "hash", o, kid);
10010 op_lvalue(kid, type);
10014 /* replace kid with newop in chain */
10016 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
10017 newop->op_next = newop;
10022 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
10023 if (kid->op_type == OP_CONST &&
10024 (kid->op_private & OPpCONST_BARE))
10026 OP * const newop = newGVOP(OP_GV, 0,
10027 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10028 /* replace kid with newop in chain */
10029 op_sibling_splice(o, prev_kid, 1, newop);
10033 else if (kid->op_type == OP_READLINE) {
10034 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10035 bad_type_pv(numargs, "HANDLE", o, kid);
10038 I32 flags = OPf_SPECIAL;
10040 PADOFFSET targ = 0;
10042 /* is this op a FH constructor? */
10043 if (is_handle_constructor(o,numargs)) {
10044 const char *name = NULL;
10047 bool want_dollar = TRUE;
10050 /* Set a flag to tell rv2gv to vivify
10051 * need to "prove" flag does not mean something
10052 * else already - NI-S 1999/05/07
10055 if (kid->op_type == OP_PADSV) {
10057 = PAD_COMPNAME_SV(kid->op_targ);
10058 name = PadnamePV (pn);
10059 len = PadnameLEN(pn);
10060 name_utf8 = PadnameUTF8(pn);
10062 else if (kid->op_type == OP_RV2SV
10063 && kUNOP->op_first->op_type == OP_GV)
10065 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10067 len = GvNAMELEN(gv);
10068 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10070 else if (kid->op_type == OP_AELEM
10071 || kid->op_type == OP_HELEM)
10074 OP *op = ((BINOP*)kid)->op_first;
10078 const char * const a =
10079 kid->op_type == OP_AELEM ?
10081 if (((op->op_type == OP_RV2AV) ||
10082 (op->op_type == OP_RV2HV)) &&
10083 (firstop = ((UNOP*)op)->op_first) &&
10084 (firstop->op_type == OP_GV)) {
10085 /* packagevar $a[] or $h{} */
10086 GV * const gv = cGVOPx_gv(firstop);
10089 Perl_newSVpvf(aTHX_
10094 else if (op->op_type == OP_PADAV
10095 || op->op_type == OP_PADHV) {
10096 /* lexicalvar $a[] or $h{} */
10097 const char * const padname =
10098 PAD_COMPNAME_PV(op->op_targ);
10101 Perl_newSVpvf(aTHX_
10107 name = SvPV_const(tmpstr, len);
10108 name_utf8 = SvUTF8(tmpstr);
10109 sv_2mortal(tmpstr);
10113 name = "__ANONIO__";
10115 want_dollar = FALSE;
10117 op_lvalue(kid, type);
10121 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10122 namesv = PAD_SVl(targ);
10123 if (want_dollar && *name != '$')
10124 sv_setpvs(namesv, "$");
10126 sv_setpvs(namesv, "");
10127 sv_catpvn(namesv, name, len);
10128 if ( name_utf8 ) SvUTF8_on(namesv);
10132 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10134 kid->op_targ = targ;
10135 kid->op_private |= priv;
10141 if ((type == OP_UNDEF || type == OP_POS)
10142 && numargs == 1 && !(oa >> 4)
10143 && kid->op_type == OP_LIST)
10144 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10145 op_lvalue(scalar(kid), type);
10150 kid = OpSIBLING(kid);
10152 /* FIXME - should the numargs or-ing move after the too many
10153 * arguments check? */
10154 o->op_private |= numargs;
10156 return too_many_arguments_pv(o,OP_DESC(o), 0);
10159 else if (PL_opargs[type] & OA_DEFGV) {
10160 /* Ordering of these two is important to keep f_map.t passing. */
10162 return newUNOP(type, 0, newDEFSVOP());
10166 while (oa & OA_OPTIONAL)
10168 if (oa && oa != OA_LIST)
10169 return too_few_arguments_pv(o,OP_DESC(o), 0);
10175 Perl_ck_glob(pTHX_ OP *o)
10179 PERL_ARGS_ASSERT_CK_GLOB;
10182 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10183 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10185 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10189 * \ null - const(wildcard)
10194 * \ mark - glob - rv2cv
10195 * | \ gv(CORE::GLOBAL::glob)
10197 * \ null - const(wildcard)
10199 o->op_flags |= OPf_SPECIAL;
10200 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10201 o = S_new_entersubop(aTHX_ gv, o);
10202 o = newUNOP(OP_NULL, 0, o);
10203 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10206 else o->op_flags &= ~OPf_SPECIAL;
10207 #if !defined(PERL_EXTERNAL_GLOB)
10208 if (!PL_globhook) {
10210 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10211 newSVpvs("File::Glob"), NULL, NULL, NULL);
10214 #endif /* !PERL_EXTERNAL_GLOB */
10215 gv = (GV *)newSV(0);
10216 gv_init(gv, 0, "", 0, 0);
10218 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10219 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10225 Perl_ck_grep(pTHX_ OP *o)
10229 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10231 PERL_ARGS_ASSERT_CK_GREP;
10233 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10235 if (o->op_flags & OPf_STACKED) {
10236 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10237 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10238 return no_fh_allowed(o);
10239 o->op_flags &= ~OPf_STACKED;
10241 kid = OpSIBLING(cLISTOPo->op_first);
10242 if (type == OP_MAPWHILE)
10247 if (PL_parser && PL_parser->error_count)
10249 kid = OpSIBLING(cLISTOPo->op_first);
10250 if (kid->op_type != OP_NULL)
10251 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10252 kid = kUNOP->op_first;
10254 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
10255 kid->op_next = (OP*)gwop;
10256 o->op_private = gwop->op_private = 0;
10257 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10259 kid = OpSIBLING(cLISTOPo->op_first);
10260 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10261 op_lvalue(kid, OP_GREPSTART);
10267 Perl_ck_index(pTHX_ OP *o)
10269 PERL_ARGS_ASSERT_CK_INDEX;
10271 if (o->op_flags & OPf_KIDS) {
10272 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10274 kid = OpSIBLING(kid); /* get past "big" */
10275 if (kid && kid->op_type == OP_CONST) {
10276 const bool save_taint = TAINT_get;
10277 SV *sv = kSVOP->op_sv;
10278 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10280 sv_copypv(sv, kSVOP->op_sv);
10281 SvREFCNT_dec_NN(kSVOP->op_sv);
10284 if (SvOK(sv)) fbm_compile(sv, 0);
10285 TAINT_set(save_taint);
10286 #ifdef NO_TAINT_SUPPORT
10287 PERL_UNUSED_VAR(save_taint);
10295 Perl_ck_lfun(pTHX_ OP *o)
10297 const OPCODE type = o->op_type;
10299 PERL_ARGS_ASSERT_CK_LFUN;
10301 return modkids(ck_fun(o), type);
10305 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10307 PERL_ARGS_ASSERT_CK_DEFINED;
10309 if ((o->op_flags & OPf_KIDS)) {
10310 switch (cUNOPo->op_first->op_type) {
10313 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10314 " (Maybe you should just omit the defined()?)");
10318 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10319 " (Maybe you should just omit the defined()?)");
10330 Perl_ck_readline(pTHX_ OP *o)
10332 PERL_ARGS_ASSERT_CK_READLINE;
10334 if (o->op_flags & OPf_KIDS) {
10335 OP *kid = cLISTOPo->op_first;
10336 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10340 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10348 Perl_ck_rfun(pTHX_ OP *o)
10350 const OPCODE type = o->op_type;
10352 PERL_ARGS_ASSERT_CK_RFUN;
10354 return refkids(ck_fun(o), type);
10358 Perl_ck_listiob(pTHX_ OP *o)
10362 PERL_ARGS_ASSERT_CK_LISTIOB;
10364 kid = cLISTOPo->op_first;
10366 o = force_list(o, 1);
10367 kid = cLISTOPo->op_first;
10369 if (kid->op_type == OP_PUSHMARK)
10370 kid = OpSIBLING(kid);
10371 if (kid && o->op_flags & OPf_STACKED)
10372 kid = OpSIBLING(kid);
10373 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10374 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10375 && !kid->op_folded) {
10376 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10378 /* replace old const op with new OP_RV2GV parent */
10379 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10380 OP_RV2GV, OPf_REF);
10381 kid = OpSIBLING(kid);
10386 op_append_elem(o->op_type, o, newDEFSVOP());
10388 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10389 return listkids(o);
10393 Perl_ck_smartmatch(pTHX_ OP *o)
10396 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10397 if (0 == (o->op_flags & OPf_SPECIAL)) {
10398 OP *first = cBINOPo->op_first;
10399 OP *second = OpSIBLING(first);
10401 /* Implicitly take a reference to an array or hash */
10403 /* remove the original two siblings, then add back the
10404 * (possibly different) first and second sibs.
10406 op_sibling_splice(o, NULL, 1, NULL);
10407 op_sibling_splice(o, NULL, 1, NULL);
10408 first = ref_array_or_hash(first);
10409 second = ref_array_or_hash(second);
10410 op_sibling_splice(o, NULL, 0, second);
10411 op_sibling_splice(o, NULL, 0, first);
10413 /* Implicitly take a reference to a regular expression */
10414 if (first->op_type == OP_MATCH) {
10415 OpTYPE_set(first, OP_QR);
10417 if (second->op_type == OP_MATCH) {
10418 OpTYPE_set(second, OP_QR);
10427 S_maybe_targlex(pTHX_ OP *o)
10429 OP * const kid = cLISTOPo->op_first;
10430 /* has a disposable target? */
10431 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10432 && !(kid->op_flags & OPf_STACKED)
10433 /* Cannot steal the second time! */
10434 && !(kid->op_private & OPpTARGET_MY)
10437 OP * const kkid = OpSIBLING(kid);
10439 /* Can just relocate the target. */
10440 if (kkid && kkid->op_type == OP_PADSV
10441 && (!(kkid->op_private & OPpLVAL_INTRO)
10442 || kkid->op_private & OPpPAD_STATE))
10444 kid->op_targ = kkid->op_targ;
10446 /* Now we do not need PADSV and SASSIGN.
10447 * Detach kid and free the rest. */
10448 op_sibling_splice(o, NULL, 1, NULL);
10450 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10458 Perl_ck_sassign(pTHX_ OP *o)
10461 OP * const kid = cLISTOPo->op_first;
10463 PERL_ARGS_ASSERT_CK_SASSIGN;
10465 if (OpHAS_SIBLING(kid)) {
10466 OP *kkid = OpSIBLING(kid);
10467 /* For state variable assignment with attributes, kkid is a list op
10468 whose op_last is a padsv. */
10469 if ((kkid->op_type == OP_PADSV ||
10470 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10471 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10474 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10475 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10476 const PADOFFSET target = kkid->op_targ;
10477 OP *const other = newOP(OP_PADSV,
10479 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10480 OP *const first = newOP(OP_NULL, 0);
10482 newCONDOP(0, first, o, other);
10483 /* XXX targlex disabled for now; see ticket #124160
10484 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10486 OP *const condop = first->op_next;
10488 OpTYPE_set(condop, OP_ONCE);
10489 other->op_targ = target;
10490 nullop->op_flags |= OPf_WANT_SCALAR;
10492 /* Store the initializedness of state vars in a separate
10495 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10496 /* hijacking PADSTALE for uninitialized state variables */
10497 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10502 return S_maybe_targlex(aTHX_ o);
10506 Perl_ck_match(pTHX_ OP *o)
10508 PERL_UNUSED_CONTEXT;
10509 PERL_ARGS_ASSERT_CK_MATCH;
10511 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10512 o->op_private |= OPpRUNTIME;
10517 Perl_ck_method(pTHX_ OP *o)
10519 SV *sv, *methsv, *rclass;
10520 const char* method;
10523 STRLEN len, nsplit = 0, i;
10525 OP * const kid = cUNOPo->op_first;
10527 PERL_ARGS_ASSERT_CK_METHOD;
10528 if (kid->op_type != OP_CONST) return o;
10532 /* replace ' with :: */
10533 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10535 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10538 method = SvPVX_const(sv);
10540 utf8 = SvUTF8(sv) ? -1 : 1;
10542 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10547 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10549 if (!nsplit) { /* $proto->method() */
10551 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10554 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10556 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10559 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10560 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10561 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10562 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10564 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10565 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10567 #ifdef USE_ITHREADS
10568 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10570 cMETHOPx(new_op)->op_rclass_sv = rclass;
10577 Perl_ck_null(pTHX_ OP *o)
10579 PERL_ARGS_ASSERT_CK_NULL;
10580 PERL_UNUSED_CONTEXT;
10585 Perl_ck_open(pTHX_ OP *o)
10587 PERL_ARGS_ASSERT_CK_OPEN;
10589 S_io_hints(aTHX_ o);
10591 /* In case of three-arg dup open remove strictness
10592 * from the last arg if it is a bareword. */
10593 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10594 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10598 if ((last->op_type == OP_CONST) && /* The bareword. */
10599 (last->op_private & OPpCONST_BARE) &&
10600 (last->op_private & OPpCONST_STRICT) &&
10601 (oa = OpSIBLING(first)) && /* The fh. */
10602 (oa = OpSIBLING(oa)) && /* The mode. */
10603 (oa->op_type == OP_CONST) &&
10604 SvPOK(((SVOP*)oa)->op_sv) &&
10605 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10606 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10607 (last == OpSIBLING(oa))) /* The bareword. */
10608 last->op_private &= ~OPpCONST_STRICT;
10614 Perl_ck_prototype(pTHX_ OP *o)
10616 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10617 if (!(o->op_flags & OPf_KIDS)) {
10619 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10625 Perl_ck_refassign(pTHX_ OP *o)
10627 OP * const right = cLISTOPo->op_first;
10628 OP * const left = OpSIBLING(right);
10629 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10632 PERL_ARGS_ASSERT_CK_REFASSIGN;
10634 assert (left->op_type == OP_SREFGEN);
10637 /* we use OPpPAD_STATE in refassign to mean either of those things,
10638 * and the code assumes the two flags occupy the same bit position
10639 * in the various ops below */
10640 assert(OPpPAD_STATE == OPpOUR_INTRO);
10642 switch (varop->op_type) {
10644 o->op_private |= OPpLVREF_AV;
10647 o->op_private |= OPpLVREF_HV;
10651 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10652 o->op_targ = varop->op_targ;
10653 varop->op_targ = 0;
10654 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10658 o->op_private |= OPpLVREF_AV;
10660 NOT_REACHED; /* NOTREACHED */
10662 o->op_private |= OPpLVREF_HV;
10666 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10667 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10669 /* Point varop to its GV kid, detached. */
10670 varop = op_sibling_splice(varop, NULL, -1, NULL);
10674 OP * const kidparent =
10675 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10676 OP * const kid = cUNOPx(kidparent)->op_first;
10677 o->op_private |= OPpLVREF_CV;
10678 if (kid->op_type == OP_GV) {
10680 goto detach_and_stack;
10682 if (kid->op_type != OP_PADCV) goto bad;
10683 o->op_targ = kid->op_targ;
10689 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10690 o->op_private |= OPpLVREF_ELEM;
10693 /* Detach varop. */
10694 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10698 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10699 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10704 if (!FEATURE_REFALIASING_IS_ENABLED)
10706 "Experimental aliasing via reference not enabled");
10707 Perl_ck_warner_d(aTHX_
10708 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10709 "Aliasing via reference is experimental");
10711 o->op_flags |= OPf_STACKED;
10712 op_sibling_splice(o, right, 1, varop);
10715 o->op_flags &=~ OPf_STACKED;
10716 op_sibling_splice(o, right, 1, NULL);
10723 Perl_ck_repeat(pTHX_ OP *o)
10725 PERL_ARGS_ASSERT_CK_REPEAT;
10727 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10729 o->op_private |= OPpREPEAT_DOLIST;
10730 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10731 kids = force_list(kids, 1); /* promote it to a list */
10732 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10740 Perl_ck_require(pTHX_ OP *o)
10744 PERL_ARGS_ASSERT_CK_REQUIRE;
10746 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10747 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10752 if (kid->op_type == OP_CONST) {
10753 SV * const sv = kid->op_sv;
10754 U32 const was_readonly = SvREADONLY(sv);
10755 if (kid->op_private & OPpCONST_BARE) {
10759 if (was_readonly) {
10760 SvREADONLY_off(sv);
10762 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10767 /* treat ::foo::bar as foo::bar */
10768 if (len >= 2 && s[0] == ':' && s[1] == ':')
10769 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
10771 DIE(aTHX_ "Bareword in require maps to empty filename");
10773 for (; s < end; s++) {
10774 if (*s == ':' && s[1] == ':') {
10776 Move(s+2, s+1, end - s - 1, char);
10780 SvEND_set(sv, end);
10781 sv_catpvs(sv, ".pm");
10782 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10783 hek = share_hek(SvPVX(sv),
10784 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10786 sv_sethek(sv, hek);
10788 SvFLAGS(sv) |= was_readonly;
10790 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10793 if (SvREFCNT(sv) > 1) {
10794 kid->op_sv = newSVpvn_share(
10795 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10796 SvREFCNT_dec_NN(sv);
10800 if (was_readonly) SvREADONLY_off(sv);
10801 PERL_HASH(hash, s, len);
10803 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10805 sv_sethek(sv, hek);
10807 SvFLAGS(sv) |= was_readonly;
10813 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10814 /* handle override, if any */
10815 && (gv = gv_override("require", 7))) {
10817 if (o->op_flags & OPf_KIDS) {
10818 kid = cUNOPo->op_first;
10819 op_sibling_splice(o, NULL, -1, NULL);
10822 kid = newDEFSVOP();
10825 newop = S_new_entersubop(aTHX_ gv, kid);
10833 Perl_ck_return(pTHX_ OP *o)
10837 PERL_ARGS_ASSERT_CK_RETURN;
10839 kid = OpSIBLING(cLISTOPo->op_first);
10840 if (CvLVALUE(PL_compcv)) {
10841 for (; kid; kid = OpSIBLING(kid))
10842 op_lvalue(kid, OP_LEAVESUBLV);
10849 Perl_ck_select(pTHX_ OP *o)
10854 PERL_ARGS_ASSERT_CK_SELECT;
10856 if (o->op_flags & OPf_KIDS) {
10857 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10858 if (kid && OpHAS_SIBLING(kid)) {
10859 OpTYPE_set(o, OP_SSELECT);
10861 return fold_constants(op_integerize(op_std_init(o)));
10865 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10866 if (kid && kid->op_type == OP_RV2GV)
10867 kid->op_private &= ~HINT_STRICT_REFS;
10872 Perl_ck_shift(pTHX_ OP *o)
10874 const I32 type = o->op_type;
10876 PERL_ARGS_ASSERT_CK_SHIFT;
10878 if (!(o->op_flags & OPf_KIDS)) {
10881 if (!CvUNIQUE(PL_compcv)) {
10882 o->op_flags |= OPf_SPECIAL;
10886 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10888 return newUNOP(type, 0, scalar(argop));
10890 return scalar(ck_fun(o));
10894 Perl_ck_sort(pTHX_ OP *o)
10898 HV * const hinthv =
10899 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10902 PERL_ARGS_ASSERT_CK_SORT;
10905 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10907 const I32 sorthints = (I32)SvIV(*svp);
10908 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10909 o->op_private |= OPpSORT_QSORT;
10910 if ((sorthints & HINT_SORT_STABLE) != 0)
10911 o->op_private |= OPpSORT_STABLE;
10915 if (o->op_flags & OPf_STACKED)
10917 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10919 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10920 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10922 /* if the first arg is a code block, process it and mark sort as
10924 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10926 if (kid->op_type == OP_LEAVE)
10927 op_null(kid); /* wipe out leave */
10928 /* Prevent execution from escaping out of the sort block. */
10931 /* provide scalar context for comparison function/block */
10932 kid = scalar(firstkid);
10933 kid->op_next = kid;
10934 o->op_flags |= OPf_SPECIAL;
10936 else if (kid->op_type == OP_CONST
10937 && kid->op_private & OPpCONST_BARE) {
10941 const char * const name = SvPV(kSVOP_sv, len);
10943 assert (len < 256);
10944 Copy(name, tmpbuf+1, len, char);
10945 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10946 if (off != NOT_IN_PAD) {
10947 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10949 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10950 sv_catpvs(fq, "::");
10951 sv_catsv(fq, kSVOP_sv);
10952 SvREFCNT_dec_NN(kSVOP_sv);
10956 OP * const padop = newOP(OP_PADCV, 0);
10957 padop->op_targ = off;
10958 /* replace the const op with the pad op */
10959 op_sibling_splice(firstkid, NULL, 1, padop);
10965 firstkid = OpSIBLING(firstkid);
10968 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10969 /* provide list context for arguments */
10972 op_lvalue(kid, OP_GREPSTART);
10978 /* for sort { X } ..., where X is one of
10979 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10980 * elide the second child of the sort (the one containing X),
10981 * and set these flags as appropriate
10985 * Also, check and warn on lexical $a, $b.
10989 S_simplify_sort(pTHX_ OP *o)
10991 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10995 const char *gvname;
10998 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
11000 kid = kUNOP->op_first; /* get past null */
11001 if (!(have_scopeop = kid->op_type == OP_SCOPE)
11002 && kid->op_type != OP_LEAVE)
11004 kid = kLISTOP->op_last; /* get past scope */
11005 switch(kid->op_type) {
11009 if (!have_scopeop) goto padkids;
11014 k = kid; /* remember this node*/
11015 if (kBINOP->op_first->op_type != OP_RV2SV
11016 || kBINOP->op_last ->op_type != OP_RV2SV)
11019 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
11020 then used in a comparison. This catches most, but not
11021 all cases. For instance, it catches
11022 sort { my($a); $a <=> $b }
11024 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
11025 (although why you'd do that is anyone's guess).
11029 if (!ckWARN(WARN_SYNTAX)) return;
11030 kid = kBINOP->op_first;
11032 if (kid->op_type == OP_PADSV) {
11033 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11034 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11035 && ( PadnamePV(name)[1] == 'a'
11036 || PadnamePV(name)[1] == 'b' ))
11037 /* diag_listed_as: "my %s" used in sort comparison */
11038 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11039 "\"%s %s\" used in sort comparison",
11040 PadnameIsSTATE(name)
11045 } while ((kid = OpSIBLING(kid)));
11048 kid = kBINOP->op_first; /* get past cmp */
11049 if (kUNOP->op_first->op_type != OP_GV)
11051 kid = kUNOP->op_first; /* get past rv2sv */
11053 if (GvSTASH(gv) != PL_curstash)
11055 gvname = GvNAME(gv);
11056 if (*gvname == 'a' && gvname[1] == '\0')
11058 else if (*gvname == 'b' && gvname[1] == '\0')
11063 kid = k; /* back to cmp */
11064 /* already checked above that it is rv2sv */
11065 kid = kBINOP->op_last; /* down to 2nd arg */
11066 if (kUNOP->op_first->op_type != OP_GV)
11068 kid = kUNOP->op_first; /* get past rv2sv */
11070 if (GvSTASH(gv) != PL_curstash)
11072 gvname = GvNAME(gv);
11074 ? !(*gvname == 'a' && gvname[1] == '\0')
11075 : !(*gvname == 'b' && gvname[1] == '\0'))
11077 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11079 o->op_private |= OPpSORT_DESCEND;
11080 if (k->op_type == OP_NCMP)
11081 o->op_private |= OPpSORT_NUMERIC;
11082 if (k->op_type == OP_I_NCMP)
11083 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11084 kid = OpSIBLING(cLISTOPo->op_first);
11085 /* cut out and delete old block (second sibling) */
11086 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11091 Perl_ck_split(pTHX_ OP *o)
11096 PERL_ARGS_ASSERT_CK_SPLIT;
11098 if (o->op_flags & OPf_STACKED)
11099 return no_fh_allowed(o);
11101 kid = cLISTOPo->op_first;
11102 if (kid->op_type != OP_NULL)
11103 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
11104 /* delete leading NULL node, then add a CONST if no other nodes */
11105 op_sibling_splice(o, NULL, 1,
11106 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11108 kid = cLISTOPo->op_first;
11110 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11111 /* remove kid, and replace with new optree */
11112 op_sibling_splice(o, NULL, 1, NULL);
11113 /* OPf_SPECIAL is used to trigger split " " behavior */
11114 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
11115 op_sibling_splice(o, NULL, 0, kid);
11117 OpTYPE_set(kid, OP_PUSHRE);
11118 /* target implies @ary=..., so wipe it */
11121 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11122 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11123 "Use of /g modifier is meaningless in split");
11126 if (!OpHAS_SIBLING(kid))
11127 op_append_elem(OP_SPLIT, o, newDEFSVOP());
11129 kid = OpSIBLING(kid);
11133 if (!OpHAS_SIBLING(kid))
11135 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
11136 o->op_private |= OPpSPLIT_IMPLIM;
11138 assert(OpHAS_SIBLING(kid));
11140 kid = OpSIBLING(kid);
11143 if (OpHAS_SIBLING(kid))
11144 return too_many_arguments_pv(o,OP_DESC(o), 0);
11150 Perl_ck_stringify(pTHX_ OP *o)
11152 OP * const kid = OpSIBLING(cUNOPo->op_first);
11153 PERL_ARGS_ASSERT_CK_STRINGIFY;
11154 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11155 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
11156 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
11157 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11159 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11167 Perl_ck_join(pTHX_ OP *o)
11169 OP * const kid = OpSIBLING(cLISTOPo->op_first);
11171 PERL_ARGS_ASSERT_CK_JOIN;
11173 if (kid && kid->op_type == OP_MATCH) {
11174 if (ckWARN(WARN_SYNTAX)) {
11175 const REGEXP *re = PM_GETRE(kPMOP);
11177 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11178 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11179 : newSVpvs_flags( "STRING", SVs_TEMP );
11180 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11181 "/%"SVf"/ should probably be written as \"%"SVf"\"",
11182 SVfARG(msg), SVfARG(msg));
11186 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11187 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11188 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11189 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11191 const OP * const bairn = OpSIBLING(kid); /* the list */
11192 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11193 && OP_GIMME(bairn,0) == G_SCALAR)
11195 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11196 op_sibling_splice(o, kid, 1, NULL));
11206 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11208 Examines an op, which is expected to identify a subroutine at runtime,
11209 and attempts to determine at compile time which subroutine it identifies.
11210 This is normally used during Perl compilation to determine whether
11211 a prototype can be applied to a function call. C<cvop> is the op
11212 being considered, normally an C<rv2cv> op. A pointer to the identified
11213 subroutine is returned, if it could be determined statically, and a null
11214 pointer is returned if it was not possible to determine statically.
11216 Currently, the subroutine can be identified statically if the RV that the
11217 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11218 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11219 suitable if the constant value must be an RV pointing to a CV. Details of
11220 this process may change in future versions of Perl. If the C<rv2cv> op
11221 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11222 the subroutine statically: this flag is used to suppress compile-time
11223 magic on a subroutine call, forcing it to use default runtime behaviour.
11225 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11226 of a GV reference is modified. If a GV was examined and its CV slot was
11227 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11228 If the op is not optimised away, and the CV slot is later populated with
11229 a subroutine having a prototype, that flag eventually triggers the warning
11230 "called too early to check prototype".
11232 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11233 of returning a pointer to the subroutine it returns a pointer to the
11234 GV giving the most appropriate name for the subroutine in this context.
11235 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11236 (C<CvANON>) subroutine that is referenced through a GV it will be the
11237 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11238 A null pointer is returned as usual if there is no statically-determinable
11244 /* shared by toke.c:yylex */
11246 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11248 PADNAME *name = PAD_COMPNAME(off);
11249 CV *compcv = PL_compcv;
11250 while (PadnameOUTER(name)) {
11251 assert(PARENT_PAD_INDEX(name));
11252 compcv = CvOUTSIDE(compcv);
11253 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11254 [off = PARENT_PAD_INDEX(name)];
11256 assert(!PadnameIsOUR(name));
11257 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11258 return PadnamePROTOCV(name);
11260 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11264 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11269 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11270 if (flags & ~RV2CVOPCV_FLAG_MASK)
11271 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11272 if (cvop->op_type != OP_RV2CV)
11274 if (cvop->op_private & OPpENTERSUB_AMPER)
11276 if (!(cvop->op_flags & OPf_KIDS))
11278 rvop = cUNOPx(cvop)->op_first;
11279 switch (rvop->op_type) {
11281 gv = cGVOPx_gv(rvop);
11283 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11284 cv = MUTABLE_CV(SvRV(gv));
11288 if (flags & RV2CVOPCV_RETURN_STUB)
11294 if (flags & RV2CVOPCV_MARK_EARLY)
11295 rvop->op_private |= OPpEARLY_CV;
11300 SV *rv = cSVOPx_sv(rvop);
11303 cv = (CV*)SvRV(rv);
11307 cv = find_lexical_cv(rvop->op_targ);
11312 } NOT_REACHED; /* NOTREACHED */
11314 if (SvTYPE((SV*)cv) != SVt_PVCV)
11316 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11317 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11318 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11327 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11329 Performs the default fixup of the arguments part of an C<entersub>
11330 op tree. This consists of applying list context to each of the
11331 argument ops. This is the standard treatment used on a call marked
11332 with C<&>, or a method call, or a call through a subroutine reference,
11333 or any other call where the callee can't be identified at compile time,
11334 or a call where the callee has no prototype.
11340 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11344 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11346 aop = cUNOPx(entersubop)->op_first;
11347 if (!OpHAS_SIBLING(aop))
11348 aop = cUNOPx(aop)->op_first;
11349 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11350 /* skip the extra attributes->import() call implicitly added in
11351 * something like foo(my $x : bar)
11353 if ( aop->op_type == OP_ENTERSUB
11354 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11358 op_lvalue(aop, OP_ENTERSUB);
11364 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11366 Performs the fixup of the arguments part of an C<entersub> op tree
11367 based on a subroutine prototype. This makes various modifications to
11368 the argument ops, from applying context up to inserting C<refgen> ops,
11369 and checking the number and syntactic types of arguments, as directed by
11370 the prototype. This is the standard treatment used on a subroutine call,
11371 not marked with C<&>, where the callee can be identified at compile time
11372 and has a prototype.
11374 C<protosv> supplies the subroutine prototype to be applied to the call.
11375 It may be a normal defined scalar, of which the string value will be used.
11376 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11377 that has been cast to C<SV*>) which has a prototype. The prototype
11378 supplied, in whichever form, does not need to match the actual callee
11379 referenced by the op tree.
11381 If the argument ops disagree with the prototype, for example by having
11382 an unacceptable number of arguments, a valid op tree is returned anyway.
11383 The error is reflected in the parser state, normally resulting in a single
11384 exception at the top level of parsing which covers all the compilation
11385 errors that occurred. In the error message, the callee is referred to
11386 by the name defined by the C<namegv> parameter.
11392 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11395 const char *proto, *proto_end;
11396 OP *aop, *prev, *cvop, *parent;
11399 I32 contextclass = 0;
11400 const char *e = NULL;
11401 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11402 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11403 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11404 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11405 if (SvTYPE(protosv) == SVt_PVCV)
11406 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11407 else proto = SvPV(protosv, proto_len);
11408 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11409 proto_end = proto + proto_len;
11410 parent = entersubop;
11411 aop = cUNOPx(entersubop)->op_first;
11412 if (!OpHAS_SIBLING(aop)) {
11414 aop = cUNOPx(aop)->op_first;
11417 aop = OpSIBLING(aop);
11418 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11419 while (aop != cvop) {
11422 if (proto >= proto_end)
11424 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11425 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11426 SVfARG(namesv)), SvUTF8(namesv));
11436 /* _ must be at the end */
11437 if (proto[1] && !strchr(";@%", proto[1]))
11453 if ( o3->op_type != OP_UNDEF
11454 && (o3->op_type != OP_SREFGEN
11455 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11457 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11459 bad_type_gv(arg, namegv, o3,
11460 arg == 1 ? "block or sub {}" : "sub {}");
11463 /* '*' allows any scalar type, including bareword */
11466 if (o3->op_type == OP_RV2GV)
11467 goto wrapref; /* autoconvert GLOB -> GLOBref */
11468 else if (o3->op_type == OP_CONST)
11469 o3->op_private &= ~OPpCONST_STRICT;
11475 if (o3->op_type == OP_RV2AV ||
11476 o3->op_type == OP_PADAV ||
11477 o3->op_type == OP_RV2HV ||
11478 o3->op_type == OP_PADHV
11484 case '[': case ']':
11491 switch (*proto++) {
11493 if (contextclass++ == 0) {
11494 e = strchr(proto, ']');
11495 if (!e || e == proto)
11503 if (contextclass) {
11504 const char *p = proto;
11505 const char *const end = proto;
11507 while (*--p != '[')
11508 /* \[$] accepts any scalar lvalue */
11510 && Perl_op_lvalue_flags(aTHX_
11512 OP_READ, /* not entersub */
11515 bad_type_gv(arg, namegv, o3,
11516 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11521 if (o3->op_type == OP_RV2GV)
11524 bad_type_gv(arg, namegv, o3, "symbol");
11527 if (o3->op_type == OP_ENTERSUB
11528 && !(o3->op_flags & OPf_STACKED))
11531 bad_type_gv(arg, namegv, o3, "subroutine");
11534 if (o3->op_type == OP_RV2SV ||
11535 o3->op_type == OP_PADSV ||
11536 o3->op_type == OP_HELEM ||
11537 o3->op_type == OP_AELEM)
11539 if (!contextclass) {
11540 /* \$ accepts any scalar lvalue */
11541 if (Perl_op_lvalue_flags(aTHX_
11543 OP_READ, /* not entersub */
11546 bad_type_gv(arg, namegv, o3, "scalar");
11550 if (o3->op_type == OP_RV2AV ||
11551 o3->op_type == OP_PADAV)
11553 o3->op_flags &=~ OPf_PARENS;
11557 bad_type_gv(arg, namegv, o3, "array");
11560 if (o3->op_type == OP_RV2HV ||
11561 o3->op_type == OP_PADHV)
11563 o3->op_flags &=~ OPf_PARENS;
11567 bad_type_gv(arg, namegv, o3, "hash");
11570 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11572 if (contextclass && e) {
11577 default: goto oops;
11587 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11588 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11593 op_lvalue(aop, OP_ENTERSUB);
11595 aop = OpSIBLING(aop);
11597 if (aop == cvop && *proto == '_') {
11598 /* generate an access to $_ */
11599 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11601 if (!optional && proto_end > proto &&
11602 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11604 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11605 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11606 SVfARG(namesv)), SvUTF8(namesv));
11612 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11614 Performs the fixup of the arguments part of an C<entersub> op tree either
11615 based on a subroutine prototype or using default list-context processing.
11616 This is the standard treatment used on a subroutine call, not marked
11617 with C<&>, where the callee can be identified at compile time.
11619 C<protosv> supplies the subroutine prototype to be applied to the call,
11620 or indicates that there is no prototype. It may be a normal scalar,
11621 in which case if it is defined then the string value will be used
11622 as a prototype, and if it is undefined then there is no prototype.
11623 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11624 that has been cast to C<SV*>), of which the prototype will be used if it
11625 has one. The prototype (or lack thereof) supplied, in whichever form,
11626 does not need to match the actual callee referenced by the op tree.
11628 If the argument ops disagree with the prototype, for example by having
11629 an unacceptable number of arguments, a valid op tree is returned anyway.
11630 The error is reflected in the parser state, normally resulting in a single
11631 exception at the top level of parsing which covers all the compilation
11632 errors that occurred. In the error message, the callee is referred to
11633 by the name defined by the C<namegv> parameter.
11639 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11640 GV *namegv, SV *protosv)
11642 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11643 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11644 return ck_entersub_args_proto(entersubop, namegv, protosv);
11646 return ck_entersub_args_list(entersubop);
11650 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11652 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11653 OP *aop = cUNOPx(entersubop)->op_first;
11655 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11659 if (!OpHAS_SIBLING(aop))
11660 aop = cUNOPx(aop)->op_first;
11661 aop = OpSIBLING(aop);
11662 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11664 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11666 op_free(entersubop);
11667 switch(GvNAME(namegv)[2]) {
11668 case 'F': return newSVOP(OP_CONST, 0,
11669 newSVpv(CopFILE(PL_curcop),0));
11670 case 'L': return newSVOP(
11672 Perl_newSVpvf(aTHX_
11673 "%"IVdf, (IV)CopLINE(PL_curcop)
11676 case 'P': return newSVOP(OP_CONST, 0,
11678 ? newSVhek(HvNAME_HEK(PL_curstash))
11683 NOT_REACHED; /* NOTREACHED */
11686 OP *prev, *cvop, *first, *parent;
11689 parent = entersubop;
11690 if (!OpHAS_SIBLING(aop)) {
11692 aop = cUNOPx(aop)->op_first;
11695 first = prev = aop;
11696 aop = OpSIBLING(aop);
11697 /* find last sibling */
11699 OpHAS_SIBLING(cvop);
11700 prev = cvop, cvop = OpSIBLING(cvop))
11702 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11703 /* Usually, OPf_SPECIAL on an op with no args means that it had
11704 * parens, but these have their own meaning for that flag: */
11705 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11706 && opnum != OP_DELETE && opnum != OP_EXISTS)
11707 flags |= OPf_SPECIAL;
11708 /* excise cvop from end of sibling chain */
11709 op_sibling_splice(parent, prev, 1, NULL);
11711 if (aop == cvop) aop = NULL;
11713 /* detach remaining siblings from the first sibling, then
11714 * dispose of original optree */
11717 op_sibling_splice(parent, first, -1, NULL);
11718 op_free(entersubop);
11720 if (opnum == OP_ENTEREVAL
11721 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11722 flags |= OPpEVAL_BYTES <<8;
11724 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11726 case OA_BASEOP_OR_UNOP:
11727 case OA_FILESTATOP:
11728 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11731 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11734 return opnum == OP_RUNCV
11735 ? newPVOP(OP_RUNCV,0,NULL)
11738 return op_convert_list(opnum,0,aop);
11741 NOT_REACHED; /* NOTREACHED */
11746 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11748 Retrieves the function that will be used to fix up a call to C<cv>.
11749 Specifically, the function is applied to an C<entersub> op tree for a
11750 subroutine call, not marked with C<&>, where the callee can be identified
11751 at compile time as C<cv>.
11753 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11754 argument for it is returned in C<*ckobj_p>. The function is intended
11755 to be called in this manner:
11757 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11759 In this call, C<entersubop> is a pointer to the C<entersub> op,
11760 which may be replaced by the check function, and C<namegv> is a GV
11761 supplying the name that should be used by the check function to refer
11762 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11763 It is permitted to apply the check function in non-standard situations,
11764 such as to a call to a different subroutine or to a method call.
11766 By default, the function is
11767 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11768 and the SV parameter is C<cv> itself. This implements standard
11769 prototype processing. It can be changed, for a particular subroutine,
11770 by L</cv_set_call_checker>.
11776 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11780 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11782 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11783 *ckobj_p = callmg->mg_obj;
11784 if (flagsp) *flagsp = callmg->mg_flags;
11786 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11787 *ckobj_p = (SV*)cv;
11788 if (flagsp) *flagsp = 0;
11793 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11795 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11796 PERL_UNUSED_CONTEXT;
11797 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11801 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11803 Sets the function that will be used to fix up a call to C<cv>.
11804 Specifically, the function is applied to an C<entersub> op tree for a
11805 subroutine call, not marked with C<&>, where the callee can be identified
11806 at compile time as C<cv>.
11808 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11809 for it is supplied in C<ckobj>. The function should be defined like this:
11811 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11813 It is intended to be called in this manner:
11815 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11817 In this call, C<entersubop> is a pointer to the C<entersub> op,
11818 which may be replaced by the check function, and C<namegv> supplies
11819 the name that should be used by the check function to refer
11820 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11821 It is permitted to apply the check function in non-standard situations,
11822 such as to a call to a different subroutine or to a method call.
11824 C<namegv> may not actually be a GV. For efficiency, perl may pass a
11825 CV or other SV instead. Whatever is passed can be used as the first
11826 argument to L</cv_name>. You can force perl to pass a GV by including
11827 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11829 The current setting for a particular CV can be retrieved by
11830 L</cv_get_call_checker>.
11832 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11834 The original form of L</cv_set_call_checker_flags>, which passes it the
11835 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11841 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11843 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11844 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11848 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11849 SV *ckobj, U32 flags)
11851 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11852 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11853 if (SvMAGICAL((SV*)cv))
11854 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11857 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11858 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11860 if (callmg->mg_flags & MGf_REFCOUNTED) {
11861 SvREFCNT_dec(callmg->mg_obj);
11862 callmg->mg_flags &= ~MGf_REFCOUNTED;
11864 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11865 callmg->mg_obj = ckobj;
11866 if (ckobj != (SV*)cv) {
11867 SvREFCNT_inc_simple_void_NN(ckobj);
11868 callmg->mg_flags |= MGf_REFCOUNTED;
11870 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11871 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11876 S_entersub_alloc_targ(pTHX_ OP * const o)
11878 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11879 o->op_private |= OPpENTERSUB_HASTARG;
11883 Perl_ck_subr(pTHX_ OP *o)
11888 SV **const_class = NULL;
11890 PERL_ARGS_ASSERT_CK_SUBR;
11892 aop = cUNOPx(o)->op_first;
11893 if (!OpHAS_SIBLING(aop))
11894 aop = cUNOPx(aop)->op_first;
11895 aop = OpSIBLING(aop);
11896 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11897 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11898 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11900 o->op_private &= ~1;
11901 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11902 if (PERLDB_SUB && PL_curstash != PL_debstash)
11903 o->op_private |= OPpENTERSUB_DB;
11904 switch (cvop->op_type) {
11906 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11910 case OP_METHOD_NAMED:
11911 case OP_METHOD_SUPER:
11912 case OP_METHOD_REDIR:
11913 case OP_METHOD_REDIR_SUPER:
11914 if (aop->op_type == OP_CONST) {
11915 aop->op_private &= ~OPpCONST_STRICT;
11916 const_class = &cSVOPx(aop)->op_sv;
11918 else if (aop->op_type == OP_LIST) {
11919 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11920 if (sib && sib->op_type == OP_CONST) {
11921 sib->op_private &= ~OPpCONST_STRICT;
11922 const_class = &cSVOPx(sib)->op_sv;
11925 /* make class name a shared cow string to speedup method calls */
11926 /* constant string might be replaced with object, f.e. bigint */
11927 if (const_class && SvPOK(*const_class)) {
11929 const char* str = SvPV(*const_class, len);
11931 SV* const shared = newSVpvn_share(
11932 str, SvUTF8(*const_class)
11933 ? -(SSize_t)len : (SSize_t)len,
11936 if (SvREADONLY(*const_class))
11937 SvREADONLY_on(shared);
11938 SvREFCNT_dec(*const_class);
11939 *const_class = shared;
11946 S_entersub_alloc_targ(aTHX_ o);
11947 return ck_entersub_args_list(o);
11949 Perl_call_checker ckfun;
11952 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11953 if (CvISXSUB(cv) || !CvROOT(cv))
11954 S_entersub_alloc_targ(aTHX_ o);
11956 /* The original call checker API guarantees that a GV will be
11957 be provided with the right name. So, if the old API was
11958 used (or the REQUIRE_GV flag was passed), we have to reify
11959 the CV’s GV, unless this is an anonymous sub. This is not
11960 ideal for lexical subs, as its stringification will include
11961 the package. But it is the best we can do. */
11962 if (flags & MGf_REQUIRE_GV) {
11963 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11966 else namegv = MUTABLE_GV(cv);
11967 /* After a syntax error in a lexical sub, the cv that
11968 rv2cv_op_cv returns may be a nameless stub. */
11969 if (!namegv) return ck_entersub_args_list(o);
11972 return ckfun(aTHX_ o, namegv, ckobj);
11977 Perl_ck_svconst(pTHX_ OP *o)
11979 SV * const sv = cSVOPo->op_sv;
11980 PERL_ARGS_ASSERT_CK_SVCONST;
11981 PERL_UNUSED_CONTEXT;
11982 #ifdef PERL_COPY_ON_WRITE
11983 /* Since the read-only flag may be used to protect a string buffer, we
11984 cannot do copy-on-write with existing read-only scalars that are not
11985 already copy-on-write scalars. To allow $_ = "hello" to do COW with
11986 that constant, mark the constant as COWable here, if it is not
11987 already read-only. */
11988 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11991 # ifdef PERL_DEBUG_READONLY_COW
12001 Perl_ck_trunc(pTHX_ OP *o)
12003 PERL_ARGS_ASSERT_CK_TRUNC;
12005 if (o->op_flags & OPf_KIDS) {
12006 SVOP *kid = (SVOP*)cUNOPo->op_first;
12008 if (kid->op_type == OP_NULL)
12009 kid = (SVOP*)OpSIBLING(kid);
12010 if (kid && kid->op_type == OP_CONST &&
12011 (kid->op_private & OPpCONST_BARE) &&
12014 o->op_flags |= OPf_SPECIAL;
12015 kid->op_private &= ~OPpCONST_STRICT;
12022 Perl_ck_substr(pTHX_ OP *o)
12024 PERL_ARGS_ASSERT_CK_SUBSTR;
12027 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
12028 OP *kid = cLISTOPo->op_first;
12030 if (kid->op_type == OP_NULL)
12031 kid = OpSIBLING(kid);
12033 kid->op_flags |= OPf_MOD;
12040 Perl_ck_tell(pTHX_ OP *o)
12042 PERL_ARGS_ASSERT_CK_TELL;
12044 if (o->op_flags & OPf_KIDS) {
12045 OP *kid = cLISTOPo->op_first;
12046 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12047 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12053 Perl_ck_each(pTHX_ OP *o)
12056 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12057 const unsigned orig_type = o->op_type;
12059 PERL_ARGS_ASSERT_CK_EACH;
12062 switch (kid->op_type) {
12068 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
12069 : orig_type == OP_KEYS ? OP_AKEYS
12073 if (kid->op_private == OPpCONST_BARE
12074 || !SvROK(cSVOPx_sv(kid))
12075 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12076 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
12080 qerror(Perl_mess(aTHX_
12081 "Experimental %s on scalar is now forbidden",
12082 PL_op_desc[orig_type]));
12084 bad_type_pv(1, "hash or array", o, kid);
12092 Perl_ck_length(pTHX_ OP *o)
12094 PERL_ARGS_ASSERT_CK_LENGTH;
12098 if (ckWARN(WARN_SYNTAX)) {
12099 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12103 const bool hash = kid->op_type == OP_PADHV
12104 || kid->op_type == OP_RV2HV;
12105 switch (kid->op_type) {
12110 name = S_op_varname(aTHX_ kid);
12116 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12117 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
12119 SVfARG(name), hash ? "keys " : "", SVfARG(name)
12122 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12123 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12124 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12126 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12127 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12128 "length() used on @array (did you mean \"scalar(@array)\"?)");
12138 ---------------------------------------------------------
12140 Common vars in list assignment
12142 There now follows some enums and static functions for detecting
12143 common variables in list assignments. Here is a little essay I wrote
12144 for myself when trying to get my head around this. DAPM.
12148 First some random observations:
12150 * If a lexical var is an alias of something else, e.g.
12151 for my $x ($lex, $pkg, $a[0]) {...}
12152 then the act of aliasing will increase the reference count of the SV
12154 * If a package var is an alias of something else, it may still have a
12155 reference count of 1, depending on how the alias was created, e.g.
12156 in *a = *b, $a may have a refcount of 1 since the GP is shared
12157 with a single GvSV pointer to the SV. So If it's an alias of another
12158 package var, then RC may be 1; if it's an alias of another scalar, e.g.
12159 a lexical var or an array element, then it will have RC > 1.
12161 * There are many ways to create a package alias; ultimately, XS code
12162 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12163 run-time tracing mechanisms are unlikely to be able to catch all cases.
12165 * When the LHS is all my declarations, the same vars can't appear directly
12166 on the RHS, but they can indirectly via closures, aliasing and lvalue
12167 subs. But those techniques all involve an increase in the lexical
12168 scalar's ref count.
12170 * When the LHS is all lexical vars (but not necessarily my declarations),
12171 it is possible for the same lexicals to appear directly on the RHS, and
12172 without an increased ref count, since the stack isn't refcounted.
12173 This case can be detected at compile time by scanning for common lex
12174 vars with PL_generation.
12176 * lvalue subs defeat common var detection, but they do at least
12177 return vars with a temporary ref count increment. Also, you can't
12178 tell at compile time whether a sub call is lvalue.
12183 A: There are a few circumstances where there definitely can't be any
12186 LHS empty: () = (...);
12187 RHS empty: (....) = ();
12188 RHS contains only constants or other 'can't possibly be shared'
12189 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
12190 i.e. they only contain ops not marked as dangerous, whose children
12191 are also not dangerous;
12193 LHS contains a single scalar element: e.g. ($x) = (....); because
12194 after $x has been modified, it won't be used again on the RHS;
12195 RHS contains a single element with no aggregate on LHS: e.g.
12196 ($a,$b,$c) = ($x); again, once $a has been modified, its value
12197 won't be used again.
12199 B: If LHS are all 'my' lexical var declarations (or safe ops, which
12202 my ($a, $b, @c) = ...;
12204 Due to closure and goto tricks, these vars may already have content.
12205 For the same reason, an element on the RHS may be a lexical or package
12206 alias of one of the vars on the left, or share common elements, for
12209 my ($x,$y) = f(); # $x and $y on both sides
12210 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12215 my @a = @$ra; # elements of @a on both sides
12216 sub f { @a = 1..4; \@a }
12219 First, just consider scalar vars on LHS:
12221 RHS is safe only if (A), or in addition,
12222 * contains only lexical *scalar* vars, where neither side's
12223 lexicals have been flagged as aliases
12225 If RHS is not safe, then it's always legal to check LHS vars for
12226 RC==1, since the only RHS aliases will always be associated
12229 Note that in particular, RHS is not safe if:
12231 * it contains package scalar vars; e.g.:
12234 my ($x, $y) = (2, $x_alias);
12235 sub f { $x = 1; *x_alias = \$x; }
12237 * It contains other general elements, such as flattened or
12238 * spliced or single array or hash elements, e.g.
12241 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12245 use feature 'refaliasing';
12246 \($a[0], $a[1]) = \($y,$x);
12249 It doesn't matter if the array/hash is lexical or package.
12251 * it contains a function call that happens to be an lvalue
12252 sub which returns one or more of the above, e.g.
12263 (so a sub call on the RHS should be treated the same
12264 as having a package var on the RHS).
12266 * any other "dangerous" thing, such an op or built-in that
12267 returns one of the above, e.g. pp_preinc
12270 If RHS is not safe, what we can do however is at compile time flag
12271 that the LHS are all my declarations, and at run time check whether
12272 all the LHS have RC == 1, and if so skip the full scan.
12274 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12276 Here the issue is whether there can be elements of @a on the RHS
12277 which will get prematurely freed when @a is cleared prior to
12278 assignment. This is only a problem if the aliasing mechanism
12279 is one which doesn't increase the refcount - only if RC == 1
12280 will the RHS element be prematurely freed.
12282 Because the array/hash is being INTROed, it or its elements
12283 can't directly appear on the RHS:
12285 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12287 but can indirectly, e.g.:
12291 sub f { @a = 1..3; \@a }
12293 So if the RHS isn't safe as defined by (A), we must always
12294 mortalise and bump the ref count of any remaining RHS elements
12295 when assigning to a non-empty LHS aggregate.
12297 Lexical scalars on the RHS aren't safe if they've been involved in
12300 use feature 'refaliasing';
12303 \(my $lex) = \$pkg;
12304 my @a = ($lex,3); # equivalent to ($a[0],3)
12311 Similarly with lexical arrays and hashes on the RHS:
12325 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12326 my $a; ($a, my $b) = (....);
12328 The difference between (B) and (C) is that it is now physically
12329 possible for the LHS vars to appear on the RHS too, where they
12330 are not reference counted; but in this case, the compile-time
12331 PL_generation sweep will detect such common vars.
12333 So the rules for (C) differ from (B) in that if common vars are
12334 detected, the runtime "test RC==1" optimisation can no longer be used,
12335 and a full mark and sweep is required
12337 D: As (C), but in addition the LHS may contain package vars.
12339 Since package vars can be aliased without a corresponding refcount
12340 increase, all bets are off. It's only safe if (A). E.g.
12342 my ($x, $y) = (1,2);
12344 for $x_alias ($x) {
12345 ($x_alias, $y) = (3, $x); # whoops
12348 Ditto for LHS aggregate package vars.
12350 E: Any other dangerous ops on LHS, e.g.
12351 (f(), $a[0], @$r) = (...);
12353 this is similar to (E) in that all bets are off. In addition, it's
12354 impossible to determine at compile time whether the LHS
12355 contains a scalar or an aggregate, e.g.
12357 sub f : lvalue { @a }
12360 * ---------------------------------------------------------
12364 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12365 * that at least one of the things flagged was seen.
12369 AAS_MY_SCALAR = 0x001, /* my $scalar */
12370 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
12371 AAS_LEX_SCALAR = 0x004, /* $lexical */
12372 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
12373 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12374 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
12375 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
12376 AAS_DANGEROUS = 0x080, /* an op (other than the above)
12377 that's flagged OA_DANGEROUS */
12378 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
12379 not in any of the categories above */
12380 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
12385 /* helper function for S_aassign_scan().
12386 * check a PAD-related op for commonality and/or set its generation number.
12387 * Returns a boolean indicating whether its shared */
12390 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12392 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12393 /* lexical used in aliasing */
12397 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12399 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12406 Helper function for OPpASSIGN_COMMON* detection in rpeep().
12407 It scans the left or right hand subtree of the aassign op, and returns a
12408 set of flags indicating what sorts of things it found there.
12409 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12410 set PL_generation on lexical vars; if the latter, we see if
12411 PL_generation matches.
12412 'top' indicates whether we're recursing or at the top level.
12413 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12414 This fn will increment it by the number seen. It's not intended to
12415 be an accurate count (especially as many ops can push a variable
12416 number of SVs onto the stack); rather it's used as to test whether there
12417 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12421 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12424 bool kid_top = FALSE;
12426 /* first, look for a solitary @_ on the RHS */
12429 && (o->op_flags & OPf_KIDS)
12430 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12432 OP *kid = cUNOPo->op_first;
12433 if ( ( kid->op_type == OP_PUSHMARK
12434 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12435 && ((kid = OpSIBLING(kid)))
12436 && !OpHAS_SIBLING(kid)
12437 && kid->op_type == OP_RV2AV
12438 && !(kid->op_flags & OPf_REF)
12439 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12440 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12441 && ((kid = cUNOPx(kid)->op_first))
12442 && kid->op_type == OP_GV
12443 && cGVOPx_gv(kid) == PL_defgv
12445 flags |= AAS_DEFAV;
12448 switch (o->op_type) {
12451 return AAS_PKG_SCALAR;
12456 if (top && (o->op_flags & OPf_REF))
12457 return (o->op_private & OPpLVAL_INTRO)
12458 ? AAS_MY_AGG : AAS_LEX_AGG;
12459 return AAS_DANGEROUS;
12463 int comm = S_aassign_padcheck(aTHX_ o, rhs)
12464 ? AAS_LEX_SCALAR_COMM : 0;
12466 return (o->op_private & OPpLVAL_INTRO)
12467 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12473 if (cUNOPx(o)->op_first->op_type != OP_GV)
12474 return AAS_DANGEROUS; /* @{expr}, %{expr} */
12476 if (top && (o->op_flags & OPf_REF))
12477 return AAS_PKG_AGG;
12478 return AAS_DANGEROUS;
12482 if (cUNOPx(o)->op_first->op_type != OP_GV) {
12484 return AAS_DANGEROUS; /* ${expr} */
12486 return AAS_PKG_SCALAR; /* $pkg */
12489 if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
12490 /* "@foo = split... " optimises away the aassign and stores its
12491 * destination array in the OP_PUSHRE that precedes it.
12492 * A flattened array is always dangerous.
12495 return AAS_DANGEROUS;
12500 /* undef counts as a scalar on the RHS:
12501 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
12502 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
12506 flags = AAS_SAFE_SCALAR;
12511 /* these are all no-ops; they don't push a potentially common SV
12512 * onto the stack, so they are neither AAS_DANGEROUS nor
12513 * AAS_SAFE_SCALAR */
12516 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12521 /* these do nothing but may have children; but their children
12522 * should also be treated as top-level */
12527 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12529 flags = AAS_DANGEROUS;
12533 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
12534 && (o->op_private & OPpTARGET_MY))
12537 return S_aassign_padcheck(aTHX_ o, rhs)
12538 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12541 /* if its an unrecognised, non-dangerous op, assume that it
12542 * it the cause of at least one safe scalar */
12544 flags = AAS_SAFE_SCALAR;
12548 if (o->op_flags & OPf_KIDS) {
12550 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12551 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12557 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12558 and modify the optree to make them work inplace */
12561 S_inplace_aassign(pTHX_ OP *o) {
12563 OP *modop, *modop_pushmark;
12565 OP *oleft, *oleft_pushmark;
12567 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12569 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12571 assert(cUNOPo->op_first->op_type == OP_NULL);
12572 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12573 assert(modop_pushmark->op_type == OP_PUSHMARK);
12574 modop = OpSIBLING(modop_pushmark);
12576 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12579 /* no other operation except sort/reverse */
12580 if (OpHAS_SIBLING(modop))
12583 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12584 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12586 if (modop->op_flags & OPf_STACKED) {
12587 /* skip sort subroutine/block */
12588 assert(oright->op_type == OP_NULL);
12589 oright = OpSIBLING(oright);
12592 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12593 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12594 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12595 oleft = OpSIBLING(oleft_pushmark);
12597 /* Check the lhs is an array */
12599 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12600 || OpHAS_SIBLING(oleft)
12601 || (oleft->op_private & OPpLVAL_INTRO)
12605 /* Only one thing on the rhs */
12606 if (OpHAS_SIBLING(oright))
12609 /* check the array is the same on both sides */
12610 if (oleft->op_type == OP_RV2AV) {
12611 if (oright->op_type != OP_RV2AV
12612 || !cUNOPx(oright)->op_first
12613 || cUNOPx(oright)->op_first->op_type != OP_GV
12614 || cUNOPx(oleft )->op_first->op_type != OP_GV
12615 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12616 cGVOPx_gv(cUNOPx(oright)->op_first)
12620 else if (oright->op_type != OP_PADAV
12621 || oright->op_targ != oleft->op_targ
12625 /* This actually is an inplace assignment */
12627 modop->op_private |= OPpSORT_INPLACE;
12629 /* transfer MODishness etc from LHS arg to RHS arg */
12630 oright->op_flags = oleft->op_flags;
12632 /* remove the aassign op and the lhs */
12634 op_null(oleft_pushmark);
12635 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12636 op_null(cUNOPx(oleft)->op_first);
12642 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12643 * that potentially represent a series of one or more aggregate derefs
12644 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12645 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12646 * additional ops left in too).
12648 * The caller will have already verified that the first few ops in the
12649 * chain following 'start' indicate a multideref candidate, and will have
12650 * set 'orig_o' to the point further on in the chain where the first index
12651 * expression (if any) begins. 'orig_action' specifies what type of
12652 * beginning has already been determined by the ops between start..orig_o
12653 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12655 * 'hints' contains any hints flags that need adding (currently just
12656 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12660 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12664 UNOP_AUX_item *arg_buf = NULL;
12665 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12666 int index_skip = -1; /* don't output index arg on this action */
12668 /* similar to regex compiling, do two passes; the first pass
12669 * determines whether the op chain is convertible and calculates the
12670 * buffer size; the second pass populates the buffer and makes any
12671 * changes necessary to ops (such as moving consts to the pad on
12672 * threaded builds).
12674 * NB: for things like Coverity, note that both passes take the same
12675 * path through the logic tree (except for 'if (pass)' bits), since
12676 * both passes are following the same op_next chain; and in
12677 * particular, if it would return early on the second pass, it would
12678 * already have returned early on the first pass.
12680 for (pass = 0; pass < 2; pass++) {
12682 UV action = orig_action;
12683 OP *first_elem_op = NULL; /* first seen aelem/helem */
12684 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12685 int action_count = 0; /* number of actions seen so far */
12686 int action_ix = 0; /* action_count % (actions per IV) */
12687 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12688 bool is_last = FALSE; /* no more derefs to follow */
12689 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12690 UNOP_AUX_item *arg = arg_buf;
12691 UNOP_AUX_item *action_ptr = arg_buf;
12694 action_ptr->uv = 0;
12698 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12699 case MDEREF_HV_gvhv_helem:
12700 next_is_hash = TRUE;
12702 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12703 case MDEREF_AV_gvav_aelem:
12705 #ifdef USE_ITHREADS
12706 arg->pad_offset = cPADOPx(start)->op_padix;
12707 /* stop it being swiped when nulled */
12708 cPADOPx(start)->op_padix = 0;
12710 arg->sv = cSVOPx(start)->op_sv;
12711 cSVOPx(start)->op_sv = NULL;
12717 case MDEREF_HV_padhv_helem:
12718 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12719 next_is_hash = TRUE;
12721 case MDEREF_AV_padav_aelem:
12722 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12724 arg->pad_offset = start->op_targ;
12725 /* we skip setting op_targ = 0 for now, since the intact
12726 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12727 reset_start_targ = TRUE;
12732 case MDEREF_HV_pop_rv2hv_helem:
12733 next_is_hash = TRUE;
12735 case MDEREF_AV_pop_rv2av_aelem:
12739 NOT_REACHED; /* NOTREACHED */
12744 /* look for another (rv2av/hv; get index;
12745 * aelem/helem/exists/delele) sequence */
12750 UV index_type = MDEREF_INDEX_none;
12752 if (action_count) {
12753 /* if this is not the first lookup, consume the rv2av/hv */
12755 /* for N levels of aggregate lookup, we normally expect
12756 * that the first N-1 [ah]elem ops will be flagged as
12757 * /DEREF (so they autovivifiy if necessary), and the last
12758 * lookup op not to be.
12759 * For other things (like @{$h{k1}{k2}}) extra scope or
12760 * leave ops can appear, so abandon the effort in that
12762 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12765 /* rv2av or rv2hv sKR/1 */
12767 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12768 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12769 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12772 /* at this point, we wouldn't expect any of these
12773 * possible private flags:
12774 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12775 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12777 ASSUME(!(o->op_private &
12778 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12780 hints = (o->op_private & OPpHINT_STRICT_REFS);
12782 /* make sure the type of the previous /DEREF matches the
12783 * type of the next lookup */
12784 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12787 action = next_is_hash
12788 ? MDEREF_HV_vivify_rv2hv_helem
12789 : MDEREF_AV_vivify_rv2av_aelem;
12793 /* if this is the second pass, and we're at the depth where
12794 * previously we encountered a non-simple index expression,
12795 * stop processing the index at this point */
12796 if (action_count != index_skip) {
12798 /* look for one or more simple ops that return an array
12799 * index or hash key */
12801 switch (o->op_type) {
12803 /* it may be a lexical var index */
12804 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12805 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12806 ASSUME(!(o->op_private &
12807 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12809 if ( OP_GIMME(o,0) == G_SCALAR
12810 && !(o->op_flags & (OPf_REF|OPf_MOD))
12811 && o->op_private == 0)
12814 arg->pad_offset = o->op_targ;
12816 index_type = MDEREF_INDEX_padsv;
12822 if (next_is_hash) {
12823 /* it's a constant hash index */
12824 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12825 /* "use constant foo => FOO; $h{+foo}" for
12826 * some weird FOO, can leave you with constants
12827 * that aren't simple strings. It's not worth
12828 * the extra hassle for those edge cases */
12833 OP * helem_op = o->op_next;
12835 ASSUME( helem_op->op_type == OP_HELEM
12836 || helem_op->op_type == OP_NULL);
12837 if (helem_op->op_type == OP_HELEM) {
12838 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12839 if ( helem_op->op_private & OPpLVAL_INTRO
12840 || rop->op_type != OP_RV2HV
12844 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12846 #ifdef USE_ITHREADS
12847 /* Relocate sv to the pad for thread safety */
12848 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12849 arg->pad_offset = o->op_targ;
12852 arg->sv = cSVOPx_sv(o);
12857 /* it's a constant array index */
12859 SV *ix_sv = cSVOPo->op_sv;
12864 if ( action_count == 0
12867 && ( action == MDEREF_AV_padav_aelem
12868 || action == MDEREF_AV_gvav_aelem)
12870 maybe_aelemfast = TRUE;
12874 SvREFCNT_dec_NN(cSVOPo->op_sv);
12878 /* we've taken ownership of the SV */
12879 cSVOPo->op_sv = NULL;
12881 index_type = MDEREF_INDEX_const;
12886 /* it may be a package var index */
12888 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12889 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12890 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12891 || o->op_private != 0
12896 if (kid->op_type != OP_RV2SV)
12899 ASSUME(!(kid->op_flags &
12900 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12901 |OPf_SPECIAL|OPf_PARENS)));
12902 ASSUME(!(kid->op_private &
12904 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12905 |OPpDEREF|OPpLVAL_INTRO)));
12906 if( (kid->op_flags &~ OPf_PARENS)
12907 != (OPf_WANT_SCALAR|OPf_KIDS)
12908 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12913 #ifdef USE_ITHREADS
12914 arg->pad_offset = cPADOPx(o)->op_padix;
12915 /* stop it being swiped when nulled */
12916 cPADOPx(o)->op_padix = 0;
12918 arg->sv = cSVOPx(o)->op_sv;
12919 cSVOPo->op_sv = NULL;
12923 index_type = MDEREF_INDEX_gvsv;
12928 } /* action_count != index_skip */
12930 action |= index_type;
12933 /* at this point we have either:
12934 * * detected what looks like a simple index expression,
12935 * and expect the next op to be an [ah]elem, or
12936 * an nulled [ah]elem followed by a delete or exists;
12937 * * found a more complex expression, so something other
12938 * than the above follows.
12941 /* possibly an optimised away [ah]elem (where op_next is
12942 * exists or delete) */
12943 if (o->op_type == OP_NULL)
12946 /* at this point we're looking for an OP_AELEM, OP_HELEM,
12947 * OP_EXISTS or OP_DELETE */
12949 /* if something like arybase (a.k.a $[ ) is in scope,
12950 * abandon optimisation attempt */
12951 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12952 && PL_check[o->op_type] != Perl_ck_null)
12955 if ( o->op_type != OP_AELEM
12956 || (o->op_private &
12957 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12959 maybe_aelemfast = FALSE;
12961 /* look for aelem/helem/exists/delete. If it's not the last elem
12962 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12963 * flags; if it's the last, then it mustn't have
12964 * OPpDEREF_AV/HV, but may have lots of other flags, like
12965 * OPpLVAL_INTRO etc
12968 if ( index_type == MDEREF_INDEX_none
12969 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
12970 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12974 /* we have aelem/helem/exists/delete with valid simple index */
12976 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12977 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
12978 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12981 ASSUME(!(o->op_flags &
12982 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12983 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12985 ok = (o->op_flags &~ OPf_PARENS)
12986 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12987 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12989 else if (o->op_type == OP_EXISTS) {
12990 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12991 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12992 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12993 ok = !(o->op_private & ~OPpARG1_MASK);
12995 else if (o->op_type == OP_DELETE) {
12996 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12997 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12998 ASSUME(!(o->op_private &
12999 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
13000 /* don't handle slices or 'local delete'; the latter
13001 * is fairly rare, and has a complex runtime */
13002 ok = !(o->op_private & ~OPpARG1_MASK);
13003 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
13004 /* skip handling run-tome error */
13005 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
13008 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
13009 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
13010 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
13011 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
13012 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
13013 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
13018 if (!first_elem_op)
13022 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
13027 action |= MDEREF_FLAG_last;
13031 /* at this point we have something that started
13032 * promisingly enough (with rv2av or whatever), but failed
13033 * to find a simple index followed by an
13034 * aelem/helem/exists/delete. If this is the first action,
13035 * give up; but if we've already seen at least one
13036 * aelem/helem, then keep them and add a new action with
13037 * MDEREF_INDEX_none, which causes it to do the vivify
13038 * from the end of the previous lookup, and do the deref,
13039 * but stop at that point. So $a[0][expr] will do one
13040 * av_fetch, vivify and deref, then continue executing at
13045 index_skip = action_count;
13046 action |= MDEREF_FLAG_last;
13047 if (index_type != MDEREF_INDEX_none)
13052 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
13055 /* if there's no space for the next action, create a new slot
13056 * for it *before* we start adding args for that action */
13057 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
13064 } /* while !is_last */
13072 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
13073 if (index_skip == -1) {
13074 mderef->op_flags = o->op_flags
13075 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
13076 if (o->op_type == OP_EXISTS)
13077 mderef->op_private = OPpMULTIDEREF_EXISTS;
13078 else if (o->op_type == OP_DELETE)
13079 mderef->op_private = OPpMULTIDEREF_DELETE;
13081 mderef->op_private = o->op_private
13082 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
13084 /* accumulate strictness from every level (although I don't think
13085 * they can actually vary) */
13086 mderef->op_private |= hints;
13088 /* integrate the new multideref op into the optree and the
13091 * In general an op like aelem or helem has two child
13092 * sub-trees: the aggregate expression (a_expr) and the
13093 * index expression (i_expr):
13099 * The a_expr returns an AV or HV, while the i-expr returns an
13100 * index. In general a multideref replaces most or all of a
13101 * multi-level tree, e.g.
13117 * With multideref, all the i_exprs will be simple vars or
13118 * constants, except that i_expr1 may be arbitrary in the case
13119 * of MDEREF_INDEX_none.
13121 * The bottom-most a_expr will be either:
13122 * 1) a simple var (so padXv or gv+rv2Xv);
13123 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
13124 * so a simple var with an extra rv2Xv;
13125 * 3) or an arbitrary expression.
13127 * 'start', the first op in the execution chain, will point to
13128 * 1),2): the padXv or gv op;
13129 * 3): the rv2Xv which forms the last op in the a_expr
13130 * execution chain, and the top-most op in the a_expr
13133 * For all cases, the 'start' node is no longer required,
13134 * but we can't free it since one or more external nodes
13135 * may point to it. E.g. consider
13136 * $h{foo} = $a ? $b : $c
13137 * Here, both the op_next and op_other branches of the
13138 * cond_expr point to the gv[*h] of the hash expression, so
13139 * we can't free the 'start' op.
13141 * For expr->[...], we need to save the subtree containing the
13142 * expression; for the other cases, we just need to save the
13144 * So in all cases, we null the start op and keep it around by
13145 * making it the child of the multideref op; for the expr->
13146 * case, the expr will be a subtree of the start node.
13148 * So in the simple 1,2 case the optree above changes to
13154 * ex-gv (or ex-padxv)
13156 * with the op_next chain being
13158 * -> ex-gv -> multideref -> op-following-ex-exists ->
13160 * In the 3 case, we have
13173 * -> rest-of-a_expr subtree ->
13174 * ex-rv2xv -> multideref -> op-following-ex-exists ->
13177 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13178 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13179 * multideref attached as the child, e.g.
13185 * ex-rv2av - i_expr1
13193 /* if we free this op, don't free the pad entry */
13194 if (reset_start_targ)
13195 start->op_targ = 0;
13198 /* Cut the bit we need to save out of the tree and attach to
13199 * the multideref op, then free the rest of the tree */
13201 /* find parent of node to be detached (for use by splice) */
13203 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
13204 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13206 /* there is an arbitrary expression preceding us, e.g.
13207 * expr->[..]? so we need to save the 'expr' subtree */
13208 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13209 p = cUNOPx(p)->op_first;
13210 ASSUME( start->op_type == OP_RV2AV
13211 || start->op_type == OP_RV2HV);
13214 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13215 * above for exists/delete. */
13216 while ( (p->op_flags & OPf_KIDS)
13217 && cUNOPx(p)->op_first != start
13219 p = cUNOPx(p)->op_first;
13221 ASSUME(cUNOPx(p)->op_first == start);
13223 /* detach from main tree, and re-attach under the multideref */
13224 op_sibling_splice(mderef, NULL, 0,
13225 op_sibling_splice(p, NULL, 1, NULL));
13228 start->op_next = mderef;
13230 mderef->op_next = index_skip == -1 ? o->op_next : o;
13232 /* excise and free the original tree, and replace with
13233 * the multideref op */
13234 p = op_sibling_splice(top_op, NULL, -1, mderef);
13243 Size_t size = arg - arg_buf;
13245 if (maybe_aelemfast && action_count == 1)
13248 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13249 sizeof(UNOP_AUX_item) * (size + 1));
13250 /* for dumping etc: store the length in a hidden first slot;
13251 * we set the op_aux pointer to the second slot */
13252 arg_buf->uv = size;
13255 } /* for (pass = ...) */
13260 /* mechanism for deferring recursion in rpeep() */
13262 #define MAX_DEFERRED 4
13266 if (defer_ix == (MAX_DEFERRED-1)) { \
13267 OP **defer = defer_queue[defer_base]; \
13268 CALL_RPEEP(*defer); \
13269 S_prune_chain_head(defer); \
13270 defer_base = (defer_base + 1) % MAX_DEFERRED; \
13273 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13276 #define IS_AND_OP(o) (o->op_type == OP_AND)
13277 #define IS_OR_OP(o) (o->op_type == OP_OR)
13280 /* A peephole optimizer. We visit the ops in the order they're to execute.
13281 * See the comments at the top of this file for more details about when
13282 * peep() is called */
13285 Perl_rpeep(pTHX_ OP *o)
13289 OP* oldoldop = NULL;
13290 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13291 int defer_base = 0;
13296 if (!o || o->op_opt)
13300 SAVEVPTR(PL_curcop);
13301 for (;; o = o->op_next) {
13302 if (o && o->op_opt)
13305 while (defer_ix >= 0) {
13307 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13308 CALL_RPEEP(*defer);
13309 S_prune_chain_head(defer);
13316 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13317 assert(!oldoldop || oldoldop->op_next == oldop);
13318 assert(!oldop || oldop->op_next == o);
13320 /* By default, this op has now been optimised. A couple of cases below
13321 clear this again. */
13325 /* look for a series of 1 or more aggregate derefs, e.g.
13326 * $a[1]{foo}[$i]{$k}
13327 * and replace with a single OP_MULTIDEREF op.
13328 * Each index must be either a const, or a simple variable,
13330 * First, look for likely combinations of starting ops,
13331 * corresponding to (global and lexical variants of)
13333 * $r->[...] $r->{...}
13334 * (preceding expression)->[...]
13335 * (preceding expression)->{...}
13336 * and if so, call maybe_multideref() to do a full inspection
13337 * of the op chain and if appropriate, replace with an
13345 switch (o2->op_type) {
13347 /* $pkg[..] : gv[*pkg]
13348 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
13350 /* Fail if there are new op flag combinations that we're
13351 * not aware of, rather than:
13352 * * silently failing to optimise, or
13353 * * silently optimising the flag away.
13354 * If this ASSUME starts failing, examine what new flag
13355 * has been added to the op, and decide whether the
13356 * optimisation should still occur with that flag, then
13357 * update the code accordingly. This applies to all the
13358 * other ASSUMEs in the block of code too.
13360 ASSUME(!(o2->op_flags &
13361 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13362 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13366 if (o2->op_type == OP_RV2AV) {
13367 action = MDEREF_AV_gvav_aelem;
13371 if (o2->op_type == OP_RV2HV) {
13372 action = MDEREF_HV_gvhv_helem;
13376 if (o2->op_type != OP_RV2SV)
13379 /* at this point we've seen gv,rv2sv, so the only valid
13380 * construct left is $pkg->[] or $pkg->{} */
13382 ASSUME(!(o2->op_flags & OPf_STACKED));
13383 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13384 != (OPf_WANT_SCALAR|OPf_MOD))
13387 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13388 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13389 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13391 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
13392 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13396 if (o2->op_type == OP_RV2AV) {
13397 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13400 if (o2->op_type == OP_RV2HV) {
13401 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13407 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13409 ASSUME(!(o2->op_flags &
13410 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13411 if ((o2->op_flags &
13412 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13413 != (OPf_WANT_SCALAR|OPf_MOD))
13416 ASSUME(!(o2->op_private &
13417 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13418 /* skip if state or intro, or not a deref */
13419 if ( o2->op_private != OPpDEREF_AV
13420 && o2->op_private != OPpDEREF_HV)
13424 if (o2->op_type == OP_RV2AV) {
13425 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13428 if (o2->op_type == OP_RV2HV) {
13429 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13436 /* $lex[..]: padav[@lex:1,2] sR *
13437 * or $lex{..}: padhv[%lex:1,2] sR */
13438 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13439 OPf_REF|OPf_SPECIAL)));
13440 if ((o2->op_flags &
13441 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13442 != (OPf_WANT_SCALAR|OPf_REF))
13444 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13446 /* OPf_PARENS isn't currently used in this case;
13447 * if that changes, let us know! */
13448 ASSUME(!(o2->op_flags & OPf_PARENS));
13450 /* at this point, we wouldn't expect any of the remaining
13451 * possible private flags:
13452 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13453 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13455 * OPpSLICEWARNING shouldn't affect runtime
13457 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13459 action = o2->op_type == OP_PADAV
13460 ? MDEREF_AV_padav_aelem
13461 : MDEREF_HV_padhv_helem;
13463 S_maybe_multideref(aTHX_ o, o2, action, 0);
13469 action = o2->op_type == OP_RV2AV
13470 ? MDEREF_AV_pop_rv2av_aelem
13471 : MDEREF_HV_pop_rv2hv_helem;
13474 /* (expr)->[...]: rv2av sKR/1;
13475 * (expr)->{...}: rv2hv sKR/1; */
13477 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13479 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13480 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13481 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13484 /* at this point, we wouldn't expect any of these
13485 * possible private flags:
13486 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13487 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13489 ASSUME(!(o2->op_private &
13490 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13492 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13496 S_maybe_multideref(aTHX_ o, o2, action, hints);
13505 switch (o->op_type) {
13507 PL_curcop = ((COP*)o); /* for warnings */
13510 PL_curcop = ((COP*)o); /* for warnings */
13512 /* Optimise a "return ..." at the end of a sub to just be "...".
13513 * This saves 2 ops. Before:
13514 * 1 <;> nextstate(main 1 -e:1) v ->2
13515 * 4 <@> return K ->5
13516 * 2 <0> pushmark s ->3
13517 * - <1> ex-rv2sv sK/1 ->4
13518 * 3 <#> gvsv[*cat] s ->4
13521 * - <@> return K ->-
13522 * - <0> pushmark s ->2
13523 * - <1> ex-rv2sv sK/1 ->-
13524 * 2 <$> gvsv(*cat) s ->3
13527 OP *next = o->op_next;
13528 OP *sibling = OpSIBLING(o);
13529 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13530 && OP_TYPE_IS(sibling, OP_RETURN)
13531 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13532 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13533 ||OP_TYPE_IS(sibling->op_next->op_next,
13535 && cUNOPx(sibling)->op_first == next
13536 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13539 /* Look through the PUSHMARK's siblings for one that
13540 * points to the RETURN */
13541 OP *top = OpSIBLING(next);
13542 while (top && top->op_next) {
13543 if (top->op_next == sibling) {
13544 top->op_next = sibling->op_next;
13545 o->op_next = next->op_next;
13548 top = OpSIBLING(top);
13553 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13555 * This latter form is then suitable for conversion into padrange
13556 * later on. Convert:
13558 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13562 * nextstate1 -> listop -> nextstate3
13564 * pushmark -> padop1 -> padop2
13566 if (o->op_next && (
13567 o->op_next->op_type == OP_PADSV
13568 || o->op_next->op_type == OP_PADAV
13569 || o->op_next->op_type == OP_PADHV
13571 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13572 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13573 && o->op_next->op_next->op_next && (
13574 o->op_next->op_next->op_next->op_type == OP_PADSV
13575 || o->op_next->op_next->op_next->op_type == OP_PADAV
13576 || o->op_next->op_next->op_next->op_type == OP_PADHV
13578 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13579 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13580 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13581 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13583 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13586 ns2 = pad1->op_next;
13587 pad2 = ns2->op_next;
13588 ns3 = pad2->op_next;
13590 /* we assume here that the op_next chain is the same as
13591 * the op_sibling chain */
13592 assert(OpSIBLING(o) == pad1);
13593 assert(OpSIBLING(pad1) == ns2);
13594 assert(OpSIBLING(ns2) == pad2);
13595 assert(OpSIBLING(pad2) == ns3);
13597 /* excise and delete ns2 */
13598 op_sibling_splice(NULL, pad1, 1, NULL);
13601 /* excise pad1 and pad2 */
13602 op_sibling_splice(NULL, o, 2, NULL);
13604 /* create new listop, with children consisting of:
13605 * a new pushmark, pad1, pad2. */
13606 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13607 newop->op_flags |= OPf_PARENS;
13608 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13610 /* insert newop between o and ns3 */
13611 op_sibling_splice(NULL, o, 0, newop);
13613 /*fixup op_next chain */
13614 newpm = cUNOPx(newop)->op_first; /* pushmark */
13615 o ->op_next = newpm;
13616 newpm->op_next = pad1;
13617 pad1 ->op_next = pad2;
13618 pad2 ->op_next = newop; /* listop */
13619 newop->op_next = ns3;
13621 /* Ensure pushmark has this flag if padops do */
13622 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13623 newpm->op_flags |= OPf_MOD;
13629 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13630 to carry two labels. For now, take the easier option, and skip
13631 this optimisation if the first NEXTSTATE has a label. */
13632 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13633 OP *nextop = o->op_next;
13634 while (nextop && nextop->op_type == OP_NULL)
13635 nextop = nextop->op_next;
13637 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13640 oldop->op_next = nextop;
13642 /* Skip (old)oldop assignment since the current oldop's
13643 op_next already points to the next op. */
13650 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13651 if (o->op_next->op_private & OPpTARGET_MY) {
13652 if (o->op_flags & OPf_STACKED) /* chained concats */
13653 break; /* ignore_optimization */
13655 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13656 o->op_targ = o->op_next->op_targ;
13657 o->op_next->op_targ = 0;
13658 o->op_private |= OPpTARGET_MY;
13661 op_null(o->op_next);
13665 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13666 break; /* Scalar stub must produce undef. List stub is noop */
13670 if (o->op_targ == OP_NEXTSTATE
13671 || o->op_targ == OP_DBSTATE)
13673 PL_curcop = ((COP*)o);
13675 /* XXX: We avoid setting op_seq here to prevent later calls
13676 to rpeep() from mistakenly concluding that optimisation
13677 has already occurred. This doesn't fix the real problem,
13678 though (See 20010220.007 (#5874)). AMS 20010719 */
13679 /* op_seq functionality is now replaced by op_opt */
13687 oldop->op_next = o->op_next;
13701 convert repeat into a stub with no kids.
13703 if (o->op_next->op_type == OP_CONST
13704 || ( o->op_next->op_type == OP_PADSV
13705 && !(o->op_next->op_private & OPpLVAL_INTRO))
13706 || ( o->op_next->op_type == OP_GV
13707 && o->op_next->op_next->op_type == OP_RV2SV
13708 && !(o->op_next->op_next->op_private
13709 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13711 const OP *kid = o->op_next->op_next;
13712 if (o->op_next->op_type == OP_GV)
13713 kid = kid->op_next;
13714 /* kid is now the ex-list. */
13715 if (kid->op_type == OP_NULL
13716 && (kid = kid->op_next)->op_type == OP_CONST
13717 /* kid is now the repeat count. */
13718 && kid->op_next->op_type == OP_REPEAT
13719 && kid->op_next->op_private & OPpREPEAT_DOLIST
13720 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13721 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13723 o = kid->op_next; /* repeat */
13725 oldop->op_next = o;
13726 op_free(cBINOPo->op_first);
13727 op_free(cBINOPo->op_last );
13728 o->op_flags &=~ OPf_KIDS;
13729 /* stub is a baseop; repeat is a binop */
13730 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13731 OpTYPE_set(o, OP_STUB);
13737 /* Convert a series of PAD ops for my vars plus support into a
13738 * single padrange op. Basically
13740 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13742 * becomes, depending on circumstances, one of
13744 * padrange ----------------------------------> (list) -> rest
13745 * padrange --------------------------------------------> rest
13747 * where all the pad indexes are sequential and of the same type
13749 * We convert the pushmark into a padrange op, then skip
13750 * any other pad ops, and possibly some trailing ops.
13751 * Note that we don't null() the skipped ops, to make it
13752 * easier for Deparse to undo this optimisation (and none of
13753 * the skipped ops are holding any resourses). It also makes
13754 * it easier for find_uninit_var(), as it can just ignore
13755 * padrange, and examine the original pad ops.
13759 OP *followop = NULL; /* the op that will follow the padrange op */
13762 PADOFFSET base = 0; /* init only to stop compiler whining */
13763 bool gvoid = 0; /* init only to stop compiler whining */
13764 bool defav = 0; /* seen (...) = @_ */
13765 bool reuse = 0; /* reuse an existing padrange op */
13767 /* look for a pushmark -> gv[_] -> rv2av */
13772 if ( p->op_type == OP_GV
13773 && cGVOPx_gv(p) == PL_defgv
13774 && (rv2av = p->op_next)
13775 && rv2av->op_type == OP_RV2AV
13776 && !(rv2av->op_flags & OPf_REF)
13777 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13778 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13780 q = rv2av->op_next;
13781 if (q->op_type == OP_NULL)
13783 if (q->op_type == OP_PUSHMARK) {
13793 /* scan for PAD ops */
13795 for (p = p->op_next; p; p = p->op_next) {
13796 if (p->op_type == OP_NULL)
13799 if (( p->op_type != OP_PADSV
13800 && p->op_type != OP_PADAV
13801 && p->op_type != OP_PADHV
13803 /* any private flag other than INTRO? e.g. STATE */
13804 || (p->op_private & ~OPpLVAL_INTRO)
13808 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13810 if ( p->op_type == OP_PADAV
13812 && p->op_next->op_type == OP_CONST
13813 && p->op_next->op_next
13814 && p->op_next->op_next->op_type == OP_AELEM
13818 /* for 1st padop, note what type it is and the range
13819 * start; for the others, check that it's the same type
13820 * and that the targs are contiguous */
13822 intro = (p->op_private & OPpLVAL_INTRO);
13824 gvoid = OP_GIMME(p,0) == G_VOID;
13827 if ((p->op_private & OPpLVAL_INTRO) != intro)
13829 /* Note that you'd normally expect targs to be
13830 * contiguous in my($a,$b,$c), but that's not the case
13831 * when external modules start doing things, e.g.
13832 * Function::Parameters */
13833 if (p->op_targ != base + count)
13835 assert(p->op_targ == base + count);
13836 /* Either all the padops or none of the padops should
13837 be in void context. Since we only do the optimisa-
13838 tion for av/hv when the aggregate itself is pushed
13839 on to the stack (one item), there is no need to dis-
13840 tinguish list from scalar context. */
13841 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13845 /* for AV, HV, only when we're not flattening */
13846 if ( p->op_type != OP_PADSV
13848 && !(p->op_flags & OPf_REF)
13852 if (count >= OPpPADRANGE_COUNTMASK)
13855 /* there's a biggest base we can fit into a
13856 * SAVEt_CLEARPADRANGE in pp_padrange.
13857 * (The sizeof() stuff will be constant-folded, and is
13858 * intended to avoid getting "comparison is always false"
13859 * compiler warnings. See the comments above
13860 * MEM_WRAP_CHECK for more explanation on why we do this
13861 * in a weird way to avoid compiler warnings.)
13864 && (8*sizeof(base) >
13865 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13867 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13869 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13873 /* Success! We've got another valid pad op to optimise away */
13875 followop = p->op_next;
13878 if (count < 1 || (count == 1 && !defav))
13881 /* pp_padrange in specifically compile-time void context
13882 * skips pushing a mark and lexicals; in all other contexts
13883 * (including unknown till runtime) it pushes a mark and the
13884 * lexicals. We must be very careful then, that the ops we
13885 * optimise away would have exactly the same effect as the
13887 * In particular in void context, we can only optimise to
13888 * a padrange if we see the complete sequence
13889 * pushmark, pad*v, ...., list
13890 * which has the net effect of leaving the markstack as it
13891 * was. Not pushing onto the stack (whereas padsv does touch
13892 * the stack) makes no difference in void context.
13896 if (followop->op_type == OP_LIST
13897 && OP_GIMME(followop,0) == G_VOID
13900 followop = followop->op_next; /* skip OP_LIST */
13902 /* consolidate two successive my(...);'s */
13905 && oldoldop->op_type == OP_PADRANGE
13906 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13907 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13908 && !(oldoldop->op_flags & OPf_SPECIAL)
13911 assert(oldoldop->op_next == oldop);
13912 assert( oldop->op_type == OP_NEXTSTATE
13913 || oldop->op_type == OP_DBSTATE);
13914 assert(oldop->op_next == o);
13917 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13919 /* Do not assume pad offsets for $c and $d are con-
13924 if ( oldoldop->op_targ + old_count == base
13925 && old_count < OPpPADRANGE_COUNTMASK - count) {
13926 base = oldoldop->op_targ;
13927 count += old_count;
13932 /* if there's any immediately following singleton
13933 * my var's; then swallow them and the associated
13935 * my ($a,$b); my $c; my $d;
13937 * my ($a,$b,$c,$d);
13940 while ( ((p = followop->op_next))
13941 && ( p->op_type == OP_PADSV
13942 || p->op_type == OP_PADAV
13943 || p->op_type == OP_PADHV)
13944 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13945 && (p->op_private & OPpLVAL_INTRO) == intro
13946 && !(p->op_private & ~OPpLVAL_INTRO)
13948 && ( p->op_next->op_type == OP_NEXTSTATE
13949 || p->op_next->op_type == OP_DBSTATE)
13950 && count < OPpPADRANGE_COUNTMASK
13951 && base + count == p->op_targ
13954 followop = p->op_next;
13962 assert(oldoldop->op_type == OP_PADRANGE);
13963 oldoldop->op_next = followop;
13964 oldoldop->op_private = (intro | count);
13970 /* Convert the pushmark into a padrange.
13971 * To make Deparse easier, we guarantee that a padrange was
13972 * *always* formerly a pushmark */
13973 assert(o->op_type == OP_PUSHMARK);
13974 o->op_next = followop;
13975 OpTYPE_set(o, OP_PADRANGE);
13977 /* bit 7: INTRO; bit 6..0: count */
13978 o->op_private = (intro | count);
13979 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13980 | gvoid * OPf_WANT_VOID
13981 | (defav ? OPf_SPECIAL : 0));
13989 /* Skip over state($x) in void context. */
13990 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13991 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13993 oldop->op_next = o->op_next;
13994 goto redo_nextstate;
13996 if (o->op_type != OP_PADAV)
14000 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
14001 OP* const pop = (o->op_type == OP_PADAV) ?
14002 o->op_next : o->op_next->op_next;
14004 if (pop && pop->op_type == OP_CONST &&
14005 ((PL_op = pop->op_next)) &&
14006 pop->op_next->op_type == OP_AELEM &&
14007 !(pop->op_next->op_private &
14008 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
14009 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
14012 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
14013 no_bareword_allowed(pop);
14014 if (o->op_type == OP_GV)
14015 op_null(o->op_next);
14016 op_null(pop->op_next);
14018 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
14019 o->op_next = pop->op_next->op_next;
14020 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
14021 o->op_private = (U8)i;
14022 if (o->op_type == OP_GV) {
14025 o->op_type = OP_AELEMFAST;
14028 o->op_type = OP_AELEMFAST_LEX;
14030 if (o->op_type != OP_GV)
14034 /* Remove $foo from the op_next chain in void context. */
14036 && ( o->op_next->op_type == OP_RV2SV
14037 || o->op_next->op_type == OP_RV2AV
14038 || o->op_next->op_type == OP_RV2HV )
14039 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14040 && !(o->op_next->op_private & OPpLVAL_INTRO))
14042 oldop->op_next = o->op_next->op_next;
14043 /* Reprocess the previous op if it is a nextstate, to
14044 allow double-nextstate optimisation. */
14046 if (oldop->op_type == OP_NEXTSTATE) {
14053 o = oldop->op_next;
14056 else if (o->op_next->op_type == OP_RV2SV) {
14057 if (!(o->op_next->op_private & OPpDEREF)) {
14058 op_null(o->op_next);
14059 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
14061 o->op_next = o->op_next->op_next;
14062 OpTYPE_set(o, OP_GVSV);
14065 else if (o->op_next->op_type == OP_READLINE
14066 && o->op_next->op_next->op_type == OP_CONCAT
14067 && (o->op_next->op_next->op_flags & OPf_STACKED))
14069 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
14070 OpTYPE_set(o, OP_RCATLINE);
14071 o->op_flags |= OPf_STACKED;
14072 op_null(o->op_next->op_next);
14073 op_null(o->op_next);
14078 #define HV_OR_SCALARHV(op) \
14079 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
14081 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
14082 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
14083 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
14084 ? cUNOPx(op)->op_first \
14088 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
14089 fop->op_private |= OPpTRUEBOOL;
14095 fop = cLOGOP->op_first;
14096 sop = OpSIBLING(fop);
14097 while (cLOGOP->op_other->op_type == OP_NULL)
14098 cLOGOP->op_other = cLOGOP->op_other->op_next;
14099 while (o->op_next && ( o->op_type == o->op_next->op_type
14100 || o->op_next->op_type == OP_NULL))
14101 o->op_next = o->op_next->op_next;
14103 /* If we're an OR and our next is an AND in void context, we'll
14104 follow its op_other on short circuit, same for reverse.
14105 We can't do this with OP_DOR since if it's true, its return
14106 value is the underlying value which must be evaluated
14110 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
14111 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
14113 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14115 o->op_next = ((LOGOP*)o->op_next)->op_other;
14117 DEFER(cLOGOP->op_other);
14120 fop = HV_OR_SCALARHV(fop);
14121 if (sop) sop = HV_OR_SCALARHV(sop);
14126 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
14127 while (nop && nop->op_next) {
14128 switch (nop->op_next->op_type) {
14133 lop = nop = nop->op_next;
14136 nop = nop->op_next;
14145 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14146 || o->op_type == OP_AND )
14147 fop->op_private |= OPpTRUEBOOL;
14148 else if (!(lop->op_flags & OPf_WANT))
14149 fop->op_private |= OPpMAYBE_TRUEBOOL;
14151 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14153 sop->op_private |= OPpTRUEBOOL;
14160 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
14161 fop->op_private |= OPpTRUEBOOL;
14162 #undef HV_OR_SCALARHV
14163 /* GERONIMO! */ /* FALLTHROUGH */
14172 case OP_ARGDEFELEM:
14173 while (cLOGOP->op_other->op_type == OP_NULL)
14174 cLOGOP->op_other = cLOGOP->op_other->op_next;
14175 DEFER(cLOGOP->op_other);
14180 while (cLOOP->op_redoop->op_type == OP_NULL)
14181 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14182 while (cLOOP->op_nextop->op_type == OP_NULL)
14183 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14184 while (cLOOP->op_lastop->op_type == OP_NULL)
14185 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14186 /* a while(1) loop doesn't have an op_next that escapes the
14187 * loop, so we have to explicitly follow the op_lastop to
14188 * process the rest of the code */
14189 DEFER(cLOOP->op_lastop);
14193 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14194 DEFER(cLOGOPo->op_other);
14198 assert(!(cPMOP->op_pmflags & PMf_ONCE));
14199 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14200 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14201 cPMOP->op_pmstashstartu.op_pmreplstart
14202 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14203 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14209 if (o->op_flags & OPf_SPECIAL) {
14210 /* first arg is a code block */
14211 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14212 OP * kid = cUNOPx(nullop)->op_first;
14214 assert(nullop->op_type == OP_NULL);
14215 assert(kid->op_type == OP_SCOPE
14216 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14217 /* since OP_SORT doesn't have a handy op_other-style
14218 * field that can point directly to the start of the code
14219 * block, store it in the otherwise-unused op_next field
14220 * of the top-level OP_NULL. This will be quicker at
14221 * run-time, and it will also allow us to remove leading
14222 * OP_NULLs by just messing with op_nexts without
14223 * altering the basic op_first/op_sibling layout. */
14224 kid = kLISTOP->op_first;
14226 (kid->op_type == OP_NULL
14227 && ( kid->op_targ == OP_NEXTSTATE
14228 || kid->op_targ == OP_DBSTATE ))
14229 || kid->op_type == OP_STUB
14230 || kid->op_type == OP_ENTER);
14231 nullop->op_next = kLISTOP->op_next;
14232 DEFER(nullop->op_next);
14235 /* check that RHS of sort is a single plain array */
14236 oright = cUNOPo->op_first;
14237 if (!oright || oright->op_type != OP_PUSHMARK)
14240 if (o->op_private & OPpSORT_INPLACE)
14243 /* reverse sort ... can be optimised. */
14244 if (!OpHAS_SIBLING(cUNOPo)) {
14245 /* Nothing follows us on the list. */
14246 OP * const reverse = o->op_next;
14248 if (reverse->op_type == OP_REVERSE &&
14249 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14250 OP * const pushmark = cUNOPx(reverse)->op_first;
14251 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14252 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14253 /* reverse -> pushmark -> sort */
14254 o->op_private |= OPpSORT_REVERSE;
14256 pushmark->op_next = oright->op_next;
14266 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14268 LISTOP *enter, *exlist;
14270 if (o->op_private & OPpSORT_INPLACE)
14273 enter = (LISTOP *) o->op_next;
14276 if (enter->op_type == OP_NULL) {
14277 enter = (LISTOP *) enter->op_next;
14281 /* for $a (...) will have OP_GV then OP_RV2GV here.
14282 for (...) just has an OP_GV. */
14283 if (enter->op_type == OP_GV) {
14284 gvop = (OP *) enter;
14285 enter = (LISTOP *) enter->op_next;
14288 if (enter->op_type == OP_RV2GV) {
14289 enter = (LISTOP *) enter->op_next;
14295 if (enter->op_type != OP_ENTERITER)
14298 iter = enter->op_next;
14299 if (!iter || iter->op_type != OP_ITER)
14302 expushmark = enter->op_first;
14303 if (!expushmark || expushmark->op_type != OP_NULL
14304 || expushmark->op_targ != OP_PUSHMARK)
14307 exlist = (LISTOP *) OpSIBLING(expushmark);
14308 if (!exlist || exlist->op_type != OP_NULL
14309 || exlist->op_targ != OP_LIST)
14312 if (exlist->op_last != o) {
14313 /* Mmm. Was expecting to point back to this op. */
14316 theirmark = exlist->op_first;
14317 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14320 if (OpSIBLING(theirmark) != o) {
14321 /* There's something between the mark and the reverse, eg
14322 for (1, reverse (...))
14327 ourmark = ((LISTOP *)o)->op_first;
14328 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14331 ourlast = ((LISTOP *)o)->op_last;
14332 if (!ourlast || ourlast->op_next != o)
14335 rv2av = OpSIBLING(ourmark);
14336 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14337 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14338 /* We're just reversing a single array. */
14339 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14340 enter->op_flags |= OPf_STACKED;
14343 /* We don't have control over who points to theirmark, so sacrifice
14345 theirmark->op_next = ourmark->op_next;
14346 theirmark->op_flags = ourmark->op_flags;
14347 ourlast->op_next = gvop ? gvop : (OP *) enter;
14350 enter->op_private |= OPpITER_REVERSED;
14351 iter->op_private |= OPpITER_REVERSED;
14355 o = oldop->op_next;
14363 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14364 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14369 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14370 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14373 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14375 sv = newRV((SV *)PL_compcv);
14379 OpTYPE_set(o, OP_CONST);
14380 o->op_flags |= OPf_SPECIAL;
14381 cSVOPo->op_sv = sv;
14386 if (OP_GIMME(o,0) == G_VOID
14387 || ( o->op_next->op_type == OP_LINESEQ
14388 && ( o->op_next->op_next->op_type == OP_LEAVESUB
14389 || ( o->op_next->op_next->op_type == OP_RETURN
14390 && !CvLVALUE(PL_compcv)))))
14392 OP *right = cBINOP->op_first;
14411 OP *left = OpSIBLING(right);
14412 if (left->op_type == OP_SUBSTR
14413 && (left->op_private & 7) < 4) {
14415 /* cut out right */
14416 op_sibling_splice(o, NULL, 1, NULL);
14417 /* and insert it as second child of OP_SUBSTR */
14418 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14420 left->op_private |= OPpSUBSTR_REPL_FIRST;
14422 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14429 int l, r, lr, lscalars, rscalars;
14431 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14432 Note that we do this now rather than in newASSIGNOP(),
14433 since only by now are aliased lexicals flagged as such
14435 See the essay "Common vars in list assignment" above for
14436 the full details of the rationale behind all the conditions
14439 PL_generation sorcery:
14440 To detect whether there are common vars, the global var
14441 PL_generation is incremented for each assign op we scan.
14442 Then we run through all the lexical variables on the LHS,
14443 of the assignment, setting a spare slot in each of them to
14444 PL_generation. Then we scan the RHS, and if any lexicals
14445 already have that value, we know we've got commonality.
14446 Also, if the generation number is already set to
14447 PERL_INT_MAX, then the variable is involved in aliasing, so
14448 we also have potential commonality in that case.
14454 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
14457 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14461 /* After looking for things which are *always* safe, this main
14462 * if/else chain selects primarily based on the type of the
14463 * LHS, gradually working its way down from the more dangerous
14464 * to the more restrictive and thus safer cases */
14466 if ( !l /* () = ....; */
14467 || !r /* .... = (); */
14468 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14469 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14470 || (lscalars < 2) /* ($x, undef) = ... */
14472 NOOP; /* always safe */
14474 else if (l & AAS_DANGEROUS) {
14475 /* always dangerous */
14476 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14477 o->op_private |= OPpASSIGN_COMMON_AGG;
14479 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14480 /* package vars are always dangerous - too many
14481 * aliasing possibilities */
14482 if (l & AAS_PKG_SCALAR)
14483 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14484 if (l & AAS_PKG_AGG)
14485 o->op_private |= OPpASSIGN_COMMON_AGG;
14487 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14488 |AAS_LEX_SCALAR|AAS_LEX_AGG))
14490 /* LHS contains only lexicals and safe ops */
14492 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14493 o->op_private |= OPpASSIGN_COMMON_AGG;
14495 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14496 if (lr & AAS_LEX_SCALAR_COMM)
14497 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14498 else if ( !(l & AAS_LEX_SCALAR)
14499 && (r & AAS_DEFAV))
14503 * as scalar-safe for performance reasons.
14504 * (it will still have been marked _AGG if necessary */
14507 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14508 o->op_private |= OPpASSIGN_COMMON_RC1;
14513 * may have to handle aggregate on LHS, but we can't
14514 * have common scalars. */
14517 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14523 Perl_cpeep_t cpeep =
14524 XopENTRYCUSTOM(o, xop_peep);
14526 cpeep(aTHX_ o, oldop);
14531 /* did we just null the current op? If so, re-process it to handle
14532 * eliding "empty" ops from the chain */
14533 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14546 Perl_peep(pTHX_ OP *o)
14552 =head1 Custom Operators
14554 =for apidoc Ao||custom_op_xop
14555 Return the XOP structure for a given custom op. This macro should be
14556 considered internal to C<OP_NAME> and the other access macros: use them instead.
14557 This macro does call a function. Prior
14558 to 5.19.6, this was implemented as a
14565 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14571 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14573 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14574 assert(o->op_type == OP_CUSTOM);
14576 /* This is wrong. It assumes a function pointer can be cast to IV,
14577 * which isn't guaranteed, but this is what the old custom OP code
14578 * did. In principle it should be safer to Copy the bytes of the
14579 * pointer into a PV: since the new interface is hidden behind
14580 * functions, this can be changed later if necessary. */
14581 /* Change custom_op_xop if this ever happens */
14582 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14585 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14587 /* assume noone will have just registered a desc */
14588 if (!he && PL_custom_op_names &&
14589 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14594 /* XXX does all this need to be shared mem? */
14595 Newxz(xop, 1, XOP);
14596 pv = SvPV(HeVAL(he), l);
14597 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14598 if (PL_custom_op_descs &&
14599 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14601 pv = SvPV(HeVAL(he), l);
14602 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14604 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14608 xop = (XOP *)&xop_null;
14610 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14614 if(field == XOPe_xop_ptr) {
14617 const U32 flags = XopFLAGS(xop);
14618 if(flags & field) {
14620 case XOPe_xop_name:
14621 any.xop_name = xop->xop_name;
14623 case XOPe_xop_desc:
14624 any.xop_desc = xop->xop_desc;
14626 case XOPe_xop_class:
14627 any.xop_class = xop->xop_class;
14629 case XOPe_xop_peep:
14630 any.xop_peep = xop->xop_peep;
14633 NOT_REACHED; /* NOTREACHED */
14638 case XOPe_xop_name:
14639 any.xop_name = XOPd_xop_name;
14641 case XOPe_xop_desc:
14642 any.xop_desc = XOPd_xop_desc;
14644 case XOPe_xop_class:
14645 any.xop_class = XOPd_xop_class;
14647 case XOPe_xop_peep:
14648 any.xop_peep = XOPd_xop_peep;
14651 NOT_REACHED; /* NOTREACHED */
14656 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14657 * op.c: In function 'Perl_custom_op_get_field':
14658 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14659 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14660 * expands to assert(0), which expands to ((0) ? (void)0 :
14661 * __assert(...)), and gcc doesn't know that __assert can never return. */
14667 =for apidoc Ao||custom_op_register
14668 Register a custom op. See L<perlguts/"Custom Operators">.
14674 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14678 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14680 /* see the comment in custom_op_xop */
14681 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14683 if (!PL_custom_ops)
14684 PL_custom_ops = newHV();
14686 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14687 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14692 =for apidoc core_prototype
14694 This function assigns the prototype of the named core function to C<sv>, or
14695 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
14696 C<NULL> if the core function has no prototype. C<code> is a code as returned
14697 by C<keyword()>. It must not be equal to 0.
14703 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14706 int i = 0, n = 0, seen_question = 0, defgv = 0;
14708 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14709 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14710 bool nullret = FALSE;
14712 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14716 if (!sv) sv = sv_newmortal();
14718 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14720 switch (code < 0 ? -code : code) {
14721 case KEY_and : case KEY_chop: case KEY_chomp:
14722 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14723 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14724 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14725 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14726 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14727 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14728 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14729 case KEY_x : case KEY_xor :
14730 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14731 case KEY_glob: retsetpvs("_;", OP_GLOB);
14732 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
14733 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
14734 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
14735 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14736 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14738 case KEY_evalbytes:
14739 name = "entereval"; break;
14747 while (i < MAXO) { /* The slow way. */
14748 if (strEQ(name, PL_op_name[i])
14749 || strEQ(name, PL_op_desc[i]))
14751 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14758 defgv = PL_opargs[i] & OA_DEFGV;
14759 oa = PL_opargs[i] >> OASHIFT;
14761 if (oa & OA_OPTIONAL && !seen_question && (
14762 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14767 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14768 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14769 /* But globs are already references (kinda) */
14770 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14774 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14775 && !scalar_mod_type(NULL, i)) {
14780 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14784 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14785 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14786 str[n-1] = '_'; defgv = 0;
14790 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14792 sv_setpvn(sv, str, n - 1);
14793 if (opnum) *opnum = i;
14798 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14801 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14804 PERL_ARGS_ASSERT_CORESUB_OP;
14808 return op_append_elem(OP_LINESEQ,
14811 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14818 o = newUNOP(OP_AVHVSWITCH,0,argop);
14819 o->op_private = opnum-OP_EACH;
14821 case OP_SELECT: /* which represents OP_SSELECT as well */
14826 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14827 newSVOP(OP_CONST, 0, newSVuv(1))
14829 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14831 coresub_op(coreargssv, 0, OP_SELECT)
14835 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14837 return op_append_elem(
14840 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14841 ? OPpOFFBYONE << 8 : 0)
14843 case OA_BASEOP_OR_UNOP:
14844 if (opnum == OP_ENTEREVAL) {
14845 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14846 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14848 else o = newUNOP(opnum,0,argop);
14849 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14852 if (is_handle_constructor(o, 1))
14853 argop->op_private |= OPpCOREARGS_DEREF1;
14854 if (scalar_mod_type(NULL, opnum))
14855 argop->op_private |= OPpCOREARGS_SCALARMOD;
14859 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14860 if (is_handle_constructor(o, 2))
14861 argop->op_private |= OPpCOREARGS_DEREF2;
14862 if (opnum == OP_SUBSTR) {
14863 o->op_private |= OPpMAYBE_LVSUB;
14872 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14873 SV * const *new_const_svp)
14875 const char *hvname;
14876 bool is_const = !!CvCONST(old_cv);
14877 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14879 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14881 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14883 /* They are 2 constant subroutines generated from
14884 the same constant. This probably means that
14885 they are really the "same" proxy subroutine
14886 instantiated in 2 places. Most likely this is
14887 when a constant is exported twice. Don't warn.
14890 (ckWARN(WARN_REDEFINE)
14892 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14893 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14894 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14895 strEQ(hvname, "autouse"))
14899 && ckWARN_d(WARN_REDEFINE)
14900 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14903 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14905 ? "Constant subroutine %"SVf" redefined"
14906 : "Subroutine %"SVf" redefined",
14911 =head1 Hook manipulation
14913 These functions provide convenient and thread-safe means of manipulating
14920 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14922 Puts a C function into the chain of check functions for a specified op
14923 type. This is the preferred way to manipulate the L</PL_check> array.
14924 C<opcode> specifies which type of op is to be affected. C<new_checker>
14925 is a pointer to the C function that is to be added to that opcode's
14926 check chain, and C<old_checker_p> points to the storage location where a
14927 pointer to the next function in the chain will be stored. The value of
14928 C<new_pointer> is written into the L</PL_check> array, while the value
14929 previously stored there is written to C<*old_checker_p>.
14931 The function should be defined like this:
14933 static OP *new_checker(pTHX_ OP *op) { ... }
14935 It is intended to be called in this manner:
14937 new_checker(aTHX_ op)
14939 C<old_checker_p> should be defined like this:
14941 static Perl_check_t old_checker_p;
14943 L</PL_check> is global to an entire process, and a module wishing to
14944 hook op checking may find itself invoked more than once per process,
14945 typically in different threads. To handle that situation, this function
14946 is idempotent. The location C<*old_checker_p> must initially (once
14947 per process) contain a null pointer. A C variable of static duration
14948 (declared at file scope, typically also marked C<static> to give
14949 it internal linkage) will be implicitly initialised appropriately,
14950 if it does not have an explicit initialiser. This function will only
14951 actually modify the check chain if it finds C<*old_checker_p> to be null.
14952 This function is also thread safe on the small scale. It uses appropriate
14953 locking to avoid race conditions in accessing L</PL_check>.
14955 When this function is called, the function referenced by C<new_checker>
14956 must be ready to be called, except for C<*old_checker_p> being unfilled.
14957 In a threading situation, C<new_checker> may be called immediately,
14958 even before this function has returned. C<*old_checker_p> will always
14959 be appropriately set before C<new_checker> is called. If C<new_checker>
14960 decides not to do anything special with an op that it is given (which
14961 is the usual case for most uses of op check hooking), it must chain the
14962 check function referenced by C<*old_checker_p>.
14964 If you want to influence compilation of calls to a specific subroutine,
14965 then use L</cv_set_call_checker> rather than hooking checking of all
14972 Perl_wrap_op_checker(pTHX_ Optype opcode,
14973 Perl_check_t new_checker, Perl_check_t *old_checker_p)
14977 PERL_UNUSED_CONTEXT;
14978 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14979 if (*old_checker_p) return;
14980 OP_CHECK_MUTEX_LOCK;
14981 if (!*old_checker_p) {
14982 *old_checker_p = PL_check[opcode];
14983 PL_check[opcode] = new_checker;
14985 OP_CHECK_MUTEX_UNLOCK;
14990 /* Efficient sub that returns a constant scalar value. */
14992 const_sv_xsub(pTHX_ CV* cv)
14995 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14996 PERL_UNUSED_ARG(items);
15006 const_av_xsub(pTHX_ CV* cv)
15009 AV * const av = MUTABLE_AV(XSANY.any_ptr);
15017 if (SvRMAGICAL(av))
15018 Perl_croak(aTHX_ "Magical list constants are not supported");
15019 if (GIMME_V != G_ARRAY) {
15021 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15024 EXTEND(SP, AvFILLp(av)+1);
15025 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15026 XSRETURN(AvFILLp(av)+1);
15031 * ex: set ts=8 sts=4 sw=4 et: