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 const 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 switch (curop->op_type) {
4347 if ( (curop->op_private & OPpCONST_BARE)
4348 && (curop->op_private & OPpCONST_STRICT)) {
4349 no_bareword_allowed(curop);
4357 /* Foldable; move to next op in list */
4361 /* No other op types are considered foldable */
4366 curop = LINKLIST(o);
4367 old_next = o->op_next;
4371 old_cxix = cxstack_ix;
4372 create_eval_scope(NULL, G_FAKINGEVAL);
4374 /* Verify that we don't need to save it: */
4375 assert(PL_curcop == &PL_compiling);
4376 StructCopy(&PL_compiling, ¬_compiling, COP);
4377 PL_curcop = ¬_compiling;
4378 /* The above ensures that we run with all the correct hints of the
4379 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4380 assert(IN_PERL_RUNTIME);
4381 PL_warnhook = PERL_WARNHOOK_FATAL;
4385 /* Effective $^W=1. */
4386 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4387 PL_dowarn |= G_WARN_ON;
4392 sv = *(PL_stack_sp--);
4393 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4394 pad_swipe(o->op_targ, FALSE);
4396 else if (SvTEMP(sv)) { /* grab mortal temp? */
4397 SvREFCNT_inc_simple_void(sv);
4400 else { assert(SvIMMORTAL(sv)); }
4403 /* Something tried to die. Abandon constant folding. */
4404 /* Pretend the error never happened. */
4406 o->op_next = old_next;
4410 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4411 PL_warnhook = oldwarnhook;
4412 PL_diehook = olddiehook;
4413 /* XXX note that this croak may fail as we've already blown away
4414 * the stack - eg any nested evals */
4415 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4418 PL_dowarn = oldwarn;
4419 PL_warnhook = oldwarnhook;
4420 PL_diehook = olddiehook;
4421 PL_curcop = &PL_compiling;
4423 /* if we croaked, depending on how we croaked the eval scope
4424 * may or may not have already been popped */
4425 if (cxstack_ix > old_cxix) {
4426 assert(cxstack_ix == old_cxix + 1);
4427 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4428 delete_eval_scope();
4433 /* OP_STRINGIFY and constant folding are used to implement qq.
4434 Here the constant folding is an implementation detail that we
4435 want to hide. If the stringify op is itself already marked
4436 folded, however, then it is actually a folded join. */
4437 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4442 else if (!SvIMMORTAL(sv)) {
4446 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4447 if (!is_stringify) newop->op_folded = 1;
4455 S_gen_constant_list(pTHX_ OP *o)
4459 const SSize_t oldtmps_floor = PL_tmps_floor;
4464 if (PL_parser && PL_parser->error_count)
4465 return o; /* Don't attempt to run with errors */
4467 curop = LINKLIST(o);
4470 S_prune_chain_head(&curop);
4472 Perl_pp_pushmark(aTHX);
4475 assert (!(curop->op_flags & OPf_SPECIAL));
4476 assert(curop->op_type == OP_RANGE);
4477 Perl_pp_anonlist(aTHX);
4478 PL_tmps_floor = oldtmps_floor;
4480 OpTYPE_set(o, OP_RV2AV);
4481 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4482 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4483 o->op_opt = 0; /* needs to be revisited in rpeep() */
4484 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4486 /* replace subtree with an OP_CONST */
4487 curop = ((UNOP*)o)->op_first;
4488 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4491 if (AvFILLp(av) != -1)
4492 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4495 SvREADONLY_on(*svp);
4502 =head1 Optree Manipulation Functions
4505 /* List constructors */
4508 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4510 Append an item to the list of ops contained directly within a list-type
4511 op, returning the lengthened list. C<first> is the list-type op,
4512 and C<last> is the op to append to the list. C<optype> specifies the
4513 intended opcode for the list. If C<first> is not already a list of the
4514 right type, it will be upgraded into one. If either C<first> or C<last>
4515 is null, the other is returned unchanged.
4521 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4529 if (first->op_type != (unsigned)type
4530 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4532 return newLISTOP(type, 0, first, last);
4535 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4536 first->op_flags |= OPf_KIDS;
4541 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4543 Concatenate the lists of ops contained directly within two list-type ops,
4544 returning the combined list. C<first> and C<last> are the list-type ops
4545 to concatenate. C<optype> specifies the intended opcode for the list.
4546 If either C<first> or C<last> is not already a list of the right type,
4547 it will be upgraded into one. If either C<first> or C<last> is null,
4548 the other is returned unchanged.
4554 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4562 if (first->op_type != (unsigned)type)
4563 return op_prepend_elem(type, first, last);
4565 if (last->op_type != (unsigned)type)
4566 return op_append_elem(type, first, last);
4568 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4569 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4570 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4571 first->op_flags |= (last->op_flags & OPf_KIDS);
4573 S_op_destroy(aTHX_ last);
4579 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4581 Prepend an item to the list of ops contained directly within a list-type
4582 op, returning the lengthened list. C<first> is the op to prepend to the
4583 list, and C<last> is the list-type op. C<optype> specifies the intended
4584 opcode for the list. If C<last> is not already a list of the right type,
4585 it will be upgraded into one. If either C<first> or C<last> is null,
4586 the other is returned unchanged.
4592 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4600 if (last->op_type == (unsigned)type) {
4601 if (type == OP_LIST) { /* already a PUSHMARK there */
4602 /* insert 'first' after pushmark */
4603 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4604 if (!(first->op_flags & OPf_PARENS))
4605 last->op_flags &= ~OPf_PARENS;
4608 op_sibling_splice(last, NULL, 0, first);
4609 last->op_flags |= OPf_KIDS;
4613 return newLISTOP(type, 0, first, last);
4617 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4619 Converts C<o> into a list op if it is not one already, and then converts it
4620 into the specified C<type>, calling its check function, allocating a target if
4621 it needs one, and folding constants.
4623 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4624 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4625 C<op_convert_list> to make it the right type.
4631 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4634 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4635 if (!o || o->op_type != OP_LIST)
4636 o = force_list(o, 0);
4639 o->op_flags &= ~OPf_WANT;
4640 o->op_private &= ~OPpLVAL_INTRO;
4643 if (!(PL_opargs[type] & OA_MARK))
4644 op_null(cLISTOPo->op_first);
4646 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4647 if (kid2 && kid2->op_type == OP_COREARGS) {
4648 op_null(cLISTOPo->op_first);
4649 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4653 OpTYPE_set(o, type);
4654 o->op_flags |= flags;
4655 if (flags & OPf_FOLDED)
4658 o = CHECKOP(type, o);
4659 if (o->op_type != (unsigned)type)
4662 return fold_constants(op_integerize(op_std_init(o)));
4669 =head1 Optree construction
4671 =for apidoc Am|OP *|newNULLLIST
4673 Constructs, checks, and returns a new C<stub> op, which represents an
4674 empty list expression.
4680 Perl_newNULLLIST(pTHX)
4682 return newOP(OP_STUB, 0);
4685 /* promote o and any siblings to be a list if its not already; i.e.
4693 * pushmark - o - A - B
4695 * If nullit it true, the list op is nulled.
4699 S_force_list(pTHX_ OP *o, bool nullit)
4701 if (!o || o->op_type != OP_LIST) {
4704 /* manually detach any siblings then add them back later */
4705 rest = OpSIBLING(o);
4706 OpLASTSIB_set(o, NULL);
4708 o = newLISTOP(OP_LIST, 0, o, NULL);
4710 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4718 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4720 Constructs, checks, and returns an op of any list type. C<type> is
4721 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4722 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
4723 supply up to two ops to be direct children of the list op; they are
4724 consumed by this function and become part of the constructed op tree.
4726 For most list operators, the check function expects all the kid ops to be
4727 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4728 appropriate. What you want to do in that case is create an op of type
4729 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4730 See L</op_convert_list> for more information.
4737 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4742 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4743 || type == OP_CUSTOM);
4745 NewOp(1101, listop, 1, LISTOP);
4747 OpTYPE_set(listop, type);
4750 listop->op_flags = (U8)flags;
4754 else if (!first && last)
4757 OpMORESIB_set(first, last);
4758 listop->op_first = first;
4759 listop->op_last = last;
4760 if (type == OP_LIST) {
4761 OP* const pushop = newOP(OP_PUSHMARK, 0);
4762 OpMORESIB_set(pushop, first);
4763 listop->op_first = pushop;
4764 listop->op_flags |= OPf_KIDS;
4766 listop->op_last = pushop;
4768 if (listop->op_last)
4769 OpLASTSIB_set(listop->op_last, (OP*)listop);
4771 return CHECKOP(type, listop);
4775 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4777 Constructs, checks, and returns an op of any base type (any type that
4778 has no extra fields). C<type> is the opcode. C<flags> gives the
4779 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4786 Perl_newOP(pTHX_ I32 type, I32 flags)
4791 if (type == -OP_ENTEREVAL) {
4792 type = OP_ENTEREVAL;
4793 flags |= OPpEVAL_BYTES<<8;
4796 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4797 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4798 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4799 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4801 NewOp(1101, o, 1, OP);
4802 OpTYPE_set(o, type);
4803 o->op_flags = (U8)flags;
4806 o->op_private = (U8)(0 | (flags >> 8));
4807 if (PL_opargs[type] & OA_RETSCALAR)
4809 if (PL_opargs[type] & OA_TARGET)
4810 o->op_targ = pad_alloc(type, SVs_PADTMP);
4811 return CHECKOP(type, o);
4815 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4817 Constructs, checks, and returns an op of any unary type. C<type> is
4818 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4819 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4820 bits, the eight bits of C<op_private>, except that the bit with value 1
4821 is automatically set. C<first> supplies an optional op to be the direct
4822 child of the unary op; it is consumed by this function and become part
4823 of the constructed op tree.
4829 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4834 if (type == -OP_ENTEREVAL) {
4835 type = OP_ENTEREVAL;
4836 flags |= OPpEVAL_BYTES<<8;
4839 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4840 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4841 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4842 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4843 || type == OP_SASSIGN
4844 || type == OP_ENTERTRY
4845 || type == OP_CUSTOM
4846 || type == OP_NULL );
4849 first = newOP(OP_STUB, 0);
4850 if (PL_opargs[type] & OA_MARK)
4851 first = force_list(first, 1);
4853 NewOp(1101, unop, 1, UNOP);
4854 OpTYPE_set(unop, type);
4855 unop->op_first = first;
4856 unop->op_flags = (U8)(flags | OPf_KIDS);
4857 unop->op_private = (U8)(1 | (flags >> 8));
4859 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4860 OpLASTSIB_set(first, (OP*)unop);
4862 unop = (UNOP*) CHECKOP(type, unop);
4866 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4870 =for apidoc newUNOP_AUX
4872 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4873 initialised to C<aux>
4879 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4884 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4885 || type == OP_CUSTOM);
4887 NewOp(1101, unop, 1, UNOP_AUX);
4888 unop->op_type = (OPCODE)type;
4889 unop->op_ppaddr = PL_ppaddr[type];
4890 unop->op_first = first;
4891 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4892 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4895 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4896 OpLASTSIB_set(first, (OP*)unop);
4898 unop = (UNOP_AUX*) CHECKOP(type, unop);
4900 return op_std_init((OP *) unop);
4904 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4906 Constructs, checks, and returns an op of method type with a method name
4907 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
4908 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4909 and, shifted up eight bits, the eight bits of C<op_private>, except that
4910 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
4911 op which evaluates method name; it is consumed by this function and
4912 become part of the constructed op tree.
4913 Supported optypes: C<OP_METHOD>.
4919 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4923 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4924 || type == OP_CUSTOM);
4926 NewOp(1101, methop, 1, METHOP);
4928 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4929 methop->op_flags = (U8)(flags | OPf_KIDS);
4930 methop->op_u.op_first = dynamic_meth;
4931 methop->op_private = (U8)(1 | (flags >> 8));
4933 if (!OpHAS_SIBLING(dynamic_meth))
4934 OpLASTSIB_set(dynamic_meth, (OP*)methop);
4938 methop->op_flags = (U8)(flags & ~OPf_KIDS);
4939 methop->op_u.op_meth_sv = const_meth;
4940 methop->op_private = (U8)(0 | (flags >> 8));
4941 methop->op_next = (OP*)methop;
4945 methop->op_rclass_targ = 0;
4947 methop->op_rclass_sv = NULL;
4950 OpTYPE_set(methop, type);
4951 return CHECKOP(type, methop);
4955 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4956 PERL_ARGS_ASSERT_NEWMETHOP;
4957 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4961 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4963 Constructs, checks, and returns an op of method type with a constant
4964 method name. C<type> is the opcode. C<flags> gives the eight bits of
4965 C<op_flags>, and, shifted up eight bits, the eight bits of
4966 C<op_private>. C<const_meth> supplies a constant method name;
4967 it must be a shared COW string.
4968 Supported optypes: C<OP_METHOD_NAMED>.
4974 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4975 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4976 return newMETHOP_internal(type, flags, NULL, const_meth);
4980 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4982 Constructs, checks, and returns an op of any binary type. C<type>
4983 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
4984 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4985 the eight bits of C<op_private>, except that the bit with value 1 or
4986 2 is automatically set as required. C<first> and C<last> supply up to
4987 two ops to be the direct children of the binary op; they are consumed
4988 by this function and become part of the constructed op tree.
4994 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4999 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5000 || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
5002 NewOp(1101, binop, 1, BINOP);
5005 first = newOP(OP_NULL, 0);
5007 OpTYPE_set(binop, type);
5008 binop->op_first = first;
5009 binop->op_flags = (U8)(flags | OPf_KIDS);
5012 binop->op_private = (U8)(1 | (flags >> 8));
5015 binop->op_private = (U8)(2 | (flags >> 8));
5016 OpMORESIB_set(first, last);
5019 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5020 OpLASTSIB_set(last, (OP*)binop);
5022 binop->op_last = OpSIBLING(binop->op_first);
5024 OpLASTSIB_set(binop->op_last, (OP*)binop);
5026 binop = (BINOP*)CHECKOP(type, binop);
5027 if (binop->op_next || binop->op_type != (OPCODE)type)
5030 return fold_constants(op_integerize(op_std_init((OP *)binop)));
5033 static int uvcompare(const void *a, const void *b)
5034 __attribute__nonnull__(1)
5035 __attribute__nonnull__(2)
5036 __attribute__pure__;
5037 static int uvcompare(const void *a, const void *b)
5039 if (*((const UV *)a) < (*(const UV *)b))
5041 if (*((const UV *)a) > (*(const UV *)b))
5043 if (*((const UV *)a+1) < (*(const UV *)b+1))
5045 if (*((const UV *)a+1) > (*(const UV *)b+1))
5051 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5053 SV * const tstr = ((SVOP*)expr)->op_sv;
5055 ((SVOP*)repl)->op_sv;
5058 const U8 *t = (U8*)SvPV_const(tstr, tlen);
5059 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5065 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5066 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5067 I32 del = o->op_private & OPpTRANS_DELETE;
5070 PERL_ARGS_ASSERT_PMTRANS;
5072 PL_hints |= HINT_BLOCK_SCOPE;
5075 o->op_private |= OPpTRANS_FROM_UTF;
5078 o->op_private |= OPpTRANS_TO_UTF;
5080 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5081 SV* const listsv = newSVpvs("# comment\n");
5083 const U8* tend = t + tlen;
5084 const U8* rend = r + rlen;
5100 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5101 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5104 const U32 flags = UTF8_ALLOW_DEFAULT;
5108 t = tsave = bytes_to_utf8(t, &len);
5111 if (!to_utf && rlen) {
5113 r = rsave = bytes_to_utf8(r, &len);
5117 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5118 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5122 U8 tmpbuf[UTF8_MAXBYTES+1];
5125 Newx(cp, 2*tlen, UV);
5127 transv = newSVpvs("");
5129 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5131 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5133 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5137 cp[2*i+1] = cp[2*i];
5141 qsort(cp, i, 2*sizeof(UV), uvcompare);
5142 for (j = 0; j < i; j++) {
5144 diff = val - nextmin;
5146 t = uvchr_to_utf8(tmpbuf,nextmin);
5147 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5149 U8 range_mark = ILLEGAL_UTF8_BYTE;
5150 t = uvchr_to_utf8(tmpbuf, val - 1);
5151 sv_catpvn(transv, (char *)&range_mark, 1);
5152 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5159 t = uvchr_to_utf8(tmpbuf,nextmin);
5160 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5162 U8 range_mark = ILLEGAL_UTF8_BYTE;
5163 sv_catpvn(transv, (char *)&range_mark, 1);
5165 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5166 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5167 t = (const U8*)SvPVX_const(transv);
5168 tlen = SvCUR(transv);
5172 else if (!rlen && !del) {
5173 r = t; rlen = tlen; rend = tend;
5176 if ((!rlen && !del) || t == r ||
5177 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5179 o->op_private |= OPpTRANS_IDENTICAL;
5183 while (t < tend || tfirst <= tlast) {
5184 /* see if we need more "t" chars */
5185 if (tfirst > tlast) {
5186 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5188 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5190 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5197 /* now see if we need more "r" chars */
5198 if (rfirst > rlast) {
5200 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5202 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5204 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5213 rfirst = rlast = 0xffffffff;
5217 /* now see which range will peter out first, if either. */
5218 tdiff = tlast - tfirst;
5219 rdiff = rlast - rfirst;
5220 tcount += tdiff + 1;
5221 rcount += rdiff + 1;
5228 if (rfirst == 0xffffffff) {
5229 diff = tdiff; /* oops, pretend rdiff is infinite */
5231 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5232 (long)tfirst, (long)tlast);
5234 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5238 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5239 (long)tfirst, (long)(tfirst + diff),
5242 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5243 (long)tfirst, (long)rfirst);
5245 if (rfirst + diff > max)
5246 max = rfirst + diff;
5248 grows = (tfirst < rfirst &&
5249 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5261 else if (max > 0xff)
5266 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5268 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5269 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5270 PAD_SETSV(cPADOPo->op_padix, swash);
5272 SvREADONLY_on(swash);
5274 cSVOPo->op_sv = swash;
5276 SvREFCNT_dec(listsv);
5277 SvREFCNT_dec(transv);
5279 if (!del && havefinal && rlen)
5280 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5281 newSVuv((UV)final), 0);
5290 else if (rlast == 0xffffffff)
5296 tbl = (short*)PerlMemShared_calloc(
5297 (o->op_private & OPpTRANS_COMPLEMENT) &&
5298 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5300 cPVOPo->op_pv = (char*)tbl;
5302 for (i = 0; i < (I32)tlen; i++)
5304 for (i = 0, j = 0; i < 256; i++) {
5306 if (j >= (I32)rlen) {
5315 if (i < 128 && r[j] >= 128)
5325 o->op_private |= OPpTRANS_IDENTICAL;
5327 else if (j >= (I32)rlen)
5332 PerlMemShared_realloc(tbl,
5333 (0x101+rlen-j) * sizeof(short));
5334 cPVOPo->op_pv = (char*)tbl;
5336 tbl[0x100] = (short)(rlen - j);
5337 for (i=0; i < (I32)rlen - j; i++)
5338 tbl[0x101+i] = r[j+i];
5342 if (!rlen && !del) {
5345 o->op_private |= OPpTRANS_IDENTICAL;
5347 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5348 o->op_private |= OPpTRANS_IDENTICAL;
5350 for (i = 0; i < 256; i++)
5352 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5353 if (j >= (I32)rlen) {
5355 if (tbl[t[i]] == -1)
5361 if (tbl[t[i]] == -1) {
5362 if (t[i] < 128 && r[j] >= 128)
5370 if(del && rlen == tlen) {
5371 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5372 } else if(rlen > tlen && !complement) {
5373 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5377 o->op_private |= OPpTRANS_GROWS;
5385 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5387 Constructs, checks, and returns an op of any pattern matching type.
5388 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
5389 and, shifted up eight bits, the eight bits of C<op_private>.
5395 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5400 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5401 || type == OP_CUSTOM);
5403 NewOp(1101, pmop, 1, PMOP);
5404 OpTYPE_set(pmop, type);
5405 pmop->op_flags = (U8)flags;
5406 pmop->op_private = (U8)(0 | (flags >> 8));
5407 if (PL_opargs[type] & OA_RETSCALAR)
5410 if (PL_hints & HINT_RE_TAINT)
5411 pmop->op_pmflags |= PMf_RETAINT;
5412 #ifdef USE_LOCALE_CTYPE
5413 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5414 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5419 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5421 if (PL_hints & HINT_RE_FLAGS) {
5422 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5423 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5425 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5426 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5427 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5429 if (reflags && SvOK(reflags)) {
5430 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5436 assert(SvPOK(PL_regex_pad[0]));
5437 if (SvCUR(PL_regex_pad[0])) {
5438 /* Pop off the "packed" IV from the end. */
5439 SV *const repointer_list = PL_regex_pad[0];
5440 const char *p = SvEND(repointer_list) - sizeof(IV);
5441 const IV offset = *((IV*)p);
5443 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5445 SvEND_set(repointer_list, p);
5447 pmop->op_pmoffset = offset;
5448 /* This slot should be free, so assert this: */
5449 assert(PL_regex_pad[offset] == &PL_sv_undef);
5451 SV * const repointer = &PL_sv_undef;
5452 av_push(PL_regex_padav, repointer);
5453 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5454 PL_regex_pad = AvARRAY(PL_regex_padav);
5458 return CHECKOP(type, pmop);
5466 /* Any pad names in scope are potentially lvalues. */
5467 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5468 PADNAME *pn = PAD_COMPNAME_SV(i);
5469 if (!pn || !PadnameLEN(pn))
5471 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5472 S_mark_padname_lvalue(aTHX_ pn);
5476 /* Given some sort of match op o, and an expression expr containing a
5477 * pattern, either compile expr into a regex and attach it to o (if it's
5478 * constant), or convert expr into a runtime regcomp op sequence (if it's
5481 * isreg indicates that the pattern is part of a regex construct, eg
5482 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5483 * split "pattern", which aren't. In the former case, expr will be a list
5484 * if the pattern contains more than one term (eg /a$b/).
5486 * When the pattern has been compiled within a new anon CV (for
5487 * qr/(?{...})/ ), then floor indicates the savestack level just before
5488 * the new sub was created
5492 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5496 I32 repl_has_vars = 0;
5497 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5498 bool is_compiletime;
5501 PERL_ARGS_ASSERT_PMRUNTIME;
5504 return pmtrans(o, expr, repl);
5507 /* find whether we have any runtime or code elements;
5508 * at the same time, temporarily set the op_next of each DO block;
5509 * then when we LINKLIST, this will cause the DO blocks to be excluded
5510 * from the op_next chain (and from having LINKLIST recursively
5511 * applied to them). We fix up the DOs specially later */
5515 if (expr->op_type == OP_LIST) {
5517 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5518 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5520 assert(!o->op_next);
5521 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5522 assert(PL_parser && PL_parser->error_count);
5523 /* This can happen with qr/ (?{(^{})/. Just fake up
5524 the op we were expecting to see, to avoid crashing
5526 op_sibling_splice(expr, o, 0,
5527 newSVOP(OP_CONST, 0, &PL_sv_no));
5529 o->op_next = OpSIBLING(o);
5531 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5535 else if (expr->op_type != OP_CONST)
5540 /* fix up DO blocks; treat each one as a separate little sub;
5541 * also, mark any arrays as LIST/REF */
5543 if (expr->op_type == OP_LIST) {
5545 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5547 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5548 assert( !(o->op_flags & OPf_WANT));
5549 /* push the array rather than its contents. The regex
5550 * engine will retrieve and join the elements later */
5551 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5555 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5557 o->op_next = NULL; /* undo temporary hack from above */
5560 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5561 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5563 assert(leaveop->op_first->op_type == OP_ENTER);
5564 assert(OpHAS_SIBLING(leaveop->op_first));
5565 o->op_next = OpSIBLING(leaveop->op_first);
5567 assert(leaveop->op_flags & OPf_KIDS);
5568 assert(leaveop->op_last->op_next == (OP*)leaveop);
5569 leaveop->op_next = NULL; /* stop on last op */
5570 op_null((OP*)leaveop);
5574 OP *scope = cLISTOPo->op_first;
5575 assert(scope->op_type == OP_SCOPE);
5576 assert(scope->op_flags & OPf_KIDS);
5577 scope->op_next = NULL; /* stop on last op */
5580 /* have to peep the DOs individually as we've removed it from
5581 * the op_next chain */
5583 S_prune_chain_head(&(o->op_next));
5585 /* runtime finalizes as part of finalizing whole tree */
5589 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5590 assert( !(expr->op_flags & OPf_WANT));
5591 /* push the array rather than its contents. The regex
5592 * engine will retrieve and join the elements later */
5593 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5596 PL_hints |= HINT_BLOCK_SCOPE;
5598 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5600 if (is_compiletime) {
5601 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5602 regexp_engine const *eng = current_re_engine();
5604 if (o->op_flags & OPf_SPECIAL)
5605 rx_flags |= RXf_SPLIT;
5607 if (!has_code || !eng->op_comp) {
5608 /* compile-time simple constant pattern */
5610 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5611 /* whoops! we guessed that a qr// had a code block, but we
5612 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5613 * that isn't required now. Note that we have to be pretty
5614 * confident that nothing used that CV's pad while the
5615 * regex was parsed, except maybe op targets for \Q etc.
5616 * If there were any op targets, though, they should have
5617 * been stolen by constant folding.
5621 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5622 while (++i <= AvFILLp(PL_comppad)) {
5623 assert(!PL_curpad[i]);
5626 /* But we know that one op is using this CV's slab. */
5627 cv_forget_slab(PL_compcv);
5629 pm->op_pmflags &= ~PMf_HAS_CV;
5634 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5635 rx_flags, pm->op_pmflags)
5636 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5637 rx_flags, pm->op_pmflags)
5642 /* compile-time pattern that includes literal code blocks */
5643 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5646 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5649 if (pm->op_pmflags & PMf_HAS_CV) {
5651 /* this QR op (and the anon sub we embed it in) is never
5652 * actually executed. It's just a placeholder where we can
5653 * squirrel away expr in op_code_list without the peephole
5654 * optimiser etc processing it for a second time */
5655 OP *qr = newPMOP(OP_QR, 0);
5656 ((PMOP*)qr)->op_code_list = expr;
5658 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5659 SvREFCNT_inc_simple_void(PL_compcv);
5660 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5661 ReANY(re)->qr_anoncv = cv;
5663 /* attach the anon CV to the pad so that
5664 * pad_fixup_inner_anons() can find it */
5665 (void)pad_add_anon(cv, o->op_type);
5666 SvREFCNT_inc_simple_void(cv);
5669 pm->op_code_list = expr;
5674 /* runtime pattern: build chain of regcomp etc ops */
5676 PADOFFSET cv_targ = 0;
5678 reglist = isreg && expr->op_type == OP_LIST;
5683 pm->op_code_list = expr;
5684 /* don't free op_code_list; its ops are embedded elsewhere too */
5685 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5688 if (o->op_flags & OPf_SPECIAL)
5689 pm->op_pmflags |= PMf_SPLIT;
5691 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5692 * to allow its op_next to be pointed past the regcomp and
5693 * preceding stacking ops;
5694 * OP_REGCRESET is there to reset taint before executing the
5696 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5697 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5699 if (pm->op_pmflags & PMf_HAS_CV) {
5700 /* we have a runtime qr with literal code. This means
5701 * that the qr// has been wrapped in a new CV, which
5702 * means that runtime consts, vars etc will have been compiled
5703 * against a new pad. So... we need to execute those ops
5704 * within the environment of the new CV. So wrap them in a call
5705 * to a new anon sub. i.e. for
5709 * we build an anon sub that looks like
5711 * sub { "a", $b, '(?{...})' }
5713 * and call it, passing the returned list to regcomp.
5714 * Or to put it another way, the list of ops that get executed
5718 * ------ -------------------
5719 * pushmark (for regcomp)
5720 * pushmark (for entersub)
5724 * regcreset regcreset
5726 * const("a") const("a")
5728 * const("(?{...})") const("(?{...})")
5733 SvREFCNT_inc_simple_void(PL_compcv);
5734 CvLVALUE_on(PL_compcv);
5735 /* these lines are just an unrolled newANONATTRSUB */
5736 expr = newSVOP(OP_ANONCODE, 0,
5737 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5738 cv_targ = expr->op_targ;
5739 expr = newUNOP(OP_REFGEN, 0, expr);
5741 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5744 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5745 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5746 | (reglist ? OPf_STACKED : 0);
5747 rcop->op_targ = cv_targ;
5749 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5750 if (PL_hints & HINT_RE_EVAL)
5751 S_set_haseval(aTHX);
5753 /* establish postfix order */
5754 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5756 rcop->op_next = expr;
5757 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5760 rcop->op_next = LINKLIST(expr);
5761 expr->op_next = (OP*)rcop;
5764 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5770 /* If we are looking at s//.../e with a single statement, get past
5771 the implicit do{}. */
5772 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5773 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5774 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5777 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5778 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5779 && !OpHAS_SIBLING(sib))
5782 if (curop->op_type == OP_CONST)
5784 else if (( (curop->op_type == OP_RV2SV ||
5785 curop->op_type == OP_RV2AV ||
5786 curop->op_type == OP_RV2HV ||
5787 curop->op_type == OP_RV2GV)
5788 && cUNOPx(curop)->op_first
5789 && cUNOPx(curop)->op_first->op_type == OP_GV )
5790 || curop->op_type == OP_PADSV
5791 || curop->op_type == OP_PADAV
5792 || curop->op_type == OP_PADHV
5793 || curop->op_type == OP_PADANY) {
5801 || !RX_PRELEN(PM_GETRE(pm))
5802 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5804 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5805 op_prepend_elem(o->op_type, scalar(repl), o);
5808 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5809 rcop->op_private = 1;
5811 /* establish postfix order */
5812 rcop->op_next = LINKLIST(repl);
5813 repl->op_next = (OP*)rcop;
5815 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5816 assert(!(pm->op_pmflags & PMf_ONCE));
5817 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5826 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5828 Constructs, checks, and returns an op of any type that involves an
5829 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
5830 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
5831 takes ownership of one reference to it.
5837 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5842 PERL_ARGS_ASSERT_NEWSVOP;
5844 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5845 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5846 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5847 || type == OP_CUSTOM);
5849 NewOp(1101, svop, 1, SVOP);
5850 OpTYPE_set(svop, type);
5852 svop->op_next = (OP*)svop;
5853 svop->op_flags = (U8)flags;
5854 svop->op_private = (U8)(0 | (flags >> 8));
5855 if (PL_opargs[type] & OA_RETSCALAR)
5857 if (PL_opargs[type] & OA_TARGET)
5858 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5859 return CHECKOP(type, svop);
5863 =for apidoc Am|OP *|newDEFSVOP|
5865 Constructs and returns an op to access C<$_>.
5871 Perl_newDEFSVOP(pTHX)
5873 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5879 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5881 Constructs, checks, and returns an op of any type that involves a
5882 reference to a pad element. C<type> is the opcode. C<flags> gives the
5883 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5884 is populated with C<sv>; this function takes ownership of one reference
5887 This function only exists if Perl has been compiled to use ithreads.
5893 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5898 PERL_ARGS_ASSERT_NEWPADOP;
5900 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5901 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5902 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5903 || type == OP_CUSTOM);
5905 NewOp(1101, padop, 1, PADOP);
5906 OpTYPE_set(padop, type);
5908 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5909 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5910 PAD_SETSV(padop->op_padix, sv);
5912 padop->op_next = (OP*)padop;
5913 padop->op_flags = (U8)flags;
5914 if (PL_opargs[type] & OA_RETSCALAR)
5916 if (PL_opargs[type] & OA_TARGET)
5917 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5918 return CHECKOP(type, padop);
5921 #endif /* USE_ITHREADS */
5924 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5926 Constructs, checks, and returns an op of any type that involves an
5927 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
5928 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
5929 reference; calling this function does not transfer ownership of any
5936 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5938 PERL_ARGS_ASSERT_NEWGVOP;
5941 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5943 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5948 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5950 Constructs, checks, and returns an op of any type that involves an
5951 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
5952 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
5953 must have been allocated using C<PerlMemShared_malloc>; the memory will
5954 be freed when the op is destroyed.
5960 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5963 const bool utf8 = cBOOL(flags & SVf_UTF8);
5968 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5969 || type == OP_RUNCV || type == OP_CUSTOM
5970 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5972 NewOp(1101, pvop, 1, PVOP);
5973 OpTYPE_set(pvop, type);
5975 pvop->op_next = (OP*)pvop;
5976 pvop->op_flags = (U8)flags;
5977 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5978 if (PL_opargs[type] & OA_RETSCALAR)
5980 if (PL_opargs[type] & OA_TARGET)
5981 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5982 return CHECKOP(type, pvop);
5986 Perl_package(pTHX_ OP *o)
5988 SV *const sv = cSVOPo->op_sv;
5990 PERL_ARGS_ASSERT_PACKAGE;
5992 SAVEGENERICSV(PL_curstash);
5993 save_item(PL_curstname);
5995 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5997 sv_setsv(PL_curstname, sv);
5999 PL_hints |= HINT_BLOCK_SCOPE;
6000 PL_parser->copline = NOLINE;
6006 Perl_package_version( pTHX_ OP *v )
6008 U32 savehints = PL_hints;
6009 PERL_ARGS_ASSERT_PACKAGE_VERSION;
6010 PL_hints &= ~HINT_STRICT_VARS;
6011 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6012 PL_hints = savehints;
6017 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6022 SV *use_version = NULL;
6024 PERL_ARGS_ASSERT_UTILIZE;
6026 if (idop->op_type != OP_CONST)
6027 Perl_croak(aTHX_ "Module name must be constant");
6032 SV * const vesv = ((SVOP*)version)->op_sv;
6034 if (!arg && !SvNIOKp(vesv)) {
6041 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6042 Perl_croak(aTHX_ "Version number must be a constant number");
6044 /* Make copy of idop so we don't free it twice */
6045 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6047 /* Fake up a method call to VERSION */
6048 meth = newSVpvs_share("VERSION");
6049 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6050 op_append_elem(OP_LIST,
6051 op_prepend_elem(OP_LIST, pack, version),
6052 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6056 /* Fake up an import/unimport */
6057 if (arg && arg->op_type == OP_STUB) {
6058 imop = arg; /* no import on explicit () */
6060 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6061 imop = NULL; /* use 5.0; */
6063 use_version = ((SVOP*)idop)->op_sv;
6065 idop->op_private |= OPpCONST_NOVER;
6070 /* Make copy of idop so we don't free it twice */
6071 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6073 /* Fake up a method call to import/unimport */
6075 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6076 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6077 op_append_elem(OP_LIST,
6078 op_prepend_elem(OP_LIST, pack, arg),
6079 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6083 /* Fake up the BEGIN {}, which does its thing immediately. */
6085 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6088 op_append_elem(OP_LINESEQ,
6089 op_append_elem(OP_LINESEQ,
6090 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6091 newSTATEOP(0, NULL, veop)),
6092 newSTATEOP(0, NULL, imop) ));
6096 * feature bundle that corresponds to the required version. */
6097 use_version = sv_2mortal(new_version(use_version));
6098 S_enable_feature_bundle(aTHX_ use_version);
6100 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6101 if (vcmp(use_version,
6102 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6103 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6104 PL_hints |= HINT_STRICT_REFS;
6105 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6106 PL_hints |= HINT_STRICT_SUBS;
6107 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6108 PL_hints |= HINT_STRICT_VARS;
6110 /* otherwise they are off */
6112 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6113 PL_hints &= ~HINT_STRICT_REFS;
6114 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6115 PL_hints &= ~HINT_STRICT_SUBS;
6116 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6117 PL_hints &= ~HINT_STRICT_VARS;
6121 /* The "did you use incorrect case?" warning used to be here.
6122 * The problem is that on case-insensitive filesystems one
6123 * might get false positives for "use" (and "require"):
6124 * "use Strict" or "require CARP" will work. This causes
6125 * portability problems for the script: in case-strict
6126 * filesystems the script will stop working.
6128 * The "incorrect case" warning checked whether "use Foo"
6129 * imported "Foo" to your namespace, but that is wrong, too:
6130 * there is no requirement nor promise in the language that
6131 * a Foo.pm should or would contain anything in package "Foo".
6133 * There is very little Configure-wise that can be done, either:
6134 * the case-sensitivity of the build filesystem of Perl does not
6135 * help in guessing the case-sensitivity of the runtime environment.
6138 PL_hints |= HINT_BLOCK_SCOPE;
6139 PL_parser->copline = NOLINE;
6140 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6144 =head1 Embedding Functions
6146 =for apidoc load_module
6148 Loads the module whose name is pointed to by the string part of name.
6149 Note that the actual module name, not its filename, should be given.
6150 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
6151 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6152 (or 0 for no flags). ver, if specified
6153 and not NULL, provides version semantics
6154 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
6155 arguments can be used to specify arguments to the module's C<import()>
6156 method, similar to C<use Foo::Bar VERSION LIST>. They must be
6157 terminated with a final C<NULL> pointer. Note that this list can only
6158 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6159 Otherwise at least a single C<NULL> pointer to designate the default
6160 import list is required.
6162 The reference count for each specified C<SV*> parameter is decremented.
6167 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6171 PERL_ARGS_ASSERT_LOAD_MODULE;
6173 va_start(args, ver);
6174 vload_module(flags, name, ver, &args);
6178 #ifdef PERL_IMPLICIT_CONTEXT
6180 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6184 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6185 va_start(args, ver);
6186 vload_module(flags, name, ver, &args);
6192 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6195 OP * const modname = newSVOP(OP_CONST, 0, name);
6197 PERL_ARGS_ASSERT_VLOAD_MODULE;
6199 modname->op_private |= OPpCONST_BARE;
6201 veop = newSVOP(OP_CONST, 0, ver);
6205 if (flags & PERL_LOADMOD_NOIMPORT) {
6206 imop = sawparens(newNULLLIST());
6208 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6209 imop = va_arg(*args, OP*);
6214 sv = va_arg(*args, SV*);
6216 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6217 sv = va_arg(*args, SV*);
6221 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6222 * that it has a PL_parser to play with while doing that, and also
6223 * that it doesn't mess with any existing parser, by creating a tmp
6224 * new parser with lex_start(). This won't actually be used for much,
6225 * since pp_require() will create another parser for the real work.
6226 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6229 SAVEVPTR(PL_curcop);
6230 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6231 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6232 veop, modname, imop);
6236 PERL_STATIC_INLINE OP *
6237 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6239 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6240 newLISTOP(OP_LIST, 0, arg,
6241 newUNOP(OP_RV2CV, 0,
6242 newGVOP(OP_GV, 0, gv))));
6246 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6251 PERL_ARGS_ASSERT_DOFILE;
6253 if (!force_builtin && (gv = gv_override("do", 2))) {
6254 doop = S_new_entersubop(aTHX_ gv, term);
6257 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6263 =head1 Optree construction
6265 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6267 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
6268 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6269 be set automatically, and, shifted up eight bits, the eight bits of
6270 C<op_private>, except that the bit with value 1 or 2 is automatically
6271 set as required. C<listval> and C<subscript> supply the parameters of
6272 the slice; they are consumed by this function and become part of the
6273 constructed op tree.
6279 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6281 return newBINOP(OP_LSLICE, flags,
6282 list(force_list(subscript, 1)),
6283 list(force_list(listval, 1)) );
6286 #define ASSIGN_LIST 1
6287 #define ASSIGN_REF 2
6290 S_assignment_type(pTHX_ const OP *o)
6299 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6300 o = cUNOPo->op_first;
6302 flags = o->op_flags;
6304 if (type == OP_COND_EXPR) {
6305 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6306 const I32 t = assignment_type(sib);
6307 const I32 f = assignment_type(OpSIBLING(sib));
6309 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6311 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6312 yyerror("Assignment to both a list and a scalar");
6316 if (type == OP_SREFGEN)
6318 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6319 type = kid->op_type;
6320 flags |= kid->op_flags;
6321 if (!(flags & OPf_PARENS)
6322 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6323 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6329 if (type == OP_LIST &&
6330 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6331 o->op_private & OPpLVAL_INTRO)
6334 if (type == OP_LIST || flags & OPf_PARENS ||
6335 type == OP_RV2AV || type == OP_RV2HV ||
6336 type == OP_ASLICE || type == OP_HSLICE ||
6337 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6340 if (type == OP_PADAV || type == OP_PADHV)
6343 if (type == OP_RV2SV)
6351 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6353 Constructs, checks, and returns an assignment op. C<left> and C<right>
6354 supply the parameters of the assignment; they are consumed by this
6355 function and become part of the constructed op tree.
6357 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6358 a suitable conditional optree is constructed. If C<optype> is the opcode
6359 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6360 performs the binary operation and assigns the result to the left argument.
6361 Either way, if C<optype> is non-zero then C<flags> has no effect.
6363 If C<optype> is zero, then a plain scalar or list assignment is
6364 constructed. Which type of assignment it is is automatically determined.
6365 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6366 will be set automatically, and, shifted up eight bits, the eight bits
6367 of C<op_private>, except that the bit with value 1 or 2 is automatically
6374 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6380 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6381 return newLOGOP(optype, 0,
6382 op_lvalue(scalar(left), optype),
6383 newUNOP(OP_SASSIGN, 0, scalar(right)));
6386 return newBINOP(optype, OPf_STACKED,
6387 op_lvalue(scalar(left), optype), scalar(right));
6391 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6392 static const char no_list_state[] = "Initialization of state variables"
6393 " in list context currently forbidden";
6396 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6397 left->op_private &= ~ OPpSLICEWARNING;
6400 left = op_lvalue(left, OP_AASSIGN);
6401 curop = list(force_list(left, 1));
6402 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6403 o->op_private = (U8)(0 | (flags >> 8));
6405 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6407 OP* lop = ((LISTOP*)left)->op_first;
6409 if ((lop->op_type == OP_PADSV ||
6410 lop->op_type == OP_PADAV ||
6411 lop->op_type == OP_PADHV ||
6412 lop->op_type == OP_PADANY)
6413 && (lop->op_private & OPpPAD_STATE)
6415 yyerror(no_list_state);
6416 lop = OpSIBLING(lop);
6419 else if ( (left->op_private & OPpLVAL_INTRO)
6420 && (left->op_private & OPpPAD_STATE)
6421 && ( left->op_type == OP_PADSV
6422 || left->op_type == OP_PADAV
6423 || left->op_type == OP_PADHV
6424 || left->op_type == OP_PADANY)
6426 /* All single variable list context state assignments, hence
6436 yyerror(no_list_state);
6439 if (right && right->op_type == OP_SPLIT
6440 && !(right->op_flags & OPf_STACKED)) {
6441 OP* tmpop = ((LISTOP*)right)->op_first;
6442 PMOP * const pm = (PMOP*)tmpop;
6443 assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6446 !pm->op_pmreplrootu.op_pmtargetoff
6448 !pm->op_pmreplrootu.op_pmtargetgv
6452 if (!(left->op_private & OPpLVAL_INTRO) &&
6453 ( (left->op_type == OP_RV2AV &&
6454 (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6455 || left->op_type == OP_PADAV )
6457 if (tmpop != (OP *)pm) {
6459 pm->op_pmreplrootu.op_pmtargetoff
6460 = cPADOPx(tmpop)->op_padix;
6461 cPADOPx(tmpop)->op_padix = 0; /* steal it */
6463 pm->op_pmreplrootu.op_pmtargetgv
6464 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6465 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
6467 right->op_private |=
6468 left->op_private & OPpOUR_INTRO;
6471 pm->op_targ = left->op_targ;
6472 left->op_targ = 0; /* filch it */
6475 tmpop = cUNOPo->op_first; /* to list (nulled) */
6476 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6477 /* detach rest of siblings from o subtree,
6478 * and free subtree */
6479 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6480 op_free(o); /* blow off assign */
6481 right->op_flags &= ~OPf_WANT;
6482 /* "I don't know and I don't care." */
6485 else if (left->op_type == OP_RV2AV
6486 || left->op_type == OP_PADAV)
6488 /* Detach the array. */
6492 op_sibling_splice(cBINOPo->op_last,
6493 cUNOPx(cBINOPo->op_last)
6494 ->op_first, 1, NULL);
6495 assert(ary == left);
6496 /* Attach it to the split. */
6497 op_sibling_splice(right, cLISTOPx(right)->op_last,
6499 right->op_flags |= OPf_STACKED;
6500 /* Detach split and expunge aassign as above. */
6503 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6504 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6507 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6508 SV * const sv = *svp;
6509 if (SvIOK(sv) && SvIVX(sv) == 0)
6511 if (right->op_private & OPpSPLIT_IMPLIM) {
6512 /* our own SV, created in ck_split */
6514 sv_setiv(sv, PL_modcount+1);
6517 /* SV may belong to someone else */
6519 *svp = newSViv(PL_modcount+1);
6527 if (assign_type == ASSIGN_REF)
6528 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6530 right = newOP(OP_UNDEF, 0);
6531 if (right->op_type == OP_READLINE) {
6532 right->op_flags |= OPf_STACKED;
6533 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6537 o = newBINOP(OP_SASSIGN, flags,
6538 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6544 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6546 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6547 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6548 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6549 If C<label> is non-null, it supplies the name of a label to attach to
6550 the state op; this function takes ownership of the memory pointed at by
6551 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
6554 If C<o> is null, the state op is returned. Otherwise the state op is
6555 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
6556 is consumed by this function and becomes part of the returned op tree.
6562 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6565 const U32 seq = intro_my();
6566 const U32 utf8 = flags & SVf_UTF8;
6569 PL_parser->parsed_sub = 0;
6573 NewOp(1101, cop, 1, COP);
6574 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6575 OpTYPE_set(cop, OP_DBSTATE);
6578 OpTYPE_set(cop, OP_NEXTSTATE);
6580 cop->op_flags = (U8)flags;
6581 CopHINTS_set(cop, PL_hints);
6583 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6585 cop->op_next = (OP*)cop;
6588 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6589 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6591 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6593 PL_hints |= HINT_BLOCK_SCOPE;
6594 /* It seems that we need to defer freeing this pointer, as other parts
6595 of the grammar end up wanting to copy it after this op has been
6600 if (PL_parser->preambling != NOLINE) {
6601 CopLINE_set(cop, PL_parser->preambling);
6602 PL_parser->copline = NOLINE;
6604 else if (PL_parser->copline == NOLINE)
6605 CopLINE_set(cop, CopLINE(PL_curcop));
6607 CopLINE_set(cop, PL_parser->copline);
6608 PL_parser->copline = NOLINE;
6611 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6613 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6615 CopSTASH_set(cop, PL_curstash);
6617 if (cop->op_type == OP_DBSTATE) {
6618 /* this line can have a breakpoint - store the cop in IV */
6619 AV *av = CopFILEAVx(PL_curcop);
6621 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6622 if (svp && *svp != &PL_sv_undef ) {
6623 (void)SvIOK_on(*svp);
6624 SvIV_set(*svp, PTR2IV(cop));
6629 if (flags & OPf_SPECIAL)
6631 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6635 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6637 Constructs, checks, and returns a logical (flow control) op. C<type>
6638 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6639 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6640 the eight bits of C<op_private>, except that the bit with value 1 is
6641 automatically set. C<first> supplies the expression controlling the
6642 flow, and C<other> supplies the side (alternate) chain of ops; they are
6643 consumed by this function and become part of the constructed op tree.
6649 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6651 PERL_ARGS_ASSERT_NEWLOGOP;
6653 return new_logop(type, flags, &first, &other);
6657 S_search_const(pTHX_ OP *o)
6659 PERL_ARGS_ASSERT_SEARCH_CONST;
6661 switch (o->op_type) {
6665 if (o->op_flags & OPf_KIDS)
6666 return search_const(cUNOPo->op_first);
6673 if (!(o->op_flags & OPf_KIDS))
6675 kid = cLISTOPo->op_first;
6677 switch (kid->op_type) {
6681 kid = OpSIBLING(kid);
6684 if (kid != cLISTOPo->op_last)
6690 kid = cLISTOPo->op_last;
6692 return search_const(kid);
6700 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6708 int prepend_not = 0;
6710 PERL_ARGS_ASSERT_NEW_LOGOP;
6715 /* [perl #59802]: Warn about things like "return $a or $b", which
6716 is parsed as "(return $a) or $b" rather than "return ($a or
6717 $b)". NB: This also applies to xor, which is why we do it
6720 switch (first->op_type) {
6724 /* XXX: Perhaps we should emit a stronger warning for these.
6725 Even with the high-precedence operator they don't seem to do
6728 But until we do, fall through here.
6734 /* XXX: Currently we allow people to "shoot themselves in the
6735 foot" by explicitly writing "(return $a) or $b".
6737 Warn unless we are looking at the result from folding or if
6738 the programmer explicitly grouped the operators like this.
6739 The former can occur with e.g.
6741 use constant FEATURE => ( $] >= ... );
6742 sub { not FEATURE and return or do_stuff(); }
6744 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6745 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6746 "Possible precedence issue with control flow operator");
6747 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6753 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6754 return newBINOP(type, flags, scalar(first), scalar(other));
6756 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6757 || type == OP_CUSTOM);
6759 scalarboolean(first);
6761 /* search for a constant op that could let us fold the test */
6762 if ((cstop = search_const(first))) {
6763 if (cstop->op_private & OPpCONST_STRICT)
6764 no_bareword_allowed(cstop);
6765 else if ((cstop->op_private & OPpCONST_BARE))
6766 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6767 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6768 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6769 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6770 /* Elide the (constant) lhs, since it can't affect the outcome */
6772 if (other->op_type == OP_CONST)
6773 other->op_private |= OPpCONST_SHORTCIRCUIT;
6775 if (other->op_type == OP_LEAVE)
6776 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6777 else if (other->op_type == OP_MATCH
6778 || other->op_type == OP_SUBST
6779 || other->op_type == OP_TRANSR
6780 || other->op_type == OP_TRANS)
6781 /* Mark the op as being unbindable with =~ */
6782 other->op_flags |= OPf_SPECIAL;
6784 other->op_folded = 1;
6788 /* Elide the rhs, since the outcome is entirely determined by
6789 * the (constant) lhs */
6791 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6792 const OP *o2 = other;
6793 if ( ! (o2->op_type == OP_LIST
6794 && (( o2 = cUNOPx(o2)->op_first))
6795 && o2->op_type == OP_PUSHMARK
6796 && (( o2 = OpSIBLING(o2))) )
6799 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6800 || o2->op_type == OP_PADHV)
6801 && o2->op_private & OPpLVAL_INTRO
6802 && !(o2->op_private & OPpPAD_STATE))
6804 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6805 "Deprecated use of my() in false conditional");
6809 if (cstop->op_type == OP_CONST)
6810 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6815 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6816 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6818 const OP * const k1 = ((UNOP*)first)->op_first;
6819 const OP * const k2 = OpSIBLING(k1);
6821 switch (first->op_type)
6824 if (k2 && k2->op_type == OP_READLINE
6825 && (k2->op_flags & OPf_STACKED)
6826 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6828 warnop = k2->op_type;
6833 if (k1->op_type == OP_READDIR
6834 || k1->op_type == OP_GLOB
6835 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6836 || k1->op_type == OP_EACH
6837 || k1->op_type == OP_AEACH)
6839 warnop = ((k1->op_type == OP_NULL)
6840 ? (OPCODE)k1->op_targ : k1->op_type);
6845 const line_t oldline = CopLINE(PL_curcop);
6846 /* This ensures that warnings are reported at the first line
6847 of the construction, not the last. */
6848 CopLINE_set(PL_curcop, PL_parser->copline);
6849 Perl_warner(aTHX_ packWARN(WARN_MISC),
6850 "Value of %s%s can be \"0\"; test with defined()",
6852 ((warnop == OP_READLINE || warnop == OP_GLOB)
6853 ? " construct" : "() operator"));
6854 CopLINE_set(PL_curcop, oldline);
6858 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6859 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6861 /* optimize AND and OR ops that have NOTs as children */
6862 if (first->op_type == OP_NOT
6863 && (first->op_flags & OPf_KIDS)
6864 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6865 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6867 if (type == OP_AND || type == OP_OR) {
6873 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6875 prepend_not = 1; /* prepend a NOT op later */
6880 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6881 logop->op_flags |= (U8)flags;
6882 logop->op_private = (U8)(1 | (flags >> 8));
6884 /* establish postfix order */
6885 logop->op_next = LINKLIST(first);
6886 first->op_next = (OP*)logop;
6887 assert(!OpHAS_SIBLING(first));
6888 op_sibling_splice((OP*)logop, first, 0, other);
6890 CHECKOP(type,logop);
6892 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
6893 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
6901 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6903 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6904 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6905 will be set automatically, and, shifted up eight bits, the eight bits of
6906 C<op_private>, except that the bit with value 1 is automatically set.
6907 C<first> supplies the expression selecting between the two branches,
6908 and C<trueop> and C<falseop> supply the branches; they are consumed by
6909 this function and become part of the constructed op tree.
6915 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6923 PERL_ARGS_ASSERT_NEWCONDOP;
6926 return newLOGOP(OP_AND, 0, first, trueop);
6928 return newLOGOP(OP_OR, 0, first, falseop);
6930 scalarboolean(first);
6931 if ((cstop = search_const(first))) {
6932 /* Left or right arm of the conditional? */
6933 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6934 OP *live = left ? trueop : falseop;
6935 OP *const dead = left ? falseop : trueop;
6936 if (cstop->op_private & OPpCONST_BARE &&
6937 cstop->op_private & OPpCONST_STRICT) {
6938 no_bareword_allowed(cstop);
6942 if (live->op_type == OP_LEAVE)
6943 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6944 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6945 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6946 /* Mark the op as being unbindable with =~ */
6947 live->op_flags |= OPf_SPECIAL;
6948 live->op_folded = 1;
6951 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6952 logop->op_flags |= (U8)flags;
6953 logop->op_private = (U8)(1 | (flags >> 8));
6954 logop->op_next = LINKLIST(falseop);
6956 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6959 /* establish postfix order */
6960 start = LINKLIST(first);
6961 first->op_next = (OP*)logop;
6963 /* make first, trueop, falseop siblings */
6964 op_sibling_splice((OP*)logop, first, 0, trueop);
6965 op_sibling_splice((OP*)logop, trueop, 0, falseop);
6967 o = newUNOP(OP_NULL, 0, (OP*)logop);
6969 trueop->op_next = falseop->op_next = o;
6976 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6978 Constructs and returns a C<range> op, with subordinate C<flip> and
6979 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
6980 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6981 for both the C<flip> and C<range> ops, except that the bit with value
6982 1 is automatically set. C<left> and C<right> supply the expressions
6983 controlling the endpoints of the range; they are consumed by this function
6984 and become part of the constructed op tree.
6990 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6998 PERL_ARGS_ASSERT_NEWRANGE;
7000 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
7001 range->op_flags = OPf_KIDS;
7002 leftstart = LINKLIST(left);
7003 range->op_private = (U8)(1 | (flags >> 8));
7005 /* make left and right siblings */
7006 op_sibling_splice((OP*)range, left, 0, right);
7008 range->op_next = (OP*)range;
7009 flip = newUNOP(OP_FLIP, flags, (OP*)range);
7010 flop = newUNOP(OP_FLOP, 0, flip);
7011 o = newUNOP(OP_NULL, 0, flop);
7013 range->op_next = leftstart;
7015 left->op_next = flip;
7016 right->op_next = flop;
7019 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7020 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7022 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7023 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7024 SvPADTMP_on(PAD_SV(flip->op_targ));
7026 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7027 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7029 /* check barewords before they might be optimized aways */
7030 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7031 no_bareword_allowed(left);
7032 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7033 no_bareword_allowed(right);
7036 if (!flip->op_private || !flop->op_private)
7037 LINKLIST(o); /* blow off optimizer unless constant */
7043 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7045 Constructs, checks, and returns an op tree expressing a loop. This is
7046 only a loop in the control flow through the op tree; it does not have
7047 the heavyweight loop structure that allows exiting the loop by C<last>
7048 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
7049 top-level op, except that some bits will be set automatically as required.
7050 C<expr> supplies the expression controlling loop iteration, and C<block>
7051 supplies the body of the loop; they are consumed by this function and
7052 become part of the constructed op tree. C<debuggable> is currently
7053 unused and should always be 1.
7059 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7063 const bool once = block && block->op_flags & OPf_SPECIAL &&
7064 block->op_type == OP_NULL;
7066 PERL_UNUSED_ARG(debuggable);
7070 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7071 || ( expr->op_type == OP_NOT
7072 && cUNOPx(expr)->op_first->op_type == OP_CONST
7073 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7076 /* Return the block now, so that S_new_logop does not try to
7078 return block; /* do {} while 0 does once */
7079 if (expr->op_type == OP_READLINE
7080 || expr->op_type == OP_READDIR
7081 || expr->op_type == OP_GLOB
7082 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7083 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7084 expr = newUNOP(OP_DEFINED, 0,
7085 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7086 } else if (expr->op_flags & OPf_KIDS) {
7087 const OP * const k1 = ((UNOP*)expr)->op_first;
7088 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7089 switch (expr->op_type) {
7091 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7092 && (k2->op_flags & OPf_STACKED)
7093 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7094 expr = newUNOP(OP_DEFINED, 0, expr);
7098 if (k1 && (k1->op_type == OP_READDIR
7099 || k1->op_type == OP_GLOB
7100 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7101 || k1->op_type == OP_EACH
7102 || k1->op_type == OP_AEACH))
7103 expr = newUNOP(OP_DEFINED, 0, expr);
7109 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7110 * op, in listop. This is wrong. [perl #27024] */
7112 block = newOP(OP_NULL, 0);
7113 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7114 o = new_logop(OP_AND, 0, &expr, &listop);
7121 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7123 if (once && o != listop)
7125 assert(cUNOPo->op_first->op_type == OP_AND
7126 || cUNOPo->op_first->op_type == OP_OR);
7127 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7131 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7133 o->op_flags |= flags;
7135 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7140 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7142 Constructs, checks, and returns an op tree expressing a C<while> loop.
7143 This is a heavyweight loop, with structure that allows exiting the loop
7144 by C<last> and suchlike.
7146 C<loop> is an optional preconstructed C<enterloop> op to use in the
7147 loop; if it is null then a suitable op will be constructed automatically.
7148 C<expr> supplies the loop's controlling expression. C<block> supplies the
7149 main body of the loop, and C<cont> optionally supplies a C<continue> block
7150 that operates as a second half of the body. All of these optree inputs
7151 are consumed by this function and become part of the constructed op tree.
7153 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7154 op and, shifted up eight bits, the eight bits of C<op_private> for
7155 the C<leaveloop> op, except that (in both cases) some bits will be set
7156 automatically. C<debuggable> is currently unused and should always be 1.
7157 C<has_my> can be supplied as true to force the
7158 loop body to be enclosed in its own scope.
7164 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7165 OP *expr, OP *block, OP *cont, I32 has_my)
7174 PERL_UNUSED_ARG(debuggable);
7177 if (expr->op_type == OP_READLINE
7178 || expr->op_type == OP_READDIR
7179 || expr->op_type == OP_GLOB
7180 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7181 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7182 expr = newUNOP(OP_DEFINED, 0,
7183 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7184 } else if (expr->op_flags & OPf_KIDS) {
7185 const OP * const k1 = ((UNOP*)expr)->op_first;
7186 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7187 switch (expr->op_type) {
7189 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7190 && (k2->op_flags & OPf_STACKED)
7191 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7192 expr = newUNOP(OP_DEFINED, 0, expr);
7196 if (k1 && (k1->op_type == OP_READDIR
7197 || k1->op_type == OP_GLOB
7198 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7199 || k1->op_type == OP_EACH
7200 || k1->op_type == OP_AEACH))
7201 expr = newUNOP(OP_DEFINED, 0, expr);
7208 block = newOP(OP_NULL, 0);
7209 else if (cont || has_my) {
7210 block = op_scope(block);
7214 next = LINKLIST(cont);
7217 OP * const unstack = newOP(OP_UNSTACK, 0);
7220 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7224 listop = op_append_list(OP_LINESEQ, block, cont);
7226 redo = LINKLIST(listop);
7230 o = new_logop(OP_AND, 0, &expr, &listop);
7231 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7233 return expr; /* listop already freed by new_logop */
7236 ((LISTOP*)listop)->op_last->op_next =
7237 (o == listop ? redo : LINKLIST(o));
7243 NewOp(1101,loop,1,LOOP);
7244 OpTYPE_set(loop, OP_ENTERLOOP);
7245 loop->op_private = 0;
7246 loop->op_next = (OP*)loop;
7249 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7251 loop->op_redoop = redo;
7252 loop->op_lastop = o;
7253 o->op_private |= loopflags;
7256 loop->op_nextop = next;
7258 loop->op_nextop = o;
7260 o->op_flags |= flags;
7261 o->op_private |= (flags >> 8);
7266 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7268 Constructs, checks, and returns an op tree expressing a C<foreach>
7269 loop (iteration through a list of values). This is a heavyweight loop,
7270 with structure that allows exiting the loop by C<last> and suchlike.
7272 C<sv> optionally supplies the variable that will be aliased to each
7273 item in turn; if null, it defaults to C<$_>.
7274 C<expr> supplies the list of values to iterate over. C<block> supplies
7275 the main body of the loop, and C<cont> optionally supplies a C<continue>
7276 block that operates as a second half of the body. All of these optree
7277 inputs are consumed by this function and become part of the constructed
7280 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7281 op and, shifted up eight bits, the eight bits of C<op_private> for
7282 the C<leaveloop> op, except that (in both cases) some bits will be set
7289 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7294 PADOFFSET padoff = 0;
7298 PERL_ARGS_ASSERT_NEWFOROP;
7301 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7302 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7303 OpTYPE_set(sv, OP_RV2GV);
7305 /* The op_type check is needed to prevent a possible segfault
7306 * if the loop variable is undeclared and 'strict vars' is in
7307 * effect. This is illegal but is nonetheless parsed, so we
7308 * may reach this point with an OP_CONST where we're expecting
7311 if (cUNOPx(sv)->op_first->op_type == OP_GV
7312 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7313 iterpflags |= OPpITER_DEF;
7315 else if (sv->op_type == OP_PADSV) { /* private variable */
7316 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7317 padoff = sv->op_targ;
7321 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7323 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7326 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7328 PADNAME * const pn = PAD_COMPNAME(padoff);
7329 const char * const name = PadnamePV(pn);
7331 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7332 iterpflags |= OPpITER_DEF;
7336 sv = newGVOP(OP_GV, 0, PL_defgv);
7337 iterpflags |= OPpITER_DEF;
7340 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7341 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7342 iterflags |= OPf_STACKED;
7344 else if (expr->op_type == OP_NULL &&
7345 (expr->op_flags & OPf_KIDS) &&
7346 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7348 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7349 * set the STACKED flag to indicate that these values are to be
7350 * treated as min/max values by 'pp_enteriter'.
7352 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7353 LOGOP* const range = (LOGOP*) flip->op_first;
7354 OP* const left = range->op_first;
7355 OP* const right = OpSIBLING(left);
7358 range->op_flags &= ~OPf_KIDS;
7359 /* detach range's children */
7360 op_sibling_splice((OP*)range, NULL, -1, NULL);
7362 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7363 listop->op_first->op_next = range->op_next;
7364 left->op_next = range->op_other;
7365 right->op_next = (OP*)listop;
7366 listop->op_next = listop->op_first;
7369 expr = (OP*)(listop);
7371 iterflags |= OPf_STACKED;
7374 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7377 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7378 op_append_elem(OP_LIST, list(expr),
7380 assert(!loop->op_next);
7381 /* for my $x () sets OPpLVAL_INTRO;
7382 * for our $x () sets OPpOUR_INTRO */
7383 loop->op_private = (U8)iterpflags;
7384 if (loop->op_slabbed
7385 && DIFF(loop, OpSLOT(loop)->opslot_next)
7386 < SIZE_TO_PSIZE(sizeof(LOOP)))
7389 NewOp(1234,tmp,1,LOOP);
7390 Copy(loop,tmp,1,LISTOP);
7391 #ifdef PERL_OP_PARENT
7392 assert(loop->op_last->op_sibparent == (OP*)loop);
7393 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7395 S_op_destroy(aTHX_ (OP*)loop);
7398 else if (!loop->op_slabbed)
7400 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7401 #ifdef PERL_OP_PARENT
7402 OpLASTSIB_set(loop->op_last, (OP*)loop);
7405 loop->op_targ = padoff;
7406 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7411 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7413 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7414 or C<last>). C<type> is the opcode. C<label> supplies the parameter
7415 determining the target of the op; it is consumed by this function and
7416 becomes part of the constructed op tree.
7422 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7426 PERL_ARGS_ASSERT_NEWLOOPEX;
7428 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7429 || type == OP_CUSTOM);
7431 if (type != OP_GOTO) {
7432 /* "last()" means "last" */
7433 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7434 o = newOP(type, OPf_SPECIAL);
7438 /* Check whether it's going to be a goto &function */
7439 if (label->op_type == OP_ENTERSUB
7440 && !(label->op_flags & OPf_STACKED))
7441 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7444 /* Check for a constant argument */
7445 if (label->op_type == OP_CONST) {
7446 SV * const sv = ((SVOP *)label)->op_sv;
7448 const char *s = SvPV_const(sv,l);
7449 if (l == strlen(s)) {
7451 SvUTF8(((SVOP*)label)->op_sv),
7453 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7457 /* If we have already created an op, we do not need the label. */
7460 else o = newUNOP(type, OPf_STACKED, label);
7462 PL_hints |= HINT_BLOCK_SCOPE;
7466 /* if the condition is a literal array or hash
7467 (or @{ ... } etc), make a reference to it.
7470 S_ref_array_or_hash(pTHX_ OP *cond)
7473 && (cond->op_type == OP_RV2AV
7474 || cond->op_type == OP_PADAV
7475 || cond->op_type == OP_RV2HV
7476 || cond->op_type == OP_PADHV))
7478 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7481 && (cond->op_type == OP_ASLICE
7482 || cond->op_type == OP_KVASLICE
7483 || cond->op_type == OP_HSLICE
7484 || cond->op_type == OP_KVHSLICE)) {
7486 /* anonlist now needs a list from this op, was previously used in
7488 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7489 cond->op_flags |= OPf_WANT_LIST;
7491 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7498 /* These construct the optree fragments representing given()
7501 entergiven and enterwhen are LOGOPs; the op_other pointer
7502 points up to the associated leave op. We need this so we
7503 can put it in the context and make break/continue work.
7504 (Also, of course, pp_enterwhen will jump straight to
7505 op_other if the match fails.)
7509 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7510 I32 enter_opcode, I32 leave_opcode,
7511 PADOFFSET entertarg)
7517 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7518 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7520 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7521 enterop->op_targ = 0;
7522 enterop->op_private = 0;
7524 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7527 /* prepend cond if we have one */
7528 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7530 o->op_next = LINKLIST(cond);
7531 cond->op_next = (OP *) enterop;
7534 /* This is a default {} block */
7535 enterop->op_flags |= OPf_SPECIAL;
7536 o ->op_flags |= OPf_SPECIAL;
7538 o->op_next = (OP *) enterop;
7541 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7542 entergiven and enterwhen both
7545 enterop->op_next = LINKLIST(block);
7546 block->op_next = enterop->op_other = o;
7551 /* Does this look like a boolean operation? For these purposes
7552 a boolean operation is:
7553 - a subroutine call [*]
7554 - a logical connective
7555 - a comparison operator
7556 - a filetest operator, with the exception of -s -M -A -C
7557 - defined(), exists() or eof()
7558 - /$re/ or $foo =~ /$re/
7560 [*] possibly surprising
7563 S_looks_like_bool(pTHX_ const OP *o)
7565 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7567 switch(o->op_type) {
7570 return looks_like_bool(cLOGOPo->op_first);
7574 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7577 looks_like_bool(cLOGOPo->op_first)
7578 && looks_like_bool(sibl));
7584 o->op_flags & OPf_KIDS
7585 && looks_like_bool(cUNOPo->op_first));
7589 case OP_NOT: case OP_XOR:
7591 case OP_EQ: case OP_NE: case OP_LT:
7592 case OP_GT: case OP_LE: case OP_GE:
7594 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7595 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7597 case OP_SEQ: case OP_SNE: case OP_SLT:
7598 case OP_SGT: case OP_SLE: case OP_SGE:
7602 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7603 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7604 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7605 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7606 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7607 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7608 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7609 case OP_FTTEXT: case OP_FTBINARY:
7611 case OP_DEFINED: case OP_EXISTS:
7612 case OP_MATCH: case OP_EOF:
7619 /* Detect comparisons that have been optimized away */
7620 if (cSVOPo->op_sv == &PL_sv_yes
7621 || cSVOPo->op_sv == &PL_sv_no)
7634 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7636 Constructs, checks, and returns an op tree expressing a C<given> block.
7637 C<cond> supplies the expression that will be locally assigned to a lexical
7638 variable, and C<block> supplies the body of the C<given> construct; they
7639 are consumed by this function and become part of the constructed op tree.
7640 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7646 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7648 PERL_ARGS_ASSERT_NEWGIVENOP;
7649 PERL_UNUSED_ARG(defsv_off);
7652 return newGIVWHENOP(
7653 ref_array_or_hash(cond),
7655 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7660 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7662 Constructs, checks, and returns an op tree expressing a C<when> block.
7663 C<cond> supplies the test expression, and C<block> supplies the block
7664 that will be executed if the test evaluates to true; they are consumed
7665 by this function and become part of the constructed op tree. C<cond>
7666 will be interpreted DWIMically, often as a comparison against C<$_>,
7667 and may be null to generate a C<default> block.
7673 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7675 const bool cond_llb = (!cond || looks_like_bool(cond));
7678 PERL_ARGS_ASSERT_NEWWHENOP;
7683 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7685 scalar(ref_array_or_hash(cond)));
7688 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7691 /* must not conflict with SVf_UTF8 */
7692 #define CV_CKPROTO_CURSTASH 0x1
7695 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7696 const STRLEN len, const U32 flags)
7698 SV *name = NULL, *msg;
7699 const char * cvp = SvROK(cv)
7700 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7701 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7704 STRLEN clen = CvPROTOLEN(cv), plen = len;
7706 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7708 if (p == NULL && cvp == NULL)
7711 if (!ckWARN_d(WARN_PROTOTYPE))
7715 p = S_strip_spaces(aTHX_ p, &plen);
7716 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7717 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7718 if (plen == clen && memEQ(cvp, p, plen))
7721 if (flags & SVf_UTF8) {
7722 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7726 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7732 msg = sv_newmortal();
7737 gv_efullname3(name = sv_newmortal(), gv, NULL);
7738 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7739 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7740 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7741 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7742 sv_catpvs(name, "::");
7744 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7745 assert (CvNAMED(SvRV_const(gv)));
7746 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7748 else sv_catsv(name, (SV *)gv);
7750 else name = (SV *)gv;
7752 sv_setpvs(msg, "Prototype mismatch:");
7754 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7756 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7757 UTF8fARG(SvUTF8(cv),clen,cvp)
7760 sv_catpvs(msg, ": none");
7761 sv_catpvs(msg, " vs ");
7763 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7765 sv_catpvs(msg, "none");
7766 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7769 static void const_sv_xsub(pTHX_ CV* cv);
7770 static void const_av_xsub(pTHX_ CV* cv);
7774 =head1 Optree Manipulation Functions
7776 =for apidoc cv_const_sv
7778 If C<cv> is a constant sub eligible for inlining, returns the constant
7779 value returned by the sub. Otherwise, returns C<NULL>.
7781 Constant subs can be created with C<newCONSTSUB> or as described in
7782 L<perlsub/"Constant Functions">.
7787 Perl_cv_const_sv(const CV *const cv)
7792 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7794 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7795 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7800 Perl_cv_const_sv_or_av(const CV * const cv)
7804 if (SvROK(cv)) return SvRV((SV *)cv);
7805 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7806 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7809 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7810 * Can be called in 2 ways:
7813 * look for a single OP_CONST with attached value: return the value
7815 * allow_lex && !CvCONST(cv);
7817 * examine the clone prototype, and if contains only a single
7818 * OP_CONST, return the value; or if it contains a single PADSV ref-
7819 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7820 * a candidate for "constizing" at clone time, and return NULL.
7824 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7832 for (; o; o = o->op_next) {
7833 const OPCODE type = o->op_type;
7835 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7837 || type == OP_PUSHMARK)
7839 if (type == OP_DBSTATE)
7841 if (type == OP_LEAVESUB)
7845 if (type == OP_CONST && cSVOPo->op_sv)
7847 else if (type == OP_UNDEF && !o->op_private) {
7851 else if (allow_lex && type == OP_PADSV) {
7852 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7854 sv = &PL_sv_undef; /* an arbitrary non-null value */
7872 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7873 PADNAME * const name, SV ** const const_svp)
7880 if (CvFLAGS(PL_compcv)) {
7881 /* might have had built-in attrs applied */
7882 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7883 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7884 && ckWARN(WARN_MISC))
7886 /* protect against fatal warnings leaking compcv */
7887 SAVEFREESV(PL_compcv);
7888 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7889 SvREFCNT_inc_simple_void_NN(PL_compcv);
7892 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7893 & ~(CVf_LVALUE * pureperl));
7898 /* redundant check for speed: */
7899 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7900 const line_t oldline = CopLINE(PL_curcop);
7903 : sv_2mortal(newSVpvn_utf8(
7904 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7906 if (PL_parser && PL_parser->copline != NOLINE)
7907 /* This ensures that warnings are reported at the first
7908 line of a redefinition, not the last. */
7909 CopLINE_set(PL_curcop, PL_parser->copline);
7910 /* protect against fatal warnings leaking compcv */
7911 SAVEFREESV(PL_compcv);
7912 report_redefined_cv(namesv, cv, const_svp);
7913 SvREFCNT_inc_simple_void_NN(PL_compcv);
7914 CopLINE_set(PL_curcop, oldline);
7921 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7926 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7929 CV *compcv = PL_compcv;
7932 PADOFFSET pax = o->op_targ;
7933 CV *outcv = CvOUTSIDE(PL_compcv);
7936 bool reusable = FALSE;
7938 #ifdef PERL_DEBUG_READONLY_OPS
7939 OPSLAB *slab = NULL;
7942 PERL_ARGS_ASSERT_NEWMYSUB;
7944 /* Find the pad slot for storing the new sub.
7945 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7946 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7947 ing sub. And then we need to dig deeper if this is a lexical from
7949 my sub foo; sub { sub foo { } }
7952 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7953 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7954 pax = PARENT_PAD_INDEX(name);
7955 outcv = CvOUTSIDE(outcv);
7960 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7961 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7962 spot = (CV **)svspot;
7964 if (!(PL_parser && PL_parser->error_count))
7965 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
7968 assert(proto->op_type == OP_CONST);
7969 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7970 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7980 if (PL_parser && PL_parser->error_count) {
7982 SvREFCNT_dec(PL_compcv);
7987 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7989 svspot = (SV **)(spot = &clonee);
7991 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7994 assert (SvTYPE(*spot) == SVt_PVCV);
7996 hek = CvNAME_HEK(*spot);
8000 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8001 CvNAME_HEK_set(*spot, hek =
8004 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8008 CvLEXICAL_on(*spot);
8010 cv = PadnamePROTOCV(name);
8011 svspot = (SV **)(spot = &PadnamePROTOCV(name));
8015 /* This makes sub {}; work as expected. */
8016 if (block->op_type == OP_STUB) {
8017 const line_t l = PL_parser->copline;
8019 block = newSTATEOP(0, NULL, 0);
8020 PL_parser->copline = l;
8022 block = CvLVALUE(compcv)
8023 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8024 ? newUNOP(OP_LEAVESUBLV, 0,
8025 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8026 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8027 start = LINKLIST(block);
8029 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8030 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8038 const bool exists = CvROOT(cv) || CvXSUB(cv);
8040 /* if the subroutine doesn't exist and wasn't pre-declared
8041 * with a prototype, assume it will be AUTOLOADed,
8042 * skipping the prototype check
8044 if (exists || SvPOK(cv))
8045 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8047 /* already defined? */
8049 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8052 if (attrs) goto attrs;
8053 /* just a "sub foo;" when &foo is already defined */
8058 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8064 SvREFCNT_inc_simple_void_NN(const_sv);
8065 SvFLAGS(const_sv) |= SVs_PADTMP;
8067 assert(!CvROOT(cv) && !CvCONST(cv));
8071 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8072 CvFILE_set_from_cop(cv, PL_curcop);
8073 CvSTASH_set(cv, PL_curstash);
8076 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8077 CvXSUBANY(cv).any_ptr = const_sv;
8078 CvXSUB(cv) = const_sv_xsub;
8082 CvFLAGS(cv) |= CvMETHOD(compcv);
8084 SvREFCNT_dec(compcv);
8088 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8089 determine whether this sub definition is in the same scope as its
8090 declaration. If this sub definition is inside an inner named pack-
8091 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8092 the package sub. So check PadnameOUTER(name) too.
8094 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8095 assert(!CvWEAKOUTSIDE(compcv));
8096 SvREFCNT_dec(CvOUTSIDE(compcv));
8097 CvWEAKOUTSIDE_on(compcv);
8099 /* XXX else do we have a circular reference? */
8100 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8101 /* transfer PL_compcv to cv */
8104 cv_flags_t preserved_flags =
8105 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8106 PADLIST *const temp_padl = CvPADLIST(cv);
8107 CV *const temp_cv = CvOUTSIDE(cv);
8108 const cv_flags_t other_flags =
8109 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8110 OP * const cvstart = CvSTART(cv);
8114 CvFLAGS(compcv) | preserved_flags;
8115 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8116 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8117 CvPADLIST_set(cv, CvPADLIST(compcv));
8118 CvOUTSIDE(compcv) = temp_cv;
8119 CvPADLIST_set(compcv, temp_padl);
8120 CvSTART(cv) = CvSTART(compcv);
8121 CvSTART(compcv) = cvstart;
8122 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8123 CvFLAGS(compcv) |= other_flags;
8125 if (CvFILE(cv) && CvDYNFILE(cv)) {
8126 Safefree(CvFILE(cv));
8129 /* inner references to compcv must be fixed up ... */
8130 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8131 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8132 ++PL_sub_generation;
8135 /* Might have had built-in attributes applied -- propagate them. */
8136 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8138 /* ... before we throw it away */
8139 SvREFCNT_dec(compcv);
8140 PL_compcv = compcv = cv;
8148 if (!CvNAME_HEK(cv)) {
8149 if (hek) (void)share_hek_hek(hek);
8153 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8154 hek = share_hek(PadnamePV(name)+1,
8155 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8158 CvNAME_HEK_set(cv, hek);
8160 if (const_sv) goto clone;
8162 CvFILE_set_from_cop(cv, PL_curcop);
8163 CvSTASH_set(cv, PL_curstash);
8166 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8167 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8173 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8174 the debugger could be able to set a breakpoint in, so signal to
8175 pp_entereval that it should not throw away any saved lines at scope
8178 PL_breakable_sub_gen++;
8180 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8181 OpREFCNT_set(CvROOT(cv), 1);
8182 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8183 itself has a refcount. */
8185 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8186 #ifdef PERL_DEBUG_READONLY_OPS
8187 slab = (OPSLAB *)CvSTART(cv);
8189 CvSTART(cv) = start;
8191 finalize_optree(CvROOT(cv));
8192 S_prune_chain_head(&CvSTART(cv));
8194 /* now that optimizer has done its work, adjust pad values */
8196 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8200 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8201 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8205 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8206 SV * const tmpstr = sv_newmortal();
8207 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8208 GV_ADDMULTI, SVt_PVHV);
8210 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8213 (long)CopLINE(PL_curcop));
8214 if (HvNAME_HEK(PL_curstash)) {
8215 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8216 sv_catpvs(tmpstr, "::");
8218 else sv_setpvs(tmpstr, "__ANON__::");
8219 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8220 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8221 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8222 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8223 hv = GvHVn(db_postponed);
8224 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8225 CV * const pcv = GvCV(db_postponed);
8231 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8239 assert(CvDEPTH(outcv));
8241 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8242 if (reusable) cv_clone_into(clonee, *spot);
8243 else *spot = cv_clone(clonee);
8244 SvREFCNT_dec_NN(clonee);
8247 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8248 PADOFFSET depth = CvDEPTH(outcv);
8251 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8253 *svspot = SvREFCNT_inc_simple_NN(cv);
8254 SvREFCNT_dec(oldcv);
8260 PL_parser->copline = NOLINE;
8262 #ifdef PERL_DEBUG_READONLY_OPS
8272 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8273 OP *block, bool o_is_gv)
8277 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8281 const bool ec = PL_parser && PL_parser->error_count;
8282 /* If the subroutine has no body, no attributes, and no builtin attributes
8283 then it's just a sub declaration, and we may be able to get away with
8284 storing with a placeholder scalar in the symbol table, rather than a
8285 full CV. If anything is present then it will take a full CV to
8287 const I32 gv_fetch_flags
8288 = ec ? GV_NOADD_NOINIT :
8289 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8290 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8292 const char * const name =
8293 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8295 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8296 bool evanescent = FALSE;
8298 #ifdef PERL_DEBUG_READONLY_OPS
8299 OPSLAB *slab = NULL;
8307 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8308 hek and CvSTASH pointer together can imply the GV. If the name
8309 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8310 CvSTASH, so forego the optimisation if we find any.
8311 Also, we may be called from load_module at run time, so
8312 PL_curstash (which sets CvSTASH) may not point to the stash the
8313 sub is stored in. */
8315 ec ? GV_NOADD_NOINIT
8316 : PL_curstash != CopSTASH(PL_curcop)
8317 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8319 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8320 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8322 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8323 SV * const sv = sv_newmortal();
8324 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8325 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8326 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8327 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8329 } else if (PL_curstash) {
8330 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8333 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8338 move_proto_attr(&proto, &attrs, gv);
8341 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8346 assert(proto->op_type == OP_CONST);
8347 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8348 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8362 if (name) SvREFCNT_dec(PL_compcv);
8363 else cv = PL_compcv;
8365 if (name && block) {
8366 const char *s = strrchr(name, ':');
8368 if (strEQ(s, "BEGIN")) {
8369 if (PL_in_eval & EVAL_KEEPERR)
8370 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8372 SV * const errsv = ERRSV;
8373 /* force display of errors found but not reported */
8374 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8375 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8382 if (!block && SvTYPE(gv) != SVt_PVGV) {
8383 /* If we are not defining a new sub and the existing one is not a
8385 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8386 /* We are applying attributes to an existing sub, so we need it
8387 upgraded if it is a constant. */
8388 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8389 gv_init_pvn(gv, PL_curstash, name, namlen,
8390 SVf_UTF8 * name_is_utf8);
8392 else { /* Maybe prototype now, and had at maximum
8393 a prototype or const/sub ref before. */
8394 if (SvTYPE(gv) > SVt_NULL) {
8395 cv_ckproto_len_flags((const CV *)gv,
8396 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8401 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8402 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8405 sv_setiv(MUTABLE_SV(gv), -1);
8408 SvREFCNT_dec(PL_compcv);
8409 cv = PL_compcv = NULL;
8414 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8418 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8424 /* This makes sub {}; work as expected. */
8425 if (block->op_type == OP_STUB) {
8426 const line_t l = PL_parser->copline;
8428 block = newSTATEOP(0, NULL, 0);
8429 PL_parser->copline = l;
8431 block = CvLVALUE(PL_compcv)
8432 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8433 && (!isGV(gv) || !GvASSUMECV(gv)))
8434 ? newUNOP(OP_LEAVESUBLV, 0,
8435 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8436 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8437 start = LINKLIST(block);
8439 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8441 S_op_const_sv(aTHX_ start, PL_compcv,
8442 cBOOL(CvCLONE(PL_compcv)));
8449 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8450 cv_ckproto_len_flags((const CV *)gv,
8451 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8452 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8454 /* All the other code for sub redefinition warnings expects the
8455 clobbered sub to be a CV. Instead of making all those code
8456 paths more complex, just inline the RV version here. */
8457 const line_t oldline = CopLINE(PL_curcop);
8458 assert(IN_PERL_COMPILETIME);
8459 if (PL_parser && PL_parser->copline != NOLINE)
8460 /* This ensures that warnings are reported at the first
8461 line of a redefinition, not the last. */
8462 CopLINE_set(PL_curcop, PL_parser->copline);
8463 /* protect against fatal warnings leaking compcv */
8464 SAVEFREESV(PL_compcv);
8466 if (ckWARN(WARN_REDEFINE)
8467 || ( ckWARN_d(WARN_REDEFINE)
8468 && ( !const_sv || SvRV(gv) == const_sv
8469 || sv_cmp(SvRV(gv), const_sv) ))) {
8471 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8472 "Constant subroutine %"SVf" redefined",
8473 SVfARG(cSVOPo->op_sv));
8476 SvREFCNT_inc_simple_void_NN(PL_compcv);
8477 CopLINE_set(PL_curcop, oldline);
8478 SvREFCNT_dec(SvRV(gv));
8483 const bool exists = CvROOT(cv) || CvXSUB(cv);
8485 /* if the subroutine doesn't exist and wasn't pre-declared
8486 * with a prototype, assume it will be AUTOLOADed,
8487 * skipping the prototype check
8489 if (exists || SvPOK(cv))
8490 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8491 /* already defined (or promised)? */
8492 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8493 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8496 if (attrs) goto attrs;
8497 /* just a "sub foo;" when &foo is already defined */
8498 SAVEFREESV(PL_compcv);
8504 SvREFCNT_inc_simple_void_NN(const_sv);
8505 SvFLAGS(const_sv) |= SVs_PADTMP;
8507 assert(!CvROOT(cv) && !CvCONST(cv));
8509 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8510 CvXSUBANY(cv).any_ptr = const_sv;
8511 CvXSUB(cv) = const_sv_xsub;
8515 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8518 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8519 if (name && isGV(gv))
8521 cv = newCONSTSUB_flags(
8522 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8525 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8529 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8530 prepare_SV_for_RV((SV *)gv);
8534 SvRV_set(gv, const_sv);
8538 SvREFCNT_dec(PL_compcv);
8542 if (cv) { /* must reuse cv if autoloaded */
8543 /* transfer PL_compcv to cv */
8546 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8547 PADLIST *const temp_av = CvPADLIST(cv);
8548 CV *const temp_cv = CvOUTSIDE(cv);
8549 const cv_flags_t other_flags =
8550 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8551 OP * const cvstart = CvSTART(cv);
8555 assert(!CvCVGV_RC(cv));
8556 assert(CvGV(cv) == gv);
8561 PERL_HASH(hash, name, namlen);
8571 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8573 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8574 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8575 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8576 CvOUTSIDE(PL_compcv) = temp_cv;
8577 CvPADLIST_set(PL_compcv, temp_av);
8578 CvSTART(cv) = CvSTART(PL_compcv);
8579 CvSTART(PL_compcv) = cvstart;
8580 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8581 CvFLAGS(PL_compcv) |= other_flags;
8583 if (CvFILE(cv) && CvDYNFILE(cv)) {
8584 Safefree(CvFILE(cv));
8586 CvFILE_set_from_cop(cv, PL_curcop);
8587 CvSTASH_set(cv, PL_curstash);
8589 /* inner references to PL_compcv must be fixed up ... */
8590 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8591 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8592 ++PL_sub_generation;
8595 /* Might have had built-in attributes applied -- propagate them. */
8596 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8598 /* ... before we throw it away */
8599 SvREFCNT_dec(PL_compcv);
8604 if (name && isGV(gv)) {
8607 if (HvENAME_HEK(GvSTASH(gv)))
8608 /* sub Foo::bar { (shift)+1 } */
8609 gv_method_changed(gv);
8613 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8614 prepare_SV_for_RV((SV *)gv);
8618 SvRV_set(gv, (SV *)cv);
8622 if (isGV(gv)) CvGV_set(cv, gv);
8626 PERL_HASH(hash, name, namlen);
8627 CvNAME_HEK_set(cv, share_hek(name,
8633 CvFILE_set_from_cop(cv, PL_curcop);
8634 CvSTASH_set(cv, PL_curstash);
8638 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8639 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8645 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8646 the debugger could be able to set a breakpoint in, so signal to
8647 pp_entereval that it should not throw away any saved lines at scope
8650 PL_breakable_sub_gen++;
8652 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8653 OpREFCNT_set(CvROOT(cv), 1);
8654 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8655 itself has a refcount. */
8657 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8658 #ifdef PERL_DEBUG_READONLY_OPS
8659 slab = (OPSLAB *)CvSTART(cv);
8661 CvSTART(cv) = start;
8663 finalize_optree(CvROOT(cv));
8664 S_prune_chain_head(&CvSTART(cv));
8666 /* now that optimizer has done its work, adjust pad values */
8668 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8672 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8673 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8676 if (!name) SAVEFREESV(cv);
8677 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8678 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8681 if (block && has_name) {
8682 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8683 SV * const tmpstr = cv_name(cv,NULL,0);
8684 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8685 GV_ADDMULTI, SVt_PVHV);
8687 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8690 (long)CopLINE(PL_curcop));
8691 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8692 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8693 hv = GvHVn(db_postponed);
8694 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8695 CV * const pcv = GvCV(db_postponed);
8701 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8707 if (PL_parser && PL_parser->error_count)
8708 clear_special_blocks(name, gv, cv);
8711 process_special_blocks(floor, name, gv, cv);
8717 PL_parser->copline = NOLINE;
8720 #ifdef PERL_DEBUG_READONLY_OPS
8724 if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8725 pad_add_weakref(cv);
8731 S_clear_special_blocks(pTHX_ const char *const fullname,
8732 GV *const gv, CV *const cv) {
8736 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8738 colon = strrchr(fullname,':');
8739 name = colon ? colon + 1 : fullname;
8741 if ((*name == 'B' && strEQ(name, "BEGIN"))
8742 || (*name == 'E' && strEQ(name, "END"))
8743 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8744 || (*name == 'C' && strEQ(name, "CHECK"))
8745 || (*name == 'I' && strEQ(name, "INIT"))) {
8751 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8755 /* Returns true if the sub has been freed. */
8757 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8761 const char *const colon = strrchr(fullname,':');
8762 const char *const name = colon ? colon + 1 : fullname;
8764 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8767 if (strEQ(name, "BEGIN")) {
8768 const I32 oldscope = PL_scopestack_ix;
8771 if (floor) LEAVE_SCOPE(floor);
8773 PUSHSTACKi(PERLSI_REQUIRE);
8774 SAVECOPFILE(&PL_compiling);
8775 SAVECOPLINE(&PL_compiling);
8776 SAVEVPTR(PL_curcop);
8778 DEBUG_x( dump_sub(gv) );
8779 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8780 GvCV_set(gv,0); /* cv has been hijacked */
8781 call_list(oldscope, PL_beginav);
8785 return !PL_savebegin;
8791 if strEQ(name, "END") {
8792 DEBUG_x( dump_sub(gv) );
8793 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8796 } else if (*name == 'U') {
8797 if (strEQ(name, "UNITCHECK")) {
8798 /* It's never too late to run a unitcheck block */
8799 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8803 } else if (*name == 'C') {
8804 if (strEQ(name, "CHECK")) {
8806 /* diag_listed_as: Too late to run %s block */
8807 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8808 "Too late to run CHECK block");
8809 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8813 } else if (*name == 'I') {
8814 if (strEQ(name, "INIT")) {
8816 /* diag_listed_as: Too late to run %s block */
8817 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8818 "Too late to run INIT block");
8819 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8825 DEBUG_x( dump_sub(gv) );
8827 GvCV_set(gv,0); /* cv has been hijacked */
8833 =for apidoc newCONSTSUB
8835 See L</newCONSTSUB_flags>.
8841 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8843 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8847 =for apidoc newCONSTSUB_flags
8849 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
8850 eligible for inlining at compile-time.
8852 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
8854 The newly created subroutine takes ownership of a reference to the passed in
8857 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
8858 which won't be called if used as a destructor, but will suppress the overhead
8859 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8866 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8870 const char *const file = CopFILE(PL_curcop);
8874 if (IN_PERL_RUNTIME) {
8875 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8876 * an op shared between threads. Use a non-shared COP for our
8878 SAVEVPTR(PL_curcop);
8879 SAVECOMPILEWARNINGS();
8880 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8881 PL_curcop = &PL_compiling;
8883 SAVECOPLINE(PL_curcop);
8884 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8887 PL_hints &= ~HINT_BLOCK_SCOPE;
8890 SAVEGENERICSV(PL_curstash);
8891 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8894 /* Protect sv against leakage caused by fatal warnings. */
8895 if (sv) SAVEFREESV(sv);
8897 /* file becomes the CvFILE. For an XS, it's usually static storage,
8898 and so doesn't get free()d. (It's expected to be from the C pre-
8899 processor __FILE__ directive). But we need a dynamically allocated one,
8900 and we need it to get freed. */
8901 cv = newXS_len_flags(name, len,
8902 sv && SvTYPE(sv) == SVt_PVAV
8905 file ? file : "", "",
8906 &sv, XS_DYNAMIC_FILENAME | flags);
8907 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8916 =for apidoc U||newXS
8918 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
8919 static storage, as it is used directly as CvFILE(), without a copy being made.
8925 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8927 PERL_ARGS_ASSERT_NEWXS;
8928 return newXS_len_flags(
8929 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8934 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8935 const char *const filename, const char *const proto,
8938 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8939 return newXS_len_flags(
8940 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8945 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
8947 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
8948 return newXS_len_flags(
8949 name, strlen(name), subaddr, NULL, NULL, NULL, 0
8954 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8955 XSUBADDR_t subaddr, const char *const filename,
8956 const char *const proto, SV **const_svp,
8960 bool interleave = FALSE;
8962 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8965 GV * const gv = gv_fetchpvn(
8966 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8967 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8968 sizeof("__ANON__::__ANON__") - 1,
8969 GV_ADDMULTI | flags, SVt_PVCV);
8971 if ((cv = (name ? GvCV(gv) : NULL))) {
8973 /* just a cached method */
8977 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8978 /* already defined (or promised) */
8979 /* Redundant check that allows us to avoid creating an SV
8980 most of the time: */
8981 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8982 report_redefined_cv(newSVpvn_flags(
8983 name,len,(flags&SVf_UTF8)|SVs_TEMP
8994 if (cv) /* must reuse cv if autoloaded */
8997 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9001 if (HvENAME_HEK(GvSTASH(gv)))
9002 gv_method_changed(gv); /* newXS */
9008 /* XSUBs can't be perl lang/perl5db.pl debugged
9009 if (PERLDB_LINE_OR_SAVESRC)
9010 (void)gv_fetchfile(filename); */
9011 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9012 if (flags & XS_DYNAMIC_FILENAME) {
9014 CvFILE(cv) = savepv(filename);
9016 /* NOTE: not copied, as it is expected to be an external constant string */
9017 CvFILE(cv) = (char *)filename;
9020 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9021 CvFILE(cv) = (char*)PL_xsubfilename;
9024 CvXSUB(cv) = subaddr;
9025 #ifndef PERL_IMPLICIT_CONTEXT
9026 CvHSCXT(cv) = &PL_stack_sp;
9032 process_special_blocks(0, name, gv, cv);
9035 } /* <- not a conditional branch */
9038 sv_setpv(MUTABLE_SV(cv), proto);
9039 if (interleave) LEAVE;
9044 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9046 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9048 PERL_ARGS_ASSERT_NEWSTUB;
9052 if (!fake && HvENAME_HEK(GvSTASH(gv)))
9053 gv_method_changed(gv);
9055 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9060 CvFILE_set_from_cop(cv, PL_curcop);
9061 CvSTASH_set(cv, PL_curstash);
9067 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9073 if (PL_parser && PL_parser->error_count) {
9079 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9080 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9083 if ((cv = GvFORM(gv))) {
9084 if (ckWARN(WARN_REDEFINE)) {
9085 const line_t oldline = CopLINE(PL_curcop);
9086 if (PL_parser && PL_parser->copline != NOLINE)
9087 CopLINE_set(PL_curcop, PL_parser->copline);
9089 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9090 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9092 /* diag_listed_as: Format %s redefined */
9093 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9094 "Format STDOUT redefined");
9096 CopLINE_set(PL_curcop, oldline);
9101 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9103 CvFILE_set_from_cop(cv, PL_curcop);
9106 pad_tidy(padtidy_FORMAT);
9107 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9108 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9109 OpREFCNT_set(CvROOT(cv), 1);
9110 CvSTART(cv) = LINKLIST(CvROOT(cv));
9111 CvROOT(cv)->op_next = 0;
9112 CALL_PEEP(CvSTART(cv));
9113 finalize_optree(CvROOT(cv));
9114 S_prune_chain_head(&CvSTART(cv));
9120 PL_parser->copline = NOLINE;
9122 PL_compiling.cop_seq = 0;
9126 Perl_newANONLIST(pTHX_ OP *o)
9128 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9132 Perl_newANONHASH(pTHX_ OP *o)
9134 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9138 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9140 return newANONATTRSUB(floor, proto, NULL, block);
9144 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9146 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9148 newSVOP(OP_ANONCODE, 0,
9150 if (CvANONCONST(cv))
9151 anoncode = newUNOP(OP_ANONCONST, 0,
9152 op_convert_list(OP_ENTERSUB,
9153 OPf_STACKED|OPf_WANT_SCALAR,
9155 return newUNOP(OP_REFGEN, 0, anoncode);
9159 Perl_oopsAV(pTHX_ OP *o)
9163 PERL_ARGS_ASSERT_OOPSAV;
9165 switch (o->op_type) {
9168 OpTYPE_set(o, OP_PADAV);
9169 return ref(o, OP_RV2AV);
9173 OpTYPE_set(o, OP_RV2AV);
9178 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9185 Perl_oopsHV(pTHX_ OP *o)
9189 PERL_ARGS_ASSERT_OOPSHV;
9191 switch (o->op_type) {
9194 OpTYPE_set(o, OP_PADHV);
9195 return ref(o, OP_RV2HV);
9199 OpTYPE_set(o, OP_RV2HV);
9204 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9211 Perl_newAVREF(pTHX_ OP *o)
9215 PERL_ARGS_ASSERT_NEWAVREF;
9217 if (o->op_type == OP_PADANY) {
9218 OpTYPE_set(o, OP_PADAV);
9221 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9222 Perl_croak(aTHX_ "Can't use an array as a reference");
9224 return newUNOP(OP_RV2AV, 0, scalar(o));
9228 Perl_newGVREF(pTHX_ I32 type, OP *o)
9230 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9231 return newUNOP(OP_NULL, 0, o);
9232 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9236 Perl_newHVREF(pTHX_ OP *o)
9240 PERL_ARGS_ASSERT_NEWHVREF;
9242 if (o->op_type == OP_PADANY) {
9243 OpTYPE_set(o, OP_PADHV);
9246 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9247 Perl_croak(aTHX_ "Can't use a hash as a reference");
9249 return newUNOP(OP_RV2HV, 0, scalar(o));
9253 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9255 if (o->op_type == OP_PADANY) {
9257 OpTYPE_set(o, OP_PADCV);
9259 return newUNOP(OP_RV2CV, flags, scalar(o));
9263 Perl_newSVREF(pTHX_ OP *o)
9267 PERL_ARGS_ASSERT_NEWSVREF;
9269 if (o->op_type == OP_PADANY) {
9270 OpTYPE_set(o, OP_PADSV);
9274 return newUNOP(OP_RV2SV, 0, scalar(o));
9277 /* Check routines. See the comments at the top of this file for details
9278 * on when these are called */
9281 Perl_ck_anoncode(pTHX_ OP *o)
9283 PERL_ARGS_ASSERT_CK_ANONCODE;
9285 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9286 cSVOPo->op_sv = NULL;
9291 S_io_hints(pTHX_ OP *o)
9293 #if O_BINARY != 0 || O_TEXT != 0
9295 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9297 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9300 const char *d = SvPV_const(*svp, len);
9301 const I32 mode = mode_from_discipline(d, len);
9302 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9304 if (mode & O_BINARY)
9305 o->op_private |= OPpOPEN_IN_RAW;
9309 o->op_private |= OPpOPEN_IN_CRLF;
9313 svp = hv_fetchs(table, "open_OUT", FALSE);
9316 const char *d = SvPV_const(*svp, len);
9317 const I32 mode = mode_from_discipline(d, len);
9318 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9320 if (mode & O_BINARY)
9321 o->op_private |= OPpOPEN_OUT_RAW;
9325 o->op_private |= OPpOPEN_OUT_CRLF;
9330 PERL_UNUSED_CONTEXT;
9336 Perl_ck_backtick(pTHX_ OP *o)
9341 PERL_ARGS_ASSERT_CK_BACKTICK;
9342 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9343 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9344 && (gv = gv_override("readpipe",8)))
9346 /* detach rest of siblings from o and its first child */
9347 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9348 newop = S_new_entersubop(aTHX_ gv, sibl);
9350 else if (!(o->op_flags & OPf_KIDS))
9351 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9356 S_io_hints(aTHX_ o);
9361 Perl_ck_bitop(pTHX_ OP *o)
9363 PERL_ARGS_ASSERT_CK_BITOP;
9365 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9367 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9368 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9369 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9370 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9371 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9372 "The bitwise feature is experimental");
9373 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9374 && OP_IS_INFIX_BIT(o->op_type))
9376 const OP * const left = cBINOPo->op_first;
9377 const OP * const right = OpSIBLING(left);
9378 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9379 (left->op_flags & OPf_PARENS) == 0) ||
9380 (OP_IS_NUMCOMPARE(right->op_type) &&
9381 (right->op_flags & OPf_PARENS) == 0))
9382 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9383 "Possible precedence problem on bitwise %s operator",
9384 o->op_type == OP_BIT_OR
9385 ||o->op_type == OP_NBIT_OR ? "|"
9386 : o->op_type == OP_BIT_AND
9387 ||o->op_type == OP_NBIT_AND ? "&"
9388 : o->op_type == OP_BIT_XOR
9389 ||o->op_type == OP_NBIT_XOR ? "^"
9390 : o->op_type == OP_SBIT_OR ? "|."
9391 : o->op_type == OP_SBIT_AND ? "&." : "^."
9397 PERL_STATIC_INLINE bool
9398 is_dollar_bracket(pTHX_ const OP * const o)
9401 PERL_UNUSED_CONTEXT;
9402 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9403 && (kid = cUNOPx(o)->op_first)
9404 && kid->op_type == OP_GV
9405 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9409 Perl_ck_cmp(pTHX_ OP *o)
9411 PERL_ARGS_ASSERT_CK_CMP;
9412 if (ckWARN(WARN_SYNTAX)) {
9413 const OP *kid = cUNOPo->op_first;
9416 ( is_dollar_bracket(aTHX_ kid)
9417 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9419 || ( kid->op_type == OP_CONST
9420 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9424 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9425 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9431 Perl_ck_concat(pTHX_ OP *o)
9433 const OP * const kid = cUNOPo->op_first;
9435 PERL_ARGS_ASSERT_CK_CONCAT;
9436 PERL_UNUSED_CONTEXT;
9438 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9439 !(kUNOP->op_first->op_flags & OPf_MOD))
9440 o->op_flags |= OPf_STACKED;
9445 Perl_ck_spair(pTHX_ OP *o)
9449 PERL_ARGS_ASSERT_CK_SPAIR;
9451 if (o->op_flags & OPf_KIDS) {
9455 const OPCODE type = o->op_type;
9456 o = modkids(ck_fun(o), type);
9457 kid = cUNOPo->op_first;
9458 kidkid = kUNOP->op_first;
9459 newop = OpSIBLING(kidkid);
9461 const OPCODE type = newop->op_type;
9462 if (OpHAS_SIBLING(newop))
9464 if (o->op_type == OP_REFGEN
9465 && ( type == OP_RV2CV
9466 || ( !(newop->op_flags & OPf_PARENS)
9467 && ( type == OP_RV2AV || type == OP_PADAV
9468 || type == OP_RV2HV || type == OP_PADHV))))
9469 NOOP; /* OK (allow srefgen for \@a and \%h) */
9470 else if (OP_GIMME(newop,0) != G_SCALAR)
9473 /* excise first sibling */
9474 op_sibling_splice(kid, NULL, 1, NULL);
9477 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9478 * and OP_CHOMP into OP_SCHOMP */
9479 o->op_ppaddr = PL_ppaddr[++o->op_type];
9484 Perl_ck_delete(pTHX_ OP *o)
9486 PERL_ARGS_ASSERT_CK_DELETE;
9490 if (o->op_flags & OPf_KIDS) {
9491 OP * const kid = cUNOPo->op_first;
9492 switch (kid->op_type) {
9494 o->op_flags |= OPf_SPECIAL;
9497 o->op_private |= OPpSLICE;
9500 o->op_flags |= OPf_SPECIAL;
9505 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9506 " use array slice");
9508 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9511 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9512 "element or slice");
9514 if (kid->op_private & OPpLVAL_INTRO)
9515 o->op_private |= OPpLVAL_INTRO;
9522 Perl_ck_eof(pTHX_ OP *o)
9524 PERL_ARGS_ASSERT_CK_EOF;
9526 if (o->op_flags & OPf_KIDS) {
9528 if (cLISTOPo->op_first->op_type == OP_STUB) {
9530 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9535 kid = cLISTOPo->op_first;
9536 if (kid->op_type == OP_RV2GV)
9537 kid->op_private |= OPpALLOW_FAKE;
9543 Perl_ck_eval(pTHX_ OP *o)
9547 PERL_ARGS_ASSERT_CK_EVAL;
9549 PL_hints |= HINT_BLOCK_SCOPE;
9550 if (o->op_flags & OPf_KIDS) {
9551 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9554 if (o->op_type == OP_ENTERTRY) {
9557 /* cut whole sibling chain free from o */
9558 op_sibling_splice(o, NULL, -1, NULL);
9561 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9563 /* establish postfix order */
9564 enter->op_next = (OP*)enter;
9566 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9567 OpTYPE_set(o, OP_LEAVETRY);
9568 enter->op_other = o;
9573 S_set_haseval(aTHX);
9577 const U8 priv = o->op_private;
9579 /* the newUNOP will recursively call ck_eval(), which will handle
9580 * all the stuff at the end of this function, like adding
9583 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9585 o->op_targ = (PADOFFSET)PL_hints;
9586 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9587 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9588 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9589 /* Store a copy of %^H that pp_entereval can pick up. */
9590 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9591 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9592 /* append hhop to only child */
9593 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9595 o->op_private |= OPpEVAL_HAS_HH;
9597 if (!(o->op_private & OPpEVAL_BYTES)
9598 && FEATURE_UNIEVAL_IS_ENABLED)
9599 o->op_private |= OPpEVAL_UNICODE;
9604 Perl_ck_exec(pTHX_ OP *o)
9606 PERL_ARGS_ASSERT_CK_EXEC;
9608 if (o->op_flags & OPf_STACKED) {
9611 kid = OpSIBLING(cUNOPo->op_first);
9612 if (kid->op_type == OP_RV2GV)
9621 Perl_ck_exists(pTHX_ OP *o)
9623 PERL_ARGS_ASSERT_CK_EXISTS;
9626 if (o->op_flags & OPf_KIDS) {
9627 OP * const kid = cUNOPo->op_first;
9628 if (kid->op_type == OP_ENTERSUB) {
9629 (void) ref(kid, o->op_type);
9630 if (kid->op_type != OP_RV2CV
9631 && !(PL_parser && PL_parser->error_count))
9633 "exists argument is not a subroutine name");
9634 o->op_private |= OPpEXISTS_SUB;
9636 else if (kid->op_type == OP_AELEM)
9637 o->op_flags |= OPf_SPECIAL;
9638 else if (kid->op_type != OP_HELEM)
9639 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9640 "element or a subroutine");
9647 Perl_ck_rvconst(pTHX_ OP *o)
9650 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9652 PERL_ARGS_ASSERT_CK_RVCONST;
9654 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9656 if (kid->op_type == OP_CONST) {
9659 SV * const kidsv = kid->op_sv;
9661 /* Is it a constant from cv_const_sv()? */
9662 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9665 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9666 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9667 const char *badthing;
9668 switch (o->op_type) {
9670 badthing = "a SCALAR";
9673 badthing = "an ARRAY";
9676 badthing = "a HASH";
9684 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9685 SVfARG(kidsv), badthing);
9688 * This is a little tricky. We only want to add the symbol if we
9689 * didn't add it in the lexer. Otherwise we get duplicate strict
9690 * warnings. But if we didn't add it in the lexer, we must at
9691 * least pretend like we wanted to add it even if it existed before,
9692 * or we get possible typo warnings. OPpCONST_ENTERED says
9693 * whether the lexer already added THIS instance of this symbol.
9695 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9696 gv = gv_fetchsv(kidsv,
9697 o->op_type == OP_RV2CV
9698 && o->op_private & OPpMAY_RETURN_CONSTANT
9700 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9703 : o->op_type == OP_RV2SV
9705 : o->op_type == OP_RV2AV
9707 : o->op_type == OP_RV2HV
9714 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9715 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9716 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9718 OpTYPE_set(kid, OP_GV);
9719 SvREFCNT_dec(kid->op_sv);
9721 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9722 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9723 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9724 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9725 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9727 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9729 kid->op_private = 0;
9730 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9738 Perl_ck_ftst(pTHX_ OP *o)
9741 const I32 type = o->op_type;
9743 PERL_ARGS_ASSERT_CK_FTST;
9745 if (o->op_flags & OPf_REF) {
9748 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9749 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9750 const OPCODE kidtype = kid->op_type;
9752 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9753 && !kid->op_folded) {
9754 OP * const newop = newGVOP(type, OPf_REF,
9755 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9760 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
9761 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
9763 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9764 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
9765 array_passed_to_stat, name);
9768 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9769 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
9773 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9774 o->op_private |= OPpFT_ACCESS;
9775 if (type != OP_STAT && type != OP_LSTAT
9776 && PL_check[kidtype] == Perl_ck_ftst
9777 && kidtype != OP_STAT && kidtype != OP_LSTAT
9779 o->op_private |= OPpFT_STACKED;
9780 kid->op_private |= OPpFT_STACKING;
9781 if (kidtype == OP_FTTTY && (
9782 !(kid->op_private & OPpFT_STACKED)
9783 || kid->op_private & OPpFT_AFTER_t
9785 o->op_private |= OPpFT_AFTER_t;
9790 if (type == OP_FTTTY)
9791 o = newGVOP(type, OPf_REF, PL_stdingv);
9793 o = newUNOP(type, 0, newDEFSVOP());
9799 Perl_ck_fun(pTHX_ OP *o)
9801 const int type = o->op_type;
9802 I32 oa = PL_opargs[type] >> OASHIFT;
9804 PERL_ARGS_ASSERT_CK_FUN;
9806 if (o->op_flags & OPf_STACKED) {
9807 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9810 return no_fh_allowed(o);
9813 if (o->op_flags & OPf_KIDS) {
9814 OP *prev_kid = NULL;
9815 OP *kid = cLISTOPo->op_first;
9817 bool seen_optional = FALSE;
9819 if (kid->op_type == OP_PUSHMARK ||
9820 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9823 kid = OpSIBLING(kid);
9825 if (kid && kid->op_type == OP_COREARGS) {
9826 bool optional = FALSE;
9829 if (oa & OA_OPTIONAL) optional = TRUE;
9832 if (optional) o->op_private |= numargs;
9837 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9838 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9840 /* append kid to chain */
9841 op_sibling_splice(o, prev_kid, 0, kid);
9843 seen_optional = TRUE;
9850 /* list seen where single (scalar) arg expected? */
9851 if (numargs == 1 && !(oa >> 4)
9852 && kid->op_type == OP_LIST && type != OP_SCALAR)
9854 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9856 if (type != OP_DELETE) scalar(kid);
9867 if ((type == OP_PUSH || type == OP_UNSHIFT)
9868 && !OpHAS_SIBLING(kid))
9869 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9870 "Useless use of %s with no values",
9873 if (kid->op_type == OP_CONST
9874 && ( !SvROK(cSVOPx_sv(kid))
9875 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9877 bad_type_pv(numargs, "array", o, kid);
9878 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9879 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9880 PL_op_desc[type]), 0);
9883 op_lvalue(kid, type);
9887 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9888 bad_type_pv(numargs, "hash", o, kid);
9889 op_lvalue(kid, type);
9893 /* replace kid with newop in chain */
9895 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9896 newop->op_next = newop;
9901 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9902 if (kid->op_type == OP_CONST &&
9903 (kid->op_private & OPpCONST_BARE))
9905 OP * const newop = newGVOP(OP_GV, 0,
9906 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9907 /* replace kid with newop in chain */
9908 op_sibling_splice(o, prev_kid, 1, newop);
9912 else if (kid->op_type == OP_READLINE) {
9913 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9914 bad_type_pv(numargs, "HANDLE", o, kid);
9917 I32 flags = OPf_SPECIAL;
9921 /* is this op a FH constructor? */
9922 if (is_handle_constructor(o,numargs)) {
9923 const char *name = NULL;
9926 bool want_dollar = TRUE;
9929 /* Set a flag to tell rv2gv to vivify
9930 * need to "prove" flag does not mean something
9931 * else already - NI-S 1999/05/07
9934 if (kid->op_type == OP_PADSV) {
9936 = PAD_COMPNAME_SV(kid->op_targ);
9937 name = PadnamePV (pn);
9938 len = PadnameLEN(pn);
9939 name_utf8 = PadnameUTF8(pn);
9941 else if (kid->op_type == OP_RV2SV
9942 && kUNOP->op_first->op_type == OP_GV)
9944 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9946 len = GvNAMELEN(gv);
9947 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9949 else if (kid->op_type == OP_AELEM
9950 || kid->op_type == OP_HELEM)
9953 OP *op = ((BINOP*)kid)->op_first;
9957 const char * const a =
9958 kid->op_type == OP_AELEM ?
9960 if (((op->op_type == OP_RV2AV) ||
9961 (op->op_type == OP_RV2HV)) &&
9962 (firstop = ((UNOP*)op)->op_first) &&
9963 (firstop->op_type == OP_GV)) {
9964 /* packagevar $a[] or $h{} */
9965 GV * const gv = cGVOPx_gv(firstop);
9973 else if (op->op_type == OP_PADAV
9974 || op->op_type == OP_PADHV) {
9975 /* lexicalvar $a[] or $h{} */
9976 const char * const padname =
9977 PAD_COMPNAME_PV(op->op_targ);
9986 name = SvPV_const(tmpstr, len);
9987 name_utf8 = SvUTF8(tmpstr);
9992 name = "__ANONIO__";
9994 want_dollar = FALSE;
9996 op_lvalue(kid, type);
10000 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10001 namesv = PAD_SVl(targ);
10002 if (want_dollar && *name != '$')
10003 sv_setpvs(namesv, "$");
10005 sv_setpvs(namesv, "");
10006 sv_catpvn(namesv, name, len);
10007 if ( name_utf8 ) SvUTF8_on(namesv);
10011 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10013 kid->op_targ = targ;
10014 kid->op_private |= priv;
10020 if ((type == OP_UNDEF || type == OP_POS)
10021 && numargs == 1 && !(oa >> 4)
10022 && kid->op_type == OP_LIST)
10023 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10024 op_lvalue(scalar(kid), type);
10029 kid = OpSIBLING(kid);
10031 /* FIXME - should the numargs or-ing move after the too many
10032 * arguments check? */
10033 o->op_private |= numargs;
10035 return too_many_arguments_pv(o,OP_DESC(o), 0);
10038 else if (PL_opargs[type] & OA_DEFGV) {
10039 /* Ordering of these two is important to keep f_map.t passing. */
10041 return newUNOP(type, 0, newDEFSVOP());
10045 while (oa & OA_OPTIONAL)
10047 if (oa && oa != OA_LIST)
10048 return too_few_arguments_pv(o,OP_DESC(o), 0);
10054 Perl_ck_glob(pTHX_ OP *o)
10058 PERL_ARGS_ASSERT_CK_GLOB;
10061 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10062 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10064 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10068 * \ null - const(wildcard)
10073 * \ mark - glob - rv2cv
10074 * | \ gv(CORE::GLOBAL::glob)
10076 * \ null - const(wildcard)
10078 o->op_flags |= OPf_SPECIAL;
10079 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10080 o = S_new_entersubop(aTHX_ gv, o);
10081 o = newUNOP(OP_NULL, 0, o);
10082 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10085 else o->op_flags &= ~OPf_SPECIAL;
10086 #if !defined(PERL_EXTERNAL_GLOB)
10087 if (!PL_globhook) {
10089 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10090 newSVpvs("File::Glob"), NULL, NULL, NULL);
10093 #endif /* !PERL_EXTERNAL_GLOB */
10094 gv = (GV *)newSV(0);
10095 gv_init(gv, 0, "", 0, 0);
10097 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10098 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10104 Perl_ck_grep(pTHX_ OP *o)
10108 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10110 PERL_ARGS_ASSERT_CK_GREP;
10112 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10114 if (o->op_flags & OPf_STACKED) {
10115 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10116 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10117 return no_fh_allowed(o);
10118 o->op_flags &= ~OPf_STACKED;
10120 kid = OpSIBLING(cLISTOPo->op_first);
10121 if (type == OP_MAPWHILE)
10126 if (PL_parser && PL_parser->error_count)
10128 kid = OpSIBLING(cLISTOPo->op_first);
10129 if (kid->op_type != OP_NULL)
10130 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10131 kid = kUNOP->op_first;
10133 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10134 kid->op_next = (OP*)gwop;
10135 o->op_private = gwop->op_private = 0;
10136 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10138 kid = OpSIBLING(cLISTOPo->op_first);
10139 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10140 op_lvalue(kid, OP_GREPSTART);
10146 Perl_ck_index(pTHX_ OP *o)
10148 PERL_ARGS_ASSERT_CK_INDEX;
10150 if (o->op_flags & OPf_KIDS) {
10151 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10153 kid = OpSIBLING(kid); /* get past "big" */
10154 if (kid && kid->op_type == OP_CONST) {
10155 const bool save_taint = TAINT_get;
10156 SV *sv = kSVOP->op_sv;
10157 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10159 sv_copypv(sv, kSVOP->op_sv);
10160 SvREFCNT_dec_NN(kSVOP->op_sv);
10163 if (SvOK(sv)) fbm_compile(sv, 0);
10164 TAINT_set(save_taint);
10165 #ifdef NO_TAINT_SUPPORT
10166 PERL_UNUSED_VAR(save_taint);
10174 Perl_ck_lfun(pTHX_ OP *o)
10176 const OPCODE type = o->op_type;
10178 PERL_ARGS_ASSERT_CK_LFUN;
10180 return modkids(ck_fun(o), type);
10184 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10186 PERL_ARGS_ASSERT_CK_DEFINED;
10188 if ((o->op_flags & OPf_KIDS)) {
10189 switch (cUNOPo->op_first->op_type) {
10192 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10193 " (Maybe you should just omit the defined()?)");
10197 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10198 " (Maybe you should just omit the defined()?)");
10209 Perl_ck_readline(pTHX_ OP *o)
10211 PERL_ARGS_ASSERT_CK_READLINE;
10213 if (o->op_flags & OPf_KIDS) {
10214 OP *kid = cLISTOPo->op_first;
10215 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10219 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10227 Perl_ck_rfun(pTHX_ OP *o)
10229 const OPCODE type = o->op_type;
10231 PERL_ARGS_ASSERT_CK_RFUN;
10233 return refkids(ck_fun(o), type);
10237 Perl_ck_listiob(pTHX_ OP *o)
10241 PERL_ARGS_ASSERT_CK_LISTIOB;
10243 kid = cLISTOPo->op_first;
10245 o = force_list(o, 1);
10246 kid = cLISTOPo->op_first;
10248 if (kid->op_type == OP_PUSHMARK)
10249 kid = OpSIBLING(kid);
10250 if (kid && o->op_flags & OPf_STACKED)
10251 kid = OpSIBLING(kid);
10252 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10253 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10254 && !kid->op_folded) {
10255 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10257 /* replace old const op with new OP_RV2GV parent */
10258 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10259 OP_RV2GV, OPf_REF);
10260 kid = OpSIBLING(kid);
10265 op_append_elem(o->op_type, o, newDEFSVOP());
10267 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10268 return listkids(o);
10272 Perl_ck_smartmatch(pTHX_ OP *o)
10275 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10276 if (0 == (o->op_flags & OPf_SPECIAL)) {
10277 OP *first = cBINOPo->op_first;
10278 OP *second = OpSIBLING(first);
10280 /* Implicitly take a reference to an array or hash */
10282 /* remove the original two siblings, then add back the
10283 * (possibly different) first and second sibs.
10285 op_sibling_splice(o, NULL, 1, NULL);
10286 op_sibling_splice(o, NULL, 1, NULL);
10287 first = ref_array_or_hash(first);
10288 second = ref_array_or_hash(second);
10289 op_sibling_splice(o, NULL, 0, second);
10290 op_sibling_splice(o, NULL, 0, first);
10292 /* Implicitly take a reference to a regular expression */
10293 if (first->op_type == OP_MATCH) {
10294 OpTYPE_set(first, OP_QR);
10296 if (second->op_type == OP_MATCH) {
10297 OpTYPE_set(second, OP_QR);
10306 S_maybe_targlex(pTHX_ OP *o)
10308 OP * const kid = cLISTOPo->op_first;
10309 /* has a disposable target? */
10310 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10311 && !(kid->op_flags & OPf_STACKED)
10312 /* Cannot steal the second time! */
10313 && !(kid->op_private & OPpTARGET_MY)
10316 OP * const kkid = OpSIBLING(kid);
10318 /* Can just relocate the target. */
10319 if (kkid && kkid->op_type == OP_PADSV
10320 && (!(kkid->op_private & OPpLVAL_INTRO)
10321 || kkid->op_private & OPpPAD_STATE))
10323 kid->op_targ = kkid->op_targ;
10325 /* Now we do not need PADSV and SASSIGN.
10326 * Detach kid and free the rest. */
10327 op_sibling_splice(o, NULL, 1, NULL);
10329 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10337 Perl_ck_sassign(pTHX_ OP *o)
10340 OP * const kid = cLISTOPo->op_first;
10342 PERL_ARGS_ASSERT_CK_SASSIGN;
10344 if (OpHAS_SIBLING(kid)) {
10345 OP *kkid = OpSIBLING(kid);
10346 /* For state variable assignment with attributes, kkid is a list op
10347 whose op_last is a padsv. */
10348 if ((kkid->op_type == OP_PADSV ||
10349 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10350 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10353 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10354 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10355 const PADOFFSET target = kkid->op_targ;
10356 OP *const other = newOP(OP_PADSV,
10358 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10359 OP *const first = newOP(OP_NULL, 0);
10361 newCONDOP(0, first, o, other);
10362 /* XXX targlex disabled for now; see ticket #124160
10363 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10365 OP *const condop = first->op_next;
10367 OpTYPE_set(condop, OP_ONCE);
10368 other->op_targ = target;
10369 nullop->op_flags |= OPf_WANT_SCALAR;
10371 /* Store the initializedness of state vars in a separate
10374 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10375 /* hijacking PADSTALE for uninitialized state variables */
10376 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10381 return S_maybe_targlex(aTHX_ o);
10385 Perl_ck_match(pTHX_ OP *o)
10387 PERL_UNUSED_CONTEXT;
10388 PERL_ARGS_ASSERT_CK_MATCH;
10390 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10391 o->op_private |= OPpRUNTIME;
10396 Perl_ck_method(pTHX_ OP *o)
10398 SV *sv, *methsv, *rclass;
10399 const char* method;
10402 STRLEN len, nsplit = 0, i;
10404 OP * const kid = cUNOPo->op_first;
10406 PERL_ARGS_ASSERT_CK_METHOD;
10407 if (kid->op_type != OP_CONST) return o;
10411 /* replace ' with :: */
10412 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10414 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10417 method = SvPVX_const(sv);
10419 utf8 = SvUTF8(sv) ? -1 : 1;
10421 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10426 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10428 if (!nsplit) { /* $proto->method() */
10430 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10433 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10435 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10438 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10439 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10440 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10441 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10443 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10444 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10446 #ifdef USE_ITHREADS
10447 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10449 cMETHOPx(new_op)->op_rclass_sv = rclass;
10456 Perl_ck_null(pTHX_ OP *o)
10458 PERL_ARGS_ASSERT_CK_NULL;
10459 PERL_UNUSED_CONTEXT;
10464 Perl_ck_open(pTHX_ OP *o)
10466 PERL_ARGS_ASSERT_CK_OPEN;
10468 S_io_hints(aTHX_ o);
10470 /* In case of three-arg dup open remove strictness
10471 * from the last arg if it is a bareword. */
10472 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10473 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10477 if ((last->op_type == OP_CONST) && /* The bareword. */
10478 (last->op_private & OPpCONST_BARE) &&
10479 (last->op_private & OPpCONST_STRICT) &&
10480 (oa = OpSIBLING(first)) && /* The fh. */
10481 (oa = OpSIBLING(oa)) && /* The mode. */
10482 (oa->op_type == OP_CONST) &&
10483 SvPOK(((SVOP*)oa)->op_sv) &&
10484 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10485 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10486 (last == OpSIBLING(oa))) /* The bareword. */
10487 last->op_private &= ~OPpCONST_STRICT;
10493 Perl_ck_prototype(pTHX_ OP *o)
10495 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10496 if (!(o->op_flags & OPf_KIDS)) {
10498 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10504 Perl_ck_refassign(pTHX_ OP *o)
10506 OP * const right = cLISTOPo->op_first;
10507 OP * const left = OpSIBLING(right);
10508 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10511 PERL_ARGS_ASSERT_CK_REFASSIGN;
10513 assert (left->op_type == OP_SREFGEN);
10516 /* we use OPpPAD_STATE in refassign to mean either of those things,
10517 * and the code assumes the two flags occupy the same bit position
10518 * in the various ops below */
10519 assert(OPpPAD_STATE == OPpOUR_INTRO);
10521 switch (varop->op_type) {
10523 o->op_private |= OPpLVREF_AV;
10526 o->op_private |= OPpLVREF_HV;
10530 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10531 o->op_targ = varop->op_targ;
10532 varop->op_targ = 0;
10533 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10537 o->op_private |= OPpLVREF_AV;
10539 NOT_REACHED; /* NOTREACHED */
10541 o->op_private |= OPpLVREF_HV;
10545 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10546 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10548 /* Point varop to its GV kid, detached. */
10549 varop = op_sibling_splice(varop, NULL, -1, NULL);
10553 OP * const kidparent =
10554 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10555 OP * const kid = cUNOPx(kidparent)->op_first;
10556 o->op_private |= OPpLVREF_CV;
10557 if (kid->op_type == OP_GV) {
10559 goto detach_and_stack;
10561 if (kid->op_type != OP_PADCV) goto bad;
10562 o->op_targ = kid->op_targ;
10568 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10569 o->op_private |= OPpLVREF_ELEM;
10572 /* Detach varop. */
10573 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10577 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10578 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10583 if (!FEATURE_REFALIASING_IS_ENABLED)
10585 "Experimental aliasing via reference not enabled");
10586 Perl_ck_warner_d(aTHX_
10587 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10588 "Aliasing via reference is experimental");
10590 o->op_flags |= OPf_STACKED;
10591 op_sibling_splice(o, right, 1, varop);
10594 o->op_flags &=~ OPf_STACKED;
10595 op_sibling_splice(o, right, 1, NULL);
10602 Perl_ck_repeat(pTHX_ OP *o)
10604 PERL_ARGS_ASSERT_CK_REPEAT;
10606 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10608 o->op_private |= OPpREPEAT_DOLIST;
10609 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10610 kids = force_list(kids, 1); /* promote it to a list */
10611 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10619 Perl_ck_require(pTHX_ OP *o)
10623 PERL_ARGS_ASSERT_CK_REQUIRE;
10625 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10626 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10631 if (kid->op_type == OP_CONST) {
10632 SV * const sv = kid->op_sv;
10633 U32 const was_readonly = SvREADONLY(sv);
10634 if (kid->op_private & OPpCONST_BARE) {
10638 if (was_readonly) {
10639 SvREADONLY_off(sv);
10641 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10646 /* treat ::foo::bar as foo::bar */
10647 if (len >= 2 && s[0] == ':' && s[1] == ':')
10648 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
10650 DIE(aTHX_ "Bareword in require maps to empty filename");
10652 for (; s < end; s++) {
10653 if (*s == ':' && s[1] == ':') {
10655 Move(s+2, s+1, end - s - 1, char);
10659 SvEND_set(sv, end);
10660 sv_catpvs(sv, ".pm");
10661 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10662 hek = share_hek(SvPVX(sv),
10663 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10665 sv_sethek(sv, hek);
10667 SvFLAGS(sv) |= was_readonly;
10669 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10672 if (SvREFCNT(sv) > 1) {
10673 kid->op_sv = newSVpvn_share(
10674 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10675 SvREFCNT_dec_NN(sv);
10679 if (was_readonly) SvREADONLY_off(sv);
10680 PERL_HASH(hash, s, len);
10682 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10684 sv_sethek(sv, hek);
10686 SvFLAGS(sv) |= was_readonly;
10692 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10693 /* handle override, if any */
10694 && (gv = gv_override("require", 7))) {
10696 if (o->op_flags & OPf_KIDS) {
10697 kid = cUNOPo->op_first;
10698 op_sibling_splice(o, NULL, -1, NULL);
10701 kid = newDEFSVOP();
10704 newop = S_new_entersubop(aTHX_ gv, kid);
10712 Perl_ck_return(pTHX_ OP *o)
10716 PERL_ARGS_ASSERT_CK_RETURN;
10718 kid = OpSIBLING(cLISTOPo->op_first);
10719 if (CvLVALUE(PL_compcv)) {
10720 for (; kid; kid = OpSIBLING(kid))
10721 op_lvalue(kid, OP_LEAVESUBLV);
10728 Perl_ck_select(pTHX_ OP *o)
10733 PERL_ARGS_ASSERT_CK_SELECT;
10735 if (o->op_flags & OPf_KIDS) {
10736 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10737 if (kid && OpHAS_SIBLING(kid)) {
10738 OpTYPE_set(o, OP_SSELECT);
10740 return fold_constants(op_integerize(op_std_init(o)));
10744 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10745 if (kid && kid->op_type == OP_RV2GV)
10746 kid->op_private &= ~HINT_STRICT_REFS;
10751 Perl_ck_shift(pTHX_ OP *o)
10753 const I32 type = o->op_type;
10755 PERL_ARGS_ASSERT_CK_SHIFT;
10757 if (!(o->op_flags & OPf_KIDS)) {
10760 if (!CvUNIQUE(PL_compcv)) {
10761 o->op_flags |= OPf_SPECIAL;
10765 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10767 return newUNOP(type, 0, scalar(argop));
10769 return scalar(ck_fun(o));
10773 Perl_ck_sort(pTHX_ OP *o)
10777 HV * const hinthv =
10778 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10781 PERL_ARGS_ASSERT_CK_SORT;
10784 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10786 const I32 sorthints = (I32)SvIV(*svp);
10787 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10788 o->op_private |= OPpSORT_QSORT;
10789 if ((sorthints & HINT_SORT_STABLE) != 0)
10790 o->op_private |= OPpSORT_STABLE;
10794 if (o->op_flags & OPf_STACKED)
10796 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10798 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10799 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10801 /* if the first arg is a code block, process it and mark sort as
10803 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10805 if (kid->op_type == OP_LEAVE)
10806 op_null(kid); /* wipe out leave */
10807 /* Prevent execution from escaping out of the sort block. */
10810 /* provide scalar context for comparison function/block */
10811 kid = scalar(firstkid);
10812 kid->op_next = kid;
10813 o->op_flags |= OPf_SPECIAL;
10815 else if (kid->op_type == OP_CONST
10816 && kid->op_private & OPpCONST_BARE) {
10820 const char * const name = SvPV(kSVOP_sv, len);
10822 assert (len < 256);
10823 Copy(name, tmpbuf+1, len, char);
10824 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10825 if (off != NOT_IN_PAD) {
10826 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10828 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10829 sv_catpvs(fq, "::");
10830 sv_catsv(fq, kSVOP_sv);
10831 SvREFCNT_dec_NN(kSVOP_sv);
10835 OP * const padop = newOP(OP_PADCV, 0);
10836 padop->op_targ = off;
10837 /* replace the const op with the pad op */
10838 op_sibling_splice(firstkid, NULL, 1, padop);
10844 firstkid = OpSIBLING(firstkid);
10847 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10848 /* provide list context for arguments */
10851 op_lvalue(kid, OP_GREPSTART);
10857 /* for sort { X } ..., where X is one of
10858 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10859 * elide the second child of the sort (the one containing X),
10860 * and set these flags as appropriate
10864 * Also, check and warn on lexical $a, $b.
10868 S_simplify_sort(pTHX_ OP *o)
10870 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10874 const char *gvname;
10877 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10879 kid = kUNOP->op_first; /* get past null */
10880 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10881 && kid->op_type != OP_LEAVE)
10883 kid = kLISTOP->op_last; /* get past scope */
10884 switch(kid->op_type) {
10888 if (!have_scopeop) goto padkids;
10893 k = kid; /* remember this node*/
10894 if (kBINOP->op_first->op_type != OP_RV2SV
10895 || kBINOP->op_last ->op_type != OP_RV2SV)
10898 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10899 then used in a comparison. This catches most, but not
10900 all cases. For instance, it catches
10901 sort { my($a); $a <=> $b }
10903 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10904 (although why you'd do that is anyone's guess).
10908 if (!ckWARN(WARN_SYNTAX)) return;
10909 kid = kBINOP->op_first;
10911 if (kid->op_type == OP_PADSV) {
10912 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
10913 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
10914 && ( PadnamePV(name)[1] == 'a'
10915 || PadnamePV(name)[1] == 'b' ))
10916 /* diag_listed_as: "my %s" used in sort comparison */
10917 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10918 "\"%s %s\" used in sort comparison",
10919 PadnameIsSTATE(name)
10924 } while ((kid = OpSIBLING(kid)));
10927 kid = kBINOP->op_first; /* get past cmp */
10928 if (kUNOP->op_first->op_type != OP_GV)
10930 kid = kUNOP->op_first; /* get past rv2sv */
10932 if (GvSTASH(gv) != PL_curstash)
10934 gvname = GvNAME(gv);
10935 if (*gvname == 'a' && gvname[1] == '\0')
10937 else if (*gvname == 'b' && gvname[1] == '\0')
10942 kid = k; /* back to cmp */
10943 /* already checked above that it is rv2sv */
10944 kid = kBINOP->op_last; /* down to 2nd arg */
10945 if (kUNOP->op_first->op_type != OP_GV)
10947 kid = kUNOP->op_first; /* get past rv2sv */
10949 if (GvSTASH(gv) != PL_curstash)
10951 gvname = GvNAME(gv);
10953 ? !(*gvname == 'a' && gvname[1] == '\0')
10954 : !(*gvname == 'b' && gvname[1] == '\0'))
10956 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10958 o->op_private |= OPpSORT_DESCEND;
10959 if (k->op_type == OP_NCMP)
10960 o->op_private |= OPpSORT_NUMERIC;
10961 if (k->op_type == OP_I_NCMP)
10962 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10963 kid = OpSIBLING(cLISTOPo->op_first);
10964 /* cut out and delete old block (second sibling) */
10965 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10970 Perl_ck_split(pTHX_ OP *o)
10975 PERL_ARGS_ASSERT_CK_SPLIT;
10977 if (o->op_flags & OPf_STACKED)
10978 return no_fh_allowed(o);
10980 kid = cLISTOPo->op_first;
10981 if (kid->op_type != OP_NULL)
10982 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10983 /* delete leading NULL node, then add a CONST if no other nodes */
10984 op_sibling_splice(o, NULL, 1,
10985 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10987 kid = cLISTOPo->op_first;
10989 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10990 /* remove kid, and replace with new optree */
10991 op_sibling_splice(o, NULL, 1, NULL);
10992 /* OPf_SPECIAL is used to trigger split " " behavior */
10993 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
10994 op_sibling_splice(o, NULL, 0, kid);
10996 OpTYPE_set(kid, OP_PUSHRE);
10997 /* target implies @ary=..., so wipe it */
11000 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11001 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11002 "Use of /g modifier is meaningless in split");
11005 if (!OpHAS_SIBLING(kid))
11006 op_append_elem(OP_SPLIT, o, newDEFSVOP());
11008 kid = OpSIBLING(kid);
11012 if (!OpHAS_SIBLING(kid))
11014 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
11015 o->op_private |= OPpSPLIT_IMPLIM;
11017 assert(OpHAS_SIBLING(kid));
11019 kid = OpSIBLING(kid);
11022 if (OpHAS_SIBLING(kid))
11023 return too_many_arguments_pv(o,OP_DESC(o), 0);
11029 Perl_ck_stringify(pTHX_ OP *o)
11031 OP * const kid = OpSIBLING(cUNOPo->op_first);
11032 PERL_ARGS_ASSERT_CK_STRINGIFY;
11033 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11034 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
11035 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
11036 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11038 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11046 Perl_ck_join(pTHX_ OP *o)
11048 OP * const kid = OpSIBLING(cLISTOPo->op_first);
11050 PERL_ARGS_ASSERT_CK_JOIN;
11052 if (kid && kid->op_type == OP_MATCH) {
11053 if (ckWARN(WARN_SYNTAX)) {
11054 const REGEXP *re = PM_GETRE(kPMOP);
11056 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11057 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11058 : newSVpvs_flags( "STRING", SVs_TEMP );
11059 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11060 "/%"SVf"/ should probably be written as \"%"SVf"\"",
11061 SVfARG(msg), SVfARG(msg));
11065 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11066 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11067 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11068 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11070 const OP * const bairn = OpSIBLING(kid); /* the list */
11071 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11072 && OP_GIMME(bairn,0) == G_SCALAR)
11074 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11075 op_sibling_splice(o, kid, 1, NULL));
11085 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11087 Examines an op, which is expected to identify a subroutine at runtime,
11088 and attempts to determine at compile time which subroutine it identifies.
11089 This is normally used during Perl compilation to determine whether
11090 a prototype can be applied to a function call. C<cvop> is the op
11091 being considered, normally an C<rv2cv> op. A pointer to the identified
11092 subroutine is returned, if it could be determined statically, and a null
11093 pointer is returned if it was not possible to determine statically.
11095 Currently, the subroutine can be identified statically if the RV that the
11096 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11097 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11098 suitable if the constant value must be an RV pointing to a CV. Details of
11099 this process may change in future versions of Perl. If the C<rv2cv> op
11100 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11101 the subroutine statically: this flag is used to suppress compile-time
11102 magic on a subroutine call, forcing it to use default runtime behaviour.
11104 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11105 of a GV reference is modified. If a GV was examined and its CV slot was
11106 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11107 If the op is not optimised away, and the CV slot is later populated with
11108 a subroutine having a prototype, that flag eventually triggers the warning
11109 "called too early to check prototype".
11111 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11112 of returning a pointer to the subroutine it returns a pointer to the
11113 GV giving the most appropriate name for the subroutine in this context.
11114 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11115 (C<CvANON>) subroutine that is referenced through a GV it will be the
11116 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11117 A null pointer is returned as usual if there is no statically-determinable
11123 /* shared by toke.c:yylex */
11125 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11127 PADNAME *name = PAD_COMPNAME(off);
11128 CV *compcv = PL_compcv;
11129 while (PadnameOUTER(name)) {
11130 assert(PARENT_PAD_INDEX(name));
11131 compcv = CvOUTSIDE(compcv);
11132 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11133 [off = PARENT_PAD_INDEX(name)];
11135 assert(!PadnameIsOUR(name));
11136 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11137 return PadnamePROTOCV(name);
11139 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11143 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11148 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11149 if (flags & ~RV2CVOPCV_FLAG_MASK)
11150 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11151 if (cvop->op_type != OP_RV2CV)
11153 if (cvop->op_private & OPpENTERSUB_AMPER)
11155 if (!(cvop->op_flags & OPf_KIDS))
11157 rvop = cUNOPx(cvop)->op_first;
11158 switch (rvop->op_type) {
11160 gv = cGVOPx_gv(rvop);
11162 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11163 cv = MUTABLE_CV(SvRV(gv));
11167 if (flags & RV2CVOPCV_RETURN_STUB)
11173 if (flags & RV2CVOPCV_MARK_EARLY)
11174 rvop->op_private |= OPpEARLY_CV;
11179 SV *rv = cSVOPx_sv(rvop);
11182 cv = (CV*)SvRV(rv);
11186 cv = find_lexical_cv(rvop->op_targ);
11191 } NOT_REACHED; /* NOTREACHED */
11193 if (SvTYPE((SV*)cv) != SVt_PVCV)
11195 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11196 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11197 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11206 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11208 Performs the default fixup of the arguments part of an C<entersub>
11209 op tree. This consists of applying list context to each of the
11210 argument ops. This is the standard treatment used on a call marked
11211 with C<&>, or a method call, or a call through a subroutine reference,
11212 or any other call where the callee can't be identified at compile time,
11213 or a call where the callee has no prototype.
11219 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11223 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11225 aop = cUNOPx(entersubop)->op_first;
11226 if (!OpHAS_SIBLING(aop))
11227 aop = cUNOPx(aop)->op_first;
11228 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11229 /* skip the extra attributes->import() call implicitly added in
11230 * something like foo(my $x : bar)
11232 if ( aop->op_type == OP_ENTERSUB
11233 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11237 op_lvalue(aop, OP_ENTERSUB);
11243 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11245 Performs the fixup of the arguments part of an C<entersub> op tree
11246 based on a subroutine prototype. This makes various modifications to
11247 the argument ops, from applying context up to inserting C<refgen> ops,
11248 and checking the number and syntactic types of arguments, as directed by
11249 the prototype. This is the standard treatment used on a subroutine call,
11250 not marked with C<&>, where the callee can be identified at compile time
11251 and has a prototype.
11253 C<protosv> supplies the subroutine prototype to be applied to the call.
11254 It may be a normal defined scalar, of which the string value will be used.
11255 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11256 that has been cast to C<SV*>) which has a prototype. The prototype
11257 supplied, in whichever form, does not need to match the actual callee
11258 referenced by the op tree.
11260 If the argument ops disagree with the prototype, for example by having
11261 an unacceptable number of arguments, a valid op tree is returned anyway.
11262 The error is reflected in the parser state, normally resulting in a single
11263 exception at the top level of parsing which covers all the compilation
11264 errors that occurred. In the error message, the callee is referred to
11265 by the name defined by the C<namegv> parameter.
11271 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11274 const char *proto, *proto_end;
11275 OP *aop, *prev, *cvop, *parent;
11278 I32 contextclass = 0;
11279 const char *e = NULL;
11280 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11281 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11282 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11283 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11284 if (SvTYPE(protosv) == SVt_PVCV)
11285 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11286 else proto = SvPV(protosv, proto_len);
11287 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11288 proto_end = proto + proto_len;
11289 parent = entersubop;
11290 aop = cUNOPx(entersubop)->op_first;
11291 if (!OpHAS_SIBLING(aop)) {
11293 aop = cUNOPx(aop)->op_first;
11296 aop = OpSIBLING(aop);
11297 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11298 while (aop != cvop) {
11301 if (proto >= proto_end)
11303 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11304 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11305 SVfARG(namesv)), SvUTF8(namesv));
11315 /* _ must be at the end */
11316 if (proto[1] && !strchr(";@%", proto[1]))
11332 if ( o3->op_type != OP_UNDEF
11333 && (o3->op_type != OP_SREFGEN
11334 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11336 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11338 bad_type_gv(arg, namegv, o3,
11339 arg == 1 ? "block or sub {}" : "sub {}");
11342 /* '*' allows any scalar type, including bareword */
11345 if (o3->op_type == OP_RV2GV)
11346 goto wrapref; /* autoconvert GLOB -> GLOBref */
11347 else if (o3->op_type == OP_CONST)
11348 o3->op_private &= ~OPpCONST_STRICT;
11354 if (o3->op_type == OP_RV2AV ||
11355 o3->op_type == OP_PADAV ||
11356 o3->op_type == OP_RV2HV ||
11357 o3->op_type == OP_PADHV
11363 case '[': case ']':
11370 switch (*proto++) {
11372 if (contextclass++ == 0) {
11373 e = strchr(proto, ']');
11374 if (!e || e == proto)
11382 if (contextclass) {
11383 const char *p = proto;
11384 const char *const end = proto;
11386 while (*--p != '[')
11387 /* \[$] accepts any scalar lvalue */
11389 && Perl_op_lvalue_flags(aTHX_
11391 OP_READ, /* not entersub */
11394 bad_type_gv(arg, namegv, o3,
11395 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11400 if (o3->op_type == OP_RV2GV)
11403 bad_type_gv(arg, namegv, o3, "symbol");
11406 if (o3->op_type == OP_ENTERSUB
11407 && !(o3->op_flags & OPf_STACKED))
11410 bad_type_gv(arg, namegv, o3, "subroutine");
11413 if (o3->op_type == OP_RV2SV ||
11414 o3->op_type == OP_PADSV ||
11415 o3->op_type == OP_HELEM ||
11416 o3->op_type == OP_AELEM)
11418 if (!contextclass) {
11419 /* \$ accepts any scalar lvalue */
11420 if (Perl_op_lvalue_flags(aTHX_
11422 OP_READ, /* not entersub */
11425 bad_type_gv(arg, namegv, o3, "scalar");
11429 if (o3->op_type == OP_RV2AV ||
11430 o3->op_type == OP_PADAV)
11432 o3->op_flags &=~ OPf_PARENS;
11436 bad_type_gv(arg, namegv, o3, "array");
11439 if (o3->op_type == OP_RV2HV ||
11440 o3->op_type == OP_PADHV)
11442 o3->op_flags &=~ OPf_PARENS;
11446 bad_type_gv(arg, namegv, o3, "hash");
11449 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11451 if (contextclass && e) {
11456 default: goto oops;
11466 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11467 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11472 op_lvalue(aop, OP_ENTERSUB);
11474 aop = OpSIBLING(aop);
11476 if (aop == cvop && *proto == '_') {
11477 /* generate an access to $_ */
11478 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11480 if (!optional && proto_end > proto &&
11481 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11483 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11484 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11485 SVfARG(namesv)), SvUTF8(namesv));
11491 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11493 Performs the fixup of the arguments part of an C<entersub> op tree either
11494 based on a subroutine prototype or using default list-context processing.
11495 This is the standard treatment used on a subroutine call, not marked
11496 with C<&>, where the callee can be identified at compile time.
11498 C<protosv> supplies the subroutine prototype to be applied to the call,
11499 or indicates that there is no prototype. It may be a normal scalar,
11500 in which case if it is defined then the string value will be used
11501 as a prototype, and if it is undefined then there is no prototype.
11502 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11503 that has been cast to C<SV*>), of which the prototype will be used if it
11504 has one. The prototype (or lack thereof) supplied, in whichever form,
11505 does not need to match the actual callee referenced by the op tree.
11507 If the argument ops disagree with the prototype, for example by having
11508 an unacceptable number of arguments, a valid op tree is returned anyway.
11509 The error is reflected in the parser state, normally resulting in a single
11510 exception at the top level of parsing which covers all the compilation
11511 errors that occurred. In the error message, the callee is referred to
11512 by the name defined by the C<namegv> parameter.
11518 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11519 GV *namegv, SV *protosv)
11521 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11522 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11523 return ck_entersub_args_proto(entersubop, namegv, protosv);
11525 return ck_entersub_args_list(entersubop);
11529 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11531 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11532 OP *aop = cUNOPx(entersubop)->op_first;
11534 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11538 if (!OpHAS_SIBLING(aop))
11539 aop = cUNOPx(aop)->op_first;
11540 aop = OpSIBLING(aop);
11541 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11543 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11545 op_free(entersubop);
11546 switch(GvNAME(namegv)[2]) {
11547 case 'F': return newSVOP(OP_CONST, 0,
11548 newSVpv(CopFILE(PL_curcop),0));
11549 case 'L': return newSVOP(
11551 Perl_newSVpvf(aTHX_
11552 "%"IVdf, (IV)CopLINE(PL_curcop)
11555 case 'P': return newSVOP(OP_CONST, 0,
11557 ? newSVhek(HvNAME_HEK(PL_curstash))
11562 NOT_REACHED; /* NOTREACHED */
11565 OP *prev, *cvop, *first, *parent;
11568 parent = entersubop;
11569 if (!OpHAS_SIBLING(aop)) {
11571 aop = cUNOPx(aop)->op_first;
11574 first = prev = aop;
11575 aop = OpSIBLING(aop);
11576 /* find last sibling */
11578 OpHAS_SIBLING(cvop);
11579 prev = cvop, cvop = OpSIBLING(cvop))
11581 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11582 /* Usually, OPf_SPECIAL on an op with no args means that it had
11583 * parens, but these have their own meaning for that flag: */
11584 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11585 && opnum != OP_DELETE && opnum != OP_EXISTS)
11586 flags |= OPf_SPECIAL;
11587 /* excise cvop from end of sibling chain */
11588 op_sibling_splice(parent, prev, 1, NULL);
11590 if (aop == cvop) aop = NULL;
11592 /* detach remaining siblings from the first sibling, then
11593 * dispose of original optree */
11596 op_sibling_splice(parent, first, -1, NULL);
11597 op_free(entersubop);
11599 if (opnum == OP_ENTEREVAL
11600 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11601 flags |= OPpEVAL_BYTES <<8;
11603 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11605 case OA_BASEOP_OR_UNOP:
11606 case OA_FILESTATOP:
11607 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11610 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11613 return opnum == OP_RUNCV
11614 ? newPVOP(OP_RUNCV,0,NULL)
11617 return op_convert_list(opnum,0,aop);
11620 NOT_REACHED; /* NOTREACHED */
11625 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11627 Retrieves the function that will be used to fix up a call to C<cv>.
11628 Specifically, the function is applied to an C<entersub> op tree for a
11629 subroutine call, not marked with C<&>, where the callee can be identified
11630 at compile time as C<cv>.
11632 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11633 argument for it is returned in C<*ckobj_p>. The function is intended
11634 to be called in this manner:
11636 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11638 In this call, C<entersubop> is a pointer to the C<entersub> op,
11639 which may be replaced by the check function, and C<namegv> is a GV
11640 supplying the name that should be used by the check function to refer
11641 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11642 It is permitted to apply the check function in non-standard situations,
11643 such as to a call to a different subroutine or to a method call.
11645 By default, the function is
11646 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11647 and the SV parameter is C<cv> itself. This implements standard
11648 prototype processing. It can be changed, for a particular subroutine,
11649 by L</cv_set_call_checker>.
11655 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11659 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11661 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11662 *ckobj_p = callmg->mg_obj;
11663 if (flagsp) *flagsp = callmg->mg_flags;
11665 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11666 *ckobj_p = (SV*)cv;
11667 if (flagsp) *flagsp = 0;
11672 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11674 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11675 PERL_UNUSED_CONTEXT;
11676 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11680 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11682 Sets the function that will be used to fix up a call to C<cv>.
11683 Specifically, the function is applied to an C<entersub> op tree for a
11684 subroutine call, not marked with C<&>, where the callee can be identified
11685 at compile time as C<cv>.
11687 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11688 for it is supplied in C<ckobj>. The function should be defined like this:
11690 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11692 It is intended to be called in this manner:
11694 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11696 In this call, C<entersubop> is a pointer to the C<entersub> op,
11697 which may be replaced by the check function, and C<namegv> supplies
11698 the name that should be used by the check function to refer
11699 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11700 It is permitted to apply the check function in non-standard situations,
11701 such as to a call to a different subroutine or to a method call.
11703 C<namegv> may not actually be a GV. For efficiency, perl may pass a
11704 CV or other SV instead. Whatever is passed can be used as the first
11705 argument to L</cv_name>. You can force perl to pass a GV by including
11706 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11708 The current setting for a particular CV can be retrieved by
11709 L</cv_get_call_checker>.
11711 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11713 The original form of L</cv_set_call_checker_flags>, which passes it the
11714 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11720 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11722 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11723 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11727 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11728 SV *ckobj, U32 flags)
11730 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11731 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11732 if (SvMAGICAL((SV*)cv))
11733 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11736 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11737 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11739 if (callmg->mg_flags & MGf_REFCOUNTED) {
11740 SvREFCNT_dec(callmg->mg_obj);
11741 callmg->mg_flags &= ~MGf_REFCOUNTED;
11743 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11744 callmg->mg_obj = ckobj;
11745 if (ckobj != (SV*)cv) {
11746 SvREFCNT_inc_simple_void_NN(ckobj);
11747 callmg->mg_flags |= MGf_REFCOUNTED;
11749 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11750 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11755 S_entersub_alloc_targ(pTHX_ OP * const o)
11757 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11758 o->op_private |= OPpENTERSUB_HASTARG;
11762 Perl_ck_subr(pTHX_ OP *o)
11767 SV **const_class = NULL;
11769 PERL_ARGS_ASSERT_CK_SUBR;
11771 aop = cUNOPx(o)->op_first;
11772 if (!OpHAS_SIBLING(aop))
11773 aop = cUNOPx(aop)->op_first;
11774 aop = OpSIBLING(aop);
11775 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11776 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11777 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11779 o->op_private &= ~1;
11780 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11781 if (PERLDB_SUB && PL_curstash != PL_debstash)
11782 o->op_private |= OPpENTERSUB_DB;
11783 switch (cvop->op_type) {
11785 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11789 case OP_METHOD_NAMED:
11790 case OP_METHOD_SUPER:
11791 case OP_METHOD_REDIR:
11792 case OP_METHOD_REDIR_SUPER:
11793 if (aop->op_type == OP_CONST) {
11794 aop->op_private &= ~OPpCONST_STRICT;
11795 const_class = &cSVOPx(aop)->op_sv;
11797 else if (aop->op_type == OP_LIST) {
11798 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11799 if (sib && sib->op_type == OP_CONST) {
11800 sib->op_private &= ~OPpCONST_STRICT;
11801 const_class = &cSVOPx(sib)->op_sv;
11804 /* make class name a shared cow string to speedup method calls */
11805 /* constant string might be replaced with object, f.e. bigint */
11806 if (const_class && SvPOK(*const_class)) {
11808 const char* str = SvPV(*const_class, len);
11810 SV* const shared = newSVpvn_share(
11811 str, SvUTF8(*const_class)
11812 ? -(SSize_t)len : (SSize_t)len,
11815 if (SvREADONLY(*const_class))
11816 SvREADONLY_on(shared);
11817 SvREFCNT_dec(*const_class);
11818 *const_class = shared;
11825 S_entersub_alloc_targ(aTHX_ o);
11826 return ck_entersub_args_list(o);
11828 Perl_call_checker ckfun;
11831 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11832 if (CvISXSUB(cv) || !CvROOT(cv))
11833 S_entersub_alloc_targ(aTHX_ o);
11835 /* The original call checker API guarantees that a GV will be
11836 be provided with the right name. So, if the old API was
11837 used (or the REQUIRE_GV flag was passed), we have to reify
11838 the CV’s GV, unless this is an anonymous sub. This is not
11839 ideal for lexical subs, as its stringification will include
11840 the package. But it is the best we can do. */
11841 if (flags & MGf_REQUIRE_GV) {
11842 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11845 else namegv = MUTABLE_GV(cv);
11846 /* After a syntax error in a lexical sub, the cv that
11847 rv2cv_op_cv returns may be a nameless stub. */
11848 if (!namegv) return ck_entersub_args_list(o);
11851 return ckfun(aTHX_ o, namegv, ckobj);
11856 Perl_ck_svconst(pTHX_ OP *o)
11858 SV * const sv = cSVOPo->op_sv;
11859 PERL_ARGS_ASSERT_CK_SVCONST;
11860 PERL_UNUSED_CONTEXT;
11861 #ifdef PERL_COPY_ON_WRITE
11862 /* Since the read-only flag may be used to protect a string buffer, we
11863 cannot do copy-on-write with existing read-only scalars that are not
11864 already copy-on-write scalars. To allow $_ = "hello" to do COW with
11865 that constant, mark the constant as COWable here, if it is not
11866 already read-only. */
11867 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11870 # ifdef PERL_DEBUG_READONLY_COW
11880 Perl_ck_trunc(pTHX_ OP *o)
11882 PERL_ARGS_ASSERT_CK_TRUNC;
11884 if (o->op_flags & OPf_KIDS) {
11885 SVOP *kid = (SVOP*)cUNOPo->op_first;
11887 if (kid->op_type == OP_NULL)
11888 kid = (SVOP*)OpSIBLING(kid);
11889 if (kid && kid->op_type == OP_CONST &&
11890 (kid->op_private & OPpCONST_BARE) &&
11893 o->op_flags |= OPf_SPECIAL;
11894 kid->op_private &= ~OPpCONST_STRICT;
11901 Perl_ck_substr(pTHX_ OP *o)
11903 PERL_ARGS_ASSERT_CK_SUBSTR;
11906 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11907 OP *kid = cLISTOPo->op_first;
11909 if (kid->op_type == OP_NULL)
11910 kid = OpSIBLING(kid);
11912 kid->op_flags |= OPf_MOD;
11919 Perl_ck_tell(pTHX_ OP *o)
11921 PERL_ARGS_ASSERT_CK_TELL;
11923 if (o->op_flags & OPf_KIDS) {
11924 OP *kid = cLISTOPo->op_first;
11925 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
11926 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11932 Perl_ck_each(pTHX_ OP *o)
11935 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11936 const unsigned orig_type = o->op_type;
11938 PERL_ARGS_ASSERT_CK_EACH;
11941 switch (kid->op_type) {
11947 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
11948 : orig_type == OP_KEYS ? OP_AKEYS
11952 if (kid->op_private == OPpCONST_BARE
11953 || !SvROK(cSVOPx_sv(kid))
11954 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11955 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
11957 /* we let ck_fun handle it */
11960 yyerror_pv(Perl_form(aTHX_
11961 "Experimental %s on scalar is now forbidden",
11962 PL_op_desc[orig_type]), 0);
11970 Perl_ck_length(pTHX_ OP *o)
11972 PERL_ARGS_ASSERT_CK_LENGTH;
11976 if (ckWARN(WARN_SYNTAX)) {
11977 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11981 const bool hash = kid->op_type == OP_PADHV
11982 || kid->op_type == OP_RV2HV;
11983 switch (kid->op_type) {
11988 name = S_op_varname(aTHX_ kid);
11994 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11995 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11997 SVfARG(name), hash ? "keys " : "", SVfARG(name)
12000 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12001 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12002 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12004 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12005 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12006 "length() used on @array (did you mean \"scalar(@array)\"?)");
12016 ---------------------------------------------------------
12018 Common vars in list assignment
12020 There now follows some enums and static functions for detecting
12021 common variables in list assignments. Here is a little essay I wrote
12022 for myself when trying to get my head around this. DAPM.
12026 First some random observations:
12028 * If a lexical var is an alias of something else, e.g.
12029 for my $x ($lex, $pkg, $a[0]) {...}
12030 then the act of aliasing will increase the reference count of the SV
12032 * If a package var is an alias of something else, it may still have a
12033 reference count of 1, depending on how the alias was created, e.g.
12034 in *a = *b, $a may have a refcount of 1 since the GP is shared
12035 with a single GvSV pointer to the SV. So If it's an alias of another
12036 package var, then RC may be 1; if it's an alias of another scalar, e.g.
12037 a lexical var or an array element, then it will have RC > 1.
12039 * There are many ways to create a package alias; ultimately, XS code
12040 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12041 run-time tracing mechanisms are unlikely to be able to catch all cases.
12043 * When the LHS is all my declarations, the same vars can't appear directly
12044 on the RHS, but they can indirectly via closures, aliasing and lvalue
12045 subs. But those techniques all involve an increase in the lexical
12046 scalar's ref count.
12048 * When the LHS is all lexical vars (but not necessarily my declarations),
12049 it is possible for the same lexicals to appear directly on the RHS, and
12050 without an increased ref count, since the stack isn't refcounted.
12051 This case can be detected at compile time by scanning for common lex
12052 vars with PL_generation.
12054 * lvalue subs defeat common var detection, but they do at least
12055 return vars with a temporary ref count increment. Also, you can't
12056 tell at compile time whether a sub call is lvalue.
12061 A: There are a few circumstances where there definitely can't be any
12064 LHS empty: () = (...);
12065 RHS empty: (....) = ();
12066 RHS contains only constants or other 'can't possibly be shared'
12067 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
12068 i.e. they only contain ops not marked as dangerous, whose children
12069 are also not dangerous;
12071 LHS contains a single scalar element: e.g. ($x) = (....); because
12072 after $x has been modified, it won't be used again on the RHS;
12073 RHS contains a single element with no aggregate on LHS: e.g.
12074 ($a,$b,$c) = ($x); again, once $a has been modified, its value
12075 won't be used again.
12077 B: If LHS are all 'my' lexical var declarations (or safe ops, which
12080 my ($a, $b, @c) = ...;
12082 Due to closure and goto tricks, these vars may already have content.
12083 For the same reason, an element on the RHS may be a lexical or package
12084 alias of one of the vars on the left, or share common elements, for
12087 my ($x,$y) = f(); # $x and $y on both sides
12088 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12093 my @a = @$ra; # elements of @a on both sides
12094 sub f { @a = 1..4; \@a }
12097 First, just consider scalar vars on LHS:
12099 RHS is safe only if (A), or in addition,
12100 * contains only lexical *scalar* vars, where neither side's
12101 lexicals have been flagged as aliases
12103 If RHS is not safe, then it's always legal to check LHS vars for
12104 RC==1, since the only RHS aliases will always be associated
12107 Note that in particular, RHS is not safe if:
12109 * it contains package scalar vars; e.g.:
12112 my ($x, $y) = (2, $x_alias);
12113 sub f { $x = 1; *x_alias = \$x; }
12115 * It contains other general elements, such as flattened or
12116 * spliced or single array or hash elements, e.g.
12119 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12123 use feature 'refaliasing';
12124 \($a[0], $a[1]) = \($y,$x);
12127 It doesn't matter if the array/hash is lexical or package.
12129 * it contains a function call that happens to be an lvalue
12130 sub which returns one or more of the above, e.g.
12141 (so a sub call on the RHS should be treated the same
12142 as having a package var on the RHS).
12144 * any other "dangerous" thing, such an op or built-in that
12145 returns one of the above, e.g. pp_preinc
12148 If RHS is not safe, what we can do however is at compile time flag
12149 that the LHS are all my declarations, and at run time check whether
12150 all the LHS have RC == 1, and if so skip the full scan.
12152 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12154 Here the issue is whether there can be elements of @a on the RHS
12155 which will get prematurely freed when @a is cleared prior to
12156 assignment. This is only a problem if the aliasing mechanism
12157 is one which doesn't increase the refcount - only if RC == 1
12158 will the RHS element be prematurely freed.
12160 Because the array/hash is being INTROed, it or its elements
12161 can't directly appear on the RHS:
12163 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12165 but can indirectly, e.g.:
12169 sub f { @a = 1..3; \@a }
12171 So if the RHS isn't safe as defined by (A), we must always
12172 mortalise and bump the ref count of any remaining RHS elements
12173 when assigning to a non-empty LHS aggregate.
12175 Lexical scalars on the RHS aren't safe if they've been involved in
12178 use feature 'refaliasing';
12181 \(my $lex) = \$pkg;
12182 my @a = ($lex,3); # equivalent to ($a[0],3)
12189 Similarly with lexical arrays and hashes on the RHS:
12203 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12204 my $a; ($a, my $b) = (....);
12206 The difference between (B) and (C) is that it is now physically
12207 possible for the LHS vars to appear on the RHS too, where they
12208 are not reference counted; but in this case, the compile-time
12209 PL_generation sweep will detect such common vars.
12211 So the rules for (C) differ from (B) in that if common vars are
12212 detected, the runtime "test RC==1" optimisation can no longer be used,
12213 and a full mark and sweep is required
12215 D: As (C), but in addition the LHS may contain package vars.
12217 Since package vars can be aliased without a corresponding refcount
12218 increase, all bets are off. It's only safe if (A). E.g.
12220 my ($x, $y) = (1,2);
12222 for $x_alias ($x) {
12223 ($x_alias, $y) = (3, $x); # whoops
12226 Ditto for LHS aggregate package vars.
12228 E: Any other dangerous ops on LHS, e.g.
12229 (f(), $a[0], @$r) = (...);
12231 this is similar to (E) in that all bets are off. In addition, it's
12232 impossible to determine at compile time whether the LHS
12233 contains a scalar or an aggregate, e.g.
12235 sub f : lvalue { @a }
12238 * ---------------------------------------------------------
12242 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12243 * that at least one of the things flagged was seen.
12247 AAS_MY_SCALAR = 0x001, /* my $scalar */
12248 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
12249 AAS_LEX_SCALAR = 0x004, /* $lexical */
12250 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
12251 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12252 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
12253 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
12254 AAS_DANGEROUS = 0x080, /* an op (other than the above)
12255 that's flagged OA_DANGEROUS */
12256 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
12257 not in any of the categories above */
12258 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
12263 /* helper function for S_aassign_scan().
12264 * check a PAD-related op for commonality and/or set its generation number.
12265 * Returns a boolean indicating whether its shared */
12268 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12270 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12271 /* lexical used in aliasing */
12275 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12277 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12284 Helper function for OPpASSIGN_COMMON* detection in rpeep().
12285 It scans the left or right hand subtree of the aassign op, and returns a
12286 set of flags indicating what sorts of things it found there.
12287 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12288 set PL_generation on lexical vars; if the latter, we see if
12289 PL_generation matches.
12290 'top' indicates whether we're recursing or at the top level.
12291 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12292 This fn will increment it by the number seen. It's not intended to
12293 be an accurate count (especially as many ops can push a variable
12294 number of SVs onto the stack); rather it's used as to test whether there
12295 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12299 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12302 bool kid_top = FALSE;
12304 /* first, look for a solitary @_ on the RHS */
12307 && (o->op_flags & OPf_KIDS)
12308 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12310 OP *kid = cUNOPo->op_first;
12311 if ( ( kid->op_type == OP_PUSHMARK
12312 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12313 && ((kid = OpSIBLING(kid)))
12314 && !OpHAS_SIBLING(kid)
12315 && kid->op_type == OP_RV2AV
12316 && !(kid->op_flags & OPf_REF)
12317 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12318 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12319 && ((kid = cUNOPx(kid)->op_first))
12320 && kid->op_type == OP_GV
12321 && cGVOPx_gv(kid) == PL_defgv
12323 flags |= AAS_DEFAV;
12326 switch (o->op_type) {
12329 return AAS_PKG_SCALAR;
12334 if (top && (o->op_flags & OPf_REF))
12335 return (o->op_private & OPpLVAL_INTRO)
12336 ? AAS_MY_AGG : AAS_LEX_AGG;
12337 return AAS_DANGEROUS;
12341 int comm = S_aassign_padcheck(aTHX_ o, rhs)
12342 ? AAS_LEX_SCALAR_COMM : 0;
12344 return (o->op_private & OPpLVAL_INTRO)
12345 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12351 if (cUNOPx(o)->op_first->op_type != OP_GV)
12352 return AAS_DANGEROUS; /* @{expr}, %{expr} */
12354 if (top && (o->op_flags & OPf_REF))
12355 return AAS_PKG_AGG;
12356 return AAS_DANGEROUS;
12360 if (cUNOPx(o)->op_first->op_type != OP_GV) {
12362 return AAS_DANGEROUS; /* ${expr} */
12364 return AAS_PKG_SCALAR; /* $pkg */
12367 if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
12368 /* "@foo = split... " optimises away the aassign and stores its
12369 * destination array in the OP_PUSHRE that precedes it.
12370 * A flattened array is always dangerous.
12373 return AAS_DANGEROUS;
12378 /* undef counts as a scalar on the RHS:
12379 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
12380 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
12384 flags = AAS_SAFE_SCALAR;
12389 /* these are all no-ops; they don't push a potentially common SV
12390 * onto the stack, so they are neither AAS_DANGEROUS nor
12391 * AAS_SAFE_SCALAR */
12394 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12399 /* these do nothing but may have children; but their children
12400 * should also be treated as top-level */
12405 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12407 flags = AAS_DANGEROUS;
12411 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
12412 && (o->op_private & OPpTARGET_MY))
12415 return S_aassign_padcheck(aTHX_ o, rhs)
12416 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12419 /* if its an unrecognised, non-dangerous op, assume that it
12420 * it the cause of at least one safe scalar */
12422 flags = AAS_SAFE_SCALAR;
12426 if (o->op_flags & OPf_KIDS) {
12428 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12429 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12435 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12436 and modify the optree to make them work inplace */
12439 S_inplace_aassign(pTHX_ OP *o) {
12441 OP *modop, *modop_pushmark;
12443 OP *oleft, *oleft_pushmark;
12445 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12447 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12449 assert(cUNOPo->op_first->op_type == OP_NULL);
12450 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12451 assert(modop_pushmark->op_type == OP_PUSHMARK);
12452 modop = OpSIBLING(modop_pushmark);
12454 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12457 /* no other operation except sort/reverse */
12458 if (OpHAS_SIBLING(modop))
12461 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12462 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12464 if (modop->op_flags & OPf_STACKED) {
12465 /* skip sort subroutine/block */
12466 assert(oright->op_type == OP_NULL);
12467 oright = OpSIBLING(oright);
12470 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12471 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12472 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12473 oleft = OpSIBLING(oleft_pushmark);
12475 /* Check the lhs is an array */
12477 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12478 || OpHAS_SIBLING(oleft)
12479 || (oleft->op_private & OPpLVAL_INTRO)
12483 /* Only one thing on the rhs */
12484 if (OpHAS_SIBLING(oright))
12487 /* check the array is the same on both sides */
12488 if (oleft->op_type == OP_RV2AV) {
12489 if (oright->op_type != OP_RV2AV
12490 || !cUNOPx(oright)->op_first
12491 || cUNOPx(oright)->op_first->op_type != OP_GV
12492 || cUNOPx(oleft )->op_first->op_type != OP_GV
12493 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12494 cGVOPx_gv(cUNOPx(oright)->op_first)
12498 else if (oright->op_type != OP_PADAV
12499 || oright->op_targ != oleft->op_targ
12503 /* This actually is an inplace assignment */
12505 modop->op_private |= OPpSORT_INPLACE;
12507 /* transfer MODishness etc from LHS arg to RHS arg */
12508 oright->op_flags = oleft->op_flags;
12510 /* remove the aassign op and the lhs */
12512 op_null(oleft_pushmark);
12513 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12514 op_null(cUNOPx(oleft)->op_first);
12520 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12521 * that potentially represent a series of one or more aggregate derefs
12522 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12523 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12524 * additional ops left in too).
12526 * The caller will have already verified that the first few ops in the
12527 * chain following 'start' indicate a multideref candidate, and will have
12528 * set 'orig_o' to the point further on in the chain where the first index
12529 * expression (if any) begins. 'orig_action' specifies what type of
12530 * beginning has already been determined by the ops between start..orig_o
12531 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12533 * 'hints' contains any hints flags that need adding (currently just
12534 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12538 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12542 UNOP_AUX_item *arg_buf = NULL;
12543 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12544 int index_skip = -1; /* don't output index arg on this action */
12546 /* similar to regex compiling, do two passes; the first pass
12547 * determines whether the op chain is convertible and calculates the
12548 * buffer size; the second pass populates the buffer and makes any
12549 * changes necessary to ops (such as moving consts to the pad on
12550 * threaded builds).
12552 * NB: for things like Coverity, note that both passes take the same
12553 * path through the logic tree (except for 'if (pass)' bits), since
12554 * both passes are following the same op_next chain; and in
12555 * particular, if it would return early on the second pass, it would
12556 * already have returned early on the first pass.
12558 for (pass = 0; pass < 2; pass++) {
12560 UV action = orig_action;
12561 OP *first_elem_op = NULL; /* first seen aelem/helem */
12562 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12563 int action_count = 0; /* number of actions seen so far */
12564 int action_ix = 0; /* action_count % (actions per IV) */
12565 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12566 bool is_last = FALSE; /* no more derefs to follow */
12567 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12568 UNOP_AUX_item *arg = arg_buf;
12569 UNOP_AUX_item *action_ptr = arg_buf;
12572 action_ptr->uv = 0;
12576 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12577 case MDEREF_HV_gvhv_helem:
12578 next_is_hash = TRUE;
12580 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12581 case MDEREF_AV_gvav_aelem:
12583 #ifdef USE_ITHREADS
12584 arg->pad_offset = cPADOPx(start)->op_padix;
12585 /* stop it being swiped when nulled */
12586 cPADOPx(start)->op_padix = 0;
12588 arg->sv = cSVOPx(start)->op_sv;
12589 cSVOPx(start)->op_sv = NULL;
12595 case MDEREF_HV_padhv_helem:
12596 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12597 next_is_hash = TRUE;
12599 case MDEREF_AV_padav_aelem:
12600 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12602 arg->pad_offset = start->op_targ;
12603 /* we skip setting op_targ = 0 for now, since the intact
12604 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12605 reset_start_targ = TRUE;
12610 case MDEREF_HV_pop_rv2hv_helem:
12611 next_is_hash = TRUE;
12613 case MDEREF_AV_pop_rv2av_aelem:
12617 NOT_REACHED; /* NOTREACHED */
12622 /* look for another (rv2av/hv; get index;
12623 * aelem/helem/exists/delele) sequence */
12628 UV index_type = MDEREF_INDEX_none;
12630 if (action_count) {
12631 /* if this is not the first lookup, consume the rv2av/hv */
12633 /* for N levels of aggregate lookup, we normally expect
12634 * that the first N-1 [ah]elem ops will be flagged as
12635 * /DEREF (so they autovivifiy if necessary), and the last
12636 * lookup op not to be.
12637 * For other things (like @{$h{k1}{k2}}) extra scope or
12638 * leave ops can appear, so abandon the effort in that
12640 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12643 /* rv2av or rv2hv sKR/1 */
12645 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12646 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12647 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12650 /* at this point, we wouldn't expect any of these
12651 * possible private flags:
12652 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12653 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12655 ASSUME(!(o->op_private &
12656 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12658 hints = (o->op_private & OPpHINT_STRICT_REFS);
12660 /* make sure the type of the previous /DEREF matches the
12661 * type of the next lookup */
12662 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12665 action = next_is_hash
12666 ? MDEREF_HV_vivify_rv2hv_helem
12667 : MDEREF_AV_vivify_rv2av_aelem;
12671 /* if this is the second pass, and we're at the depth where
12672 * previously we encountered a non-simple index expression,
12673 * stop processing the index at this point */
12674 if (action_count != index_skip) {
12676 /* look for one or more simple ops that return an array
12677 * index or hash key */
12679 switch (o->op_type) {
12681 /* it may be a lexical var index */
12682 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12683 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12684 ASSUME(!(o->op_private &
12685 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12687 if ( OP_GIMME(o,0) == G_SCALAR
12688 && !(o->op_flags & (OPf_REF|OPf_MOD))
12689 && o->op_private == 0)
12692 arg->pad_offset = o->op_targ;
12694 index_type = MDEREF_INDEX_padsv;
12700 if (next_is_hash) {
12701 /* it's a constant hash index */
12702 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12703 /* "use constant foo => FOO; $h{+foo}" for
12704 * some weird FOO, can leave you with constants
12705 * that aren't simple strings. It's not worth
12706 * the extra hassle for those edge cases */
12711 OP * helem_op = o->op_next;
12713 ASSUME( helem_op->op_type == OP_HELEM
12714 || helem_op->op_type == OP_NULL);
12715 if (helem_op->op_type == OP_HELEM) {
12716 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12717 if ( helem_op->op_private & OPpLVAL_INTRO
12718 || rop->op_type != OP_RV2HV
12722 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12724 #ifdef USE_ITHREADS
12725 /* Relocate sv to the pad for thread safety */
12726 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12727 arg->pad_offset = o->op_targ;
12730 arg->sv = cSVOPx_sv(o);
12735 /* it's a constant array index */
12737 SV *ix_sv = cSVOPo->op_sv;
12742 if ( action_count == 0
12745 && ( action == MDEREF_AV_padav_aelem
12746 || action == MDEREF_AV_gvav_aelem)
12748 maybe_aelemfast = TRUE;
12752 SvREFCNT_dec_NN(cSVOPo->op_sv);
12756 /* we've taken ownership of the SV */
12757 cSVOPo->op_sv = NULL;
12759 index_type = MDEREF_INDEX_const;
12764 /* it may be a package var index */
12766 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12767 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12768 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12769 || o->op_private != 0
12774 if (kid->op_type != OP_RV2SV)
12777 ASSUME(!(kid->op_flags &
12778 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12779 |OPf_SPECIAL|OPf_PARENS)));
12780 ASSUME(!(kid->op_private &
12782 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12783 |OPpDEREF|OPpLVAL_INTRO)));
12784 if( (kid->op_flags &~ OPf_PARENS)
12785 != (OPf_WANT_SCALAR|OPf_KIDS)
12786 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12791 #ifdef USE_ITHREADS
12792 arg->pad_offset = cPADOPx(o)->op_padix;
12793 /* stop it being swiped when nulled */
12794 cPADOPx(o)->op_padix = 0;
12796 arg->sv = cSVOPx(o)->op_sv;
12797 cSVOPo->op_sv = NULL;
12801 index_type = MDEREF_INDEX_gvsv;
12806 } /* action_count != index_skip */
12808 action |= index_type;
12811 /* at this point we have either:
12812 * * detected what looks like a simple index expression,
12813 * and expect the next op to be an [ah]elem, or
12814 * an nulled [ah]elem followed by a delete or exists;
12815 * * found a more complex expression, so something other
12816 * than the above follows.
12819 /* possibly an optimised away [ah]elem (where op_next is
12820 * exists or delete) */
12821 if (o->op_type == OP_NULL)
12824 /* at this point we're looking for an OP_AELEM, OP_HELEM,
12825 * OP_EXISTS or OP_DELETE */
12827 /* if something like arybase (a.k.a $[ ) is in scope,
12828 * abandon optimisation attempt */
12829 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12830 && PL_check[o->op_type] != Perl_ck_null)
12833 if ( o->op_type != OP_AELEM
12834 || (o->op_private &
12835 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12837 maybe_aelemfast = FALSE;
12839 /* look for aelem/helem/exists/delete. If it's not the last elem
12840 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12841 * flags; if it's the last, then it mustn't have
12842 * OPpDEREF_AV/HV, but may have lots of other flags, like
12843 * OPpLVAL_INTRO etc
12846 if ( index_type == MDEREF_INDEX_none
12847 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
12848 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12852 /* we have aelem/helem/exists/delete with valid simple index */
12854 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12855 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
12856 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12859 ASSUME(!(o->op_flags &
12860 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12861 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12863 ok = (o->op_flags &~ OPf_PARENS)
12864 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12865 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12867 else if (o->op_type == OP_EXISTS) {
12868 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12869 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12870 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12871 ok = !(o->op_private & ~OPpARG1_MASK);
12873 else if (o->op_type == OP_DELETE) {
12874 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12875 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12876 ASSUME(!(o->op_private &
12877 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12878 /* don't handle slices or 'local delete'; the latter
12879 * is fairly rare, and has a complex runtime */
12880 ok = !(o->op_private & ~OPpARG1_MASK);
12881 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12882 /* skip handling run-tome error */
12883 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12886 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12887 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12888 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12889 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12890 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12891 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12896 if (!first_elem_op)
12900 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12905 action |= MDEREF_FLAG_last;
12909 /* at this point we have something that started
12910 * promisingly enough (with rv2av or whatever), but failed
12911 * to find a simple index followed by an
12912 * aelem/helem/exists/delete. If this is the first action,
12913 * give up; but if we've already seen at least one
12914 * aelem/helem, then keep them and add a new action with
12915 * MDEREF_INDEX_none, which causes it to do the vivify
12916 * from the end of the previous lookup, and do the deref,
12917 * but stop at that point. So $a[0][expr] will do one
12918 * av_fetch, vivify and deref, then continue executing at
12923 index_skip = action_count;
12924 action |= MDEREF_FLAG_last;
12928 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12931 /* if there's no space for the next action, create a new slot
12932 * for it *before* we start adding args for that action */
12933 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12940 } /* while !is_last */
12948 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12949 if (index_skip == -1) {
12950 mderef->op_flags = o->op_flags
12951 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12952 if (o->op_type == OP_EXISTS)
12953 mderef->op_private = OPpMULTIDEREF_EXISTS;
12954 else if (o->op_type == OP_DELETE)
12955 mderef->op_private = OPpMULTIDEREF_DELETE;
12957 mderef->op_private = o->op_private
12958 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12960 /* accumulate strictness from every level (although I don't think
12961 * they can actually vary) */
12962 mderef->op_private |= hints;
12964 /* integrate the new multideref op into the optree and the
12967 * In general an op like aelem or helem has two child
12968 * sub-trees: the aggregate expression (a_expr) and the
12969 * index expression (i_expr):
12975 * The a_expr returns an AV or HV, while the i-expr returns an
12976 * index. In general a multideref replaces most or all of a
12977 * multi-level tree, e.g.
12993 * With multideref, all the i_exprs will be simple vars or
12994 * constants, except that i_expr1 may be arbitrary in the case
12995 * of MDEREF_INDEX_none.
12997 * The bottom-most a_expr will be either:
12998 * 1) a simple var (so padXv or gv+rv2Xv);
12999 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
13000 * so a simple var with an extra rv2Xv;
13001 * 3) or an arbitrary expression.
13003 * 'start', the first op in the execution chain, will point to
13004 * 1),2): the padXv or gv op;
13005 * 3): the rv2Xv which forms the last op in the a_expr
13006 * execution chain, and the top-most op in the a_expr
13009 * For all cases, the 'start' node is no longer required,
13010 * but we can't free it since one or more external nodes
13011 * may point to it. E.g. consider
13012 * $h{foo} = $a ? $b : $c
13013 * Here, both the op_next and op_other branches of the
13014 * cond_expr point to the gv[*h] of the hash expression, so
13015 * we can't free the 'start' op.
13017 * For expr->[...], we need to save the subtree containing the
13018 * expression; for the other cases, we just need to save the
13020 * So in all cases, we null the start op and keep it around by
13021 * making it the child of the multideref op; for the expr->
13022 * case, the expr will be a subtree of the start node.
13024 * So in the simple 1,2 case the optree above changes to
13030 * ex-gv (or ex-padxv)
13032 * with the op_next chain being
13034 * -> ex-gv -> multideref -> op-following-ex-exists ->
13036 * In the 3 case, we have
13049 * -> rest-of-a_expr subtree ->
13050 * ex-rv2xv -> multideref -> op-following-ex-exists ->
13053 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13054 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13055 * multideref attached as the child, e.g.
13061 * ex-rv2av - i_expr1
13069 /* if we free this op, don't free the pad entry */
13070 if (reset_start_targ)
13071 start->op_targ = 0;
13074 /* Cut the bit we need to save out of the tree and attach to
13075 * the multideref op, then free the rest of the tree */
13077 /* find parent of node to be detached (for use by splice) */
13079 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
13080 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13082 /* there is an arbitrary expression preceding us, e.g.
13083 * expr->[..]? so we need to save the 'expr' subtree */
13084 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13085 p = cUNOPx(p)->op_first;
13086 ASSUME( start->op_type == OP_RV2AV
13087 || start->op_type == OP_RV2HV);
13090 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13091 * above for exists/delete. */
13092 while ( (p->op_flags & OPf_KIDS)
13093 && cUNOPx(p)->op_first != start
13095 p = cUNOPx(p)->op_first;
13097 ASSUME(cUNOPx(p)->op_first == start);
13099 /* detach from main tree, and re-attach under the multideref */
13100 op_sibling_splice(mderef, NULL, 0,
13101 op_sibling_splice(p, NULL, 1, NULL));
13104 start->op_next = mderef;
13106 mderef->op_next = index_skip == -1 ? o->op_next : o;
13108 /* excise and free the original tree, and replace with
13109 * the multideref op */
13110 p = op_sibling_splice(top_op, NULL, -1, mderef);
13119 Size_t size = arg - arg_buf;
13121 if (maybe_aelemfast && action_count == 1)
13124 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13125 sizeof(UNOP_AUX_item) * (size + 1));
13126 /* for dumping etc: store the length in a hidden first slot;
13127 * we set the op_aux pointer to the second slot */
13128 arg_buf->uv = size;
13131 } /* for (pass = ...) */
13136 /* mechanism for deferring recursion in rpeep() */
13138 #define MAX_DEFERRED 4
13142 if (defer_ix == (MAX_DEFERRED-1)) { \
13143 OP **defer = defer_queue[defer_base]; \
13144 CALL_RPEEP(*defer); \
13145 S_prune_chain_head(defer); \
13146 defer_base = (defer_base + 1) % MAX_DEFERRED; \
13149 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13152 #define IS_AND_OP(o) (o->op_type == OP_AND)
13153 #define IS_OR_OP(o) (o->op_type == OP_OR)
13156 /* A peephole optimizer. We visit the ops in the order they're to execute.
13157 * See the comments at the top of this file for more details about when
13158 * peep() is called */
13161 Perl_rpeep(pTHX_ OP *o)
13165 OP* oldoldop = NULL;
13166 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13167 int defer_base = 0;
13172 if (!o || o->op_opt)
13176 SAVEVPTR(PL_curcop);
13177 for (;; o = o->op_next) {
13178 if (o && o->op_opt)
13181 while (defer_ix >= 0) {
13183 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13184 CALL_RPEEP(*defer);
13185 S_prune_chain_head(defer);
13192 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13193 assert(!oldoldop || oldoldop->op_next == oldop);
13194 assert(!oldop || oldop->op_next == o);
13196 /* By default, this op has now been optimised. A couple of cases below
13197 clear this again. */
13201 /* look for a series of 1 or more aggregate derefs, e.g.
13202 * $a[1]{foo}[$i]{$k}
13203 * and replace with a single OP_MULTIDEREF op.
13204 * Each index must be either a const, or a simple variable,
13206 * First, look for likely combinations of starting ops,
13207 * corresponding to (global and lexical variants of)
13209 * $r->[...] $r->{...}
13210 * (preceding expression)->[...]
13211 * (preceding expression)->{...}
13212 * and if so, call maybe_multideref() to do a full inspection
13213 * of the op chain and if appropriate, replace with an
13221 switch (o2->op_type) {
13223 /* $pkg[..] : gv[*pkg]
13224 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
13226 /* Fail if there are new op flag combinations that we're
13227 * not aware of, rather than:
13228 * * silently failing to optimise, or
13229 * * silently optimising the flag away.
13230 * If this ASSUME starts failing, examine what new flag
13231 * has been added to the op, and decide whether the
13232 * optimisation should still occur with that flag, then
13233 * update the code accordingly. This applies to all the
13234 * other ASSUMEs in the block of code too.
13236 ASSUME(!(o2->op_flags &
13237 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13238 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13242 if (o2->op_type == OP_RV2AV) {
13243 action = MDEREF_AV_gvav_aelem;
13247 if (o2->op_type == OP_RV2HV) {
13248 action = MDEREF_HV_gvhv_helem;
13252 if (o2->op_type != OP_RV2SV)
13255 /* at this point we've seen gv,rv2sv, so the only valid
13256 * construct left is $pkg->[] or $pkg->{} */
13258 ASSUME(!(o2->op_flags & OPf_STACKED));
13259 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13260 != (OPf_WANT_SCALAR|OPf_MOD))
13263 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13264 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13265 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13267 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
13268 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13272 if (o2->op_type == OP_RV2AV) {
13273 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13276 if (o2->op_type == OP_RV2HV) {
13277 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13283 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13285 ASSUME(!(o2->op_flags &
13286 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13287 if ((o2->op_flags &
13288 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13289 != (OPf_WANT_SCALAR|OPf_MOD))
13292 ASSUME(!(o2->op_private &
13293 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13294 /* skip if state or intro, or not a deref */
13295 if ( o2->op_private != OPpDEREF_AV
13296 && o2->op_private != OPpDEREF_HV)
13300 if (o2->op_type == OP_RV2AV) {
13301 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13304 if (o2->op_type == OP_RV2HV) {
13305 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13312 /* $lex[..]: padav[@lex:1,2] sR *
13313 * or $lex{..}: padhv[%lex:1,2] sR */
13314 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13315 OPf_REF|OPf_SPECIAL)));
13316 if ((o2->op_flags &
13317 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13318 != (OPf_WANT_SCALAR|OPf_REF))
13320 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13322 /* OPf_PARENS isn't currently used in this case;
13323 * if that changes, let us know! */
13324 ASSUME(!(o2->op_flags & OPf_PARENS));
13326 /* at this point, we wouldn't expect any of the remaining
13327 * possible private flags:
13328 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13329 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13331 * OPpSLICEWARNING shouldn't affect runtime
13333 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13335 action = o2->op_type == OP_PADAV
13336 ? MDEREF_AV_padav_aelem
13337 : MDEREF_HV_padhv_helem;
13339 S_maybe_multideref(aTHX_ o, o2, action, 0);
13345 action = o2->op_type == OP_RV2AV
13346 ? MDEREF_AV_pop_rv2av_aelem
13347 : MDEREF_HV_pop_rv2hv_helem;
13350 /* (expr)->[...]: rv2av sKR/1;
13351 * (expr)->{...}: rv2hv sKR/1; */
13353 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13355 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13356 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13357 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13360 /* at this point, we wouldn't expect any of these
13361 * possible private flags:
13362 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13363 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13365 ASSUME(!(o2->op_private &
13366 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13368 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13372 S_maybe_multideref(aTHX_ o, o2, action, hints);
13381 switch (o->op_type) {
13383 PL_curcop = ((COP*)o); /* for warnings */
13386 PL_curcop = ((COP*)o); /* for warnings */
13388 /* Optimise a "return ..." at the end of a sub to just be "...".
13389 * This saves 2 ops. Before:
13390 * 1 <;> nextstate(main 1 -e:1) v ->2
13391 * 4 <@> return K ->5
13392 * 2 <0> pushmark s ->3
13393 * - <1> ex-rv2sv sK/1 ->4
13394 * 3 <#> gvsv[*cat] s ->4
13397 * - <@> return K ->-
13398 * - <0> pushmark s ->2
13399 * - <1> ex-rv2sv sK/1 ->-
13400 * 2 <$> gvsv(*cat) s ->3
13403 OP *next = o->op_next;
13404 OP *sibling = OpSIBLING(o);
13405 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13406 && OP_TYPE_IS(sibling, OP_RETURN)
13407 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13408 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13409 ||OP_TYPE_IS(sibling->op_next->op_next,
13411 && cUNOPx(sibling)->op_first == next
13412 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13415 /* Look through the PUSHMARK's siblings for one that
13416 * points to the RETURN */
13417 OP *top = OpSIBLING(next);
13418 while (top && top->op_next) {
13419 if (top->op_next == sibling) {
13420 top->op_next = sibling->op_next;
13421 o->op_next = next->op_next;
13424 top = OpSIBLING(top);
13429 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13431 * This latter form is then suitable for conversion into padrange
13432 * later on. Convert:
13434 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13438 * nextstate1 -> listop -> nextstate3
13440 * pushmark -> padop1 -> padop2
13442 if (o->op_next && (
13443 o->op_next->op_type == OP_PADSV
13444 || o->op_next->op_type == OP_PADAV
13445 || o->op_next->op_type == OP_PADHV
13447 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13448 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13449 && o->op_next->op_next->op_next && (
13450 o->op_next->op_next->op_next->op_type == OP_PADSV
13451 || o->op_next->op_next->op_next->op_type == OP_PADAV
13452 || o->op_next->op_next->op_next->op_type == OP_PADHV
13454 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13455 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13456 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13457 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13459 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13462 ns2 = pad1->op_next;
13463 pad2 = ns2->op_next;
13464 ns3 = pad2->op_next;
13466 /* we assume here that the op_next chain is the same as
13467 * the op_sibling chain */
13468 assert(OpSIBLING(o) == pad1);
13469 assert(OpSIBLING(pad1) == ns2);
13470 assert(OpSIBLING(ns2) == pad2);
13471 assert(OpSIBLING(pad2) == ns3);
13473 /* excise and delete ns2 */
13474 op_sibling_splice(NULL, pad1, 1, NULL);
13477 /* excise pad1 and pad2 */
13478 op_sibling_splice(NULL, o, 2, NULL);
13480 /* create new listop, with children consisting of:
13481 * a new pushmark, pad1, pad2. */
13482 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13483 newop->op_flags |= OPf_PARENS;
13484 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13486 /* insert newop between o and ns3 */
13487 op_sibling_splice(NULL, o, 0, newop);
13489 /*fixup op_next chain */
13490 newpm = cUNOPx(newop)->op_first; /* pushmark */
13491 o ->op_next = newpm;
13492 newpm->op_next = pad1;
13493 pad1 ->op_next = pad2;
13494 pad2 ->op_next = newop; /* listop */
13495 newop->op_next = ns3;
13497 /* Ensure pushmark has this flag if padops do */
13498 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13499 newpm->op_flags |= OPf_MOD;
13505 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13506 to carry two labels. For now, take the easier option, and skip
13507 this optimisation if the first NEXTSTATE has a label. */
13508 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13509 OP *nextop = o->op_next;
13510 while (nextop && nextop->op_type == OP_NULL)
13511 nextop = nextop->op_next;
13513 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13516 oldop->op_next = nextop;
13518 /* Skip (old)oldop assignment since the current oldop's
13519 op_next already points to the next op. */
13526 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13527 if (o->op_next->op_private & OPpTARGET_MY) {
13528 if (o->op_flags & OPf_STACKED) /* chained concats */
13529 break; /* ignore_optimization */
13531 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13532 o->op_targ = o->op_next->op_targ;
13533 o->op_next->op_targ = 0;
13534 o->op_private |= OPpTARGET_MY;
13537 op_null(o->op_next);
13541 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13542 break; /* Scalar stub must produce undef. List stub is noop */
13546 if (o->op_targ == OP_NEXTSTATE
13547 || o->op_targ == OP_DBSTATE)
13549 PL_curcop = ((COP*)o);
13551 /* XXX: We avoid setting op_seq here to prevent later calls
13552 to rpeep() from mistakenly concluding that optimisation
13553 has already occurred. This doesn't fix the real problem,
13554 though (See 20010220.007). AMS 20010719 */
13555 /* op_seq functionality is now replaced by op_opt */
13563 oldop->op_next = o->op_next;
13577 convert repeat into a stub with no kids.
13579 if (o->op_next->op_type == OP_CONST
13580 || ( o->op_next->op_type == OP_PADSV
13581 && !(o->op_next->op_private & OPpLVAL_INTRO))
13582 || ( o->op_next->op_type == OP_GV
13583 && o->op_next->op_next->op_type == OP_RV2SV
13584 && !(o->op_next->op_next->op_private
13585 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13587 const OP *kid = o->op_next->op_next;
13588 if (o->op_next->op_type == OP_GV)
13589 kid = kid->op_next;
13590 /* kid is now the ex-list. */
13591 if (kid->op_type == OP_NULL
13592 && (kid = kid->op_next)->op_type == OP_CONST
13593 /* kid is now the repeat count. */
13594 && kid->op_next->op_type == OP_REPEAT
13595 && kid->op_next->op_private & OPpREPEAT_DOLIST
13596 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13597 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13599 o = kid->op_next; /* repeat */
13601 oldop->op_next = o;
13602 op_free(cBINOPo->op_first);
13603 op_free(cBINOPo->op_last );
13604 o->op_flags &=~ OPf_KIDS;
13605 /* stub is a baseop; repeat is a binop */
13606 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13607 OpTYPE_set(o, OP_STUB);
13613 /* Convert a series of PAD ops for my vars plus support into a
13614 * single padrange op. Basically
13616 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13618 * becomes, depending on circumstances, one of
13620 * padrange ----------------------------------> (list) -> rest
13621 * padrange --------------------------------------------> rest
13623 * where all the pad indexes are sequential and of the same type
13625 * We convert the pushmark into a padrange op, then skip
13626 * any other pad ops, and possibly some trailing ops.
13627 * Note that we don't null() the skipped ops, to make it
13628 * easier for Deparse to undo this optimisation (and none of
13629 * the skipped ops are holding any resourses). It also makes
13630 * it easier for find_uninit_var(), as it can just ignore
13631 * padrange, and examine the original pad ops.
13635 OP *followop = NULL; /* the op that will follow the padrange op */
13638 PADOFFSET base = 0; /* init only to stop compiler whining */
13639 bool gvoid = 0; /* init only to stop compiler whining */
13640 bool defav = 0; /* seen (...) = @_ */
13641 bool reuse = 0; /* reuse an existing padrange op */
13643 /* look for a pushmark -> gv[_] -> rv2av */
13648 if ( p->op_type == OP_GV
13649 && cGVOPx_gv(p) == PL_defgv
13650 && (rv2av = p->op_next)
13651 && rv2av->op_type == OP_RV2AV
13652 && !(rv2av->op_flags & OPf_REF)
13653 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13654 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13656 q = rv2av->op_next;
13657 if (q->op_type == OP_NULL)
13659 if (q->op_type == OP_PUSHMARK) {
13669 /* scan for PAD ops */
13671 for (p = p->op_next; p; p = p->op_next) {
13672 if (p->op_type == OP_NULL)
13675 if (( p->op_type != OP_PADSV
13676 && p->op_type != OP_PADAV
13677 && p->op_type != OP_PADHV
13679 /* any private flag other than INTRO? e.g. STATE */
13680 || (p->op_private & ~OPpLVAL_INTRO)
13684 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13686 if ( p->op_type == OP_PADAV
13688 && p->op_next->op_type == OP_CONST
13689 && p->op_next->op_next
13690 && p->op_next->op_next->op_type == OP_AELEM
13694 /* for 1st padop, note what type it is and the range
13695 * start; for the others, check that it's the same type
13696 * and that the targs are contiguous */
13698 intro = (p->op_private & OPpLVAL_INTRO);
13700 gvoid = OP_GIMME(p,0) == G_VOID;
13703 if ((p->op_private & OPpLVAL_INTRO) != intro)
13705 /* Note that you'd normally expect targs to be
13706 * contiguous in my($a,$b,$c), but that's not the case
13707 * when external modules start doing things, e.g.
13708 * Function::Parameters */
13709 if (p->op_targ != base + count)
13711 assert(p->op_targ == base + count);
13712 /* Either all the padops or none of the padops should
13713 be in void context. Since we only do the optimisa-
13714 tion for av/hv when the aggregate itself is pushed
13715 on to the stack (one item), there is no need to dis-
13716 tinguish list from scalar context. */
13717 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13721 /* for AV, HV, only when we're not flattening */
13722 if ( p->op_type != OP_PADSV
13724 && !(p->op_flags & OPf_REF)
13728 if (count >= OPpPADRANGE_COUNTMASK)
13731 /* there's a biggest base we can fit into a
13732 * SAVEt_CLEARPADRANGE in pp_padrange.
13733 * (The sizeof() stuff will be constant-folded, and is
13734 * intended to avoid getting "comparison is always false"
13735 * compiler warnings. See the comments above
13736 * MEM_WRAP_CHECK for more explanation on why we do this
13737 * in a weird way to avoid compiler warnings.)
13740 && (8*sizeof(base) >
13741 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13743 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13745 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13749 /* Success! We've got another valid pad op to optimise away */
13751 followop = p->op_next;
13754 if (count < 1 || (count == 1 && !defav))
13757 /* pp_padrange in specifically compile-time void context
13758 * skips pushing a mark and lexicals; in all other contexts
13759 * (including unknown till runtime) it pushes a mark and the
13760 * lexicals. We must be very careful then, that the ops we
13761 * optimise away would have exactly the same effect as the
13763 * In particular in void context, we can only optimise to
13764 * a padrange if we see the complete sequence
13765 * pushmark, pad*v, ...., list
13766 * which has the net effect of leaving the markstack as it
13767 * was. Not pushing onto the stack (whereas padsv does touch
13768 * the stack) makes no difference in void context.
13772 if (followop->op_type == OP_LIST
13773 && OP_GIMME(followop,0) == G_VOID
13776 followop = followop->op_next; /* skip OP_LIST */
13778 /* consolidate two successive my(...);'s */
13781 && oldoldop->op_type == OP_PADRANGE
13782 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13783 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13784 && !(oldoldop->op_flags & OPf_SPECIAL)
13787 assert(oldoldop->op_next == oldop);
13788 assert( oldop->op_type == OP_NEXTSTATE
13789 || oldop->op_type == OP_DBSTATE);
13790 assert(oldop->op_next == o);
13793 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13795 /* Do not assume pad offsets for $c and $d are con-
13800 if ( oldoldop->op_targ + old_count == base
13801 && old_count < OPpPADRANGE_COUNTMASK - count) {
13802 base = oldoldop->op_targ;
13803 count += old_count;
13808 /* if there's any immediately following singleton
13809 * my var's; then swallow them and the associated
13811 * my ($a,$b); my $c; my $d;
13813 * my ($a,$b,$c,$d);
13816 while ( ((p = followop->op_next))
13817 && ( p->op_type == OP_PADSV
13818 || p->op_type == OP_PADAV
13819 || p->op_type == OP_PADHV)
13820 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13821 && (p->op_private & OPpLVAL_INTRO) == intro
13822 && !(p->op_private & ~OPpLVAL_INTRO)
13824 && ( p->op_next->op_type == OP_NEXTSTATE
13825 || p->op_next->op_type == OP_DBSTATE)
13826 && count < OPpPADRANGE_COUNTMASK
13827 && base + count == p->op_targ
13830 followop = p->op_next;
13838 assert(oldoldop->op_type == OP_PADRANGE);
13839 oldoldop->op_next = followop;
13840 oldoldop->op_private = (intro | count);
13846 /* Convert the pushmark into a padrange.
13847 * To make Deparse easier, we guarantee that a padrange was
13848 * *always* formerly a pushmark */
13849 assert(o->op_type == OP_PUSHMARK);
13850 o->op_next = followop;
13851 OpTYPE_set(o, OP_PADRANGE);
13853 /* bit 7: INTRO; bit 6..0: count */
13854 o->op_private = (intro | count);
13855 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13856 | gvoid * OPf_WANT_VOID
13857 | (defav ? OPf_SPECIAL : 0));
13865 /* Skip over state($x) in void context. */
13866 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13867 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13869 oldop->op_next = o->op_next;
13870 goto redo_nextstate;
13872 if (o->op_type != OP_PADAV)
13876 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13877 OP* const pop = (o->op_type == OP_PADAV) ?
13878 o->op_next : o->op_next->op_next;
13880 if (pop && pop->op_type == OP_CONST &&
13881 ((PL_op = pop->op_next)) &&
13882 pop->op_next->op_type == OP_AELEM &&
13883 !(pop->op_next->op_private &
13884 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13885 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13888 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13889 no_bareword_allowed(pop);
13890 if (o->op_type == OP_GV)
13891 op_null(o->op_next);
13892 op_null(pop->op_next);
13894 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13895 o->op_next = pop->op_next->op_next;
13896 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13897 o->op_private = (U8)i;
13898 if (o->op_type == OP_GV) {
13901 o->op_type = OP_AELEMFAST;
13904 o->op_type = OP_AELEMFAST_LEX;
13906 if (o->op_type != OP_GV)
13910 /* Remove $foo from the op_next chain in void context. */
13912 && ( o->op_next->op_type == OP_RV2SV
13913 || o->op_next->op_type == OP_RV2AV
13914 || o->op_next->op_type == OP_RV2HV )
13915 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13916 && !(o->op_next->op_private & OPpLVAL_INTRO))
13918 oldop->op_next = o->op_next->op_next;
13919 /* Reprocess the previous op if it is a nextstate, to
13920 allow double-nextstate optimisation. */
13922 if (oldop->op_type == OP_NEXTSTATE) {
13929 o = oldop->op_next;
13932 else if (o->op_next->op_type == OP_RV2SV) {
13933 if (!(o->op_next->op_private & OPpDEREF)) {
13934 op_null(o->op_next);
13935 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13937 o->op_next = o->op_next->op_next;
13938 OpTYPE_set(o, OP_GVSV);
13941 else if (o->op_next->op_type == OP_READLINE
13942 && o->op_next->op_next->op_type == OP_CONCAT
13943 && (o->op_next->op_next->op_flags & OPf_STACKED))
13945 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13946 OpTYPE_set(o, OP_RCATLINE);
13947 o->op_flags |= OPf_STACKED;
13948 op_null(o->op_next->op_next);
13949 op_null(o->op_next);
13954 #define HV_OR_SCALARHV(op) \
13955 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13957 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13958 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
13959 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
13960 ? cUNOPx(op)->op_first \
13964 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13965 fop->op_private |= OPpTRUEBOOL;
13971 fop = cLOGOP->op_first;
13972 sop = OpSIBLING(fop);
13973 while (cLOGOP->op_other->op_type == OP_NULL)
13974 cLOGOP->op_other = cLOGOP->op_other->op_next;
13975 while (o->op_next && ( o->op_type == o->op_next->op_type
13976 || o->op_next->op_type == OP_NULL))
13977 o->op_next = o->op_next->op_next;
13979 /* If we're an OR and our next is an AND in void context, we'll
13980 follow its op_other on short circuit, same for reverse.
13981 We can't do this with OP_DOR since if it's true, its return
13982 value is the underlying value which must be evaluated
13986 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13987 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13989 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13991 o->op_next = ((LOGOP*)o->op_next)->op_other;
13993 DEFER(cLOGOP->op_other);
13996 fop = HV_OR_SCALARHV(fop);
13997 if (sop) sop = HV_OR_SCALARHV(sop);
14002 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
14003 while (nop && nop->op_next) {
14004 switch (nop->op_next->op_type) {
14009 lop = nop = nop->op_next;
14012 nop = nop->op_next;
14021 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14022 || o->op_type == OP_AND )
14023 fop->op_private |= OPpTRUEBOOL;
14024 else if (!(lop->op_flags & OPf_WANT))
14025 fop->op_private |= OPpMAYBE_TRUEBOOL;
14027 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14029 sop->op_private |= OPpTRUEBOOL;
14036 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
14037 fop->op_private |= OPpTRUEBOOL;
14038 #undef HV_OR_SCALARHV
14039 /* GERONIMO! */ /* FALLTHROUGH */
14048 while (cLOGOP->op_other->op_type == OP_NULL)
14049 cLOGOP->op_other = cLOGOP->op_other->op_next;
14050 DEFER(cLOGOP->op_other);
14055 while (cLOOP->op_redoop->op_type == OP_NULL)
14056 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14057 while (cLOOP->op_nextop->op_type == OP_NULL)
14058 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14059 while (cLOOP->op_lastop->op_type == OP_NULL)
14060 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14061 /* a while(1) loop doesn't have an op_next that escapes the
14062 * loop, so we have to explicitly follow the op_lastop to
14063 * process the rest of the code */
14064 DEFER(cLOOP->op_lastop);
14068 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14069 DEFER(cLOGOPo->op_other);
14073 assert(!(cPMOP->op_pmflags & PMf_ONCE));
14074 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14075 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14076 cPMOP->op_pmstashstartu.op_pmreplstart
14077 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14078 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14084 if (o->op_flags & OPf_SPECIAL) {
14085 /* first arg is a code block */
14086 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14087 OP * kid = cUNOPx(nullop)->op_first;
14089 assert(nullop->op_type == OP_NULL);
14090 assert(kid->op_type == OP_SCOPE
14091 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14092 /* since OP_SORT doesn't have a handy op_other-style
14093 * field that can point directly to the start of the code
14094 * block, store it in the otherwise-unused op_next field
14095 * of the top-level OP_NULL. This will be quicker at
14096 * run-time, and it will also allow us to remove leading
14097 * OP_NULLs by just messing with op_nexts without
14098 * altering the basic op_first/op_sibling layout. */
14099 kid = kLISTOP->op_first;
14101 (kid->op_type == OP_NULL
14102 && ( kid->op_targ == OP_NEXTSTATE
14103 || kid->op_targ == OP_DBSTATE ))
14104 || kid->op_type == OP_STUB
14105 || kid->op_type == OP_ENTER);
14106 nullop->op_next = kLISTOP->op_next;
14107 DEFER(nullop->op_next);
14110 /* check that RHS of sort is a single plain array */
14111 oright = cUNOPo->op_first;
14112 if (!oright || oright->op_type != OP_PUSHMARK)
14115 if (o->op_private & OPpSORT_INPLACE)
14118 /* reverse sort ... can be optimised. */
14119 if (!OpHAS_SIBLING(cUNOPo)) {
14120 /* Nothing follows us on the list. */
14121 OP * const reverse = o->op_next;
14123 if (reverse->op_type == OP_REVERSE &&
14124 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14125 OP * const pushmark = cUNOPx(reverse)->op_first;
14126 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14127 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14128 /* reverse -> pushmark -> sort */
14129 o->op_private |= OPpSORT_REVERSE;
14131 pushmark->op_next = oright->op_next;
14141 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14143 LISTOP *enter, *exlist;
14145 if (o->op_private & OPpSORT_INPLACE)
14148 enter = (LISTOP *) o->op_next;
14151 if (enter->op_type == OP_NULL) {
14152 enter = (LISTOP *) enter->op_next;
14156 /* for $a (...) will have OP_GV then OP_RV2GV here.
14157 for (...) just has an OP_GV. */
14158 if (enter->op_type == OP_GV) {
14159 gvop = (OP *) enter;
14160 enter = (LISTOP *) enter->op_next;
14163 if (enter->op_type == OP_RV2GV) {
14164 enter = (LISTOP *) enter->op_next;
14170 if (enter->op_type != OP_ENTERITER)
14173 iter = enter->op_next;
14174 if (!iter || iter->op_type != OP_ITER)
14177 expushmark = enter->op_first;
14178 if (!expushmark || expushmark->op_type != OP_NULL
14179 || expushmark->op_targ != OP_PUSHMARK)
14182 exlist = (LISTOP *) OpSIBLING(expushmark);
14183 if (!exlist || exlist->op_type != OP_NULL
14184 || exlist->op_targ != OP_LIST)
14187 if (exlist->op_last != o) {
14188 /* Mmm. Was expecting to point back to this op. */
14191 theirmark = exlist->op_first;
14192 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14195 if (OpSIBLING(theirmark) != o) {
14196 /* There's something between the mark and the reverse, eg
14197 for (1, reverse (...))
14202 ourmark = ((LISTOP *)o)->op_first;
14203 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14206 ourlast = ((LISTOP *)o)->op_last;
14207 if (!ourlast || ourlast->op_next != o)
14210 rv2av = OpSIBLING(ourmark);
14211 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14212 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14213 /* We're just reversing a single array. */
14214 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14215 enter->op_flags |= OPf_STACKED;
14218 /* We don't have control over who points to theirmark, so sacrifice
14220 theirmark->op_next = ourmark->op_next;
14221 theirmark->op_flags = ourmark->op_flags;
14222 ourlast->op_next = gvop ? gvop : (OP *) enter;
14225 enter->op_private |= OPpITER_REVERSED;
14226 iter->op_private |= OPpITER_REVERSED;
14230 o = oldop->op_next;
14238 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14239 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14244 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14245 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14248 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14250 sv = newRV((SV *)PL_compcv);
14254 OpTYPE_set(o, OP_CONST);
14255 o->op_flags |= OPf_SPECIAL;
14256 cSVOPo->op_sv = sv;
14261 if (OP_GIMME(o,0) == G_VOID
14262 || ( o->op_next->op_type == OP_LINESEQ
14263 && ( o->op_next->op_next->op_type == OP_LEAVESUB
14264 || ( o->op_next->op_next->op_type == OP_RETURN
14265 && !CvLVALUE(PL_compcv)))))
14267 OP *right = cBINOP->op_first;
14286 OP *left = OpSIBLING(right);
14287 if (left->op_type == OP_SUBSTR
14288 && (left->op_private & 7) < 4) {
14290 /* cut out right */
14291 op_sibling_splice(o, NULL, 1, NULL);
14292 /* and insert it as second child of OP_SUBSTR */
14293 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14295 left->op_private |= OPpSUBSTR_REPL_FIRST;
14297 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14304 int l, r, lr, lscalars, rscalars;
14306 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14307 Note that we do this now rather than in newASSIGNOP(),
14308 since only by now are aliased lexicals flagged as such
14310 See the essay "Common vars in list assignment" above for
14311 the full details of the rationale behind all the conditions
14314 PL_generation sorcery:
14315 To detect whether there are common vars, the global var
14316 PL_generation is incremented for each assign op we scan.
14317 Then we run through all the lexical variables on the LHS,
14318 of the assignment, setting a spare slot in each of them to
14319 PL_generation. Then we scan the RHS, and if any lexicals
14320 already have that value, we know we've got commonality.
14321 Also, if the generation number is already set to
14322 PERL_INT_MAX, then the variable is involved in aliasing, so
14323 we also have potential commonality in that case.
14329 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
14332 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14336 /* After looking for things which are *always* safe, this main
14337 * if/else chain selects primarily based on the type of the
14338 * LHS, gradually working its way down from the more dangerous
14339 * to the more restrictive and thus safer cases */
14341 if ( !l /* () = ....; */
14342 || !r /* .... = (); */
14343 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14344 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14345 || (lscalars < 2) /* ($x, undef) = ... */
14347 NOOP; /* always safe */
14349 else if (l & AAS_DANGEROUS) {
14350 /* always dangerous */
14351 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14352 o->op_private |= OPpASSIGN_COMMON_AGG;
14354 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14355 /* package vars are always dangerous - too many
14356 * aliasing possibilities */
14357 if (l & AAS_PKG_SCALAR)
14358 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14359 if (l & AAS_PKG_AGG)
14360 o->op_private |= OPpASSIGN_COMMON_AGG;
14362 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14363 |AAS_LEX_SCALAR|AAS_LEX_AGG))
14365 /* LHS contains only lexicals and safe ops */
14367 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14368 o->op_private |= OPpASSIGN_COMMON_AGG;
14370 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14371 if (lr & AAS_LEX_SCALAR_COMM)
14372 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14373 else if ( !(l & AAS_LEX_SCALAR)
14374 && (r & AAS_DEFAV))
14378 * as scalar-safe for performance reasons.
14379 * (it will still have been marked _AGG if necessary */
14382 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14383 o->op_private |= OPpASSIGN_COMMON_RC1;
14388 * may have to handle aggregate on LHS, but we can't
14389 * have common scalars. */
14392 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14398 Perl_cpeep_t cpeep =
14399 XopENTRYCUSTOM(o, xop_peep);
14401 cpeep(aTHX_ o, oldop);
14406 /* did we just null the current op? If so, re-process it to handle
14407 * eliding "empty" ops from the chain */
14408 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14421 Perl_peep(pTHX_ OP *o)
14427 =head1 Custom Operators
14429 =for apidoc Ao||custom_op_xop
14430 Return the XOP structure for a given custom op. This macro should be
14431 considered internal to C<OP_NAME> and the other access macros: use them instead.
14432 This macro does call a function. Prior
14433 to 5.19.6, this was implemented as a
14440 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14446 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14448 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14449 assert(o->op_type == OP_CUSTOM);
14451 /* This is wrong. It assumes a function pointer can be cast to IV,
14452 * which isn't guaranteed, but this is what the old custom OP code
14453 * did. In principle it should be safer to Copy the bytes of the
14454 * pointer into a PV: since the new interface is hidden behind
14455 * functions, this can be changed later if necessary. */
14456 /* Change custom_op_xop if this ever happens */
14457 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14460 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14462 /* assume noone will have just registered a desc */
14463 if (!he && PL_custom_op_names &&
14464 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14469 /* XXX does all this need to be shared mem? */
14470 Newxz(xop, 1, XOP);
14471 pv = SvPV(HeVAL(he), l);
14472 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14473 if (PL_custom_op_descs &&
14474 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14476 pv = SvPV(HeVAL(he), l);
14477 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14479 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14483 xop = (XOP *)&xop_null;
14485 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14489 if(field == XOPe_xop_ptr) {
14492 const U32 flags = XopFLAGS(xop);
14493 if(flags & field) {
14495 case XOPe_xop_name:
14496 any.xop_name = xop->xop_name;
14498 case XOPe_xop_desc:
14499 any.xop_desc = xop->xop_desc;
14501 case XOPe_xop_class:
14502 any.xop_class = xop->xop_class;
14504 case XOPe_xop_peep:
14505 any.xop_peep = xop->xop_peep;
14508 NOT_REACHED; /* NOTREACHED */
14513 case XOPe_xop_name:
14514 any.xop_name = XOPd_xop_name;
14516 case XOPe_xop_desc:
14517 any.xop_desc = XOPd_xop_desc;
14519 case XOPe_xop_class:
14520 any.xop_class = XOPd_xop_class;
14522 case XOPe_xop_peep:
14523 any.xop_peep = XOPd_xop_peep;
14526 NOT_REACHED; /* NOTREACHED */
14531 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14532 * op.c: In function 'Perl_custom_op_get_field':
14533 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14534 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14535 * expands to assert(0), which expands to ((0) ? (void)0 :
14536 * __assert(...)), and gcc doesn't know that __assert can never return. */
14542 =for apidoc Ao||custom_op_register
14543 Register a custom op. See L<perlguts/"Custom Operators">.
14549 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14553 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14555 /* see the comment in custom_op_xop */
14556 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14558 if (!PL_custom_ops)
14559 PL_custom_ops = newHV();
14561 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14562 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14567 =for apidoc core_prototype
14569 This function assigns the prototype of the named core function to C<sv>, or
14570 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
14571 C<NULL> if the core function has no prototype. C<code> is a code as returned
14572 by C<keyword()>. It must not be equal to 0.
14578 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14581 int i = 0, n = 0, seen_question = 0, defgv = 0;
14583 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14584 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14585 bool nullret = FALSE;
14587 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14591 if (!sv) sv = sv_newmortal();
14593 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14595 switch (code < 0 ? -code : code) {
14596 case KEY_and : case KEY_chop: case KEY_chomp:
14597 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14598 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14599 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14600 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14601 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14602 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14603 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14604 case KEY_x : case KEY_xor :
14605 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14606 case KEY_glob: retsetpvs("_;", OP_GLOB);
14607 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
14608 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
14609 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
14610 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14611 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14613 case KEY_evalbytes:
14614 name = "entereval"; break;
14622 while (i < MAXO) { /* The slow way. */
14623 if (strEQ(name, PL_op_name[i])
14624 || strEQ(name, PL_op_desc[i]))
14626 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14633 defgv = PL_opargs[i] & OA_DEFGV;
14634 oa = PL_opargs[i] >> OASHIFT;
14636 if (oa & OA_OPTIONAL && !seen_question && (
14637 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14642 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14643 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14644 /* But globs are already references (kinda) */
14645 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14649 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14650 && !scalar_mod_type(NULL, i)) {
14655 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14659 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14660 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14661 str[n-1] = '_'; defgv = 0;
14665 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14667 sv_setpvn(sv, str, n - 1);
14668 if (opnum) *opnum = i;
14673 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14676 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14679 PERL_ARGS_ASSERT_CORESUB_OP;
14683 return op_append_elem(OP_LINESEQ,
14686 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14690 case OP_SELECT: /* which represents OP_SSELECT as well */
14695 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14696 newSVOP(OP_CONST, 0, newSVuv(1))
14698 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14700 coresub_op(coreargssv, 0, OP_SELECT)
14704 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14706 return op_append_elem(
14709 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14710 ? OPpOFFBYONE << 8 : 0)
14712 case OA_BASEOP_OR_UNOP:
14713 if (opnum == OP_ENTEREVAL) {
14714 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14715 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14717 else o = newUNOP(opnum,0,argop);
14718 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14721 if (is_handle_constructor(o, 1))
14722 argop->op_private |= OPpCOREARGS_DEREF1;
14723 if (scalar_mod_type(NULL, opnum))
14724 argop->op_private |= OPpCOREARGS_SCALARMOD;
14728 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14729 if (is_handle_constructor(o, 2))
14730 argop->op_private |= OPpCOREARGS_DEREF2;
14731 if (opnum == OP_SUBSTR) {
14732 o->op_private |= OPpMAYBE_LVSUB;
14741 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14742 SV * const *new_const_svp)
14744 const char *hvname;
14745 bool is_const = !!CvCONST(old_cv);
14746 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14748 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14750 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14752 /* They are 2 constant subroutines generated from
14753 the same constant. This probably means that
14754 they are really the "same" proxy subroutine
14755 instantiated in 2 places. Most likely this is
14756 when a constant is exported twice. Don't warn.
14759 (ckWARN(WARN_REDEFINE)
14761 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14762 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14763 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14764 strEQ(hvname, "autouse"))
14768 && ckWARN_d(WARN_REDEFINE)
14769 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14772 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14774 ? "Constant subroutine %"SVf" redefined"
14775 : "Subroutine %"SVf" redefined",
14780 =head1 Hook manipulation
14782 These functions provide convenient and thread-safe means of manipulating
14789 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14791 Puts a C function into the chain of check functions for a specified op
14792 type. This is the preferred way to manipulate the L</PL_check> array.
14793 C<opcode> specifies which type of op is to be affected. C<new_checker>
14794 is a pointer to the C function that is to be added to that opcode's
14795 check chain, and C<old_checker_p> points to the storage location where a
14796 pointer to the next function in the chain will be stored. The value of
14797 C<new_pointer> is written into the L</PL_check> array, while the value
14798 previously stored there is written to C<*old_checker_p>.
14800 The function should be defined like this:
14802 static OP *new_checker(pTHX_ OP *op) { ... }
14804 It is intended to be called in this manner:
14806 new_checker(aTHX_ op)
14808 C<old_checker_p> should be defined like this:
14810 static Perl_check_t old_checker_p;
14812 L</PL_check> is global to an entire process, and a module wishing to
14813 hook op checking may find itself invoked more than once per process,
14814 typically in different threads. To handle that situation, this function
14815 is idempotent. The location C<*old_checker_p> must initially (once
14816 per process) contain a null pointer. A C variable of static duration
14817 (declared at file scope, typically also marked C<static> to give
14818 it internal linkage) will be implicitly initialised appropriately,
14819 if it does not have an explicit initialiser. This function will only
14820 actually modify the check chain if it finds C<*old_checker_p> to be null.
14821 This function is also thread safe on the small scale. It uses appropriate
14822 locking to avoid race conditions in accessing L</PL_check>.
14824 When this function is called, the function referenced by C<new_checker>
14825 must be ready to be called, except for C<*old_checker_p> being unfilled.
14826 In a threading situation, C<new_checker> may be called immediately,
14827 even before this function has returned. C<*old_checker_p> will always
14828 be appropriately set before C<new_checker> is called. If C<new_checker>
14829 decides not to do anything special with an op that it is given (which
14830 is the usual case for most uses of op check hooking), it must chain the
14831 check function referenced by C<*old_checker_p>.
14833 If you want to influence compilation of calls to a specific subroutine,
14834 then use L</cv_set_call_checker> rather than hooking checking of all
14841 Perl_wrap_op_checker(pTHX_ Optype opcode,
14842 Perl_check_t new_checker, Perl_check_t *old_checker_p)
14846 PERL_UNUSED_CONTEXT;
14847 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14848 if (*old_checker_p) return;
14849 OP_CHECK_MUTEX_LOCK;
14850 if (!*old_checker_p) {
14851 *old_checker_p = PL_check[opcode];
14852 PL_check[opcode] = new_checker;
14854 OP_CHECK_MUTEX_UNLOCK;
14859 /* Efficient sub that returns a constant scalar value. */
14861 const_sv_xsub(pTHX_ CV* cv)
14864 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14865 PERL_UNUSED_ARG(items);
14875 const_av_xsub(pTHX_ CV* cv)
14878 AV * const av = MUTABLE_AV(XSANY.any_ptr);
14886 if (SvRMAGICAL(av))
14887 Perl_croak(aTHX_ "Magical list constants are not supported");
14888 if (GIMME_V != G_ARRAY) {
14890 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14893 EXTEND(SP, AvFILLp(av)+1);
14894 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14895 XSRETURN(AvFILLp(av)+1);
14899 * ex: set ts=8 sts=4 sw=4 et: