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 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
112 static char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
114 /* Used to avoid recursion through the op tree in scalarvoid() and
118 #define DEFERRED_OP_STEP 100
119 #define DEFER_OP(o) \
121 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
122 defer_stack_alloc += DEFERRED_OP_STEP; \
123 assert(defer_stack_alloc > 0); \
124 Renew(defer_stack, defer_stack_alloc, OP *); \
126 defer_stack[++defer_ix] = o; \
129 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
131 /* remove any leading "empty" ops from the op_next chain whose first
132 * node's address is stored in op_p. Store the updated address of the
133 * first node in op_p.
137 S_prune_chain_head(OP** op_p)
140 && ( (*op_p)->op_type == OP_NULL
141 || (*op_p)->op_type == OP_SCOPE
142 || (*op_p)->op_type == OP_SCALAR
143 || (*op_p)->op_type == OP_LINESEQ)
145 *op_p = (*op_p)->op_next;
149 /* See the explanatory comments above struct opslab in op.h. */
151 #ifdef PERL_DEBUG_READONLY_OPS
152 # define PERL_SLAB_SIZE 128
153 # define PERL_MAX_SLAB_SIZE 4096
154 # include <sys/mman.h>
157 #ifndef PERL_SLAB_SIZE
158 # define PERL_SLAB_SIZE 64
160 #ifndef PERL_MAX_SLAB_SIZE
161 # define PERL_MAX_SLAB_SIZE 2048
164 /* rounds up to nearest pointer */
165 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
166 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
169 S_new_slab(pTHX_ size_t sz)
171 #ifdef PERL_DEBUG_READONLY_OPS
172 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
173 PROT_READ|PROT_WRITE,
174 MAP_ANON|MAP_PRIVATE, -1, 0);
175 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
176 (unsigned long) sz, slab));
177 if (slab == MAP_FAILED) {
178 perror("mmap failed");
181 slab->opslab_size = (U16)sz;
183 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
186 /* The context is unused in non-Windows */
189 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
193 /* requires double parens and aTHX_ */
194 #define DEBUG_S_warn(args) \
196 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
200 Perl_Slab_Alloc(pTHX_ size_t sz)
208 /* We only allocate ops from the slab during subroutine compilation.
209 We find the slab via PL_compcv, hence that must be non-NULL. It could
210 also be pointing to a subroutine which is now fully set up (CvROOT()
211 pointing to the top of the optree for that sub), or a subroutine
212 which isn't using the slab allocator. If our sanity checks aren't met,
213 don't use a slab, but allocate the OP directly from the heap. */
214 if (!PL_compcv || CvROOT(PL_compcv)
215 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
217 o = (OP*)PerlMemShared_calloc(1, sz);
221 /* While the subroutine is under construction, the slabs are accessed via
222 CvSTART(), to avoid needing to expand PVCV by one pointer for something
223 unneeded at runtime. Once a subroutine is constructed, the slabs are
224 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
225 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
227 if (!CvSTART(PL_compcv)) {
229 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
230 CvSLABBED_on(PL_compcv);
231 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
233 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
235 opsz = SIZE_TO_PSIZE(sz);
236 sz = opsz + OPSLOT_HEADER_P;
238 /* The slabs maintain a free list of OPs. In particular, constant folding
239 will free up OPs, so it makes sense to re-use them where possible. A
240 freed up slot is used in preference to a new allocation. */
241 if (slab->opslab_freed) {
242 OP **too = &slab->opslab_freed;
244 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
245 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
246 DEBUG_S_warn((aTHX_ "Alas! too small"));
247 o = *(too = &o->op_next);
248 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
252 Zero(o, opsz, I32 *);
258 #define INIT_OPSLOT \
259 slot->opslot_slab = slab; \
260 slot->opslot_next = slab2->opslab_first; \
261 slab2->opslab_first = slot; \
262 o = &slot->opslot_op; \
265 /* The partially-filled slab is next in the chain. */
266 slab2 = slab->opslab_next ? slab->opslab_next : slab;
267 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
268 /* Remaining space is too small. */
270 /* If we can fit a BASEOP, add it to the free chain, so as not
272 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
273 slot = &slab2->opslab_slots;
275 o->op_type = OP_FREED;
276 o->op_next = slab->opslab_freed;
277 slab->opslab_freed = o;
280 /* Create a new slab. Make this one twice as big. */
281 slot = slab2->opslab_first;
282 while (slot->opslot_next) slot = slot->opslot_next;
283 slab2 = S_new_slab(aTHX_
284 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
286 : (DIFF(slab2, slot)+1)*2);
287 slab2->opslab_next = slab->opslab_next;
288 slab->opslab_next = slab2;
290 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
292 /* Create a new op slot */
293 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
294 assert(slot >= &slab2->opslab_slots);
295 if (DIFF(&slab2->opslab_slots, slot)
296 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
297 slot = &slab2->opslab_slots;
299 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
302 #ifdef PERL_OP_PARENT
303 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
304 assert(!o->op_moresib);
305 assert(!o->op_sibparent);
313 #ifdef PERL_DEBUG_READONLY_OPS
315 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
317 PERL_ARGS_ASSERT_SLAB_TO_RO;
319 if (slab->opslab_readonly) return;
320 slab->opslab_readonly = 1;
321 for (; slab; slab = slab->opslab_next) {
322 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
323 (unsigned long) slab->opslab_size, slab));*/
324 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
325 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
326 (unsigned long)slab->opslab_size, errno);
331 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
335 PERL_ARGS_ASSERT_SLAB_TO_RW;
337 if (!slab->opslab_readonly) return;
339 for (; slab2; slab2 = slab2->opslab_next) {
340 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
341 (unsigned long) size, slab2));*/
342 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
343 PROT_READ|PROT_WRITE)) {
344 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
345 (unsigned long)slab2->opslab_size, errno);
348 slab->opslab_readonly = 0;
352 # define Slab_to_rw(op) NOOP
355 /* This cannot possibly be right, but it was copied from the old slab
356 allocator, to which it was originally added, without explanation, in
359 # define PerlMemShared PerlMem
363 Perl_Slab_Free(pTHX_ void *op)
365 OP * const o = (OP *)op;
368 PERL_ARGS_ASSERT_SLAB_FREE;
370 if (!o->op_slabbed) {
372 PerlMemShared_free(op);
377 /* If this op is already freed, our refcount will get screwy. */
378 assert(o->op_type != OP_FREED);
379 o->op_type = OP_FREED;
380 o->op_next = slab->opslab_freed;
381 slab->opslab_freed = o;
382 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
383 OpslabREFCNT_dec_padok(slab);
387 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
389 const bool havepad = !!PL_comppad;
390 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
393 PAD_SAVE_SETNULLPAD();
400 Perl_opslab_free(pTHX_ OPSLAB *slab)
403 PERL_ARGS_ASSERT_OPSLAB_FREE;
405 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
406 assert(slab->opslab_refcnt == 1);
408 slab2 = slab->opslab_next;
410 slab->opslab_refcnt = ~(size_t)0;
412 #ifdef PERL_DEBUG_READONLY_OPS
413 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
415 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
416 perror("munmap failed");
420 PerlMemShared_free(slab);
427 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
432 size_t savestack_count = 0;
434 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
437 for (slot = slab2->opslab_first;
439 slot = slot->opslot_next) {
440 if (slot->opslot_op.op_type != OP_FREED
441 && !(slot->opslot_op.op_savefree
447 assert(slot->opslot_op.op_slabbed);
448 op_free(&slot->opslot_op);
449 if (slab->opslab_refcnt == 1) goto free;
452 } while ((slab2 = slab2->opslab_next));
453 /* > 1 because the CV still holds a reference count. */
454 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
456 assert(savestack_count == slab->opslab_refcnt-1);
458 /* Remove the CV’s reference count. */
459 slab->opslab_refcnt--;
466 #ifdef PERL_DEBUG_READONLY_OPS
468 Perl_op_refcnt_inc(pTHX_ OP *o)
471 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
472 if (slab && slab->opslab_readonly) {
485 Perl_op_refcnt_dec(pTHX_ OP *o)
488 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
490 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
492 if (slab && slab->opslab_readonly) {
494 result = --o->op_targ;
497 result = --o->op_targ;
503 * In the following definition, the ", (OP*)0" is just to make the compiler
504 * think the expression is of the right type: croak actually does a Siglongjmp.
506 #define CHECKOP(type,o) \
507 ((PL_op_mask && PL_op_mask[type]) \
508 ? ( op_free((OP*)o), \
509 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
511 : PL_check[type](aTHX_ (OP*)o))
513 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
515 #define OpTYPE_set(o,type) \
517 o->op_type = (OPCODE)type; \
518 o->op_ppaddr = PL_ppaddr[type]; \
522 S_no_fh_allowed(pTHX_ OP *o)
524 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
526 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
532 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
534 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
535 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
540 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
542 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
544 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
549 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
551 PERL_ARGS_ASSERT_BAD_TYPE_PV;
553 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
554 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
557 /* remove flags var, its unused in all callers, move to to right end since gv
558 and kid are always the same */
560 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
562 SV * const namesv = cv_name((CV *)gv, NULL, 0);
563 PERL_ARGS_ASSERT_BAD_TYPE_GV;
565 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
566 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
570 S_no_bareword_allowed(pTHX_ OP *o)
572 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
574 qerror(Perl_mess(aTHX_
575 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
577 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
580 /* "register" allocation */
583 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
586 const bool is_our = (PL_parser->in_my == KEY_our);
588 PERL_ARGS_ASSERT_ALLOCMY;
590 if (flags & ~SVf_UTF8)
591 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
594 /* complain about "my $<special_var>" etc etc */
598 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
599 (name[1] == '_' && len > 2)))
601 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
603 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
604 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
605 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
606 PL_parser->in_my == KEY_state ? "state" : "my"));
608 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
609 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
613 /* allocate a spare slot and store the name in that slot */
615 off = pad_add_name_pvn(name, len,
616 (is_our ? padadd_OUR :
617 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
618 PL_parser->in_my_stash,
620 /* $_ is always in main::, even with our */
621 ? (PL_curstash && !memEQs(name,len,"$_")
627 /* anon sub prototypes contains state vars should always be cloned,
628 * otherwise the state var would be shared between anon subs */
630 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
631 CvCLONE_on(PL_compcv);
637 =head1 Optree Manipulation Functions
639 =for apidoc alloccopstash
641 Available only under threaded builds, this function allocates an entry in
642 C<PL_stashpad> for the stash passed to it.
649 Perl_alloccopstash(pTHX_ HV *hv)
651 PADOFFSET off = 0, o = 1;
652 bool found_slot = FALSE;
654 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
656 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
658 for (; o < PL_stashpadmax; ++o) {
659 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
660 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
661 found_slot = TRUE, off = o;
664 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
665 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
666 off = PL_stashpadmax;
667 PL_stashpadmax += 10;
670 PL_stashpad[PL_stashpadix = off] = hv;
675 /* free the body of an op without examining its contents.
676 * Always use this rather than FreeOp directly */
679 S_op_destroy(pTHX_ OP *o)
687 =for apidoc Am|void|op_free|OP *o
689 Free an op. Only use this when an op is no longer linked to from any
696 Perl_op_free(pTHX_ OP *o)
700 SSize_t defer_ix = -1;
701 SSize_t defer_stack_alloc = 0;
702 OP **defer_stack = NULL;
706 /* Though ops may be freed twice, freeing the op after its slab is a
708 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
709 /* During the forced freeing of ops after compilation failure, kidops
710 may be freed before their parents. */
711 if (!o || o->op_type == OP_FREED)
716 /* an op should only ever acquire op_private flags that we know about.
717 * If this fails, you may need to fix something in regen/op_private.
718 * Don't bother testing if:
719 * * the op_ppaddr doesn't match the op; someone may have
720 * overridden the op and be doing strange things with it;
721 * * we've errored, as op flags are often left in an
722 * inconsistent state then. Note that an error when
723 * compiling the main program leaves PL_parser NULL, so
724 * we can't spot faults in the main code, only
725 * evaled/required code */
727 if ( o->op_ppaddr == PL_ppaddr[o->op_type]
729 && !PL_parser->error_count)
731 assert(!(o->op_private & ~PL_op_private_valid[type]));
735 if (o->op_private & OPpREFCOUNTED) {
746 refcnt = OpREFCNT_dec(o);
749 /* Need to find and remove any pattern match ops from the list
750 we maintain for reset(). */
751 find_and_forget_pmops(o);
761 /* Call the op_free hook if it has been set. Do it now so that it's called
762 * at the right time for refcounted ops, but still before all of the kids
766 if (o->op_flags & OPf_KIDS) {
768 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
769 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
770 if (!kid || kid->op_type == OP_FREED)
771 /* During the forced freeing of ops after
772 compilation failure, kidops may be freed before
775 if (!(kid->op_flags & OPf_KIDS))
776 /* If it has no kids, just free it now */
783 type = (OPCODE)o->op_targ;
786 Slab_to_rw(OpSLAB(o));
788 /* COP* is not cleared by op_clear() so that we may track line
789 * numbers etc even after null() */
790 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
796 #ifdef DEBUG_LEAKING_SCALARS
800 } while ( (o = POP_DEFERRED_OP()) );
802 Safefree(defer_stack);
805 /* S_op_clear_gv(): free a GV attached to an OP */
809 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
811 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
815 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
816 || o->op_type == OP_MULTIDEREF)
819 ? ((GV*)PAD_SVl(*ixp)) : NULL;
821 ? (GV*)(*svp) : NULL;
823 /* It's possible during global destruction that the GV is freed
824 before the optree. Whilst the SvREFCNT_inc is happy to bump from
825 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
826 will trigger an assertion failure, because the entry to sv_clear
827 checks that the scalar is not already freed. A check of for
828 !SvIS_FREED(gv) turns out to be invalid, because during global
829 destruction the reference count can be forced down to zero
830 (with SVf_BREAK set). In which case raising to 1 and then
831 dropping to 0 triggers cleanup before it should happen. I
832 *think* that this might actually be a general, systematic,
833 weakness of the whole idea of SVf_BREAK, in that code *is*
834 allowed to raise and lower references during global destruction,
835 so any *valid* code that happens to do this during global
836 destruction might well trigger premature cleanup. */
837 bool still_valid = gv && SvREFCNT(gv);
840 SvREFCNT_inc_simple_void(gv);
843 pad_swipe(*ixp, TRUE);
851 int try_downgrade = SvREFCNT(gv) == 2;
854 gv_try_downgrade(gv);
860 Perl_op_clear(pTHX_ OP *o)
865 PERL_ARGS_ASSERT_OP_CLEAR;
867 switch (o->op_type) {
868 case OP_NULL: /* Was holding old type, if any. */
871 case OP_ENTEREVAL: /* Was holding hints. */
875 if (!(o->op_flags & OPf_REF)
876 || (PL_check[o->op_type] != Perl_ck_ftst))
883 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
885 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
888 case OP_METHOD_REDIR:
889 case OP_METHOD_REDIR_SUPER:
891 if (cMETHOPx(o)->op_rclass_targ) {
892 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
893 cMETHOPx(o)->op_rclass_targ = 0;
896 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
897 cMETHOPx(o)->op_rclass_sv = NULL;
899 case OP_METHOD_NAMED:
900 case OP_METHOD_SUPER:
901 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
902 cMETHOPx(o)->op_u.op_meth_sv = NULL;
905 pad_swipe(o->op_targ, 1);
912 SvREFCNT_dec(cSVOPo->op_sv);
913 cSVOPo->op_sv = NULL;
916 Even if op_clear does a pad_free for the target of the op,
917 pad_free doesn't actually remove the sv that exists in the pad;
918 instead it lives on. This results in that it could be reused as
919 a target later on when the pad was reallocated.
922 pad_swipe(o->op_targ,1);
932 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
937 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
938 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
940 if (cPADOPo->op_padix > 0) {
941 pad_swipe(cPADOPo->op_padix, TRUE);
942 cPADOPo->op_padix = 0;
945 SvREFCNT_dec(cSVOPo->op_sv);
946 cSVOPo->op_sv = NULL;
950 PerlMemShared_free(cPVOPo->op_pv);
951 cPVOPo->op_pv = NULL;
955 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
959 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
960 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
963 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
969 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
970 op_free(cPMOPo->op_code_list);
971 cPMOPo->op_code_list = NULL;
973 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
974 /* we use the same protection as the "SAFE" version of the PM_ macros
975 * here since sv_clean_all might release some PMOPs
976 * after PL_regex_padav has been cleared
977 * and the clearing of PL_regex_padav needs to
978 * happen before sv_clean_all
981 if(PL_regex_pad) { /* We could be in destruction */
982 const IV offset = (cPMOPo)->op_pmoffset;
983 ReREFCNT_dec(PM_GETRE(cPMOPo));
984 PL_regex_pad[offset] = &PL_sv_undef;
985 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
989 ReREFCNT_dec(PM_GETRE(cPMOPo));
990 PM_SETRE(cPMOPo, NULL);
997 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
998 UV actions = items->uv;
1000 bool is_hash = FALSE;
1003 switch (actions & MDEREF_ACTION_MASK) {
1006 actions = (++items)->uv;
1009 case MDEREF_HV_padhv_helem:
1011 case MDEREF_AV_padav_aelem:
1012 pad_free((++items)->pad_offset);
1015 case MDEREF_HV_gvhv_helem:
1017 case MDEREF_AV_gvav_aelem:
1019 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1021 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1025 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1027 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1029 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1031 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1033 goto do_vivify_rv2xv_elem;
1035 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1037 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1038 pad_free((++items)->pad_offset);
1039 goto do_vivify_rv2xv_elem;
1041 case MDEREF_HV_pop_rv2hv_helem:
1042 case MDEREF_HV_vivify_rv2hv_helem:
1044 do_vivify_rv2xv_elem:
1045 case MDEREF_AV_pop_rv2av_aelem:
1046 case MDEREF_AV_vivify_rv2av_aelem:
1048 switch (actions & MDEREF_INDEX_MASK) {
1049 case MDEREF_INDEX_none:
1052 case MDEREF_INDEX_const:
1056 pad_swipe((++items)->pad_offset, 1);
1058 SvREFCNT_dec((++items)->sv);
1064 case MDEREF_INDEX_padsv:
1065 pad_free((++items)->pad_offset);
1067 case MDEREF_INDEX_gvsv:
1069 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1071 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1076 if (actions & MDEREF_FLAG_last)
1089 actions >>= MDEREF_SHIFT;
1092 /* start of malloc is at op_aux[-1], where the length is
1094 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1099 if (o->op_targ > 0) {
1100 pad_free(o->op_targ);
1106 S_cop_free(pTHX_ COP* cop)
1108 PERL_ARGS_ASSERT_COP_FREE;
1111 if (! specialWARN(cop->cop_warnings))
1112 PerlMemShared_free(cop->cop_warnings);
1113 cophh_free(CopHINTHASH_get(cop));
1114 if (PL_curcop == cop)
1119 S_forget_pmop(pTHX_ PMOP *const o
1122 HV * const pmstash = PmopSTASH(o);
1124 PERL_ARGS_ASSERT_FORGET_PMOP;
1126 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1127 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1129 PMOP **const array = (PMOP**) mg->mg_ptr;
1130 U32 count = mg->mg_len / sizeof(PMOP**);
1134 if (array[i] == o) {
1135 /* Found it. Move the entry at the end to overwrite it. */
1136 array[i] = array[--count];
1137 mg->mg_len = count * sizeof(PMOP**);
1138 /* Could realloc smaller at this point always, but probably
1139 not worth it. Probably worth free()ing if we're the
1142 Safefree(mg->mg_ptr);
1155 S_find_and_forget_pmops(pTHX_ OP *o)
1157 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1159 if (o->op_flags & OPf_KIDS) {
1160 OP *kid = cUNOPo->op_first;
1162 switch (kid->op_type) {
1167 forget_pmop((PMOP*)kid);
1169 find_and_forget_pmops(kid);
1170 kid = OpSIBLING(kid);
1176 =for apidoc Am|void|op_null|OP *o
1178 Neutralizes an op when it is no longer needed, but is still linked to from
1185 Perl_op_null(pTHX_ OP *o)
1189 PERL_ARGS_ASSERT_OP_NULL;
1191 if (o->op_type == OP_NULL)
1194 o->op_targ = o->op_type;
1195 OpTYPE_set(o, OP_NULL);
1199 Perl_op_refcnt_lock(pTHX)
1200 PERL_TSA_ACQUIRE(PL_op_mutex)
1205 PERL_UNUSED_CONTEXT;
1210 Perl_op_refcnt_unlock(pTHX)
1211 PERL_TSA_RELEASE(PL_op_mutex)
1216 PERL_UNUSED_CONTEXT;
1222 =for apidoc op_sibling_splice
1224 A general function for editing the structure of an existing chain of
1225 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1226 you to delete zero or more sequential nodes, replacing them with zero or
1227 more different nodes. Performs the necessary op_first/op_last
1228 housekeeping on the parent node and op_sibling manipulation on the
1229 children. The last deleted node will be marked as as the last node by
1230 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1232 Note that op_next is not manipulated, and nodes are not freed; that is the
1233 responsibility of the caller. It also won't create a new list op for an
1234 empty list etc; use higher-level functions like op_append_elem() for that.
1236 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1237 the splicing doesn't affect the first or last op in the chain.
1239 C<start> is the node preceding the first node to be spliced. Node(s)
1240 following it will be deleted, and ops will be inserted after it. If it is
1241 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1244 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1245 If -1 or greater than or equal to the number of remaining kids, all
1246 remaining kids are deleted.
1248 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1249 If C<NULL>, no nodes are inserted.
1251 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1256 action before after returns
1257 ------ ----- ----- -------
1260 splice(P, A, 2, X-Y-Z) | | B-C
1264 splice(P, NULL, 1, X-Y) | | A
1268 splice(P, NULL, 3, NULL) | | A-B-C
1272 splice(P, B, 0, X-Y) | | NULL
1276 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1277 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1283 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1287 OP *last_del = NULL;
1288 OP *last_ins = NULL;
1291 first = OpSIBLING(start);
1295 first = cLISTOPx(parent)->op_first;
1297 assert(del_count >= -1);
1299 if (del_count && first) {
1301 while (--del_count && OpHAS_SIBLING(last_del))
1302 last_del = OpSIBLING(last_del);
1303 rest = OpSIBLING(last_del);
1304 OpLASTSIB_set(last_del, NULL);
1311 while (OpHAS_SIBLING(last_ins))
1312 last_ins = OpSIBLING(last_ins);
1313 OpMAYBESIB_set(last_ins, rest, NULL);
1319 OpMAYBESIB_set(start, insert, NULL);
1324 cLISTOPx(parent)->op_first = insert;
1326 parent->op_flags |= OPf_KIDS;
1328 parent->op_flags &= ~OPf_KIDS;
1332 /* update op_last etc */
1339 /* ought to use OP_CLASS(parent) here, but that can't handle
1340 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1342 type = parent->op_type;
1343 if (type == OP_CUSTOM) {
1345 type = XopENTRYCUSTOM(parent, xop_class);
1348 if (type == OP_NULL)
1349 type = parent->op_targ;
1350 type = PL_opargs[type] & OA_CLASS_MASK;
1353 lastop = last_ins ? last_ins : start ? start : NULL;
1354 if ( type == OA_BINOP
1355 || type == OA_LISTOP
1359 cLISTOPx(parent)->op_last = lastop;
1362 OpLASTSIB_set(lastop, parent);
1364 return last_del ? first : NULL;
1367 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1371 #ifdef PERL_OP_PARENT
1374 =for apidoc op_parent
1376 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1377 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1383 Perl_op_parent(OP *o)
1385 PERL_ARGS_ASSERT_OP_PARENT;
1386 while (OpHAS_SIBLING(o))
1388 return o->op_sibparent;
1394 /* replace the sibling following start with a new UNOP, which becomes
1395 * the parent of the original sibling; e.g.
1397 * op_sibling_newUNOP(P, A, unop-args...)
1405 * where U is the new UNOP.
1407 * parent and start args are the same as for op_sibling_splice();
1408 * type and flags args are as newUNOP().
1410 * Returns the new UNOP.
1414 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1418 kid = op_sibling_splice(parent, start, 1, NULL);
1419 newop = newUNOP(type, flags, kid);
1420 op_sibling_splice(parent, start, 0, newop);
1425 /* lowest-level newLOGOP-style function - just allocates and populates
1426 * the struct. Higher-level stuff should be done by S_new_logop() /
1427 * newLOGOP(). This function exists mainly to avoid op_first assignment
1428 * being spread throughout this file.
1432 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1437 NewOp(1101, logop, 1, LOGOP);
1438 OpTYPE_set(logop, type);
1439 logop->op_first = first;
1440 logop->op_other = other;
1441 logop->op_flags = OPf_KIDS;
1442 while (kid && OpHAS_SIBLING(kid))
1443 kid = OpSIBLING(kid);
1445 OpLASTSIB_set(kid, (OP*)logop);
1450 /* Contextualizers */
1453 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1455 Applies a syntactic context to an op tree representing an expression.
1456 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1457 or C<G_VOID> to specify the context to apply. The modified op tree
1464 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1466 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1468 case G_SCALAR: return scalar(o);
1469 case G_ARRAY: return list(o);
1470 case G_VOID: return scalarvoid(o);
1472 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1479 =for apidoc Am|OP*|op_linklist|OP *o
1480 This function is the implementation of the L</LINKLIST> macro. It should
1481 not be called directly.
1487 Perl_op_linklist(pTHX_ OP *o)
1491 PERL_ARGS_ASSERT_OP_LINKLIST;
1496 /* establish postfix order */
1497 first = cUNOPo->op_first;
1500 o->op_next = LINKLIST(first);
1503 OP *sibl = OpSIBLING(kid);
1505 kid->op_next = LINKLIST(sibl);
1520 S_scalarkids(pTHX_ OP *o)
1522 if (o && o->op_flags & OPf_KIDS) {
1524 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1531 S_scalarboolean(pTHX_ OP *o)
1533 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1535 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1536 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1537 if (ckWARN(WARN_SYNTAX)) {
1538 const line_t oldline = CopLINE(PL_curcop);
1540 if (PL_parser && PL_parser->copline != NOLINE) {
1541 /* This ensures that warnings are reported at the first line
1542 of the conditional, not the last. */
1543 CopLINE_set(PL_curcop, PL_parser->copline);
1545 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1546 CopLINE_set(PL_curcop, oldline);
1553 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1556 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1557 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1559 const char funny = o->op_type == OP_PADAV
1560 || o->op_type == OP_RV2AV ? '@' : '%';
1561 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1563 if (cUNOPo->op_first->op_type != OP_GV
1564 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1566 return varname(gv, funny, 0, NULL, 0, subscript_type);
1569 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1574 S_op_varname(pTHX_ const OP *o)
1576 return S_op_varname_subscript(aTHX_ o, 1);
1580 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1581 { /* or not so pretty :-) */
1582 if (o->op_type == OP_CONST) {
1584 if (SvPOK(*retsv)) {
1586 *retsv = sv_newmortal();
1587 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1588 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1590 else if (!SvOK(*retsv))
1593 else *retpv = "...";
1597 S_scalar_slice_warning(pTHX_ const OP *o)
1601 o->op_type == OP_HSLICE ? '{' : '[';
1603 o->op_type == OP_HSLICE ? '}' : ']';
1605 SV *keysv = NULL; /* just to silence compiler warnings */
1606 const char *key = NULL;
1608 if (!(o->op_private & OPpSLICEWARNING))
1610 if (PL_parser && PL_parser->error_count)
1611 /* This warning can be nonsensical when there is a syntax error. */
1614 kid = cLISTOPo->op_first;
1615 kid = OpSIBLING(kid); /* get past pushmark */
1616 /* weed out false positives: any ops that can return lists */
1617 switch (kid->op_type) {
1643 /* Don't warn if we have a nulled list either. */
1644 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1647 assert(OpSIBLING(kid));
1648 name = S_op_varname(aTHX_ OpSIBLING(kid));
1649 if (!name) /* XS module fiddling with the op tree */
1651 S_op_pretty(aTHX_ kid, &keysv, &key);
1652 assert(SvPOK(name));
1653 sv_chop(name,SvPVX(name)+1);
1655 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1656 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1657 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1659 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1660 lbrack, key, rbrack);
1662 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1663 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1664 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1666 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1667 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1671 Perl_scalar(pTHX_ OP *o)
1675 /* assumes no premature commitment */
1676 if (!o || (PL_parser && PL_parser->error_count)
1677 || (o->op_flags & OPf_WANT)
1678 || o->op_type == OP_RETURN)
1683 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1685 switch (o->op_type) {
1687 scalar(cBINOPo->op_first);
1688 if (o->op_private & OPpREPEAT_DOLIST) {
1689 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1690 assert(kid->op_type == OP_PUSHMARK);
1691 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1692 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1693 o->op_private &=~ OPpREPEAT_DOLIST;
1700 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1710 if (o->op_flags & OPf_KIDS) {
1711 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1717 kid = cLISTOPo->op_first;
1719 kid = OpSIBLING(kid);
1722 OP *sib = OpSIBLING(kid);
1723 if (sib && kid->op_type != OP_LEAVEWHEN
1724 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1725 || ( sib->op_targ != OP_NEXTSTATE
1726 && sib->op_targ != OP_DBSTATE )))
1732 PL_curcop = &PL_compiling;
1737 kid = cLISTOPo->op_first;
1740 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1745 /* Warn about scalar context */
1746 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1747 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1750 const char *key = NULL;
1752 /* This warning can be nonsensical when there is a syntax error. */
1753 if (PL_parser && PL_parser->error_count)
1756 if (!ckWARN(WARN_SYNTAX)) break;
1758 kid = cLISTOPo->op_first;
1759 kid = OpSIBLING(kid); /* get past pushmark */
1760 assert(OpSIBLING(kid));
1761 name = S_op_varname(aTHX_ OpSIBLING(kid));
1762 if (!name) /* XS module fiddling with the op tree */
1764 S_op_pretty(aTHX_ kid, &keysv, &key);
1765 assert(SvPOK(name));
1766 sv_chop(name,SvPVX(name)+1);
1768 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1769 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1770 "%%%"SVf"%c%s%c in scalar context better written "
1772 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1773 lbrack, key, rbrack);
1775 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1776 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1777 "%%%"SVf"%c%"SVf"%c in scalar context better "
1778 "written as $%"SVf"%c%"SVf"%c",
1779 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1780 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1787 Perl_scalarvoid(pTHX_ OP *arg)
1793 SSize_t defer_stack_alloc = 0;
1794 SSize_t defer_ix = -1;
1795 OP **defer_stack = NULL;
1798 PERL_ARGS_ASSERT_SCALARVOID;
1801 SV *useless_sv = NULL;
1802 const char* useless = NULL;
1804 if (o->op_type == OP_NEXTSTATE
1805 || o->op_type == OP_DBSTATE
1806 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1807 || o->op_targ == OP_DBSTATE)))
1808 PL_curcop = (COP*)o; /* for warning below */
1810 /* assumes no premature commitment */
1811 want = o->op_flags & OPf_WANT;
1812 if ((want && want != OPf_WANT_SCALAR)
1813 || (PL_parser && PL_parser->error_count)
1814 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1819 if ((o->op_private & OPpTARGET_MY)
1820 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1822 /* newASSIGNOP has already applied scalar context, which we
1823 leave, as if this op is inside SASSIGN. */
1827 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1829 switch (o->op_type) {
1831 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1835 if (o->op_flags & OPf_STACKED)
1837 if (o->op_type == OP_REPEAT)
1838 scalar(cBINOPo->op_first);
1841 if (o->op_private == 4)
1876 case OP_GETSOCKNAME:
1877 case OP_GETPEERNAME:
1882 case OP_GETPRIORITY:
1907 useless = OP_DESC(o);
1917 case OP_AELEMFAST_LEX:
1921 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1922 /* Otherwise it's "Useless use of grep iterator" */
1923 useless = OP_DESC(o);
1927 kid = cLISTOPo->op_first;
1928 if (kid && kid->op_type == OP_PUSHRE
1930 && !(o->op_flags & OPf_STACKED)
1932 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1934 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1937 useless = OP_DESC(o);
1941 kid = cUNOPo->op_first;
1942 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1943 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1946 useless = "negative pattern binding (!~)";
1950 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1951 useless = "non-destructive substitution (s///r)";
1955 useless = "non-destructive transliteration (tr///r)";
1962 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1963 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1964 useless = "a variable";
1969 if (cSVOPo->op_private & OPpCONST_STRICT)
1970 no_bareword_allowed(o);
1972 if (ckWARN(WARN_VOID)) {
1974 /* don't warn on optimised away booleans, eg
1975 * use constant Foo, 5; Foo || print; */
1976 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1978 /* the constants 0 and 1 are permitted as they are
1979 conventionally used as dummies in constructs like
1980 1 while some_condition_with_side_effects; */
1981 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1983 else if (SvPOK(sv)) {
1984 SV * const dsv = newSVpvs("");
1986 = Perl_newSVpvf(aTHX_
1988 pv_pretty(dsv, SvPVX_const(sv),
1989 SvCUR(sv), 32, NULL, NULL,
1991 | PERL_PV_ESCAPE_NOCLEAR
1992 | PERL_PV_ESCAPE_UNI_DETECT));
1993 SvREFCNT_dec_NN(dsv);
1995 else if (SvOK(sv)) {
1996 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1999 useless = "a constant (undef)";
2002 op_null(o); /* don't execute or even remember it */
2006 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2010 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2014 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2018 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2023 UNOP *refgen, *rv2cv;
2026 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2029 rv2gv = ((BINOP *)o)->op_last;
2030 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2033 refgen = (UNOP *)((BINOP *)o)->op_first;
2035 if (!refgen || (refgen->op_type != OP_REFGEN
2036 && refgen->op_type != OP_SREFGEN))
2039 exlist = (LISTOP *)refgen->op_first;
2040 if (!exlist || exlist->op_type != OP_NULL
2041 || exlist->op_targ != OP_LIST)
2044 if (exlist->op_first->op_type != OP_PUSHMARK
2045 && exlist->op_first != exlist->op_last)
2048 rv2cv = (UNOP*)exlist->op_last;
2050 if (rv2cv->op_type != OP_RV2CV)
2053 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2054 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2055 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2057 o->op_private |= OPpASSIGN_CV_TO_GV;
2058 rv2gv->op_private |= OPpDONT_INIT_GV;
2059 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2071 kid = cLOGOPo->op_first;
2072 if (kid->op_type == OP_NOT
2073 && (kid->op_flags & OPf_KIDS)) {
2074 if (o->op_type == OP_AND) {
2075 OpTYPE_set(o, OP_OR);
2077 OpTYPE_set(o, OP_AND);
2087 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2088 if (!(kid->op_flags & OPf_KIDS))
2095 if (o->op_flags & OPf_STACKED)
2102 if (!(o->op_flags & OPf_KIDS))
2113 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2114 if (!(kid->op_flags & OPf_KIDS))
2120 /* If the first kid after pushmark is something that the padrange
2121 optimisation would reject, then null the list and the pushmark.
2123 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2124 && ( !(kid = OpSIBLING(kid))
2125 || ( kid->op_type != OP_PADSV
2126 && kid->op_type != OP_PADAV
2127 && kid->op_type != OP_PADHV)
2128 || kid->op_private & ~OPpLVAL_INTRO
2129 || !(kid = OpSIBLING(kid))
2130 || ( kid->op_type != OP_PADSV
2131 && kid->op_type != OP_PADAV
2132 && kid->op_type != OP_PADHV)
2133 || kid->op_private & ~OPpLVAL_INTRO)
2135 op_null(cUNOPo->op_first); /* NULL the pushmark */
2136 op_null(o); /* NULL the list */
2148 /* mortalise it, in case warnings are fatal. */
2149 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2150 "Useless use of %"SVf" in void context",
2151 SVfARG(sv_2mortal(useless_sv)));
2154 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2155 "Useless use of %s in void context",
2158 } while ( (o = POP_DEFERRED_OP()) );
2160 Safefree(defer_stack);
2166 S_listkids(pTHX_ OP *o)
2168 if (o && o->op_flags & OPf_KIDS) {
2170 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2177 Perl_list(pTHX_ OP *o)
2181 /* assumes no premature commitment */
2182 if (!o || (o->op_flags & OPf_WANT)
2183 || (PL_parser && PL_parser->error_count)
2184 || o->op_type == OP_RETURN)
2189 if ((o->op_private & OPpTARGET_MY)
2190 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2192 return o; /* As if inside SASSIGN */
2195 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2197 switch (o->op_type) {
2199 list(cBINOPo->op_first);
2202 if (o->op_private & OPpREPEAT_DOLIST
2203 && !(o->op_flags & OPf_STACKED))
2205 list(cBINOPo->op_first);
2206 kid = cBINOPo->op_last;
2207 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2208 && SvIVX(kSVOP_sv) == 1)
2210 op_null(o); /* repeat */
2211 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2213 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2220 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2228 if (!(o->op_flags & OPf_KIDS))
2230 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2231 list(cBINOPo->op_first);
2232 return gen_constant_list(o);
2238 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2239 op_null(cUNOPo->op_first); /* NULL the pushmark */
2240 op_null(o); /* NULL the list */
2245 kid = cLISTOPo->op_first;
2247 kid = OpSIBLING(kid);
2250 OP *sib = OpSIBLING(kid);
2251 if (sib && kid->op_type != OP_LEAVEWHEN)
2257 PL_curcop = &PL_compiling;
2261 kid = cLISTOPo->op_first;
2268 S_scalarseq(pTHX_ OP *o)
2271 const OPCODE type = o->op_type;
2273 if (type == OP_LINESEQ || type == OP_SCOPE ||
2274 type == OP_LEAVE || type == OP_LEAVETRY)
2277 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2278 if ((sib = OpSIBLING(kid))
2279 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2280 || ( sib->op_targ != OP_NEXTSTATE
2281 && sib->op_targ != OP_DBSTATE )))
2286 PL_curcop = &PL_compiling;
2288 o->op_flags &= ~OPf_PARENS;
2289 if (PL_hints & HINT_BLOCK_SCOPE)
2290 o->op_flags |= OPf_PARENS;
2293 o = newOP(OP_STUB, 0);
2298 S_modkids(pTHX_ OP *o, I32 type)
2300 if (o && o->op_flags & OPf_KIDS) {
2302 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2303 op_lvalue(kid, type);
2309 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2310 * const fields. Also, convert CONST keys to HEK-in-SVs.
2311 * rop is the op that retrieves the hash;
2312 * key_op is the first key
2316 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2322 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2324 if (rop->op_first->op_type == OP_PADSV)
2325 /* @$hash{qw(keys here)} */
2326 rop = (UNOP*)rop->op_first;
2328 /* @{$hash}{qw(keys here)} */
2329 if (rop->op_first->op_type == OP_SCOPE
2330 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2332 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2339 lexname = NULL; /* just to silence compiler warnings */
2340 fields = NULL; /* just to silence compiler warnings */
2344 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2345 SvPAD_TYPED(lexname))
2346 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2347 && isGV(*fields) && GvHV(*fields);
2349 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2351 if (key_op->op_type != OP_CONST)
2353 svp = cSVOPx_svp(key_op);
2355 /* make sure it's not a bareword under strict subs */
2356 if (key_op->op_private & OPpCONST_BARE &&
2357 key_op->op_private & OPpCONST_STRICT)
2359 no_bareword_allowed((OP*)key_op);
2362 /* Make the CONST have a shared SV */
2363 if ( !SvIsCOW_shared_hash(sv = *svp)
2364 && SvTYPE(sv) < SVt_PVMG
2369 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2370 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2371 SvREFCNT_dec_NN(sv);
2376 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2378 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2379 "in variable %"PNf" of type %"HEKf,
2380 SVfARG(*svp), PNfARG(lexname),
2381 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2388 =for apidoc finalize_optree
2390 This function finalizes the optree. Should be called directly after
2391 the complete optree is built. It does some additional
2392 checking which can't be done in the normal C<ck_>xxx functions and makes
2393 the tree thread-safe.
2398 Perl_finalize_optree(pTHX_ OP* o)
2400 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2403 SAVEVPTR(PL_curcop);
2411 /* Relocate sv to the pad for thread safety.
2412 * Despite being a "constant", the SV is written to,
2413 * for reference counts, sv_upgrade() etc. */
2414 PERL_STATIC_INLINE void
2415 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2418 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2420 ix = pad_alloc(OP_CONST, SVf_READONLY);
2421 SvREFCNT_dec(PAD_SVl(ix));
2422 PAD_SETSV(ix, *svp);
2423 /* XXX I don't know how this isn't readonly already. */
2424 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2432 S_finalize_op(pTHX_ OP* o)
2434 PERL_ARGS_ASSERT_FINALIZE_OP;
2437 switch (o->op_type) {
2440 PL_curcop = ((COP*)o); /* for warnings */
2443 if (OpHAS_SIBLING(o)) {
2444 OP *sib = OpSIBLING(o);
2445 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2446 && ckWARN(WARN_EXEC)
2447 && OpHAS_SIBLING(sib))
2449 const OPCODE type = OpSIBLING(sib)->op_type;
2450 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2451 const line_t oldline = CopLINE(PL_curcop);
2452 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2453 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2454 "Statement unlikely to be reached");
2455 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2456 "\t(Maybe you meant system() when you said exec()?)\n");
2457 CopLINE_set(PL_curcop, oldline);
2464 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2465 GV * const gv = cGVOPo_gv;
2466 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2467 /* XXX could check prototype here instead of just carping */
2468 SV * const sv = sv_newmortal();
2469 gv_efullname3(sv, gv, NULL);
2470 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2471 "%"SVf"() called too early to check prototype",
2478 if (cSVOPo->op_private & OPpCONST_STRICT)
2479 no_bareword_allowed(o);
2483 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2488 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2489 case OP_METHOD_NAMED:
2490 case OP_METHOD_SUPER:
2491 case OP_METHOD_REDIR:
2492 case OP_METHOD_REDIR_SUPER:
2493 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2502 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2505 rop = (UNOP*)((BINOP*)o)->op_first;
2510 S_scalar_slice_warning(aTHX_ o);
2514 kid = OpSIBLING(cLISTOPo->op_first);
2515 if (/* I bet there's always a pushmark... */
2516 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2517 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2522 key_op = (SVOP*)(kid->op_type == OP_CONST
2524 : OpSIBLING(kLISTOP->op_first));
2526 rop = (UNOP*)((LISTOP*)o)->op_last;
2529 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2531 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2535 S_scalar_slice_warning(aTHX_ o);
2539 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2540 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2547 if (o->op_flags & OPf_KIDS) {
2551 /* check that op_last points to the last sibling, and that
2552 * the last op_sibling/op_sibparent field points back to the
2553 * parent, and that the only ops with KIDS are those which are
2554 * entitled to them */
2555 U32 type = o->op_type;
2559 if (type == OP_NULL) {
2561 /* ck_glob creates a null UNOP with ex-type GLOB
2562 * (which is a list op. So pretend it wasn't a listop */
2563 if (type == OP_GLOB)
2566 family = PL_opargs[type] & OA_CLASS_MASK;
2568 has_last = ( family == OA_BINOP
2569 || family == OA_LISTOP
2570 || family == OA_PMOP
2571 || family == OA_LOOP
2573 assert( has_last /* has op_first and op_last, or ...
2574 ... has (or may have) op_first: */
2575 || family == OA_UNOP
2576 || family == OA_UNOP_AUX
2577 || family == OA_LOGOP
2578 || family == OA_BASEOP_OR_UNOP
2579 || family == OA_FILESTATOP
2580 || family == OA_LOOPEXOP
2581 || family == OA_METHOP
2582 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2583 || type == OP_SASSIGN
2584 || type == OP_CUSTOM
2585 || type == OP_NULL /* new_logop does this */
2588 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2589 # ifdef PERL_OP_PARENT
2590 if (!OpHAS_SIBLING(kid)) {
2592 assert(kid == cLISTOPo->op_last);
2593 assert(kid->op_sibparent == o);
2596 if (has_last && !OpHAS_SIBLING(kid))
2597 assert(kid == cLISTOPo->op_last);
2602 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2608 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2610 Propagate lvalue ("modifiable") context to an op and its children.
2611 C<type> represents the context type, roughly based on the type of op that
2612 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2613 because it has no op type of its own (it is signalled by a flag on
2616 This function detects things that can't be modified, such as C<$x+1>, and
2617 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2618 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2620 It also flags things that need to behave specially in an lvalue context,
2621 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2627 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2630 PadnameLVALUE_on(pn);
2631 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2633 /* RT #127786: cv can be NULL due to an eval within the DB package
2634 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2635 * unless they contain an eval, but calling eval within DB
2636 * pretends the eval was done in the caller's scope.
2640 assert(CvPADLIST(cv));
2642 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2643 assert(PadnameLEN(pn));
2644 PadnameLVALUE_on(pn);
2649 S_vivifies(const OPCODE type)
2652 case OP_RV2AV: case OP_ASLICE:
2653 case OP_RV2HV: case OP_KVASLICE:
2654 case OP_RV2SV: case OP_HSLICE:
2655 case OP_AELEMFAST: case OP_KVHSLICE:
2664 S_lvref(pTHX_ OP *o, I32 type)
2668 switch (o->op_type) {
2670 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2671 kid = OpSIBLING(kid))
2672 S_lvref(aTHX_ kid, type);
2677 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2678 o->op_flags |= OPf_STACKED;
2679 if (o->op_flags & OPf_PARENS) {
2680 if (o->op_private & OPpLVAL_INTRO) {
2681 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2682 "localized parenthesized array in list assignment"));
2686 OpTYPE_set(o, OP_LVAVREF);
2687 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2688 o->op_flags |= OPf_MOD|OPf_REF;
2691 o->op_private |= OPpLVREF_AV;
2694 kid = cUNOPo->op_first;
2695 if (kid->op_type == OP_NULL)
2696 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2698 o->op_private = OPpLVREF_CV;
2699 if (kid->op_type == OP_GV)
2700 o->op_flags |= OPf_STACKED;
2701 else if (kid->op_type == OP_PADCV) {
2702 o->op_targ = kid->op_targ;
2704 op_free(cUNOPo->op_first);
2705 cUNOPo->op_first = NULL;
2706 o->op_flags &=~ OPf_KIDS;
2711 if (o->op_flags & OPf_PARENS) {
2713 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2714 "parenthesized hash in list assignment"));
2717 o->op_private |= OPpLVREF_HV;
2721 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2722 o->op_flags |= OPf_STACKED;
2725 if (o->op_flags & OPf_PARENS) goto parenhash;
2726 o->op_private |= OPpLVREF_HV;
2729 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2732 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2733 if (o->op_flags & OPf_PARENS) goto slurpy;
2734 o->op_private |= OPpLVREF_AV;
2738 o->op_private |= OPpLVREF_ELEM;
2739 o->op_flags |= OPf_STACKED;
2743 OpTYPE_set(o, OP_LVREFSLICE);
2744 o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2747 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2749 else if (!(o->op_flags & OPf_KIDS))
2751 if (o->op_targ != OP_LIST) {
2752 S_lvref(aTHX_ cBINOPo->op_first, type);
2757 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2758 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2759 S_lvref(aTHX_ kid, type);
2763 if (o->op_flags & OPf_PARENS)
2768 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2769 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2770 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2775 OpTYPE_set(o, OP_LVREF);
2777 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2778 if (type == OP_ENTERLOOP)
2779 o->op_private |= OPpLVREF_ITER;
2783 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2787 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2790 if (!o || (PL_parser && PL_parser->error_count))
2793 if ((o->op_private & OPpTARGET_MY)
2794 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2799 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2801 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2803 switch (o->op_type) {
2808 if ((o->op_flags & OPf_PARENS))
2812 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2813 !(o->op_flags & OPf_STACKED)) {
2814 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
2815 assert(cUNOPo->op_first->op_type == OP_NULL);
2816 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2819 else { /* lvalue subroutine call */
2820 o->op_private |= OPpLVAL_INTRO;
2821 PL_modcount = RETURN_UNLIMITED_NUMBER;
2822 if (type == OP_GREPSTART || type == OP_ENTERSUB
2823 || type == OP_REFGEN || type == OP_LEAVESUBLV) {
2824 /* Potential lvalue context: */
2825 o->op_private |= OPpENTERSUB_INARGS;
2828 else { /* Compile-time error message: */
2829 OP *kid = cUNOPo->op_first;
2834 if (kid->op_type != OP_PUSHMARK) {
2835 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2837 "panic: unexpected lvalue entersub "
2838 "args: type/targ %ld:%"UVuf,
2839 (long)kid->op_type, (UV)kid->op_targ);
2840 kid = kLISTOP->op_first;
2842 while (OpHAS_SIBLING(kid))
2843 kid = OpSIBLING(kid);
2844 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2845 break; /* Postpone until runtime */
2848 kid = kUNOP->op_first;
2849 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2850 kid = kUNOP->op_first;
2851 if (kid->op_type == OP_NULL)
2853 "Unexpected constant lvalue entersub "
2854 "entry via type/targ %ld:%"UVuf,
2855 (long)kid->op_type, (UV)kid->op_targ);
2856 if (kid->op_type != OP_GV) {
2863 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2864 ? MUTABLE_CV(SvRV(gv))
2870 if (flags & OP_LVALUE_NO_CROAK)
2873 namesv = cv_name(cv, NULL, 0);
2874 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2875 "subroutine call of &%"SVf" in %s",
2876 SVfARG(namesv), PL_op_desc[type]),
2884 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2885 /* grep, foreach, subcalls, refgen */
2886 if (type == OP_GREPSTART || type == OP_ENTERSUB
2887 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2889 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2890 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2893 type ? PL_op_desc[type] : "local"));
2906 case OP_RIGHT_SHIFT:
2915 if (!(o->op_flags & OPf_STACKED))
2921 if (o->op_flags & OPf_STACKED) {
2925 if (!(o->op_private & OPpREPEAT_DOLIST))
2928 const I32 mods = PL_modcount;
2929 modkids(cBINOPo->op_first, type);
2930 if (type != OP_AASSIGN)
2932 kid = cBINOPo->op_last;
2933 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2934 const IV iv = SvIV(kSVOP_sv);
2935 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2937 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2940 PL_modcount = RETURN_UNLIMITED_NUMBER;
2946 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2947 op_lvalue(kid, type);
2952 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2953 PL_modcount = RETURN_UNLIMITED_NUMBER;
2954 return o; /* Treat \(@foo) like ordinary list. */
2958 if (scalar_mod_type(o, type))
2960 ref(cUNOPo->op_first, o->op_type);
2967 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2968 if (type == OP_LEAVESUBLV && (
2969 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2970 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2972 o->op_private |= OPpMAYBE_LVSUB;
2976 PL_modcount = RETURN_UNLIMITED_NUMBER;
2980 if (type == OP_LEAVESUBLV)
2981 o->op_private |= OPpMAYBE_LVSUB;
2984 PL_hints |= HINT_BLOCK_SCOPE;
2985 if (type == OP_LEAVESUBLV)
2986 o->op_private |= OPpMAYBE_LVSUB;
2990 ref(cUNOPo->op_first, o->op_type);
2994 PL_hints |= HINT_BLOCK_SCOPE;
3004 case OP_AELEMFAST_LEX:
3011 PL_modcount = RETURN_UNLIMITED_NUMBER;
3012 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3013 return o; /* Treat \(@foo) like ordinary list. */
3014 if (scalar_mod_type(o, type))
3016 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3017 && type == OP_LEAVESUBLV)
3018 o->op_private |= OPpMAYBE_LVSUB;
3022 if (!type) /* local() */
3023 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3024 PNfARG(PAD_COMPNAME(o->op_targ)));
3025 if (!(o->op_private & OPpLVAL_INTRO)
3026 || ( type != OP_SASSIGN && type != OP_AASSIGN
3027 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3028 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3036 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
3040 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3046 if (type == OP_LEAVESUBLV)
3047 o->op_private |= OPpMAYBE_LVSUB;
3048 if (o->op_flags & OPf_KIDS)
3049 op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3054 ref(cBINOPo->op_first, o->op_type);
3055 if (type == OP_ENTERSUB &&
3056 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3057 o->op_private |= OPpLVAL_DEFER;
3058 if (type == OP_LEAVESUBLV)
3059 o->op_private |= OPpMAYBE_LVSUB;
3066 o->op_private |= OPpLVALUE;
3072 if (o->op_flags & OPf_KIDS)
3073 op_lvalue(cLISTOPo->op_last, type);
3078 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3080 else if (!(o->op_flags & OPf_KIDS))
3082 if (o->op_targ != OP_LIST) {
3083 op_lvalue(cBINOPo->op_first, type);
3089 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3090 /* elements might be in void context because the list is
3091 in scalar context or because they are attribute sub calls */
3092 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3093 op_lvalue(kid, type);
3101 if (type == OP_LEAVESUBLV
3102 || !S_vivifies(cLOGOPo->op_first->op_type))
3103 op_lvalue(cLOGOPo->op_first, type);
3104 if (type == OP_LEAVESUBLV
3105 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3106 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3110 if (type != OP_AASSIGN && type != OP_SASSIGN
3111 && type != OP_ENTERLOOP)
3113 /* Don’t bother applying lvalue context to the ex-list. */
3114 kid = cUNOPx(cUNOPo->op_first)->op_first;
3115 assert (!OpHAS_SIBLING(kid));
3118 if (type != OP_AASSIGN) goto nomod;
3119 kid = cUNOPo->op_first;
3122 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3123 S_lvref(aTHX_ kid, type);
3124 if (!PL_parser || PL_parser->error_count == ec) {
3125 if (!FEATURE_REFALIASING_IS_ENABLED)
3127 "Experimental aliasing via reference not enabled");
3128 Perl_ck_warner_d(aTHX_
3129 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3130 "Aliasing via reference is experimental");
3133 if (o->op_type == OP_REFGEN)
3134 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3139 kid = cLISTOPo->op_first;
3140 if (kid && kid->op_type == OP_PUSHRE &&
3142 || o->op_flags & OPf_STACKED
3144 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3146 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3149 /* This is actually @array = split. */
3150 PL_modcount = RETURN_UNLIMITED_NUMBER;
3156 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3160 /* [20011101.069] File test operators interpret OPf_REF to mean that
3161 their argument is a filehandle; thus \stat(".") should not set
3163 if (type == OP_REFGEN &&
3164 PL_check[o->op_type] == Perl_ck_ftst)
3167 if (type != OP_LEAVESUBLV)
3168 o->op_flags |= OPf_MOD;
3170 if (type == OP_AASSIGN || type == OP_SASSIGN)
3171 o->op_flags |= OPf_SPECIAL|OPf_REF;
3172 else if (!type) { /* local() */
3175 o->op_private |= OPpLVAL_INTRO;
3176 o->op_flags &= ~OPf_SPECIAL;
3177 PL_hints |= HINT_BLOCK_SCOPE;
3182 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3183 "Useless localization of %s", OP_DESC(o));
3186 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3187 && type != OP_LEAVESUBLV)
3188 o->op_flags |= OPf_REF;
3193 S_scalar_mod_type(const OP *o, I32 type)
3198 if (o && o->op_type == OP_RV2GV)
3222 case OP_RIGHT_SHIFT:
3243 S_is_handle_constructor(const OP *o, I32 numargs)
3245 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3247 switch (o->op_type) {
3255 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3268 S_refkids(pTHX_ OP *o, I32 type)
3270 if (o && o->op_flags & OPf_KIDS) {
3272 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3279 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3284 PERL_ARGS_ASSERT_DOREF;
3286 if (PL_parser && PL_parser->error_count)
3289 switch (o->op_type) {
3291 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3292 !(o->op_flags & OPf_STACKED)) {
3293 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3294 assert(cUNOPo->op_first->op_type == OP_NULL);
3295 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3296 o->op_flags |= OPf_SPECIAL;
3298 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3299 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3300 : type == OP_RV2HV ? OPpDEREF_HV
3302 o->op_flags |= OPf_MOD;
3308 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3309 doref(kid, type, set_op_ref);
3312 if (type == OP_DEFINED)
3313 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3314 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3317 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3318 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3319 : type == OP_RV2HV ? OPpDEREF_HV
3321 o->op_flags |= OPf_MOD;
3328 o->op_flags |= OPf_REF;
3331 if (type == OP_DEFINED)
3332 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3333 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3339 o->op_flags |= OPf_REF;
3344 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3346 doref(cBINOPo->op_first, type, set_op_ref);
3350 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3351 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3352 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3353 : type == OP_RV2HV ? OPpDEREF_HV
3355 o->op_flags |= OPf_MOD;
3365 if (!(o->op_flags & OPf_KIDS))
3367 doref(cLISTOPo->op_last, type, set_op_ref);
3377 S_dup_attrlist(pTHX_ OP *o)
3381 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3383 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3384 * where the first kid is OP_PUSHMARK and the remaining ones
3385 * are OP_CONST. We need to push the OP_CONST values.
3387 if (o->op_type == OP_CONST)
3388 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3390 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3392 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3393 if (o->op_type == OP_CONST)
3394 rop = op_append_elem(OP_LIST, rop,
3395 newSVOP(OP_CONST, o->op_flags,
3396 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3403 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3405 PERL_ARGS_ASSERT_APPLY_ATTRS;
3407 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3409 /* fake up C<use attributes $pkg,$rv,@attrs> */
3411 #define ATTRSMODULE "attributes"
3412 #define ATTRSMODULE_PM "attributes.pm"
3415 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3416 newSVpvs(ATTRSMODULE),
3418 op_prepend_elem(OP_LIST,
3419 newSVOP(OP_CONST, 0, stashsv),
3420 op_prepend_elem(OP_LIST,
3421 newSVOP(OP_CONST, 0,
3423 dup_attrlist(attrs))));
3428 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3430 OP *pack, *imop, *arg;
3431 SV *meth, *stashsv, **svp;
3433 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3438 assert(target->op_type == OP_PADSV ||
3439 target->op_type == OP_PADHV ||
3440 target->op_type == OP_PADAV);
3442 /* Ensure that attributes.pm is loaded. */
3443 /* Don't force the C<use> if we don't need it. */
3444 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3445 if (svp && *svp != &PL_sv_undef)
3446 NOOP; /* already in %INC */
3448 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3449 newSVpvs(ATTRSMODULE), NULL);
3451 /* Need package name for method call. */
3452 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3454 /* Build up the real arg-list. */
3455 stashsv = newSVhek(HvNAME_HEK(stash));
3457 arg = newOP(OP_PADSV, 0);
3458 arg->op_targ = target->op_targ;
3459 arg = op_prepend_elem(OP_LIST,
3460 newSVOP(OP_CONST, 0, stashsv),
3461 op_prepend_elem(OP_LIST,
3462 newUNOP(OP_REFGEN, 0,
3464 dup_attrlist(attrs)));
3466 /* Fake up a method call to import */
3467 meth = newSVpvs_share("import");
3468 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3469 op_append_elem(OP_LIST,
3470 op_prepend_elem(OP_LIST, pack, arg),
3471 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3473 /* Combine the ops. */
3474 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3478 =notfor apidoc apply_attrs_string
3480 Attempts to apply a list of attributes specified by the C<attrstr> and
3481 C<len> arguments to the subroutine identified by the C<cv> argument which
3482 is expected to be associated with the package identified by the C<stashpv>
3483 argument (see L<attributes>). It gets this wrong, though, in that it
3484 does not correctly identify the boundaries of the individual attribute
3485 specifications within C<attrstr>. This is not really intended for the
3486 public API, but has to be listed here for systems such as AIX which
3487 need an explicit export list for symbols. (It's called from XS code
3488 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3489 to respect attribute syntax properly would be welcome.
3495 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3496 const char *attrstr, STRLEN len)
3500 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3503 len = strlen(attrstr);
3507 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3509 const char * const sstr = attrstr;
3510 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3511 attrs = op_append_elem(OP_LIST, attrs,
3512 newSVOP(OP_CONST, 0,
3513 newSVpvn(sstr, attrstr-sstr)));
3517 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3518 newSVpvs(ATTRSMODULE),
3519 NULL, op_prepend_elem(OP_LIST,
3520 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3521 op_prepend_elem(OP_LIST,
3522 newSVOP(OP_CONST, 0,
3523 newRV(MUTABLE_SV(cv))),
3528 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3530 OP *new_proto = NULL;
3535 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3541 if (o->op_type == OP_CONST) {
3542 pv = SvPV(cSVOPo_sv, pvlen);
3543 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3544 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3545 SV ** const tmpo = cSVOPx_svp(o);
3546 SvREFCNT_dec(cSVOPo_sv);
3551 } else if (o->op_type == OP_LIST) {
3553 assert(o->op_flags & OPf_KIDS);
3554 lasto = cLISTOPo->op_first;
3555 assert(lasto->op_type == OP_PUSHMARK);
3556 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3557 if (o->op_type == OP_CONST) {
3558 pv = SvPV(cSVOPo_sv, pvlen);
3559 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3560 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3561 SV ** const tmpo = cSVOPx_svp(o);
3562 SvREFCNT_dec(cSVOPo_sv);
3564 if (new_proto && ckWARN(WARN_MISC)) {
3566 const char * newp = SvPV(cSVOPo_sv, new_len);
3567 Perl_warner(aTHX_ packWARN(WARN_MISC),
3568 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3569 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3575 /* excise new_proto from the list */
3576 op_sibling_splice(*attrs, lasto, 1, NULL);
3583 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3584 would get pulled in with no real need */
3585 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3594 svname = sv_newmortal();
3595 gv_efullname3(svname, name, NULL);
3597 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3598 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3600 svname = (SV *)name;
3601 if (ckWARN(WARN_ILLEGALPROTO))
3602 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3603 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3604 STRLEN old_len, new_len;
3605 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3606 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3608 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3609 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3611 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3612 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3622 S_cant_declare(pTHX_ OP *o)
3624 if (o->op_type == OP_NULL
3625 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3626 o = cUNOPo->op_first;
3627 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3628 o->op_type == OP_NULL
3629 && o->op_flags & OPf_SPECIAL
3632 PL_parser->in_my == KEY_our ? "our" :
3633 PL_parser->in_my == KEY_state ? "state" :
3638 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3641 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3643 PERL_ARGS_ASSERT_MY_KID;
3645 if (!o || (PL_parser && PL_parser->error_count))
3650 if (type == OP_LIST) {
3652 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3653 my_kid(kid, attrs, imopsp);
3655 } else if (type == OP_UNDEF || type == OP_STUB) {
3657 } else if (type == OP_RV2SV || /* "our" declaration */
3659 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3660 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3661 S_cant_declare(aTHX_ o);
3663 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3665 PL_parser->in_my = FALSE;
3666 PL_parser->in_my_stash = NULL;
3667 apply_attrs(GvSTASH(gv),
3668 (type == OP_RV2SV ? GvSV(gv) :
3669 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3670 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3673 o->op_private |= OPpOUR_INTRO;
3676 else if (type != OP_PADSV &&
3679 type != OP_PUSHMARK)
3681 S_cant_declare(aTHX_ o);
3684 else if (attrs && type != OP_PUSHMARK) {
3688 PL_parser->in_my = FALSE;
3689 PL_parser->in_my_stash = NULL;
3691 /* check for C<my Dog $spot> when deciding package */
3692 stash = PAD_COMPNAME_TYPE(o->op_targ);
3694 stash = PL_curstash;
3695 apply_attrs_my(stash, o, attrs, imopsp);
3697 o->op_flags |= OPf_MOD;
3698 o->op_private |= OPpLVAL_INTRO;
3700 o->op_private |= OPpPAD_STATE;
3705 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3708 int maybe_scalar = 0;
3710 PERL_ARGS_ASSERT_MY_ATTRS;
3712 /* [perl #17376]: this appears to be premature, and results in code such as
3713 C< our(%x); > executing in list mode rather than void mode */
3715 if (o->op_flags & OPf_PARENS)
3725 o = my_kid(o, attrs, &rops);
3727 if (maybe_scalar && o->op_type == OP_PADSV) {
3728 o = scalar(op_append_list(OP_LIST, rops, o));
3729 o->op_private |= OPpLVAL_INTRO;
3732 /* The listop in rops might have a pushmark at the beginning,
3733 which will mess up list assignment. */
3734 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3735 if (rops->op_type == OP_LIST &&
3736 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3738 OP * const pushmark = lrops->op_first;
3739 /* excise pushmark */
3740 op_sibling_splice(rops, NULL, 1, NULL);
3743 o = op_append_list(OP_LIST, o, rops);
3746 PL_parser->in_my = FALSE;
3747 PL_parser->in_my_stash = NULL;
3752 Perl_sawparens(pTHX_ OP *o)
3754 PERL_UNUSED_CONTEXT;
3756 o->op_flags |= OPf_PARENS;
3761 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3765 const OPCODE ltype = left->op_type;
3766 const OPCODE rtype = right->op_type;
3768 PERL_ARGS_ASSERT_BIND_MATCH;
3770 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3771 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3773 const char * const desc
3775 rtype == OP_SUBST || rtype == OP_TRANS
3776 || rtype == OP_TRANSR
3778 ? (int)rtype : OP_MATCH];
3779 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3781 S_op_varname(aTHX_ left);
3783 Perl_warner(aTHX_ packWARN(WARN_MISC),
3784 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3785 desc, SVfARG(name), SVfARG(name));
3787 const char * const sample = (isary
3788 ? "@array" : "%hash");
3789 Perl_warner(aTHX_ packWARN(WARN_MISC),
3790 "Applying %s to %s will act on scalar(%s)",
3791 desc, sample, sample);
3795 if (rtype == OP_CONST &&
3796 cSVOPx(right)->op_private & OPpCONST_BARE &&
3797 cSVOPx(right)->op_private & OPpCONST_STRICT)
3799 no_bareword_allowed(right);
3802 /* !~ doesn't make sense with /r, so error on it for now */
3803 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3805 /* diag_listed_as: Using !~ with %s doesn't make sense */
3806 yyerror("Using !~ with s///r doesn't make sense");
3807 if (rtype == OP_TRANSR && type == OP_NOT)
3808 /* diag_listed_as: Using !~ with %s doesn't make sense */
3809 yyerror("Using !~ with tr///r doesn't make sense");
3811 ismatchop = (rtype == OP_MATCH ||
3812 rtype == OP_SUBST ||
3813 rtype == OP_TRANS || rtype == OP_TRANSR)
3814 && !(right->op_flags & OPf_SPECIAL);
3815 if (ismatchop && right->op_private & OPpTARGET_MY) {
3817 right->op_private &= ~OPpTARGET_MY;
3819 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3820 if (left->op_type == OP_PADSV
3821 && !(left->op_private & OPpLVAL_INTRO))
3823 right->op_targ = left->op_targ;
3828 right->op_flags |= OPf_STACKED;
3829 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3830 ! (rtype == OP_TRANS &&
3831 right->op_private & OPpTRANS_IDENTICAL) &&
3832 ! (rtype == OP_SUBST &&
3833 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3834 left = op_lvalue(left, rtype);
3835 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3836 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3838 o = op_prepend_elem(rtype, scalar(left), right);
3841 return newUNOP(OP_NOT, 0, scalar(o));
3845 return bind_match(type, left,
3846 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3850 Perl_invert(pTHX_ OP *o)
3854 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3858 =for apidoc Amx|OP *|op_scope|OP *o
3860 Wraps up an op tree with some additional ops so that at runtime a dynamic
3861 scope will be created. The original ops run in the new dynamic scope,
3862 and then, provided that they exit normally, the scope will be unwound.
3863 The additional ops used to create and unwind the dynamic scope will
3864 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3865 instead if the ops are simple enough to not need the full dynamic scope
3872 Perl_op_scope(pTHX_ OP *o)
3876 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3877 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3878 OpTYPE_set(o, OP_LEAVE);
3880 else if (o->op_type == OP_LINESEQ) {
3882 OpTYPE_set(o, OP_SCOPE);
3883 kid = ((LISTOP*)o)->op_first;
3884 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3887 /* The following deals with things like 'do {1 for 1}' */
3888 kid = OpSIBLING(kid);
3890 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3895 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3901 Perl_op_unscope(pTHX_ OP *o)
3903 if (o && o->op_type == OP_LINESEQ) {
3904 OP *kid = cLISTOPo->op_first;
3905 for(; kid; kid = OpSIBLING(kid))
3906 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3913 =for apidoc Am|int|block_start|int full
3915 Handles compile-time scope entry.
3916 Arranges for hints to be restored on block
3917 exit and also handles pad sequence numbers to make lexical variables scope
3918 right. Returns a savestack index for use with C<block_end>.
3924 Perl_block_start(pTHX_ int full)
3926 const int retval = PL_savestack_ix;
3928 PL_compiling.cop_seq = PL_cop_seqmax;
3930 pad_block_start(full);
3932 PL_hints &= ~HINT_BLOCK_SCOPE;
3933 SAVECOMPILEWARNINGS();
3934 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3935 SAVEI32(PL_compiling.cop_seq);
3936 PL_compiling.cop_seq = 0;
3938 CALL_BLOCK_HOOKS(bhk_start, full);
3944 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3946 Handles compile-time scope exit. C<floor>
3947 is the savestack index returned by
3948 C<block_start>, and C<seq> is the body of the block. Returns the block,
3955 Perl_block_end(pTHX_ I32 floor, OP *seq)
3957 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3958 OP* retval = scalarseq(seq);
3961 /* XXX Is the null PL_parser check necessary here? */
3962 assert(PL_parser); /* Let’s find out under debugging builds. */
3963 if (PL_parser && PL_parser->parsed_sub) {
3964 o = newSTATEOP(0, NULL, NULL);
3966 retval = op_append_elem(OP_LINESEQ, retval, o);
3969 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3973 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3977 /* pad_leavemy has created a sequence of introcv ops for all my
3978 subs declared in the block. We have to replicate that list with
3979 clonecv ops, to deal with this situation:
3984 sub s1 { state sub foo { \&s2 } }
3987 Originally, I was going to have introcv clone the CV and turn
3988 off the stale flag. Since &s1 is declared before &s2, the
3989 introcv op for &s1 is executed (on sub entry) before the one for
3990 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3991 cloned, since it is a state sub) closes over &s2 and expects
3992 to see it in its outer CV’s pad. If the introcv op clones &s1,
3993 then &s2 is still marked stale. Since &s1 is not active, and
3994 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3995 ble will not stay shared’ warning. Because it is the same stub
3996 that will be used when the introcv op for &s2 is executed, clos-
3997 ing over it is safe. Hence, we have to turn off the stale flag
3998 on all lexical subs in the block before we clone any of them.
3999 Hence, having introcv clone the sub cannot work. So we create a
4000 list of ops like this:
4024 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4025 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4026 for (;; kid = OpSIBLING(kid)) {
4027 OP *newkid = newOP(OP_CLONECV, 0);
4028 newkid->op_targ = kid->op_targ;
4029 o = op_append_elem(OP_LINESEQ, o, newkid);
4030 if (kid == last) break;
4032 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4035 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4041 =head1 Compile-time scope hooks
4043 =for apidoc Aox||blockhook_register
4045 Register a set of hooks to be called when the Perl lexical scope changes
4046 at compile time. See L<perlguts/"Compile-time scope hooks">.
4052 Perl_blockhook_register(pTHX_ BHK *hk)
4054 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4056 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4060 Perl_newPROG(pTHX_ OP *o)
4062 PERL_ARGS_ASSERT_NEWPROG;
4069 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4070 ((PL_in_eval & EVAL_KEEPERR)
4071 ? OPf_SPECIAL : 0), o);
4074 assert(CxTYPE(cx) == CXt_EVAL);
4076 if ((cx->blk_gimme & G_WANT) == G_VOID)
4077 scalarvoid(PL_eval_root);
4078 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4081 scalar(PL_eval_root);
4083 PL_eval_start = op_linklist(PL_eval_root);
4084 PL_eval_root->op_private |= OPpREFCOUNTED;
4085 OpREFCNT_set(PL_eval_root, 1);
4086 PL_eval_root->op_next = 0;
4087 i = PL_savestack_ix;
4090 CALL_PEEP(PL_eval_start);
4091 finalize_optree(PL_eval_root);
4092 S_prune_chain_head(&PL_eval_start);
4094 PL_savestack_ix = i;
4097 if (o->op_type == OP_STUB) {
4098 /* This block is entered if nothing is compiled for the main
4099 program. This will be the case for an genuinely empty main
4100 program, or one which only has BEGIN blocks etc, so already
4103 Historically (5.000) the guard above was !o. However, commit
4104 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4105 c71fccf11fde0068, changed perly.y so that newPROG() is now
4106 called with the output of block_end(), which returns a new
4107 OP_STUB for the case of an empty optree. ByteLoader (and
4108 maybe other things) also take this path, because they set up
4109 PL_main_start and PL_main_root directly, without generating an
4112 If the parsing the main program aborts (due to parse errors,
4113 or due to BEGIN or similar calling exit), then newPROG()
4114 isn't even called, and hence this code path and its cleanups
4115 are skipped. This shouldn't make a make a difference:
4116 * a non-zero return from perl_parse is a failure, and
4117 perl_destruct() should be called immediately.
4118 * however, if exit(0) is called during the parse, then
4119 perl_parse() returns 0, and perl_run() is called. As
4120 PL_main_start will be NULL, perl_run() will return
4121 promptly, and the exit code will remain 0.
4124 PL_comppad_name = 0;
4126 S_op_destroy(aTHX_ o);
4129 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4130 PL_curcop = &PL_compiling;
4131 PL_main_start = LINKLIST(PL_main_root);
4132 PL_main_root->op_private |= OPpREFCOUNTED;
4133 OpREFCNT_set(PL_main_root, 1);
4134 PL_main_root->op_next = 0;
4135 CALL_PEEP(PL_main_start);
4136 finalize_optree(PL_main_root);
4137 S_prune_chain_head(&PL_main_start);
4138 cv_forget_slab(PL_compcv);
4141 /* Register with debugger */
4143 CV * const cv = get_cvs("DB::postponed", 0);
4147 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4149 call_sv(MUTABLE_SV(cv), G_DISCARD);
4156 Perl_localize(pTHX_ OP *o, I32 lex)
4158 PERL_ARGS_ASSERT_LOCALIZE;
4160 if (o->op_flags & OPf_PARENS)
4161 /* [perl #17376]: this appears to be premature, and results in code such as
4162 C< our(%x); > executing in list mode rather than void mode */
4169 if ( PL_parser->bufptr > PL_parser->oldbufptr
4170 && PL_parser->bufptr[-1] == ','
4171 && ckWARN(WARN_PARENTHESIS))
4173 char *s = PL_parser->bufptr;
4176 /* some heuristics to detect a potential error */
4177 while (*s && (strchr(", \t\n", *s)))
4181 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4183 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4186 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4188 while (*s && (strchr(", \t\n", *s)))
4194 if (sigil && (*s == ';' || *s == '=')) {
4195 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4196 "Parentheses missing around \"%s\" list",
4198 ? (PL_parser->in_my == KEY_our
4200 : PL_parser->in_my == KEY_state
4210 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4211 PL_parser->in_my = FALSE;
4212 PL_parser->in_my_stash = NULL;
4217 Perl_jmaybe(pTHX_ OP *o)
4219 PERL_ARGS_ASSERT_JMAYBE;
4221 if (o->op_type == OP_LIST) {
4223 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4224 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4229 PERL_STATIC_INLINE OP *
4230 S_op_std_init(pTHX_ OP *o)
4232 I32 type = o->op_type;
4234 PERL_ARGS_ASSERT_OP_STD_INIT;
4236 if (PL_opargs[type] & OA_RETSCALAR)
4238 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4239 o->op_targ = pad_alloc(type, SVs_PADTMP);
4244 PERL_STATIC_INLINE OP *
4245 S_op_integerize(pTHX_ OP *o)
4247 I32 type = o->op_type;
4249 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4251 /* integerize op. */
4252 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4255 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4258 if (type == OP_NEGATE)
4259 /* XXX might want a ck_negate() for this */
4260 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4266 S_fold_constants(pTHX_ OP *o)
4271 VOL I32 type = o->op_type;
4276 SV * const oldwarnhook = PL_warnhook;
4277 SV * const olddiehook = PL_diehook;
4279 U8 oldwarn = PL_dowarn;
4283 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4285 if (!(PL_opargs[type] & OA_FOLDCONST))
4294 #ifdef USE_LOCALE_CTYPE
4295 if (IN_LC_COMPILETIME(LC_CTYPE))
4304 #ifdef USE_LOCALE_COLLATE
4305 if (IN_LC_COMPILETIME(LC_COLLATE))
4310 /* XXX what about the numeric ops? */
4311 #ifdef USE_LOCALE_NUMERIC
4312 if (IN_LC_COMPILETIME(LC_NUMERIC))
4317 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4318 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4321 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4322 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4324 const char *s = SvPVX_const(sv);
4325 while (s < SvEND(sv)) {
4326 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4333 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4336 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4337 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4341 if (PL_parser && PL_parser->error_count)
4342 goto nope; /* Don't try to run w/ errors */
4344 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4345 const OPCODE type = curop->op_type;
4346 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4348 type != OP_SCALAR &&
4350 type != OP_PUSHMARK)
4356 curop = LINKLIST(o);
4357 old_next = o->op_next;
4361 old_cxix = cxstack_ix;
4362 create_eval_scope(NULL, G_FAKINGEVAL);
4364 /* Verify that we don't need to save it: */
4365 assert(PL_curcop == &PL_compiling);
4366 StructCopy(&PL_compiling, ¬_compiling, COP);
4367 PL_curcop = ¬_compiling;
4368 /* The above ensures that we run with all the correct hints of the
4369 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4370 assert(IN_PERL_RUNTIME);
4371 PL_warnhook = PERL_WARNHOOK_FATAL;
4375 /* Effective $^W=1. */
4376 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4377 PL_dowarn |= G_WARN_ON;
4382 sv = *(PL_stack_sp--);
4383 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4384 pad_swipe(o->op_targ, FALSE);
4386 else if (SvTEMP(sv)) { /* grab mortal temp? */
4387 SvREFCNT_inc_simple_void(sv);
4390 else { assert(SvIMMORTAL(sv)); }
4393 /* Something tried to die. Abandon constant folding. */
4394 /* Pretend the error never happened. */
4396 o->op_next = old_next;
4400 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4401 PL_warnhook = oldwarnhook;
4402 PL_diehook = olddiehook;
4403 /* XXX note that this croak may fail as we've already blown away
4404 * the stack - eg any nested evals */
4405 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4408 PL_dowarn = oldwarn;
4409 PL_warnhook = oldwarnhook;
4410 PL_diehook = olddiehook;
4411 PL_curcop = &PL_compiling;
4413 /* if we croaked, depending on how we croaked the eval scope
4414 * may or may not have already been popped */
4415 if (cxstack_ix > old_cxix) {
4416 assert(cxstack_ix == old_cxix + 1);
4417 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4418 delete_eval_scope();
4423 /* OP_STRINGIFY and constant folding are used to implement qq.
4424 Here the constant folding is an implementation detail that we
4425 want to hide. If the stringify op is itself already marked
4426 folded, however, then it is actually a folded join. */
4427 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4432 else if (!SvIMMORTAL(sv)) {
4436 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4437 if (!is_stringify) newop->op_folded = 1;
4445 S_gen_constant_list(pTHX_ OP *o)
4449 const SSize_t oldtmps_floor = PL_tmps_floor;
4454 if (PL_parser && PL_parser->error_count)
4455 return o; /* Don't attempt to run with errors */
4457 curop = LINKLIST(o);
4460 S_prune_chain_head(&curop);
4462 Perl_pp_pushmark(aTHX);
4465 assert (!(curop->op_flags & OPf_SPECIAL));
4466 assert(curop->op_type == OP_RANGE);
4467 Perl_pp_anonlist(aTHX);
4468 PL_tmps_floor = oldtmps_floor;
4470 OpTYPE_set(o, OP_RV2AV);
4471 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4472 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4473 o->op_opt = 0; /* needs to be revisited in rpeep() */
4474 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4476 /* replace subtree with an OP_CONST */
4477 curop = ((UNOP*)o)->op_first;
4478 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4481 if (AvFILLp(av) != -1)
4482 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4485 SvREADONLY_on(*svp);
4492 =head1 Optree Manipulation Functions
4495 /* List constructors */
4498 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4500 Append an item to the list of ops contained directly within a list-type
4501 op, returning the lengthened list. C<first> is the list-type op,
4502 and C<last> is the op to append to the list. C<optype> specifies the
4503 intended opcode for the list. If C<first> is not already a list of the
4504 right type, it will be upgraded into one. If either C<first> or C<last>
4505 is null, the other is returned unchanged.
4511 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4519 if (first->op_type != (unsigned)type
4520 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4522 return newLISTOP(type, 0, first, last);
4525 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4526 first->op_flags |= OPf_KIDS;
4531 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4533 Concatenate the lists of ops contained directly within two list-type ops,
4534 returning the combined list. C<first> and C<last> are the list-type ops
4535 to concatenate. C<optype> specifies the intended opcode for the list.
4536 If either C<first> or C<last> is not already a list of the right type,
4537 it will be upgraded into one. If either C<first> or C<last> is null,
4538 the other is returned unchanged.
4544 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4552 if (first->op_type != (unsigned)type)
4553 return op_prepend_elem(type, first, last);
4555 if (last->op_type != (unsigned)type)
4556 return op_append_elem(type, first, last);
4558 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4559 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4560 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4561 first->op_flags |= (last->op_flags & OPf_KIDS);
4563 S_op_destroy(aTHX_ last);
4569 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4571 Prepend an item to the list of ops contained directly within a list-type
4572 op, returning the lengthened list. C<first> is the op to prepend to the
4573 list, and C<last> is the list-type op. C<optype> specifies the intended
4574 opcode for the list. If C<last> is not already a list of the right type,
4575 it will be upgraded into one. If either C<first> or C<last> is null,
4576 the other is returned unchanged.
4582 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4590 if (last->op_type == (unsigned)type) {
4591 if (type == OP_LIST) { /* already a PUSHMARK there */
4592 /* insert 'first' after pushmark */
4593 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4594 if (!(first->op_flags & OPf_PARENS))
4595 last->op_flags &= ~OPf_PARENS;
4598 op_sibling_splice(last, NULL, 0, first);
4599 last->op_flags |= OPf_KIDS;
4603 return newLISTOP(type, 0, first, last);
4607 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4609 Converts C<o> into a list op if it is not one already, and then converts it
4610 into the specified C<type>, calling its check function, allocating a target if
4611 it needs one, and folding constants.
4613 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4614 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4615 C<op_convert_list> to make it the right type.
4621 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4624 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4625 if (!o || o->op_type != OP_LIST)
4626 o = force_list(o, 0);
4629 o->op_flags &= ~OPf_WANT;
4630 o->op_private &= ~OPpLVAL_INTRO;
4633 if (!(PL_opargs[type] & OA_MARK))
4634 op_null(cLISTOPo->op_first);
4636 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4637 if (kid2 && kid2->op_type == OP_COREARGS) {
4638 op_null(cLISTOPo->op_first);
4639 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4643 OpTYPE_set(o, type);
4644 o->op_flags |= flags;
4645 if (flags & OPf_FOLDED)
4648 o = CHECKOP(type, o);
4649 if (o->op_type != (unsigned)type)
4652 return fold_constants(op_integerize(op_std_init(o)));
4659 =head1 Optree construction
4661 =for apidoc Am|OP *|newNULLLIST
4663 Constructs, checks, and returns a new C<stub> op, which represents an
4664 empty list expression.
4670 Perl_newNULLLIST(pTHX)
4672 return newOP(OP_STUB, 0);
4675 /* promote o and any siblings to be a list if its not already; i.e.
4683 * pushmark - o - A - B
4685 * If nullit it true, the list op is nulled.
4689 S_force_list(pTHX_ OP *o, bool nullit)
4691 if (!o || o->op_type != OP_LIST) {
4694 /* manually detach any siblings then add them back later */
4695 rest = OpSIBLING(o);
4696 OpLASTSIB_set(o, NULL);
4698 o = newLISTOP(OP_LIST, 0, o, NULL);
4700 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4708 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4710 Constructs, checks, and returns an op of any list type. C<type> is
4711 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4712 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
4713 supply up to two ops to be direct children of the list op; they are
4714 consumed by this function and become part of the constructed op tree.
4716 For most list operators, the check function expects all the kid ops to be
4717 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4718 appropriate. What you want to do in that case is create an op of type
4719 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4720 See L</op_convert_list> for more information.
4727 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4732 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4733 || type == OP_CUSTOM);
4735 NewOp(1101, listop, 1, LISTOP);
4737 OpTYPE_set(listop, type);
4740 listop->op_flags = (U8)flags;
4744 else if (!first && last)
4747 OpMORESIB_set(first, last);
4748 listop->op_first = first;
4749 listop->op_last = last;
4750 if (type == OP_LIST) {
4751 OP* const pushop = newOP(OP_PUSHMARK, 0);
4752 OpMORESIB_set(pushop, first);
4753 listop->op_first = pushop;
4754 listop->op_flags |= OPf_KIDS;
4756 listop->op_last = pushop;
4758 if (listop->op_last)
4759 OpLASTSIB_set(listop->op_last, (OP*)listop);
4761 return CHECKOP(type, listop);
4765 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4767 Constructs, checks, and returns an op of any base type (any type that
4768 has no extra fields). C<type> is the opcode. C<flags> gives the
4769 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4776 Perl_newOP(pTHX_ I32 type, I32 flags)
4781 if (type == -OP_ENTEREVAL) {
4782 type = OP_ENTEREVAL;
4783 flags |= OPpEVAL_BYTES<<8;
4786 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4787 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4788 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4789 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4791 NewOp(1101, o, 1, OP);
4792 OpTYPE_set(o, type);
4793 o->op_flags = (U8)flags;
4796 o->op_private = (U8)(0 | (flags >> 8));
4797 if (PL_opargs[type] & OA_RETSCALAR)
4799 if (PL_opargs[type] & OA_TARGET)
4800 o->op_targ = pad_alloc(type, SVs_PADTMP);
4801 return CHECKOP(type, o);
4805 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4807 Constructs, checks, and returns an op of any unary type. C<type> is
4808 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4809 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4810 bits, the eight bits of C<op_private>, except that the bit with value 1
4811 is automatically set. C<first> supplies an optional op to be the direct
4812 child of the unary op; it is consumed by this function and become part
4813 of the constructed op tree.
4819 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4824 if (type == -OP_ENTEREVAL) {
4825 type = OP_ENTEREVAL;
4826 flags |= OPpEVAL_BYTES<<8;
4829 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4830 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4831 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4832 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4833 || type == OP_SASSIGN
4834 || type == OP_ENTERTRY
4835 || type == OP_CUSTOM
4836 || type == OP_NULL );
4839 first = newOP(OP_STUB, 0);
4840 if (PL_opargs[type] & OA_MARK)
4841 first = force_list(first, 1);
4843 NewOp(1101, unop, 1, UNOP);