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 /* Used to avoid recursion through the op tree in scalarvoid() and
116 #define DEFERRED_OP_STEP 100
117 #define DEFER_OP(o) \
119 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
120 defer_stack_alloc += DEFERRED_OP_STEP; \
121 assert(defer_stack_alloc > 0); \
122 Renew(defer_stack, defer_stack_alloc, OP *); \
124 defer_stack[++defer_ix] = o; \
127 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
129 /* remove any leading "empty" ops from the op_next chain whose first
130 * node's address is stored in op_p. Store the updated address of the
131 * first node in op_p.
135 S_prune_chain_head(OP** op_p)
138 && ( (*op_p)->op_type == OP_NULL
139 || (*op_p)->op_type == OP_SCOPE
140 || (*op_p)->op_type == OP_SCALAR
141 || (*op_p)->op_type == OP_LINESEQ)
143 *op_p = (*op_p)->op_next;
147 /* See the explanatory comments above struct opslab in op.h. */
149 #ifdef PERL_DEBUG_READONLY_OPS
150 # define PERL_SLAB_SIZE 128
151 # define PERL_MAX_SLAB_SIZE 4096
152 # include <sys/mman.h>
155 #ifndef PERL_SLAB_SIZE
156 # define PERL_SLAB_SIZE 64
158 #ifndef PERL_MAX_SLAB_SIZE
159 # define PERL_MAX_SLAB_SIZE 2048
162 /* rounds up to nearest pointer */
163 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
164 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
167 S_new_slab(pTHX_ size_t sz)
169 #ifdef PERL_DEBUG_READONLY_OPS
170 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
171 PROT_READ|PROT_WRITE,
172 MAP_ANON|MAP_PRIVATE, -1, 0);
173 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
174 (unsigned long) sz, slab));
175 if (slab == MAP_FAILED) {
176 perror("mmap failed");
179 slab->opslab_size = (U16)sz;
181 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
184 /* The context is unused in non-Windows */
187 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
191 /* requires double parens and aTHX_ */
192 #define DEBUG_S_warn(args) \
194 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
198 Perl_Slab_Alloc(pTHX_ size_t sz)
206 /* We only allocate ops from the slab during subroutine compilation.
207 We find the slab via PL_compcv, hence that must be non-NULL. It could
208 also be pointing to a subroutine which is now fully set up (CvROOT()
209 pointing to the top of the optree for that sub), or a subroutine
210 which isn't using the slab allocator. If our sanity checks aren't met,
211 don't use a slab, but allocate the OP directly from the heap. */
212 if (!PL_compcv || CvROOT(PL_compcv)
213 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
215 o = (OP*)PerlMemShared_calloc(1, sz);
219 /* While the subroutine is under construction, the slabs are accessed via
220 CvSTART(), to avoid needing to expand PVCV by one pointer for something
221 unneeded at runtime. Once a subroutine is constructed, the slabs are
222 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
223 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
225 if (!CvSTART(PL_compcv)) {
227 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
228 CvSLABBED_on(PL_compcv);
229 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
231 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
233 opsz = SIZE_TO_PSIZE(sz);
234 sz = opsz + OPSLOT_HEADER_P;
236 /* The slabs maintain a free list of OPs. In particular, constant folding
237 will free up OPs, so it makes sense to re-use them where possible. A
238 freed up slot is used in preference to a new allocation. */
239 if (slab->opslab_freed) {
240 OP **too = &slab->opslab_freed;
242 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
243 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
244 DEBUG_S_warn((aTHX_ "Alas! too small"));
245 o = *(too = &o->op_next);
246 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
250 Zero(o, opsz, I32 *);
256 #define INIT_OPSLOT \
257 slot->opslot_slab = slab; \
258 slot->opslot_next = slab2->opslab_first; \
259 slab2->opslab_first = slot; \
260 o = &slot->opslot_op; \
263 /* The partially-filled slab is next in the chain. */
264 slab2 = slab->opslab_next ? slab->opslab_next : slab;
265 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
266 /* Remaining space is too small. */
268 /* If we can fit a BASEOP, add it to the free chain, so as not
270 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
271 slot = &slab2->opslab_slots;
273 o->op_type = OP_FREED;
274 o->op_next = slab->opslab_freed;
275 slab->opslab_freed = o;
278 /* Create a new slab. Make this one twice as big. */
279 slot = slab2->opslab_first;
280 while (slot->opslot_next) slot = slot->opslot_next;
281 slab2 = S_new_slab(aTHX_
282 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
284 : (DIFF(slab2, slot)+1)*2);
285 slab2->opslab_next = slab->opslab_next;
286 slab->opslab_next = slab2;
288 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
290 /* Create a new op slot */
291 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
292 assert(slot >= &slab2->opslab_slots);
293 if (DIFF(&slab2->opslab_slots, slot)
294 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
295 slot = &slab2->opslab_slots;
297 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
300 #ifdef PERL_OP_PARENT
301 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
302 assert(!o->op_moresib);
303 assert(!o->op_sibparent);
311 #ifdef PERL_DEBUG_READONLY_OPS
313 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
315 PERL_ARGS_ASSERT_SLAB_TO_RO;
317 if (slab->opslab_readonly) return;
318 slab->opslab_readonly = 1;
319 for (; slab; slab = slab->opslab_next) {
320 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
321 (unsigned long) slab->opslab_size, slab));*/
322 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
323 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
324 (unsigned long)slab->opslab_size, errno);
329 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
333 PERL_ARGS_ASSERT_SLAB_TO_RW;
335 if (!slab->opslab_readonly) return;
337 for (; slab2; slab2 = slab2->opslab_next) {
338 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
339 (unsigned long) size, slab2));*/
340 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
341 PROT_READ|PROT_WRITE)) {
342 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
343 (unsigned long)slab2->opslab_size, errno);
346 slab->opslab_readonly = 0;
350 # define Slab_to_rw(op) NOOP
353 /* This cannot possibly be right, but it was copied from the old slab
354 allocator, to which it was originally added, without explanation, in
357 # define PerlMemShared PerlMem
361 Perl_Slab_Free(pTHX_ void *op)
363 OP * const o = (OP *)op;
366 PERL_ARGS_ASSERT_SLAB_FREE;
368 if (!o->op_slabbed) {
370 PerlMemShared_free(op);
375 /* If this op is already freed, our refcount will get screwy. */
376 assert(o->op_type != OP_FREED);
377 o->op_type = OP_FREED;
378 o->op_next = slab->opslab_freed;
379 slab->opslab_freed = o;
380 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
381 OpslabREFCNT_dec_padok(slab);
385 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
387 const bool havepad = !!PL_comppad;
388 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
391 PAD_SAVE_SETNULLPAD();
398 Perl_opslab_free(pTHX_ OPSLAB *slab)
401 PERL_ARGS_ASSERT_OPSLAB_FREE;
403 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
404 assert(slab->opslab_refcnt == 1);
406 slab2 = slab->opslab_next;
408 slab->opslab_refcnt = ~(size_t)0;
410 #ifdef PERL_DEBUG_READONLY_OPS
411 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
413 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
414 perror("munmap failed");
418 PerlMemShared_free(slab);
425 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
430 size_t savestack_count = 0;
432 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
435 for (slot = slab2->opslab_first;
437 slot = slot->opslot_next) {
438 if (slot->opslot_op.op_type != OP_FREED
439 && !(slot->opslot_op.op_savefree
445 assert(slot->opslot_op.op_slabbed);
446 op_free(&slot->opslot_op);
447 if (slab->opslab_refcnt == 1) goto free;
450 } while ((slab2 = slab2->opslab_next));
451 /* > 1 because the CV still holds a reference count. */
452 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
454 assert(savestack_count == slab->opslab_refcnt-1);
456 /* Remove the CV’s reference count. */
457 slab->opslab_refcnt--;
464 #ifdef PERL_DEBUG_READONLY_OPS
466 Perl_op_refcnt_inc(pTHX_ OP *o)
469 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
470 if (slab && slab->opslab_readonly) {
483 Perl_op_refcnt_dec(pTHX_ OP *o)
486 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
488 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
490 if (slab && slab->opslab_readonly) {
492 result = --o->op_targ;
495 result = --o->op_targ;
501 * In the following definition, the ", (OP*)0" is just to make the compiler
502 * think the expression is of the right type: croak actually does a Siglongjmp.
504 #define CHECKOP(type,o) \
505 ((PL_op_mask && PL_op_mask[type]) \
506 ? ( op_free((OP*)o), \
507 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
509 : PL_check[type](aTHX_ (OP*)o))
511 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
513 #define OpTYPE_set(o,type) \
515 o->op_type = (OPCODE)type; \
516 o->op_ppaddr = PL_ppaddr[type]; \
520 S_no_fh_allowed(pTHX_ OP *o)
522 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
524 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
530 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
532 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
533 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
538 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
540 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
542 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
547 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
549 PERL_ARGS_ASSERT_BAD_TYPE_PV;
551 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
552 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
555 /* remove flags var, its unused in all callers, move to to right end since gv
556 and kid are always the same */
558 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
560 SV * const namesv = cv_name((CV *)gv, NULL, 0);
561 PERL_ARGS_ASSERT_BAD_TYPE_GV;
563 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
564 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
568 S_no_bareword_allowed(pTHX_ OP *o)
570 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
572 qerror(Perl_mess(aTHX_
573 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
575 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
578 /* "register" allocation */
581 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
584 const bool is_our = (PL_parser->in_my == KEY_our);
586 PERL_ARGS_ASSERT_ALLOCMY;
588 if (flags & ~SVf_UTF8)
589 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
592 /* complain about "my $<special_var>" etc etc */
596 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
597 (name[1] == '_' && (*name == '$' || len > 2))))
599 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
601 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
602 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
603 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
604 PL_parser->in_my == KEY_state ? "state" : "my"));
606 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
607 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
610 else if (len == 2 && name[1] == '_' && !is_our)
611 /* diag_listed_as: Use of my $_ is experimental */
612 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
613 "Use of %s $_ is experimental",
614 PL_parser->in_my == KEY_state
618 /* allocate a spare slot and store the name in that slot */
620 off = pad_add_name_pvn(name, len,
621 (is_our ? padadd_OUR :
622 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
623 PL_parser->in_my_stash,
625 /* $_ is always in main::, even with our */
626 ? (PL_curstash && !memEQs(name,len,"$_")
632 /* anon sub prototypes contains state vars should always be cloned,
633 * otherwise the state var would be shared between anon subs */
635 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
636 CvCLONE_on(PL_compcv);
642 =head1 Optree Manipulation Functions
644 =for apidoc alloccopstash
646 Available only under threaded builds, this function allocates an entry in
647 C<PL_stashpad> for the stash passed to it.
654 Perl_alloccopstash(pTHX_ HV *hv)
656 PADOFFSET off = 0, o = 1;
657 bool found_slot = FALSE;
659 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
661 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
663 for (; o < PL_stashpadmax; ++o) {
664 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
665 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
666 found_slot = TRUE, off = o;
669 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
670 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
671 off = PL_stashpadmax;
672 PL_stashpadmax += 10;
675 PL_stashpad[PL_stashpadix = off] = hv;
680 /* free the body of an op without examining its contents.
681 * Always use this rather than FreeOp directly */
684 S_op_destroy(pTHX_ OP *o)
692 =for apidoc Am|void|op_free|OP *o
694 Free an op. Only use this when an op is no longer linked to from any
701 Perl_op_free(pTHX_ OP *o)
705 SSize_t defer_ix = -1;
706 SSize_t defer_stack_alloc = 0;
707 OP **defer_stack = NULL;
711 /* Though ops may be freed twice, freeing the op after its slab is a
713 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
714 /* During the forced freeing of ops after compilation failure, kidops
715 may be freed before their parents. */
716 if (!o || o->op_type == OP_FREED)
721 /* an op should only ever acquire op_private flags that we know about.
722 * If this fails, you may need to fix something in regen/op_private */
723 if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
724 assert(!(o->op_private & ~PL_op_private_valid[type]));
727 if (o->op_private & OPpREFCOUNTED) {
738 refcnt = OpREFCNT_dec(o);
741 /* Need to find and remove any pattern match ops from the list
742 we maintain for reset(). */
743 find_and_forget_pmops(o);
753 /* Call the op_free hook if it has been set. Do it now so that it's called
754 * at the right time for refcounted ops, but still before all of the kids
758 if (o->op_flags & OPf_KIDS) {
760 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
761 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
762 if (!kid || kid->op_type == OP_FREED)
763 /* During the forced freeing of ops after
764 compilation failure, kidops may be freed before
767 if (!(kid->op_flags & OPf_KIDS))
768 /* If it has no kids, just free it now */
775 type = (OPCODE)o->op_targ;
778 Slab_to_rw(OpSLAB(o));
780 /* COP* is not cleared by op_clear() so that we may track line
781 * numbers etc even after null() */
782 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
788 #ifdef DEBUG_LEAKING_SCALARS
792 } while ( (o = POP_DEFERRED_OP()) );
794 Safefree(defer_stack);
797 /* S_op_clear_gv(): free a GV attached to an OP */
800 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
802 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
806 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
807 || o->op_type == OP_MULTIDEREF)
810 ? ((GV*)PAD_SVl(*ixp)) : NULL;
812 ? (GV*)(*svp) : NULL;
814 /* It's possible during global destruction that the GV is freed
815 before the optree. Whilst the SvREFCNT_inc is happy to bump from
816 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
817 will trigger an assertion failure, because the entry to sv_clear
818 checks that the scalar is not already freed. A check of for
819 !SvIS_FREED(gv) turns out to be invalid, because during global
820 destruction the reference count can be forced down to zero
821 (with SVf_BREAK set). In which case raising to 1 and then
822 dropping to 0 triggers cleanup before it should happen. I
823 *think* that this might actually be a general, systematic,
824 weakness of the whole idea of SVf_BREAK, in that code *is*
825 allowed to raise and lower references during global destruction,
826 so any *valid* code that happens to do this during global
827 destruction might well trigger premature cleanup. */
828 bool still_valid = gv && SvREFCNT(gv);
831 SvREFCNT_inc_simple_void(gv);
834 pad_swipe(*ixp, TRUE);
842 int try_downgrade = SvREFCNT(gv) == 2;
845 gv_try_downgrade(gv);
851 Perl_op_clear(pTHX_ OP *o)
856 PERL_ARGS_ASSERT_OP_CLEAR;
858 switch (o->op_type) {
859 case OP_NULL: /* Was holding old type, if any. */
862 case OP_ENTEREVAL: /* Was holding hints. */
866 if (!(o->op_flags & OPf_REF)
867 || (PL_check[o->op_type] != Perl_ck_ftst))
874 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
876 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
879 case OP_METHOD_REDIR:
880 case OP_METHOD_REDIR_SUPER:
882 if (cMETHOPx(o)->op_rclass_targ) {
883 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
884 cMETHOPx(o)->op_rclass_targ = 0;
887 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
888 cMETHOPx(o)->op_rclass_sv = NULL;
890 case OP_METHOD_NAMED:
891 case OP_METHOD_SUPER:
892 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
893 cMETHOPx(o)->op_u.op_meth_sv = NULL;
896 pad_swipe(o->op_targ, 1);
903 SvREFCNT_dec(cSVOPo->op_sv);
904 cSVOPo->op_sv = NULL;
907 Even if op_clear does a pad_free for the target of the op,
908 pad_free doesn't actually remove the sv that exists in the pad;
909 instead it lives on. This results in that it could be reused as
910 a target later on when the pad was reallocated.
913 pad_swipe(o->op_targ,1);
923 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
928 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
929 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
931 if (cPADOPo->op_padix > 0) {
932 pad_swipe(cPADOPo->op_padix, TRUE);
933 cPADOPo->op_padix = 0;
936 SvREFCNT_dec(cSVOPo->op_sv);
937 cSVOPo->op_sv = NULL;
941 PerlMemShared_free(cPVOPo->op_pv);
942 cPVOPo->op_pv = NULL;
946 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
950 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
951 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
954 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
960 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
961 op_free(cPMOPo->op_code_list);
962 cPMOPo->op_code_list = NULL;
964 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
965 /* we use the same protection as the "SAFE" version of the PM_ macros
966 * here since sv_clean_all might release some PMOPs
967 * after PL_regex_padav has been cleared
968 * and the clearing of PL_regex_padav needs to
969 * happen before sv_clean_all
972 if(PL_regex_pad) { /* We could be in destruction */
973 const IV offset = (cPMOPo)->op_pmoffset;
974 ReREFCNT_dec(PM_GETRE(cPMOPo));
975 PL_regex_pad[offset] = &PL_sv_undef;
976 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
980 ReREFCNT_dec(PM_GETRE(cPMOPo));
981 PM_SETRE(cPMOPo, NULL);
988 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
989 UV actions = items->uv;
991 bool is_hash = FALSE;
994 switch (actions & MDEREF_ACTION_MASK) {
997 actions = (++items)->uv;
1000 case MDEREF_HV_padhv_helem:
1002 case MDEREF_AV_padav_aelem:
1003 pad_free((++items)->pad_offset);
1006 case MDEREF_HV_gvhv_helem:
1008 case MDEREF_AV_gvav_aelem:
1010 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1012 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1016 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1018 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1020 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1022 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1024 goto do_vivify_rv2xv_elem;
1026 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1028 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1029 pad_free((++items)->pad_offset);
1030 goto do_vivify_rv2xv_elem;
1032 case MDEREF_HV_pop_rv2hv_helem:
1033 case MDEREF_HV_vivify_rv2hv_helem:
1035 do_vivify_rv2xv_elem:
1036 case MDEREF_AV_pop_rv2av_aelem:
1037 case MDEREF_AV_vivify_rv2av_aelem:
1039 switch (actions & MDEREF_INDEX_MASK) {
1040 case MDEREF_INDEX_none:
1043 case MDEREF_INDEX_const:
1047 pad_swipe((++items)->pad_offset, 1);
1049 SvREFCNT_dec((++items)->sv);
1055 case MDEREF_INDEX_padsv:
1056 pad_free((++items)->pad_offset);
1058 case MDEREF_INDEX_gvsv:
1060 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1062 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1067 if (actions & MDEREF_FLAG_last)
1080 actions >>= MDEREF_SHIFT;
1083 /* start of malloc is at op_aux[-1], where the length is
1085 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1090 if (o->op_targ > 0) {
1091 pad_free(o->op_targ);
1097 S_cop_free(pTHX_ COP* cop)
1099 PERL_ARGS_ASSERT_COP_FREE;
1102 if (! specialWARN(cop->cop_warnings))
1103 PerlMemShared_free(cop->cop_warnings);
1104 cophh_free(CopHINTHASH_get(cop));
1105 if (PL_curcop == cop)
1110 S_forget_pmop(pTHX_ PMOP *const o
1113 HV * const pmstash = PmopSTASH(o);
1115 PERL_ARGS_ASSERT_FORGET_PMOP;
1117 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1118 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1120 PMOP **const array = (PMOP**) mg->mg_ptr;
1121 U32 count = mg->mg_len / sizeof(PMOP**);
1125 if (array[i] == o) {
1126 /* Found it. Move the entry at the end to overwrite it. */
1127 array[i] = array[--count];
1128 mg->mg_len = count * sizeof(PMOP**);
1129 /* Could realloc smaller at this point always, but probably
1130 not worth it. Probably worth free()ing if we're the
1133 Safefree(mg->mg_ptr);
1146 S_find_and_forget_pmops(pTHX_ OP *o)
1148 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1150 if (o->op_flags & OPf_KIDS) {
1151 OP *kid = cUNOPo->op_first;
1153 switch (kid->op_type) {
1158 forget_pmop((PMOP*)kid);
1160 find_and_forget_pmops(kid);
1161 kid = OpSIBLING(kid);
1167 =for apidoc Am|void|op_null|OP *o
1169 Neutralizes an op when it is no longer needed, but is still linked to from
1176 Perl_op_null(pTHX_ OP *o)
1180 PERL_ARGS_ASSERT_OP_NULL;
1182 if (o->op_type == OP_NULL)
1185 o->op_targ = o->op_type;
1186 OpTYPE_set(o, OP_NULL);
1190 Perl_op_refcnt_lock(pTHX)
1195 PERL_UNUSED_CONTEXT;
1200 Perl_op_refcnt_unlock(pTHX)
1205 PERL_UNUSED_CONTEXT;
1211 =for apidoc op_sibling_splice
1213 A general function for editing the structure of an existing chain of
1214 op_sibling nodes. By analogy with the perl-level splice() function, allows
1215 you to delete zero or more sequential nodes, replacing them with zero or
1216 more different nodes. Performs the necessary op_first/op_last
1217 housekeeping on the parent node and op_sibling manipulation on the
1218 children. The last deleted node will be marked as as the last node by
1219 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1221 Note that op_next is not manipulated, and nodes are not freed; that is the
1222 responsibility of the caller. It also won't create a new list op for an
1223 empty list etc; use higher-level functions like op_append_elem() for that.
1225 parent is the parent node of the sibling chain. It may passed as NULL if
1226 the splicing doesn't affect the first or last op in the chain.
1228 start is the node preceding the first node to be spliced. Node(s)
1229 following it will be deleted, and ops will be inserted after it. If it is
1230 NULL, the first node onwards is deleted, and nodes are inserted at the
1233 del_count is the number of nodes to delete. If zero, no nodes are deleted.
1234 If -1 or greater than or equal to the number of remaining kids, all
1235 remaining kids are deleted.
1237 insert is the first of a chain of nodes to be inserted in place of the nodes.
1238 If NULL, no nodes are inserted.
1240 The head of the chain of deleted ops is returned, or NULL if no ops were
1245 action before after returns
1246 ------ ----- ----- -------
1249 splice(P, A, 2, X-Y-Z) | | B-C
1253 splice(P, NULL, 1, X-Y) | | A
1257 splice(P, NULL, 3, NULL) | | A-B-C
1261 splice(P, B, 0, X-Y) | | NULL
1265 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1266 see C<OpMORESIB_set>, C<OpLASTSIB_set>, C<OpMAYBESIB_set>.
1272 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1276 OP *last_del = NULL;
1277 OP *last_ins = NULL;
1280 first = OpSIBLING(start);
1284 first = cLISTOPx(parent)->op_first;
1286 assert(del_count >= -1);
1288 if (del_count && first) {
1290 while (--del_count && OpHAS_SIBLING(last_del))
1291 last_del = OpSIBLING(last_del);
1292 rest = OpSIBLING(last_del);
1293 OpLASTSIB_set(last_del, NULL);
1300 while (OpHAS_SIBLING(last_ins))
1301 last_ins = OpSIBLING(last_ins);
1302 OpMAYBESIB_set(last_ins, rest, NULL);
1308 OpMAYBESIB_set(start, insert, NULL);
1313 cLISTOPx(parent)->op_first = insert;
1315 parent->op_flags |= OPf_KIDS;
1317 parent->op_flags &= ~OPf_KIDS;
1321 /* update op_last etc */
1328 /* ought to use OP_CLASS(parent) here, but that can't handle
1329 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1331 type = parent->op_type;
1332 if (type == OP_CUSTOM) {
1334 type = XopENTRYCUSTOM(parent, xop_class);
1337 if (type == OP_NULL)
1338 type = parent->op_targ;
1339 type = PL_opargs[type] & OA_CLASS_MASK;
1342 lastop = last_ins ? last_ins : start ? start : NULL;
1343 if ( type == OA_BINOP
1344 || type == OA_LISTOP
1348 cLISTOPx(parent)->op_last = lastop;
1351 OpLASTSIB_set(lastop, parent);
1353 return last_del ? first : NULL;
1356 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1360 #ifdef PERL_OP_PARENT
1363 =for apidoc op_parent
1365 Returns the parent OP of o, if it has a parent. Returns NULL otherwise.
1366 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1372 Perl_op_parent(OP *o)
1374 PERL_ARGS_ASSERT_OP_PARENT;
1375 while (OpHAS_SIBLING(o))
1377 return o->op_sibparent;
1383 /* replace the sibling following start with a new UNOP, which becomes
1384 * the parent of the original sibling; e.g.
1386 * op_sibling_newUNOP(P, A, unop-args...)
1394 * where U is the new UNOP.
1396 * parent and start args are the same as for op_sibling_splice();
1397 * type and flags args are as newUNOP().
1399 * Returns the new UNOP.
1403 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1407 kid = op_sibling_splice(parent, start, 1, NULL);
1408 newop = newUNOP(type, flags, kid);
1409 op_sibling_splice(parent, start, 0, newop);
1414 /* lowest-level newLOGOP-style function - just allocates and populates
1415 * the struct. Higher-level stuff should be done by S_new_logop() /
1416 * newLOGOP(). This function exists mainly to avoid op_first assignment
1417 * being spread throughout this file.
1421 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1426 NewOp(1101, logop, 1, LOGOP);
1427 OpTYPE_set(logop, type);
1428 logop->op_first = first;
1429 logop->op_other = other;
1430 logop->op_flags = OPf_KIDS;
1431 while (kid && OpHAS_SIBLING(kid))
1432 kid = OpSIBLING(kid);
1434 OpLASTSIB_set(kid, (OP*)logop);
1439 /* Contextualizers */
1442 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1444 Applies a syntactic context to an op tree representing an expression.
1445 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1446 or C<G_VOID> to specify the context to apply. The modified op tree
1453 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1455 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1457 case G_SCALAR: return scalar(o);
1458 case G_ARRAY: return list(o);
1459 case G_VOID: return scalarvoid(o);
1461 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1468 =for apidoc Am|OP*|op_linklist|OP *o
1469 This function is the implementation of the L</LINKLIST> macro. It should
1470 not be called directly.
1476 Perl_op_linklist(pTHX_ OP *o)
1480 PERL_ARGS_ASSERT_OP_LINKLIST;
1485 /* establish postfix order */
1486 first = cUNOPo->op_first;
1489 o->op_next = LINKLIST(first);
1492 OP *sibl = OpSIBLING(kid);
1494 kid->op_next = LINKLIST(sibl);
1509 S_scalarkids(pTHX_ OP *o)
1511 if (o && o->op_flags & OPf_KIDS) {
1513 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1520 S_scalarboolean(pTHX_ OP *o)
1522 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1524 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1525 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1526 if (ckWARN(WARN_SYNTAX)) {
1527 const line_t oldline = CopLINE(PL_curcop);
1529 if (PL_parser && PL_parser->copline != NOLINE) {
1530 /* This ensures that warnings are reported at the first line
1531 of the conditional, not the last. */
1532 CopLINE_set(PL_curcop, PL_parser->copline);
1534 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1535 CopLINE_set(PL_curcop, oldline);
1542 S_op_varname(pTHX_ const OP *o)
1545 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1546 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1548 const char funny = o->op_type == OP_PADAV
1549 || o->op_type == OP_RV2AV ? '@' : '%';
1550 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1552 if (cUNOPo->op_first->op_type != OP_GV
1553 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1555 return varname(gv, funny, 0, NULL, 0, 1);
1558 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1563 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1564 { /* or not so pretty :-) */
1565 if (o->op_type == OP_CONST) {
1567 if (SvPOK(*retsv)) {
1569 *retsv = sv_newmortal();
1570 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1571 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1573 else if (!SvOK(*retsv))
1576 else *retpv = "...";
1580 S_scalar_slice_warning(pTHX_ const OP *o)
1584 o->op_type == OP_HSLICE ? '{' : '[';
1586 o->op_type == OP_HSLICE ? '}' : ']';
1588 SV *keysv = NULL; /* just to silence compiler warnings */
1589 const char *key = NULL;
1591 if (!(o->op_private & OPpSLICEWARNING))
1593 if (PL_parser && PL_parser->error_count)
1594 /* This warning can be nonsensical when there is a syntax error. */
1597 kid = cLISTOPo->op_first;
1598 kid = OpSIBLING(kid); /* get past pushmark */
1599 /* weed out false positives: any ops that can return lists */
1600 switch (kid->op_type) {
1626 /* Don't warn if we have a nulled list either. */
1627 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1630 assert(OpSIBLING(kid));
1631 name = S_op_varname(aTHX_ OpSIBLING(kid));
1632 if (!name) /* XS module fiddling with the op tree */
1634 S_op_pretty(aTHX_ kid, &keysv, &key);
1635 assert(SvPOK(name));
1636 sv_chop(name,SvPVX(name)+1);
1638 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1639 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1640 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1642 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1643 lbrack, key, rbrack);
1645 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1646 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1647 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1649 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1650 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1654 Perl_scalar(pTHX_ OP *o)
1658 /* assumes no premature commitment */
1659 if (!o || (PL_parser && PL_parser->error_count)
1660 || (o->op_flags & OPf_WANT)
1661 || o->op_type == OP_RETURN)
1666 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1668 switch (o->op_type) {
1670 scalar(cBINOPo->op_first);
1671 if (o->op_private & OPpREPEAT_DOLIST) {
1672 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1673 assert(kid->op_type == OP_PUSHMARK);
1674 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1675 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1676 o->op_private &=~ OPpREPEAT_DOLIST;
1683 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1693 if (o->op_flags & OPf_KIDS) {
1694 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1700 kid = cLISTOPo->op_first;
1702 kid = OpSIBLING(kid);
1705 OP *sib = OpSIBLING(kid);
1706 if (sib && kid->op_type != OP_LEAVEWHEN
1707 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1708 || ( sib->op_targ != OP_NEXTSTATE
1709 && sib->op_targ != OP_DBSTATE )))
1715 PL_curcop = &PL_compiling;
1720 kid = cLISTOPo->op_first;
1723 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1728 /* Warn about scalar context */
1729 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1730 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1733 const char *key = NULL;
1735 /* This warning can be nonsensical when there is a syntax error. */
1736 if (PL_parser && PL_parser->error_count)
1739 if (!ckWARN(WARN_SYNTAX)) break;
1741 kid = cLISTOPo->op_first;
1742 kid = OpSIBLING(kid); /* get past pushmark */
1743 assert(OpSIBLING(kid));
1744 name = S_op_varname(aTHX_ OpSIBLING(kid));
1745 if (!name) /* XS module fiddling with the op tree */
1747 S_op_pretty(aTHX_ kid, &keysv, &key);
1748 assert(SvPOK(name));
1749 sv_chop(name,SvPVX(name)+1);
1751 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1752 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1753 "%%%"SVf"%c%s%c in scalar context better written "
1755 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1756 lbrack, key, rbrack);
1758 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1759 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1760 "%%%"SVf"%c%"SVf"%c in scalar context better "
1761 "written as $%"SVf"%c%"SVf"%c",
1762 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1763 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1770 Perl_scalarvoid(pTHX_ OP *arg)
1776 SSize_t defer_stack_alloc = 0;
1777 SSize_t defer_ix = -1;
1778 OP **defer_stack = NULL;
1781 PERL_ARGS_ASSERT_SCALARVOID;
1784 SV *useless_sv = NULL;
1785 const char* useless = NULL;
1787 if (o->op_type == OP_NEXTSTATE
1788 || o->op_type == OP_DBSTATE
1789 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1790 || o->op_targ == OP_DBSTATE)))
1791 PL_curcop = (COP*)o; /* for warning below */
1793 /* assumes no premature commitment */
1794 want = o->op_flags & OPf_WANT;
1795 if ((want && want != OPf_WANT_SCALAR)
1796 || (PL_parser && PL_parser->error_count)
1797 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1802 if ((o->op_private & OPpTARGET_MY)
1803 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1805 /* newASSIGNOP has already applied scalar context, which we
1806 leave, as if this op is inside SASSIGN. */
1810 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1812 switch (o->op_type) {
1814 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1818 if (o->op_flags & OPf_STACKED)
1820 if (o->op_type == OP_REPEAT)
1821 scalar(cBINOPo->op_first);
1824 if (o->op_private == 4)
1859 case OP_GETSOCKNAME:
1860 case OP_GETPEERNAME:
1865 case OP_GETPRIORITY:
1890 useless = OP_DESC(o);
1900 case OP_AELEMFAST_LEX:
1904 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1905 /* Otherwise it's "Useless use of grep iterator" */
1906 useless = OP_DESC(o);
1910 kid = cLISTOPo->op_first;
1911 if (kid && kid->op_type == OP_PUSHRE
1913 && !(o->op_flags & OPf_STACKED)
1915 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1917 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1920 useless = OP_DESC(o);
1924 kid = cUNOPo->op_first;
1925 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1926 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1929 useless = "negative pattern binding (!~)";
1933 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1934 useless = "non-destructive substitution (s///r)";
1938 useless = "non-destructive transliteration (tr///r)";
1945 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1946 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1947 useless = "a variable";
1952 if (cSVOPo->op_private & OPpCONST_STRICT)
1953 no_bareword_allowed(o);
1955 if (ckWARN(WARN_VOID)) {
1957 /* don't warn on optimised away booleans, eg
1958 * use constant Foo, 5; Foo || print; */
1959 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1961 /* the constants 0 and 1 are permitted as they are
1962 conventionally used as dummies in constructs like
1963 1 while some_condition_with_side_effects; */
1964 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1966 else if (SvPOK(sv)) {
1967 SV * const dsv = newSVpvs("");
1969 = Perl_newSVpvf(aTHX_
1971 pv_pretty(dsv, SvPVX_const(sv),
1972 SvCUR(sv), 32, NULL, NULL,
1974 | PERL_PV_ESCAPE_NOCLEAR
1975 | PERL_PV_ESCAPE_UNI_DETECT));
1976 SvREFCNT_dec_NN(dsv);
1978 else if (SvOK(sv)) {
1979 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1982 useless = "a constant (undef)";
1985 op_null(o); /* don't execute or even remember it */
1989 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
1993 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
1997 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2001 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2006 UNOP *refgen, *rv2cv;
2009 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2012 rv2gv = ((BINOP *)o)->op_last;
2013 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2016 refgen = (UNOP *)((BINOP *)o)->op_first;
2018 if (!refgen || (refgen->op_type != OP_REFGEN
2019 && refgen->op_type != OP_SREFGEN))
2022 exlist = (LISTOP *)refgen->op_first;
2023 if (!exlist || exlist->op_type != OP_NULL
2024 || exlist->op_targ != OP_LIST)
2027 if (exlist->op_first->op_type != OP_PUSHMARK
2028 && exlist->op_first != exlist->op_last)
2031 rv2cv = (UNOP*)exlist->op_last;
2033 if (rv2cv->op_type != OP_RV2CV)
2036 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2037 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2038 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2040 o->op_private |= OPpASSIGN_CV_TO_GV;
2041 rv2gv->op_private |= OPpDONT_INIT_GV;
2042 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2054 kid = cLOGOPo->op_first;
2055 if (kid->op_type == OP_NOT
2056 && (kid->op_flags & OPf_KIDS)) {
2057 if (o->op_type == OP_AND) {
2058 OpTYPE_set(o, OP_OR);
2060 OpTYPE_set(o, OP_AND);
2070 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2071 if (!(kid->op_flags & OPf_KIDS))
2078 if (o->op_flags & OPf_STACKED)
2085 if (!(o->op_flags & OPf_KIDS))
2096 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2097 if (!(kid->op_flags & OPf_KIDS))
2103 /* If the first kid after pushmark is something that the padrange
2104 optimisation would reject, then null the list and the pushmark.
2106 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2107 && ( !(kid = OpSIBLING(kid))
2108 || ( kid->op_type != OP_PADSV
2109 && kid->op_type != OP_PADAV
2110 && kid->op_type != OP_PADHV)
2111 || kid->op_private & ~OPpLVAL_INTRO
2112 || !(kid = OpSIBLING(kid))
2113 || ( kid->op_type != OP_PADSV
2114 && kid->op_type != OP_PADAV
2115 && kid->op_type != OP_PADHV)
2116 || kid->op_private & ~OPpLVAL_INTRO)
2118 op_null(cUNOPo->op_first); /* NULL the pushmark */
2119 op_null(o); /* NULL the list */
2131 /* mortalise it, in case warnings are fatal. */
2132 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2133 "Useless use of %"SVf" in void context",
2134 SVfARG(sv_2mortal(useless_sv)));
2137 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2138 "Useless use of %s in void context",
2141 } while ( (o = POP_DEFERRED_OP()) );
2143 Safefree(defer_stack);
2149 S_listkids(pTHX_ OP *o)
2151 if (o && o->op_flags & OPf_KIDS) {
2153 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2160 Perl_list(pTHX_ OP *o)
2164 /* assumes no premature commitment */
2165 if (!o || (o->op_flags & OPf_WANT)
2166 || (PL_parser && PL_parser->error_count)
2167 || o->op_type == OP_RETURN)
2172 if ((o->op_private & OPpTARGET_MY)
2173 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2175 return o; /* As if inside SASSIGN */
2178 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2180 switch (o->op_type) {
2182 list(cBINOPo->op_first);
2185 if (o->op_private & OPpREPEAT_DOLIST
2186 && !(o->op_flags & OPf_STACKED))
2188 list(cBINOPo->op_first);
2189 kid = cBINOPo->op_last;
2190 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2191 && SvIVX(kSVOP_sv) == 1)
2193 op_null(o); /* repeat */
2194 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2196 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2203 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2211 if (!(o->op_flags & OPf_KIDS))
2213 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2214 list(cBINOPo->op_first);
2215 return gen_constant_list(o);
2221 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2222 op_null(cUNOPo->op_first); /* NULL the pushmark */
2223 op_null(o); /* NULL the list */
2228 kid = cLISTOPo->op_first;
2230 kid = OpSIBLING(kid);
2233 OP *sib = OpSIBLING(kid);
2234 if (sib && kid->op_type != OP_LEAVEWHEN)
2240 PL_curcop = &PL_compiling;
2244 kid = cLISTOPo->op_first;
2251 S_scalarseq(pTHX_ OP *o)
2254 const OPCODE type = o->op_type;
2256 if (type == OP_LINESEQ || type == OP_SCOPE ||
2257 type == OP_LEAVE || type == OP_LEAVETRY)
2260 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2261 if ((sib = OpSIBLING(kid))
2262 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2263 || ( sib->op_targ != OP_NEXTSTATE
2264 && sib->op_targ != OP_DBSTATE )))
2269 PL_curcop = &PL_compiling;
2271 o->op_flags &= ~OPf_PARENS;
2272 if (PL_hints & HINT_BLOCK_SCOPE)
2273 o->op_flags |= OPf_PARENS;
2276 o = newOP(OP_STUB, 0);
2281 S_modkids(pTHX_ OP *o, I32 type)
2283 if (o && o->op_flags & OPf_KIDS) {
2285 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2286 op_lvalue(kid, type);
2292 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2293 * const fields. Also, convert CONST keys to HEK-in-SVs.
2294 * rop is the op that retrieves the hash;
2295 * key_op is the first key
2299 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2305 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2307 if (rop->op_first->op_type == OP_PADSV)
2308 /* @$hash{qw(keys here)} */
2309 rop = (UNOP*)rop->op_first;
2311 /* @{$hash}{qw(keys here)} */
2312 if (rop->op_first->op_type == OP_SCOPE
2313 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2315 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2322 lexname = NULL; /* just to silence compiler warnings */
2323 fields = NULL; /* just to silence compiler warnings */
2327 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2328 SvPAD_TYPED(lexname))
2329 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2330 && isGV(*fields) && GvHV(*fields);
2332 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2334 if (key_op->op_type != OP_CONST)
2336 svp = cSVOPx_svp(key_op);
2338 /* Make the CONST have a shared SV */
2339 if ( !SvIsCOW_shared_hash(sv = *svp)
2340 && SvTYPE(sv) < SVt_PVMG
2345 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2346 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2347 SvREFCNT_dec_NN(sv);
2352 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2354 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2355 "in variable %"PNf" of type %"HEKf,
2356 SVfARG(*svp), PNfARG(lexname),
2357 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2364 =for apidoc finalize_optree
2366 This function finalizes the optree. Should be called directly after
2367 the complete optree is built. It does some additional
2368 checking which can't be done in the normal ck_xxx functions and makes
2369 the tree thread-safe.
2374 Perl_finalize_optree(pTHX_ OP* o)
2376 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2379 SAVEVPTR(PL_curcop);
2387 /* Relocate sv to the pad for thread safety.
2388 * Despite being a "constant", the SV is written to,
2389 * for reference counts, sv_upgrade() etc. */
2390 PERL_STATIC_INLINE void
2391 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2394 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2396 ix = pad_alloc(OP_CONST, SVf_READONLY);
2397 SvREFCNT_dec(PAD_SVl(ix));
2398 PAD_SETSV(ix, *svp);
2399 /* XXX I don't know how this isn't readonly already. */
2400 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2408 S_finalize_op(pTHX_ OP* o)
2410 PERL_ARGS_ASSERT_FINALIZE_OP;
2413 switch (o->op_type) {
2416 PL_curcop = ((COP*)o); /* for warnings */
2419 if (OpHAS_SIBLING(o)) {
2420 OP *sib = OpSIBLING(o);
2421 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2422 && ckWARN(WARN_EXEC)
2423 && OpHAS_SIBLING(sib))
2425 const OPCODE type = OpSIBLING(sib)->op_type;
2426 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2427 const line_t oldline = CopLINE(PL_curcop);
2428 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2429 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2430 "Statement unlikely to be reached");
2431 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2432 "\t(Maybe you meant system() when you said exec()?)\n");
2433 CopLINE_set(PL_curcop, oldline);
2440 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2441 GV * const gv = cGVOPo_gv;
2442 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2443 /* XXX could check prototype here instead of just carping */
2444 SV * const sv = sv_newmortal();
2445 gv_efullname3(sv, gv, NULL);
2446 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2447 "%"SVf"() called too early to check prototype",
2454 if (cSVOPo->op_private & OPpCONST_STRICT)
2455 no_bareword_allowed(o);
2459 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2464 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2465 case OP_METHOD_NAMED:
2466 case OP_METHOD_SUPER:
2467 case OP_METHOD_REDIR:
2468 case OP_METHOD_REDIR_SUPER:
2469 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2478 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2481 rop = (UNOP*)((BINOP*)o)->op_first;
2486 S_scalar_slice_warning(aTHX_ o);
2490 kid = OpSIBLING(cLISTOPo->op_first);
2491 if (/* I bet there's always a pushmark... */
2492 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2493 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2498 key_op = (SVOP*)(kid->op_type == OP_CONST
2500 : OpSIBLING(kLISTOP->op_first));
2502 rop = (UNOP*)((LISTOP*)o)->op_last;
2505 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2507 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2511 S_scalar_slice_warning(aTHX_ o);
2515 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2516 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2523 if (o->op_flags & OPf_KIDS) {
2527 /* check that op_last points to the last sibling, and that
2528 * the last op_sibling/op_sibparent field points back to the
2529 * parent, and that the only ops with KIDS are those which are
2530 * entitled to them */
2531 U32 type = o->op_type;
2535 if (type == OP_NULL) {
2537 /* ck_glob creates a null UNOP with ex-type GLOB
2538 * (which is a list op. So pretend it wasn't a listop */
2539 if (type == OP_GLOB)
2542 family = PL_opargs[type] & OA_CLASS_MASK;
2544 has_last = ( family == OA_BINOP
2545 || family == OA_LISTOP
2546 || family == OA_PMOP
2547 || family == OA_LOOP
2549 assert( has_last /* has op_first and op_last, or ...
2550 ... has (or may have) op_first: */
2551 || family == OA_UNOP
2552 || family == OA_UNOP_AUX
2553 || family == OA_LOGOP
2554 || family == OA_BASEOP_OR_UNOP
2555 || family == OA_FILESTATOP
2556 || family == OA_LOOPEXOP
2557 || family == OA_METHOP
2558 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2559 || type == OP_SASSIGN
2560 || type == OP_CUSTOM
2561 || type == OP_NULL /* new_logop does this */
2564 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2565 # ifdef PERL_OP_PARENT
2566 if (!OpHAS_SIBLING(kid)) {
2568 assert(kid == cLISTOPo->op_last);
2569 assert(kid->op_sibparent == o);
2572 if (has_last && !OpHAS_SIBLING(kid))
2573 assert(kid == cLISTOPo->op_last);
2578 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2584 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2586 Propagate lvalue ("modifiable") context to an op and its children.
2587 I<type> represents the context type, roughly based on the type of op that
2588 would do the modifying, although C<local()> is represented by OP_NULL,
2589 because it has no op type of its own (it is signalled by a flag on
2592 This function detects things that can't be modified, such as C<$x+1>, and
2593 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2594 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2596 It also flags things that need to behave specially in an lvalue context,
2597 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2603 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2606 PadnameLVALUE_on(pn);
2607 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2610 assert(CvPADLIST(cv));
2612 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2613 assert(PadnameLEN(pn));
2614 PadnameLVALUE_on(pn);
2619 S_vivifies(const OPCODE type)
2622 case OP_RV2AV: case OP_ASLICE:
2623 case OP_RV2HV: case OP_KVASLICE:
2624 case OP_RV2SV: case OP_HSLICE:
2625 case OP_AELEMFAST: case OP_KVHSLICE:
2634 S_lvref(pTHX_ OP *o, I32 type)
2638 switch (o->op_type) {
2640 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2641 kid = OpSIBLING(kid))
2642 S_lvref(aTHX_ kid, type);
2647 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2648 o->op_flags |= OPf_STACKED;
2649 if (o->op_flags & OPf_PARENS) {
2650 if (o->op_private & OPpLVAL_INTRO) {
2651 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2652 "localized parenthesized array in list assignment"));
2656 OpTYPE_set(o, OP_LVAVREF);
2657 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2658 o->op_flags |= OPf_MOD|OPf_REF;
2661 o->op_private |= OPpLVREF_AV;
2664 kid = cUNOPo->op_first;
2665 if (kid->op_type == OP_NULL)
2666 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2668 o->op_private = OPpLVREF_CV;
2669 if (kid->op_type == OP_GV)
2670 o->op_flags |= OPf_STACKED;
2671 else if (kid->op_type == OP_PADCV) {
2672 o->op_targ = kid->op_targ;
2674 op_free(cUNOPo->op_first);
2675 cUNOPo->op_first = NULL;
2676 o->op_flags &=~ OPf_KIDS;
2681 if (o->op_flags & OPf_PARENS) {
2683 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2684 "parenthesized hash in list assignment"));
2687 o->op_private |= OPpLVREF_HV;
2691 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2692 o->op_flags |= OPf_STACKED;
2695 if (o->op_flags & OPf_PARENS) goto parenhash;
2696 o->op_private |= OPpLVREF_HV;
2699 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2702 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2703 if (o->op_flags & OPf_PARENS) goto slurpy;
2704 o->op_private |= OPpLVREF_AV;
2708 o->op_private |= OPpLVREF_ELEM;
2709 o->op_flags |= OPf_STACKED;
2713 OpTYPE_set(o, OP_LVREFSLICE);
2714 o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2717 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2719 else if (!(o->op_flags & OPf_KIDS))
2721 if (o->op_targ != OP_LIST) {
2722 S_lvref(aTHX_ cBINOPo->op_first, type);
2727 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2728 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2729 S_lvref(aTHX_ kid, type);
2733 if (o->op_flags & OPf_PARENS)
2738 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2739 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2740 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2745 OpTYPE_set(o, OP_LVREF);
2747 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2748 if (type == OP_ENTERLOOP)
2749 o->op_private |= OPpLVREF_ITER;
2753 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2757 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2760 if (!o || (PL_parser && PL_parser->error_count))
2763 if ((o->op_private & OPpTARGET_MY)
2764 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2769 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2771 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2773 switch (o->op_type) {
2778 if ((o->op_flags & OPf_PARENS))
2782 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2783 !(o->op_flags & OPf_STACKED)) {
2784 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
2785 assert(cUNOPo->op_first->op_type == OP_NULL);
2786 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2789 else { /* lvalue subroutine call */
2790 o->op_private |= OPpLVAL_INTRO;
2791 PL_modcount = RETURN_UNLIMITED_NUMBER;
2792 if (type == OP_GREPSTART || type == OP_ENTERSUB
2793 || type == OP_REFGEN || type == OP_LEAVESUBLV) {
2794 /* Potential lvalue context: */
2795 o->op_private |= OPpENTERSUB_INARGS;
2798 else { /* Compile-time error message: */
2799 OP *kid = cUNOPo->op_first;
2803 if (kid->op_type != OP_PUSHMARK) {
2804 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2806 "panic: unexpected lvalue entersub "
2807 "args: type/targ %ld:%"UVuf,
2808 (long)kid->op_type, (UV)kid->op_targ);
2809 kid = kLISTOP->op_first;
2811 while (OpHAS_SIBLING(kid))
2812 kid = OpSIBLING(kid);
2813 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2814 break; /* Postpone until runtime */
2817 kid = kUNOP->op_first;
2818 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2819 kid = kUNOP->op_first;
2820 if (kid->op_type == OP_NULL)
2822 "Unexpected constant lvalue entersub "
2823 "entry via type/targ %ld:%"UVuf,
2824 (long)kid->op_type, (UV)kid->op_targ);
2825 if (kid->op_type != OP_GV) {
2832 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2833 ? MUTABLE_CV(SvRV(gv))
2844 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2845 /* grep, foreach, subcalls, refgen */
2846 if (type == OP_GREPSTART || type == OP_ENTERSUB
2847 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2849 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2850 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2852 : (o->op_type == OP_ENTERSUB
2853 ? "non-lvalue subroutine call"
2855 type ? PL_op_desc[type] : "local"));
2868 case OP_RIGHT_SHIFT:
2877 if (!(o->op_flags & OPf_STACKED))
2883 if (o->op_flags & OPf_STACKED) {
2887 if (!(o->op_private & OPpREPEAT_DOLIST))
2890 const I32 mods = PL_modcount;
2891 modkids(cBINOPo->op_first, type);
2892 if (type != OP_AASSIGN)
2894 kid = cBINOPo->op_last;
2895 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2896 const IV iv = SvIV(kSVOP_sv);
2897 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2899 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2902 PL_modcount = RETURN_UNLIMITED_NUMBER;
2908 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2909 op_lvalue(kid, type);
2914 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2915 PL_modcount = RETURN_UNLIMITED_NUMBER;
2916 return o; /* Treat \(@foo) like ordinary list. */
2920 if (scalar_mod_type(o, type))
2922 ref(cUNOPo->op_first, o->op_type);
2929 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2930 if (type == OP_LEAVESUBLV && (
2931 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2932 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2934 o->op_private |= OPpMAYBE_LVSUB;
2938 PL_modcount = RETURN_UNLIMITED_NUMBER;
2942 if (type == OP_LEAVESUBLV)
2943 o->op_private |= OPpMAYBE_LVSUB;
2946 PL_hints |= HINT_BLOCK_SCOPE;
2947 if (type == OP_LEAVESUBLV)
2948 o->op_private |= OPpMAYBE_LVSUB;
2952 ref(cUNOPo->op_first, o->op_type);
2956 PL_hints |= HINT_BLOCK_SCOPE;
2966 case OP_AELEMFAST_LEX:
2973 PL_modcount = RETURN_UNLIMITED_NUMBER;
2974 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2975 return o; /* Treat \(@foo) like ordinary list. */
2976 if (scalar_mod_type(o, type))
2978 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2979 && type == OP_LEAVESUBLV)
2980 o->op_private |= OPpMAYBE_LVSUB;
2984 if (!type) /* local() */
2985 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
2986 PNfARG(PAD_COMPNAME(o->op_targ)));
2987 if (!(o->op_private & OPpLVAL_INTRO)
2988 || ( type != OP_SASSIGN && type != OP_AASSIGN
2989 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
2990 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
2998 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
3002 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3008 if (type == OP_LEAVESUBLV)
3009 o->op_private |= OPpMAYBE_LVSUB;
3010 if (o->op_flags & OPf_KIDS)
3011 op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3016 ref(cBINOPo->op_first, o->op_type);
3017 if (type == OP_ENTERSUB &&
3018 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3019 o->op_private |= OPpLVAL_DEFER;
3020 if (type == OP_LEAVESUBLV)
3021 o->op_private |= OPpMAYBE_LVSUB;
3028 o->op_private |= OPpLVALUE;
3034 if (o->op_flags & OPf_KIDS)
3035 op_lvalue(cLISTOPo->op_last, type);
3040 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3042 else if (!(o->op_flags & OPf_KIDS))
3044 if (o->op_targ != OP_LIST) {
3045 op_lvalue(cBINOPo->op_first, type);
3051 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3052 /* elements might be in void context because the list is
3053 in scalar context or because they are attribute sub calls */
3054 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3055 op_lvalue(kid, type);
3063 if (type == OP_LEAVESUBLV
3064 || !S_vivifies(cLOGOPo->op_first->op_type))
3065 op_lvalue(cLOGOPo->op_first, type);
3066 if (type == OP_LEAVESUBLV
3067 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3068 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3072 if (type != OP_AASSIGN && type != OP_SASSIGN
3073 && type != OP_ENTERLOOP)
3075 /* Don’t bother applying lvalue context to the ex-list. */
3076 kid = cUNOPx(cUNOPo->op_first)->op_first;
3077 assert (!OpHAS_SIBLING(kid));
3080 if (type != OP_AASSIGN) goto nomod;
3081 kid = cUNOPo->op_first;
3084 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3085 S_lvref(aTHX_ kid, type);
3086 if (!PL_parser || PL_parser->error_count == ec) {
3087 if (!FEATURE_REFALIASING_IS_ENABLED)
3089 "Experimental aliasing via reference not enabled");
3090 Perl_ck_warner_d(aTHX_
3091 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3092 "Aliasing via reference is experimental");
3095 if (o->op_type == OP_REFGEN)
3096 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3101 kid = cLISTOPo->op_first;
3102 if (kid && kid->op_type == OP_PUSHRE &&
3104 || o->op_flags & OPf_STACKED
3106 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3108 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3111 /* This is actually @array = split. */
3112 PL_modcount = RETURN_UNLIMITED_NUMBER;
3118 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3122 /* [20011101.069] File test operators interpret OPf_REF to mean that
3123 their argument is a filehandle; thus \stat(".") should not set
3125 if (type == OP_REFGEN &&
3126 PL_check[o->op_type] == Perl_ck_ftst)
3129 if (type != OP_LEAVESUBLV)
3130 o->op_flags |= OPf_MOD;
3132 if (type == OP_AASSIGN || type == OP_SASSIGN)
3133 o->op_flags |= OPf_SPECIAL|OPf_REF;
3134 else if (!type) { /* local() */
3137 o->op_private |= OPpLVAL_INTRO;
3138 o->op_flags &= ~OPf_SPECIAL;
3139 PL_hints |= HINT_BLOCK_SCOPE;
3144 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3145 "Useless localization of %s", OP_DESC(o));
3148 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3149 && type != OP_LEAVESUBLV)
3150 o->op_flags |= OPf_REF;
3155 S_scalar_mod_type(const OP *o, I32 type)
3160 if (o && o->op_type == OP_RV2GV)
3184 case OP_RIGHT_SHIFT:
3205 S_is_handle_constructor(const OP *o, I32 numargs)
3207 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3209 switch (o->op_type) {
3217 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3230 S_refkids(pTHX_ OP *o, I32 type)
3232 if (o && o->op_flags & OPf_KIDS) {
3234 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3241 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3246 PERL_ARGS_ASSERT_DOREF;
3248 if (PL_parser && PL_parser->error_count)
3251 switch (o->op_type) {
3253 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3254 !(o->op_flags & OPf_STACKED)) {
3255 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3256 assert(cUNOPo->op_first->op_type == OP_NULL);
3257 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3258 o->op_flags |= OPf_SPECIAL;
3260 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3261 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3262 : type == OP_RV2HV ? OPpDEREF_HV
3264 o->op_flags |= OPf_MOD;
3270 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3271 doref(kid, type, set_op_ref);
3274 if (type == OP_DEFINED)
3275 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3276 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3279 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3280 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3281 : type == OP_RV2HV ? OPpDEREF_HV
3283 o->op_flags |= OPf_MOD;
3290 o->op_flags |= OPf_REF;
3293 if (type == OP_DEFINED)
3294 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3295 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3301 o->op_flags |= OPf_REF;
3306 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3308 doref(cBINOPo->op_first, type, set_op_ref);
3312 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3313 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3314 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3315 : type == OP_RV2HV ? OPpDEREF_HV
3317 o->op_flags |= OPf_MOD;
3327 if (!(o->op_flags & OPf_KIDS))
3329 doref(cLISTOPo->op_last, type, set_op_ref);
3339 S_dup_attrlist(pTHX_ OP *o)
3343 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3345 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3346 * where the first kid is OP_PUSHMARK and the remaining ones
3347 * are OP_CONST. We need to push the OP_CONST values.
3349 if (o->op_type == OP_CONST)
3350 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3352 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3354 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3355 if (o->op_type == OP_CONST)
3356 rop = op_append_elem(OP_LIST, rop,
3357 newSVOP(OP_CONST, o->op_flags,
3358 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3365 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3367 PERL_ARGS_ASSERT_APPLY_ATTRS;
3369 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3371 /* fake up C<use attributes $pkg,$rv,@attrs> */
3373 #define ATTRSMODULE "attributes"
3374 #define ATTRSMODULE_PM "attributes.pm"
3377 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3378 newSVpvs(ATTRSMODULE),
3380 op_prepend_elem(OP_LIST,
3381 newSVOP(OP_CONST, 0, stashsv),
3382 op_prepend_elem(OP_LIST,
3383 newSVOP(OP_CONST, 0,
3385 dup_attrlist(attrs))));
3390 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3392 OP *pack, *imop, *arg;
3393 SV *meth, *stashsv, **svp;
3395 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3400 assert(target->op_type == OP_PADSV ||
3401 target->op_type == OP_PADHV ||
3402 target->op_type == OP_PADAV);
3404 /* Ensure that attributes.pm is loaded. */
3405 /* Don't force the C<use> if we don't need it. */
3406 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3407 if (svp && *svp != &PL_sv_undef)
3408 NOOP; /* already in %INC */
3410 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3411 newSVpvs(ATTRSMODULE), NULL);
3413 /* Need package name for method call. */
3414 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3416 /* Build up the real arg-list. */
3417 stashsv = newSVhek(HvNAME_HEK(stash));
3419 arg = newOP(OP_PADSV, 0);
3420 arg->op_targ = target->op_targ;
3421 arg = op_prepend_elem(OP_LIST,
3422 newSVOP(OP_CONST, 0, stashsv),
3423 op_prepend_elem(OP_LIST,
3424 newUNOP(OP_REFGEN, 0,
3426 dup_attrlist(attrs)));
3428 /* Fake up a method call to import */
3429 meth = newSVpvs_share("import");
3430 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3431 op_append_elem(OP_LIST,
3432 op_prepend_elem(OP_LIST, pack, arg),
3433 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3435 /* Combine the ops. */
3436 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3440 =notfor apidoc apply_attrs_string
3442 Attempts to apply a list of attributes specified by the C<attrstr> and
3443 C<len> arguments to the subroutine identified by the C<cv> argument which
3444 is expected to be associated with the package identified by the C<stashpv>
3445 argument (see L<attributes>). It gets this wrong, though, in that it
3446 does not correctly identify the boundaries of the individual attribute
3447 specifications within C<attrstr>. This is not really intended for the
3448 public API, but has to be listed here for systems such as AIX which
3449 need an explicit export list for symbols. (It's called from XS code
3450 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3451 to respect attribute syntax properly would be welcome.
3457 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3458 const char *attrstr, STRLEN len)
3462 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3465 len = strlen(attrstr);
3469 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3471 const char * const sstr = attrstr;
3472 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3473 attrs = op_append_elem(OP_LIST, attrs,
3474 newSVOP(OP_CONST, 0,
3475 newSVpvn(sstr, attrstr-sstr)));
3479 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3480 newSVpvs(ATTRSMODULE),
3481 NULL, op_prepend_elem(OP_LIST,
3482 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3483 op_prepend_elem(OP_LIST,
3484 newSVOP(OP_CONST, 0,
3485 newRV(MUTABLE_SV(cv))),
3490 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3492 OP *new_proto = NULL;
3497 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3503 if (o->op_type == OP_CONST) {
3504 pv = SvPV(cSVOPo_sv, pvlen);
3505 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3506 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3507 SV ** const tmpo = cSVOPx_svp(o);
3508 SvREFCNT_dec(cSVOPo_sv);
3513 } else if (o->op_type == OP_LIST) {
3515 assert(o->op_flags & OPf_KIDS);
3516 lasto = cLISTOPo->op_first;
3517 assert(lasto->op_type == OP_PUSHMARK);
3518 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3519 if (o->op_type == OP_CONST) {
3520 pv = SvPV(cSVOPo_sv, pvlen);
3521 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3522 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3523 SV ** const tmpo = cSVOPx_svp(o);
3524 SvREFCNT_dec(cSVOPo_sv);
3526 if (new_proto && ckWARN(WARN_MISC)) {
3528 const char * newp = SvPV(cSVOPo_sv, new_len);
3529 Perl_warner(aTHX_ packWARN(WARN_MISC),
3530 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3531 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3537 /* excise new_proto from the list */
3538 op_sibling_splice(*attrs, lasto, 1, NULL);
3545 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3546 would get pulled in with no real need */
3547 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3556 svname = sv_newmortal();
3557 gv_efullname3(svname, name, NULL);
3559 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3560 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3562 svname = (SV *)name;
3563 if (ckWARN(WARN_ILLEGALPROTO))
3564 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3565 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3566 STRLEN old_len, new_len;
3567 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3568 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3570 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3571 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3573 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3574 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3584 S_cant_declare(pTHX_ OP *o)
3586 if (o->op_type == OP_NULL
3587 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3588 o = cUNOPo->op_first;
3589 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3590 o->op_type == OP_NULL
3591 && o->op_flags & OPf_SPECIAL
3594 PL_parser->in_my == KEY_our ? "our" :
3595 PL_parser->in_my == KEY_state ? "state" :
3600 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3603 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3605 PERL_ARGS_ASSERT_MY_KID;
3607 if (!o || (PL_parser && PL_parser->error_count))
3612 if (type == OP_LIST) {
3614 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3615 my_kid(kid, attrs, imopsp);
3617 } else if (type == OP_UNDEF || type == OP_STUB) {
3619 } else if (type == OP_RV2SV || /* "our" declaration */
3621 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3622 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3623 S_cant_declare(aTHX_ o);
3625 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3627 PL_parser->in_my = FALSE;
3628 PL_parser->in_my_stash = NULL;
3629 apply_attrs(GvSTASH(gv),
3630 (type == OP_RV2SV ? GvSV(gv) :
3631 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3632 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3635 o->op_private |= OPpOUR_INTRO;
3638 else if (type != OP_PADSV &&
3641 type != OP_PUSHMARK)
3643 S_cant_declare(aTHX_ o);
3646 else if (attrs && type != OP_PUSHMARK) {
3650 PL_parser->in_my = FALSE;
3651 PL_parser->in_my_stash = NULL;
3653 /* check for C<my Dog $spot> when deciding package */
3654 stash = PAD_COMPNAME_TYPE(o->op_targ);
3656 stash = PL_curstash;
3657 apply_attrs_my(stash, o, attrs, imopsp);
3659 o->op_flags |= OPf_MOD;
3660 o->op_private |= OPpLVAL_INTRO;
3662 o->op_private |= OPpPAD_STATE;
3667 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3670 int maybe_scalar = 0;
3672 PERL_ARGS_ASSERT_MY_ATTRS;
3674 /* [perl #17376]: this appears to be premature, and results in code such as
3675 C< our(%x); > executing in list mode rather than void mode */
3677 if (o->op_flags & OPf_PARENS)
3687 o = my_kid(o, attrs, &rops);
3689 if (maybe_scalar && o->op_type == OP_PADSV) {
3690 o = scalar(op_append_list(OP_LIST, rops, o));
3691 o->op_private |= OPpLVAL_INTRO;
3694 /* The listop in rops might have a pushmark at the beginning,
3695 which will mess up list assignment. */
3696 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3697 if (rops->op_type == OP_LIST &&
3698 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3700 OP * const pushmark = lrops->op_first;
3701 /* excise pushmark */
3702 op_sibling_splice(rops, NULL, 1, NULL);
3705 o = op_append_list(OP_LIST, o, rops);
3708 PL_parser->in_my = FALSE;
3709 PL_parser->in_my_stash = NULL;
3714 Perl_sawparens(pTHX_ OP *o)
3716 PERL_UNUSED_CONTEXT;
3718 o->op_flags |= OPf_PARENS;
3723 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3727 const OPCODE ltype = left->op_type;
3728 const OPCODE rtype = right->op_type;
3730 PERL_ARGS_ASSERT_BIND_MATCH;
3732 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3733 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3735 const char * const desc
3737 rtype == OP_SUBST || rtype == OP_TRANS
3738 || rtype == OP_TRANSR
3740 ? (int)rtype : OP_MATCH];
3741 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3743 S_op_varname(aTHX_ left);
3745 Perl_warner(aTHX_ packWARN(WARN_MISC),
3746 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3747 desc, SVfARG(name), SVfARG(name));
3749 const char * const sample = (isary
3750 ? "@array" : "%hash");
3751 Perl_warner(aTHX_ packWARN(WARN_MISC),
3752 "Applying %s to %s will act on scalar(%s)",
3753 desc, sample, sample);
3757 if (rtype == OP_CONST &&
3758 cSVOPx(right)->op_private & OPpCONST_BARE &&
3759 cSVOPx(right)->op_private & OPpCONST_STRICT)
3761 no_bareword_allowed(right);
3764 /* !~ doesn't make sense with /r, so error on it for now */
3765 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3767 /* diag_listed_as: Using !~ with %s doesn't make sense */
3768 yyerror("Using !~ with s///r doesn't make sense");
3769 if (rtype == OP_TRANSR && type == OP_NOT)
3770 /* diag_listed_as: Using !~ with %s doesn't make sense */
3771 yyerror("Using !~ with tr///r doesn't make sense");
3773 ismatchop = (rtype == OP_MATCH ||
3774 rtype == OP_SUBST ||
3775 rtype == OP_TRANS || rtype == OP_TRANSR)
3776 && !(right->op_flags & OPf_SPECIAL);
3777 if (ismatchop && right->op_private & OPpTARGET_MY) {
3779 right->op_private &= ~OPpTARGET_MY;
3781 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3782 if (left->op_type == OP_PADSV
3783 && !(left->op_private & OPpLVAL_INTRO))
3785 right->op_targ = left->op_targ;
3790 right->op_flags |= OPf_STACKED;
3791 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3792 ! (rtype == OP_TRANS &&
3793 right->op_private & OPpTRANS_IDENTICAL) &&
3794 ! (rtype == OP_SUBST &&
3795 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3796 left = op_lvalue(left, rtype);
3797 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3798 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3800 o = op_prepend_elem(rtype, scalar(left), right);
3803 return newUNOP(OP_NOT, 0, scalar(o));
3807 return bind_match(type, left,
3808 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3812 Perl_invert(pTHX_ OP *o)
3816 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3820 =for apidoc Amx|OP *|op_scope|OP *o
3822 Wraps up an op tree with some additional ops so that at runtime a dynamic
3823 scope will be created. The original ops run in the new dynamic scope,
3824 and then, provided that they exit normally, the scope will be unwound.
3825 The additional ops used to create and unwind the dynamic scope will
3826 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3827 instead if the ops are simple enough to not need the full dynamic scope
3834 Perl_op_scope(pTHX_ OP *o)
3838 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3839 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3840 OpTYPE_set(o, OP_LEAVE);
3842 else if (o->op_type == OP_LINESEQ) {
3844 OpTYPE_set(o, OP_SCOPE);
3845 kid = ((LISTOP*)o)->op_first;
3846 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3849 /* The following deals with things like 'do {1 for 1}' */
3850 kid = OpSIBLING(kid);
3852 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3857 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3863 Perl_op_unscope(pTHX_ OP *o)
3865 if (o && o->op_type == OP_LINESEQ) {
3866 OP *kid = cLISTOPo->op_first;
3867 for(; kid; kid = OpSIBLING(kid))
3868 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3875 =for apidoc Am|int|block_start|int full
3877 Handles compile-time scope entry.
3878 Arranges for hints to be restored on block
3879 exit and also handles pad sequence numbers to make lexical variables scope
3880 right. Returns a savestack index for use with C<block_end>.
3886 Perl_block_start(pTHX_ int full)
3888 const int retval = PL_savestack_ix;
3890 PL_compiling.cop_seq = PL_cop_seqmax;
3892 pad_block_start(full);
3894 PL_hints &= ~HINT_BLOCK_SCOPE;
3895 SAVECOMPILEWARNINGS();
3896 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3897 SAVEI32(PL_compiling.cop_seq);
3898 PL_compiling.cop_seq = 0;
3900 CALL_BLOCK_HOOKS(bhk_start, full);
3906 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3908 Handles compile-time scope exit. I<floor>
3909 is the savestack index returned by
3910 C<block_start>, and I<seq> is the body of the block. Returns the block,
3917 Perl_block_end(pTHX_ I32 floor, OP *seq)
3919 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3920 OP* retval = scalarseq(seq);
3923 /* XXX Is the null PL_parser check necessary here? */
3924 assert(PL_parser); /* Let’s find out under debugging builds. */
3925 if (PL_parser && PL_parser->parsed_sub) {
3926 o = newSTATEOP(0, NULL, NULL);
3928 retval = op_append_elem(OP_LINESEQ, retval, o);
3931 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3935 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3939 /* pad_leavemy has created a sequence of introcv ops for all my
3940 subs declared in the block. We have to replicate that list with
3941 clonecv ops, to deal with this situation:
3946 sub s1 { state sub foo { \&s2 } }
3949 Originally, I was going to have introcv clone the CV and turn
3950 off the stale flag. Since &s1 is declared before &s2, the
3951 introcv op for &s1 is executed (on sub entry) before the one for
3952 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3953 cloned, since it is a state sub) closes over &s2 and expects
3954 to see it in its outer CV’s pad. If the introcv op clones &s1,
3955 then &s2 is still marked stale. Since &s1 is not active, and
3956 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3957 ble will not stay shared’ warning. Because it is the same stub
3958 that will be used when the introcv op for &s2 is executed, clos-
3959 ing over it is safe. Hence, we have to turn off the stale flag
3960 on all lexical subs in the block before we clone any of them.
3961 Hence, having introcv clone the sub cannot work. So we create a
3962 list of ops like this:
3986 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3987 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3988 for (;; kid = OpSIBLING(kid)) {
3989 OP *newkid = newOP(OP_CLONECV, 0);
3990 newkid->op_targ = kid->op_targ;
3991 o = op_append_elem(OP_LINESEQ, o, newkid);
3992 if (kid == last) break;
3994 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3997 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4003 =head1 Compile-time scope hooks
4005 =for apidoc Aox||blockhook_register
4007 Register a set of hooks to be called when the Perl lexical scope changes
4008 at compile time. See L<perlguts/"Compile-time scope hooks">.
4014 Perl_blockhook_register(pTHX_ BHK *hk)
4016 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4018 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4022 Perl_newPROG(pTHX_ OP *o)
4024 PERL_ARGS_ASSERT_NEWPROG;
4031 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4032 ((PL_in_eval & EVAL_KEEPERR)
4033 ? OPf_SPECIAL : 0), o);
4035 cx = &cxstack[cxstack_ix];
4036 assert(CxTYPE(cx) == CXt_EVAL);
4038 if ((cx->blk_gimme & G_WANT) == G_VOID)
4039 scalarvoid(PL_eval_root);
4040 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4043 scalar(PL_eval_root);
4045 PL_eval_start = op_linklist(PL_eval_root);
4046 PL_eval_root->op_private |= OPpREFCOUNTED;
4047 OpREFCNT_set(PL_eval_root, 1);
4048 PL_eval_root->op_next = 0;
4049 i = PL_savestack_ix;
4052 CALL_PEEP(PL_eval_start);
4053 finalize_optree(PL_eval_root);
4054 S_prune_chain_head(&PL_eval_start);
4056 PL_savestack_ix = i;
4059 if (o->op_type == OP_STUB) {
4060 /* This block is entered if nothing is compiled for the main
4061 program. This will be the case for an genuinely empty main
4062 program, or one which only has BEGIN blocks etc, so already
4065 Historically (5.000) the guard above was !o. However, commit
4066 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4067 c71fccf11fde0068, changed perly.y so that newPROG() is now
4068 called with the output of block_end(), which returns a new
4069 OP_STUB for the case of an empty optree. ByteLoader (and
4070 maybe other things) also take this path, because they set up
4071 PL_main_start and PL_main_root directly, without generating an
4074 If the parsing the main program aborts (due to parse errors,
4075 or due to BEGIN or similar calling exit), then newPROG()
4076 isn't even called, and hence this code path and its cleanups
4077 are skipped. This shouldn't make a make a difference:
4078 * a non-zero return from perl_parse is a failure, and
4079 perl_destruct() should be called immediately.
4080 * however, if exit(0) is called during the parse, then
4081 perl_parse() returns 0, and perl_run() is called. As
4082 PL_main_start will be NULL, perl_run() will return
4083 promptly, and the exit code will remain 0.
4086 PL_comppad_name = 0;
4088 S_op_destroy(aTHX_ o);
4091 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4092 PL_curcop = &PL_compiling;
4093 PL_main_start = LINKLIST(PL_main_root);
4094 PL_main_root->op_private |= OPpREFCOUNTED;
4095 OpREFCNT_set(PL_main_root, 1);
4096 PL_main_root->op_next = 0;
4097 CALL_PEEP(PL_main_start);
4098 finalize_optree(PL_main_root);
4099 S_prune_chain_head(&PL_main_start);
4100 cv_forget_slab(PL_compcv);
4103 /* Register with debugger */
4105 CV * const cv = get_cvs("DB::postponed", 0);
4109 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4111 call_sv(MUTABLE_SV(cv), G_DISCARD);
4118 Perl_localize(pTHX_ OP *o, I32 lex)
4120 PERL_ARGS_ASSERT_LOCALIZE;
4122 if (o->op_flags & OPf_PARENS)
4123 /* [perl #17376]: this appears to be premature, and results in code such as
4124 C< our(%x); > executing in list mode rather than void mode */
4131 if ( PL_parser->bufptr > PL_parser->oldbufptr
4132 && PL_parser->bufptr[-1] == ','
4133 && ckWARN(WARN_PARENTHESIS))
4135 char *s = PL_parser->bufptr;
4138 /* some heuristics to detect a potential error */
4139 while (*s && (strchr(", \t\n", *s)))
4143 if (*s && strchr("@$%*", *s) && *++s
4144 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4147 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4149 while (*s && (strchr(", \t\n", *s)))
4155 if (sigil && (*s == ';' || *s == '=')) {
4156 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4157 "Parentheses missing around \"%s\" list",
4159 ? (PL_parser->in_my == KEY_our
4161 : PL_parser->in_my == KEY_state
4171 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4172 PL_parser->in_my = FALSE;
4173 PL_parser->in_my_stash = NULL;
4178 Perl_jmaybe(pTHX_ OP *o)
4180 PERL_ARGS_ASSERT_JMAYBE;
4182 if (o->op_type == OP_LIST) {
4184 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4185 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4190 PERL_STATIC_INLINE OP *
4191 S_op_std_init(pTHX_ OP *o)
4193 I32 type = o->op_type;
4195 PERL_ARGS_ASSERT_OP_STD_INIT;
4197 if (PL_opargs[type] & OA_RETSCALAR)
4199 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4200 o->op_targ = pad_alloc(type, SVs_PADTMP);
4205 PERL_STATIC_INLINE OP *
4206 S_op_integerize(pTHX_ OP *o)
4208 I32 type = o->op_type;
4210 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4212 /* integerize op. */
4213 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4216 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4219 if (type == OP_NEGATE)
4220 /* XXX might want a ck_negate() for this */
4221 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4227 S_fold_constants(pTHX_ OP *o)
4232 VOL I32 type = o->op_type;
4238 SV * const oldwarnhook = PL_warnhook;
4239 SV * const olddiehook = PL_diehook;
4241 U8 oldwarn = PL_dowarn;
4244 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4246 if (!(PL_opargs[type] & OA_FOLDCONST))
4255 #ifdef USE_LOCALE_CTYPE
4256 if (IN_LC_COMPILETIME(LC_CTYPE))
4265 #ifdef USE_LOCALE_COLLATE
4266 if (IN_LC_COMPILETIME(LC_COLLATE))
4271 /* XXX what about the numeric ops? */
4272 #ifdef USE_LOCALE_NUMERIC
4273 if (IN_LC_COMPILETIME(LC_NUMERIC))
4278 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4279 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4282 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4283 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4285 const char *s = SvPVX_const(sv);
4286 while (s < SvEND(sv)) {
4287 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4294 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4297 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4298 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4302 if (PL_parser && PL_parser->error_count)
4303 goto nope; /* Don't try to run w/ errors */
4305 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4306 const OPCODE type = curop->op_type;
4307 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4309 type != OP_SCALAR &&
4311 type != OP_PUSHMARK)
4317 curop = LINKLIST(o);
4318 old_next = o->op_next;
4322 oldscope = PL_scopestack_ix;
4323 create_eval_scope(G_FAKINGEVAL);
4325 /* Verify that we don't need to save it: */
4326 assert(PL_curcop == &PL_compiling);
4327 StructCopy(&PL_compiling, ¬_compiling, COP);
4328 PL_curcop = ¬_compiling;
4329 /* The above ensures that we run with all the correct hints of the
4330 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4331 assert(IN_PERL_RUNTIME);
4332 PL_warnhook = PERL_WARNHOOK_FATAL;
4336 /* Effective $^W=1. */
4337 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4338 PL_dowarn |= G_WARN_ON;
4343 sv = *(PL_stack_sp--);
4344 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4345 pad_swipe(o->op_targ, FALSE);
4347 else if (SvTEMP(sv)) { /* grab mortal temp? */
4348 SvREFCNT_inc_simple_void(sv);
4351 else { assert(SvIMMORTAL(sv)); }
4354 /* Something tried to die. Abandon constant folding. */
4355 /* Pretend the error never happened. */
4357 o->op_next = old_next;
4361 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4362 PL_warnhook = oldwarnhook;
4363 PL_diehook = olddiehook;
4364 /* XXX note that this croak may fail as we've already blown away
4365 * the stack - eg any nested evals */
4366 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4369 PL_dowarn = oldwarn;
4370 PL_warnhook = oldwarnhook;
4371 PL_diehook = olddiehook;
4372 PL_curcop = &PL_compiling;
4374 if (PL_scopestack_ix > oldscope)
4375 delete_eval_scope();
4380 /* OP_STRINGIFY and constant folding are used to implement qq.
4381 Here the constant folding is an implementation detail that we
4382 want to hide. If the stringify op is itself already marked
4383 folded, however, then it is actually a folded join. */
4384 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4389 else if (!SvIMMORTAL(sv)) {
4393 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4394 if (!is_stringify) newop->op_folded = 1;
4402 S_gen_constant_list(pTHX_ OP *o)
4406 const SSize_t oldtmps_floor = PL_tmps_floor;
4411 if (PL_parser && PL_parser->error_count)
4412 return o; /* Don't attempt to run with errors */
4414 curop = LINKLIST(o);
4417 S_prune_chain_head(&curop);
4419 Perl_pp_pushmark(aTHX);
4422 assert (!(curop->op_flags & OPf_SPECIAL));
4423 assert(curop->op_type == OP_RANGE);
4424 Perl_pp_anonlist(aTHX);
4425 PL_tmps_floor = oldtmps_floor;
4427 OpTYPE_set(o, OP_RV2AV);
4428 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4429 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4430 o->op_opt = 0; /* needs to be revisited in rpeep() */
4431 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4433 /* replace subtree with an OP_CONST */
4434 curop = ((UNOP*)o)->op_first;
4435 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4438 if (AvFILLp(av) != -1)
4439 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4442 SvREADONLY_on(*svp);
4449 =head1 Optree Manipulation Functions
4452 /* List constructors */
4455 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4457 Append an item to the list of ops contained directly within a list-type
4458 op, returning the lengthened list. I<first> is the list-type op,
4459 and I<last> is the op to append to the list. I<optype> specifies the
4460 intended opcode for the list. If I<first> is not already a list of the
4461 right type, it will be upgraded into one. If either I<first> or I<last>
4462 is null, the other is returned unchanged.
4468 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4476 if (first->op_type != (unsigned)type
4477 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4479 return newLISTOP(type, 0, first, last);
4482 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4483 first->op_flags |= OPf_KIDS;
4488 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4490 Concatenate the lists of ops contained directly within two list-type ops,
4491 returning the combined list. I<first> and I<last> are the list-type ops
4492 to concatenate. I<optype> specifies the intended opcode for the list.
4493 If either I<first> or I<last> is not already a list of the right type,
4494 it will be upgraded into one. If either I<first> or I<last> is null,
4495 the other is returned unchanged.
4501 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4509 if (first->op_type != (unsigned)type)
4510 return op_prepend_elem(type, first, last);
4512 if (last->op_type != (unsigned)type)
4513 return op_append_elem(type, first, last);
4515 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4516 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4517 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4518 first->op_flags |= (last->op_flags & OPf_KIDS);
4520 S_op_destroy(aTHX_ last);
4526 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4528 Prepend an item to the list of ops contained directly within a list-type
4529 op, returning the lengthened list. I<first> is the op to prepend to the
4530 list, and I<last> is the list-type op. I<optype> specifies the intended
4531 opcode for the list. If I<last> is not already a list of the right type,
4532 it will be upgraded into one. If either I<first> or I<last> is null,
4533 the other is returned unchanged.
4539 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4547 if (last->op_type == (unsigned)type) {
4548 if (type == OP_LIST) { /* already a PUSHMARK there */
4549 /* insert 'first' after pushmark */
4550 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4551 if (!(first->op_flags & OPf_PARENS))
4552 last->op_flags &= ~OPf_PARENS;
4555 op_sibling_splice(last, NULL, 0, first);
4556 last->op_flags |= OPf_KIDS;
4560 return newLISTOP(type, 0, first, last);
4564 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4566 Converts I<o> into a list op if it is not one already, and then converts it
4567 into the specified I<type>, calling its check function, allocating a target if
4568 it needs one, and folding constants.
4570 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4571 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4572 C<op_convert_list> to make it the right type.
4578 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4581 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4582 if (!o || o->op_type != OP_LIST)
4583 o = force_list(o, 0);
4586 o->op_flags &= ~OPf_WANT;
4587 o->op_private &= ~OPpLVAL_INTRO;
4590 if (!(PL_opargs[type] & OA_MARK))
4591 op_null(cLISTOPo->op_first);
4593 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4594 if (kid2 && kid2->op_type == OP_COREARGS) {
4595 op_null(cLISTOPo->op_first);
4596 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4600 OpTYPE_set(o, type);
4601 o->op_flags |= flags;
4602 if (flags & OPf_FOLDED)
4605 o = CHECKOP(type, o);
4606 if (o->op_type != (unsigned)type)
4609 return fold_constants(op_integerize(op_std_init(o)));
4616 =head1 Optree construction
4618 =for apidoc Am|OP *|newNULLLIST
4620 Constructs, checks, and returns a new C<stub> op, which represents an
4621 empty list expression.
4627 Perl_newNULLLIST(pTHX)
4629 return newOP(OP_STUB, 0);
4632 /* promote o and any siblings to be a list if its not already; i.e.
4640 * pushmark - o - A - B
4642 * If nullit it true, the list op is nulled.
4646 S_force_list(pTHX_ OP *o, bool nullit)
4648 if (!o || o->op_type != OP_LIST) {
4651 /* manually detach any siblings then add them back later */
4652 rest = OpSIBLING(o);
4653 OpLASTSIB_set(o, NULL);
4655 o = newLISTOP(OP_LIST, 0, o, NULL);
4657 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4665 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4667 Constructs, checks, and returns an op of any list type. I<type> is
4668 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4669 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
4670 supply up to two ops to be direct children of the list op; they are
4671 consumed by this function and become part of the constructed op tree.
4673 For most list operators, the check function expects all the kid ops to be
4674 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4675 appropriate. What you want to do in that case is create an op of type
4676 OP_LIST, append more children to it, and then call L</op_convert_list>.
4677 See L</op_convert_list> for more information.
4684 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4689 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4690 || type == OP_CUSTOM);
4692 NewOp(1101, listop, 1, LISTOP);
4694 OpTYPE_set(listop, type);
4697 listop->op_flags = (U8)flags;
4701 else if (!first && last)
4704 OpMORESIB_set(first, last);
4705 listop->op_first = first;
4706 listop->op_last = last;
4707 if (type == OP_LIST) {
4708 OP* const pushop = newOP(OP_PUSHMARK, 0);
4709 OpMORESIB_set(pushop, first);
4710 listop->op_first = pushop;
4711 listop->op_flags |= OPf_KIDS;
4713 listop->op_last = pushop;
4715 if (listop->op_last)
4716 OpLASTSIB_set(listop->op_last, (OP*)listop);
4718 return CHECKOP(type, listop);
4722 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4724 Constructs, checks, and returns an op of any base type (any type that
4725 has no extra fields). I<type> is the opcode. I<flags> gives the
4726 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4733 Perl_newOP(pTHX_ I32 type, I32 flags)
4738 if (type == -OP_ENTEREVAL) {
4739 type = OP_ENTEREVAL;
4740 flags |= OPpEVAL_BYTES<<8;
4743 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4744 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4745 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4746 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4748 NewOp(1101, o, 1, OP);
4749 OpTYPE_set(o, type);
4750 o->op_flags = (U8)flags;
4753 o->op_private = (U8)(0 | (flags >> 8));
4754 if (PL_opargs[type] & OA_RETSCALAR)
4756 if (PL_opargs[type] & OA_TARGET)
4757 o->op_targ = pad_alloc(type, SVs_PADTMP);
4758 return CHECKOP(type, o);
4762 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4764 Constructs, checks, and returns an op of any unary type. I<type> is
4765 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4766 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4767 bits, the eight bits of C<op_private>, except that the bit with value 1
4768 is automatically set. I<first> supplies an optional op to be the direct
4769 child of the unary op; it is consumed by this function and become part
4770 of the constructed op tree.
4776 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4781 if (type == -OP_ENTEREVAL) {
4782 type = OP_ENTEREVAL;
4783 flags |= OPpEVAL_BYTES<<8;
4786 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4787 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4788 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4789 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4790 || type == OP_SASSIGN
4791 || type == OP_ENTERTRY
4792 || type == OP_CUSTOM
4793 || type == OP_NULL );
4796 first = newOP(OP_STUB, 0);
4797 if (PL_opargs[type] & OA_MARK)
4798 first = force_list(first, 1);
4800 NewOp(1101, unop, 1, UNOP);
4801 OpTYPE_set(unop, type);
4802 unop->op_first = first;
4803 unop->op_flags = (U8)(flags | OPf_KIDS);
4804 unop->op_private = (U8)(1 | (flags >> 8));
4806 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4807 OpLASTSIB_set(first, (OP*)unop);
4809 unop = (UNOP*) CHECKOP(type, unop);
4813 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4817 =for apidoc newUNOP_AUX
4819 Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux
4826 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4831 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4832 || type == OP_CUSTOM);
4834 NewOp(1101, unop, 1, UNOP_AUX);
4835 unop->op_type = (OPCODE)type;
4836 unop->op_ppaddr = PL_ppaddr[type];
4837 unop->op_first = first;
4838 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4839 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4842 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4843 OpLASTSIB_set(first, (OP*)unop);
4845 unop = (UNOP_AUX*) CHECKOP(type, unop);
4847 return op_std_init((OP *) unop);
4851 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4853 Constructs, checks, and returns an op of method type with a method name
4854 evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
4855 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4856 and, shifted up eight bits, the eight bits of C<op_private>, except that
4857 the bit with value 1 is automatically set. I<dynamic_meth> supplies an
4858 op which evaluates method name; it is consumed by this function and
4859 become part of the constructed op tree.
4860 Supported optypes: OP_METHOD.
4866 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4870 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4871 || type == OP_CUSTOM);
4873 NewOp(1101, methop, 1, METHOP);
4875 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4876 methop->op_flags = (U8)(flags | OPf_KIDS);
4877 methop->op_u.op_first = dynamic_meth;
4878 methop->op_private = (U8)(1 | (flags >> 8));
4880 if (!OpHAS_SIBLING(dynamic_meth))
4881 OpLASTSIB_set(dynamic_meth, (OP*)methop);
4885 methop->op_flags = (U8)(flags & ~OPf_KIDS);
4886 methop->op_u.op_meth_sv = const_meth;
4887 methop->op_private = (U8)(0 | (flags >> 8));
4888 methop->op_next = (OP*)methop;
4892 methop->op_rclass_targ = 0;
4894 methop->op_rclass_sv = NULL;
4897 OpTYPE_set(methop, type);
4898 return CHECKOP(type, methop);
4902 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4903 PERL_ARGS_ASSERT_NEWMETHOP;
4904 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4908 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4910 Constructs, checks, and returns an op of method type with a constant
4911 method name. I<type> is the opcode. I<flags> gives the eight bits of
4912 C<op_flags>, and, shifted up eight bits, the eight bits of
4913 C<op_private>. I<const_meth> supplies a constant method name;
4914 it must be a shared COW string.
4915 Supported optypes: OP_METHOD_NAMED.
4921 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4922 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4923 return newMETHOP_internal(type, flags, NULL, const_meth);
4927 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4929 Constructs, checks, and returns an op of any binary type. I<type>
4930 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4931 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4932 the eight bits of C<op_private>, except that the bit with value 1 or
4933 2 is automatically set as required. I<first> and I<last> supply up to
4934 two ops to be the direct children of the binary op; they are consumed
4935 by this function and become part of the constructed op tree.
4941 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4946 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4947 || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
4949 NewOp(1101, binop, 1, BINOP);
4952 first = newOP(OP_NULL, 0);
4954 OpTYPE_set(binop, type);
4955 binop->op_first = first;
4956 binop->op_flags = (U8)(flags | OPf_KIDS);
4959 binop->op_private = (U8)(1 | (flags >> 8));
4962 binop->op_private = (U8)(2 | (flags >> 8));
4963 OpMORESIB_set(first, last);
4966 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
4967 OpLASTSIB_set(last, (OP*)binop);
4969 binop->op_last = OpSIBLING(binop->op_first);
4971 OpLASTSIB_set(binop->op_last, (OP*)binop);
4973 binop = (BINOP*)CHECKOP(type, binop);
4974 if (binop->op_next || binop->op_type != (OPCODE)type)
4977 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4980 static int uvcompare(const void *a, const void *b)
4981 __attribute__nonnull__(1)
4982 __attribute__nonnull__(2)
4983 __attribute__pure__;
4984 static int uvcompare(const void *a, const void *b)
4986 if (*((const UV *)a) < (*(const UV *)b))
4988 if (*((const UV *)a) > (*(const UV *)b))
4990 if (*((const UV *)a+1) < (*(const UV *)b+1))
4992 if (*((const UV *)a+1) > (*(const UV *)b+1))
4998 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5000 SV * const tstr = ((SVOP*)expr)->op_sv;
5002 ((SVOP*)repl)->op_sv;
5005 const U8 *t = (U8*)SvPV_const(tstr, tlen);
5006 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5012 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5013 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5014 I32 del = o->op_private & OPpTRANS_DELETE;
5017 PERL_ARGS_ASSERT_PMTRANS;
5019 PL_hints |= HINT_BLOCK_SCOPE;
5022 o->op_private |= OPpTRANS_FROM_UTF;
5025 o->op_private |= OPpTRANS_TO_UTF;
5027 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5028 SV* const listsv = newSVpvs("# comment\n");
5030 const U8* tend = t + tlen;
5031 const U8* rend = r + rlen;
5047 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5048 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5051 const U32 flags = UTF8_ALLOW_DEFAULT;
5055 t = tsave = bytes_to_utf8(t, &len);
5058 if (!to_utf && rlen) {
5060 r = rsave = bytes_to_utf8(r, &len);
5064 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5065 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5069 U8 tmpbuf[UTF8_MAXBYTES+1];
5072 Newx(cp, 2*tlen, UV);
5074 transv = newSVpvs("");
5076 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5078 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5080 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5084 cp[2*i+1] = cp[2*i];
5088 qsort(cp, i, 2*sizeof(UV), uvcompare);
5089 for (j = 0; j < i; j++) {
5091 diff = val - nextmin;
5093 t = uvchr_to_utf8(tmpbuf,nextmin);
5094 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5096 U8 range_mark = ILLEGAL_UTF8_BYTE;
5097 t = uvchr_to_utf8(tmpbuf, val - 1);
5098 sv_catpvn(transv, (char *)&range_mark, 1);
5099 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5106 t = uvchr_to_utf8(tmpbuf,nextmin);
5107 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5109 U8 range_mark = ILLEGAL_UTF8_BYTE;
5110 sv_catpvn(transv, (char *)&range_mark, 1);
5112 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5113 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5114 t = (const U8*)SvPVX_const(transv);
5115 tlen = SvCUR(transv);
5119 else if (!rlen && !del) {
5120 r = t; rlen = tlen; rend = tend;
5123 if ((!rlen && !del) || t == r ||
5124 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5126 o->op_private |= OPpTRANS_IDENTICAL;
5130 while (t < tend || tfirst <= tlast) {
5131 /* see if we need more "t" chars */
5132 if (tfirst > tlast) {
5133 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5135 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5137 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5144 /* now see if we need more "r" chars */
5145 if (rfirst > rlast) {
5147 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5149 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5151 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5160 rfirst = rlast = 0xffffffff;
5164 /* now see which range will peter our first, if either. */
5165 tdiff = tlast - tfirst;
5166 rdiff = rlast - rfirst;
5167 tcount += tdiff + 1;
5168 rcount += rdiff + 1;
5175 if (rfirst == 0xffffffff) {
5176 diff = tdiff; /* oops, pretend rdiff is infinite */
5178 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5179 (long)tfirst, (long)tlast);
5181 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5185 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5186 (long)tfirst, (long)(tfirst + diff),
5189 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5190 (long)tfirst, (long)rfirst);
5192 if (rfirst + diff > max)
5193 max = rfirst + diff;
5195 grows = (tfirst < rfirst &&
5196 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
5208 else if (max > 0xff)
5213 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5215 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5216 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5217 PAD_SETSV(cPADOPo->op_padix, swash);
5219 SvREADONLY_on(swash);
5221 cSVOPo->op_sv = swash;
5223 SvREFCNT_dec(listsv);
5224 SvREFCNT_dec(transv);
5226 if (!del && havefinal && rlen)
5227 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5228 newSVuv((UV)final), 0);
5237 else if (rlast == 0xffffffff)
5243 tbl = (short*)PerlMemShared_calloc(
5244 (o->op_private & OPpTRANS_COMPLEMENT) &&
5245 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5247 cPVOPo->op_pv = (char*)tbl;
5249 for (i = 0; i < (I32)tlen; i++)
5251 for (i = 0, j = 0; i < 256; i++) {
5253 if (j >= (I32)rlen) {
5262 if (i < 128 && r[j] >= 128)
5272 o->op_private |= OPpTRANS_IDENTICAL;
5274 else if (j >= (I32)rlen)
5279 PerlMemShared_realloc(tbl,
5280 (0x101+rlen-j) * sizeof(short));
5281 cPVOPo->op_pv = (char*)tbl;
5283 tbl[0x100] = (short)(rlen - j);
5284 for (i=0; i < (I32)rlen - j; i++)
5285 tbl[0x101+i] = r[j+i];
5289 if (!rlen && !del) {
5292 o->op_private |= OPpTRANS_IDENTICAL;
5294 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5295 o->op_private |= OPpTRANS_IDENTICAL;
5297 for (i = 0; i < 256; i++)
5299 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5300 if (j >= (I32)rlen) {
5302 if (tbl[t[i]] == -1)
5308 if (tbl[t[i]] == -1) {
5309 if (t[i] < 128 && r[j] >= 128)
5317 if(del && rlen == tlen) {
5318 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5319 } else if(rlen > tlen && !complement) {
5320 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5324 o->op_private |= OPpTRANS_GROWS;
5332 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5334 Constructs, checks, and returns an op of any pattern matching type.
5335 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
5336 and, shifted up eight bits, the eight bits of C<op_private>.
5342 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5347 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5348 || type == OP_CUSTOM);
5350 NewOp(1101, pmop, 1, PMOP);
5351 OpTYPE_set(pmop, type);
5352 pmop->op_flags = (U8)flags;
5353 pmop->op_private = (U8)(0 | (flags >> 8));
5354 if (PL_opargs[type] & OA_RETSCALAR)
5357 if (PL_hints & HINT_RE_TAINT)
5358 pmop->op_pmflags |= PMf_RETAINT;
5359 #ifdef USE_LOCALE_CTYPE
5360 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5361 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5366 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5368 if (PL_hints & HINT_RE_FLAGS) {
5369 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5370 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5372 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5373 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5374 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5376 if (reflags && SvOK(reflags)) {
5377 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5383 assert(SvPOK(PL_regex_pad[0]));
5384 if (SvCUR(PL_regex_pad[0])) {
5385 /* Pop off the "packed" IV from the end. */
5386 SV *const repointer_list = PL_regex_pad[0];
5387 const char *p = SvEND(repointer_list) - sizeof(IV);
5388 const IV offset = *((IV*)p);
5390 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5392 SvEND_set(repointer_list, p);
5394 pmop->op_pmoffset = offset;
5395 /* This slot should be free, so assert this: */
5396 assert(PL_regex_pad[offset] == &PL_sv_undef);
5398 SV * const repointer = &PL_sv_undef;
5399 av_push(PL_regex_padav, repointer);
5400 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5401 PL_regex_pad = AvARRAY(PL_regex_padav);
5405 return CHECKOP(type, pmop);
5413 /* Any pad names in scope are potentially lvalues. */
5414 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5415 PADNAME *pn = PAD_COMPNAME_SV(i);
5416 if (!pn || !PadnameLEN(pn))
5418 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5419 S_mark_padname_lvalue(aTHX_ pn);
5423 /* Given some sort of match op o, and an expression expr containing a
5424 * pattern, either compile expr into a regex and attach it to o (if it's
5425 * constant), or convert expr into a runtime regcomp op sequence (if it's
5428 * isreg indicates that the pattern is part of a regex construct, eg
5429 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5430 * split "pattern", which aren't. In the former case, expr will be a list
5431 * if the pattern contains more than one term (eg /a$b/).
5433 * When the pattern has been compiled within a new anon CV (for
5434 * qr/(?{...})/ ), then floor indicates the savestack level just before
5435 * the new sub was created
5439 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5443 I32 repl_has_vars = 0;
5444 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5445 bool is_compiletime;
5448 PERL_ARGS_ASSERT_PMRUNTIME;
5451 return pmtrans(o, expr, repl);
5454 /* find whether we have any runtime or code elements;
5455 * at the same time, temporarily set the op_next of each DO block;
5456 * then when we LINKLIST, this will cause the DO blocks to be excluded
5457 * from the op_next chain (and from having LINKLIST recursively
5458 * applied to them). We fix up the DOs specially later */
5462 if (expr->op_type == OP_LIST) {
5464 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5465 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5467 assert(!o->op_next);
5468 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5469 assert(PL_parser && PL_parser->error_count);
5470 /* This can happen with qr/ (?{(^{})/. Just fake up
5471 the op we were expecting to see, to avoid crashing
5473 op_sibling_splice(expr, o, 0,
5474 newSVOP(OP_CONST, 0, &PL_sv_no));
5476 o->op_next = OpSIBLING(o);
5478 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5482 else if (expr->op_type != OP_CONST)
5487 /* fix up DO blocks; treat each one as a separate little sub;
5488 * also, mark any arrays as LIST/REF */
5490 if (expr->op_type == OP_LIST) {
5492 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5494 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5495 assert( !(o->op_flags & OPf_WANT));
5496 /* push the array rather than its contents. The regex
5497 * engine will retrieve and join the elements later */
5498 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5502 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5504 o->op_next = NULL; /* undo temporary hack from above */
5507 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5508 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5510 assert(leaveop->op_first->op_type == OP_ENTER);
5511 assert(OpHAS_SIBLING(leaveop->op_first));
5512 o->op_next = OpSIBLING(leaveop->op_first);
5514 assert(leaveop->op_flags & OPf_KIDS);
5515 assert(leaveop->op_last->op_next == (OP*)leaveop);
5516 leaveop->op_next = NULL; /* stop on last op */
5517 op_null((OP*)leaveop);
5521 OP *scope = cLISTOPo->op_first;
5522 assert(scope->op_type == OP_SCOPE);
5523 assert(scope->op_flags & OPf_KIDS);
5524 scope->op_next = NULL; /* stop on last op */
5527 /* have to peep the DOs individually as we've removed it from
5528 * the op_next chain */
5530 S_prune_chain_head(&(o->op_next));
5532 /* runtime finalizes as part of finalizing whole tree */
5536 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5537 assert( !(expr->op_flags & OPf_WANT));
5538 /* push the array rather than its contents. The regex
5539 * engine will retrieve and join the elements later */
5540 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5543 PL_hints |= HINT_BLOCK_SCOPE;
5545 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5547 if (is_compiletime) {
5548 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5549 regexp_engine const *eng = current_re_engine();
5551 if (o->op_flags & OPf_SPECIAL)
5552 rx_flags |= RXf_SPLIT;
5554 if (!has_code || !eng->op_comp) {
5555 /* compile-time simple constant pattern */
5557 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5558 /* whoops! we guessed that a qr// had a code block, but we
5559 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5560 * that isn't required now. Note that we have to be pretty
5561 * confident that nothing used that CV's pad while the
5562 * regex was parsed, except maybe op targets for \Q etc.
5563 * If there were any op targets, though, they should have
5564 * been stolen by constant folding.
5568 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5569 while (++i <= AvFILLp(PL_comppad)) {
5570 assert(!PL_curpad[i]);
5573 /* But we know that one op is using this CV's slab. */
5574 cv_forget_slab(PL_compcv);
5576 pm->op_pmflags &= ~PMf_HAS_CV;
5581 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5582 rx_flags, pm->op_pmflags)
5583 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5584 rx_flags, pm->op_pmflags)
5589 /* compile-time pattern that includes literal code blocks */
5590 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5593 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5596 if (pm->op_pmflags & PMf_HAS_CV) {
5598 /* this QR op (and the anon sub we embed it in) is never
5599 * actually executed. It's just a placeholder where we can
5600 * squirrel away expr in op_code_list without the peephole
5601 * optimiser etc processing it for a second time */
5602 OP *qr = newPMOP(OP_QR, 0);
5603 ((PMOP*)qr)->op_code_list = expr;
5605 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5606 SvREFCNT_inc_simple_void(PL_compcv);
5607 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5608 ReANY(re)->qr_anoncv = cv;
5610 /* attach the anon CV to the pad so that
5611 * pad_fixup_inner_anons() can find it */
5612 (void)pad_add_anon(cv, o->op_type);
5613 SvREFCNT_inc_simple_void(cv);
5616 pm->op_code_list = expr;
5621 /* runtime pattern: build chain of regcomp etc ops */
5623 PADOFFSET cv_targ = 0;
5625 reglist = isreg && expr->op_type == OP_LIST;
5630 pm->op_code_list = expr;
5631 /* don't free op_code_list; its ops are embedded elsewhere too */
5632 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5635 if (o->op_flags & OPf_SPECIAL)
5636 pm->op_pmflags |= PMf_SPLIT;
5638 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5639 * to allow its op_next to be pointed past the regcomp and
5640 * preceding stacking ops;
5641 * OP_REGCRESET is there to reset taint before executing the
5643 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5644 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5646 if (pm->op_pmflags & PMf_HAS_CV) {
5647 /* we have a runtime qr with literal code. This means
5648 * that the qr// has been wrapped in a new CV, which
5649 * means that runtime consts, vars etc will have been compiled
5650 * against a new pad. So... we need to execute those ops
5651 * within the environment of the new CV. So wrap them in a call
5652 * to a new anon sub. i.e. for
5656 * we build an anon sub that looks like
5658 * sub { "a", $b, '(?{...})' }
5660 * and call it, passing the returned list to regcomp.
5661 * Or to put it another way, the list of ops that get executed
5665 * ------ -------------------
5666 * pushmark (for regcomp)
5667 * pushmark (for entersub)
5671 * regcreset regcreset
5673 * const("a") const("a")
5675 * const("(?{...})") const("(?{...})")
5680 SvREFCNT_inc_simple_void(PL_compcv);
5681 CvLVALUE_on(PL_compcv);
5682 /* these lines are just an unrolled newANONATTRSUB */
5683 expr = newSVOP(OP_ANONCODE, 0,
5684 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5685 cv_targ = expr->op_targ;
5686 expr = newUNOP(OP_REFGEN, 0, expr);
5688 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5691 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5692 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5693 | (reglist ? OPf_STACKED : 0);
5694 rcop->op_targ = cv_targ;
5696 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5697 if (PL_hints & HINT_RE_EVAL)
5698 S_set_haseval(aTHX);
5700 /* establish postfix order */
5701 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5703 rcop->op_next = expr;
5704 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5707 rcop->op_next = LINKLIST(expr);
5708 expr->op_next = (OP*)rcop;
5711 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5717 /* If we are looking at s//.../e with a single statement, get past
5718 the implicit do{}. */
5719 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5720 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5721 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5724 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5725 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5726 && !OpHAS_SIBLING(sib))
5729 if (curop->op_type == OP_CONST)
5731 else if (( (curop->op_type == OP_RV2SV ||
5732 curop->op_type == OP_RV2AV ||
5733 curop->op_type == OP_RV2HV ||
5734 curop->op_type == OP_RV2GV)
5735 && cUNOPx(curop)->op_first
5736 && cUNOPx(curop)->op_first->op_type == OP_GV )
5737 || curop->op_type == OP_PADSV
5738 || curop->op_type == OP_PADAV
5739 || curop->op_type == OP_PADHV
5740 || curop->op_type == OP_PADANY) {
5748 || !RX_PRELEN(PM_GETRE(pm))
5749 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5751 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5752 op_prepend_elem(o->op_type, scalar(repl), o);
5755 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5756 rcop->op_private = 1;
5758 /* establish postfix order */
5759 rcop->op_next = LINKLIST(repl);
5760 repl->op_next = (OP*)rcop;
5762 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5763 assert(!(pm->op_pmflags & PMf_ONCE));
5764 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5773 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5775 Constructs, checks, and returns an op of any type that involves an
5776 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
5777 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
5778 takes ownership of one reference to it.
5784 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5789 PERL_ARGS_ASSERT_NEWSVOP;
5791 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5792 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5793 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5794 || type == OP_CUSTOM);
5796 NewOp(1101, svop, 1, SVOP);
5797 OpTYPE_set(svop, type);
5799 svop->op_next = (OP*)svop;
5800 svop->op_flags = (U8)flags;
5801 svop->op_private = (U8)(0 | (flags >> 8));
5802 if (PL_opargs[type] & OA_RETSCALAR)
5804 if (PL_opargs[type] & OA_TARGET)
5805 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5806 return CHECKOP(type, svop);
5810 =for apidoc Am|OP *|newDEFSVOP|
5812 Constructs and returns an op to access C<$_>, either as a lexical
5813 variable (if declared as C<my $_>) in the current scope, or the
5820 Perl_newDEFSVOP(pTHX)
5822 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5823 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5824 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5827 OP * const o = newOP(OP_PADSV, 0);
5828 o->op_targ = offset;
5836 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5838 Constructs, checks, and returns an op of any type that involves a
5839 reference to a pad element. I<type> is the opcode. I<flags> gives the
5840 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5841 is populated with I<sv>; this function takes ownership of one reference
5844 This function only exists if Perl has been compiled to use ithreads.
5850 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5855 PERL_ARGS_ASSERT_NEWPADOP;
5857 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5858 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5859 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5860 || type == OP_CUSTOM);
5862 NewOp(1101, padop, 1, PADOP);
5863 OpTYPE_set(padop, type);
5865 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5866 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5867 PAD_SETSV(padop->op_padix, sv);
5869 padop->op_next = (OP*)padop;
5870 padop->op_flags = (U8)flags;
5871 if (PL_opargs[type] & OA_RETSCALAR)
5873 if (PL_opargs[type] & OA_TARGET)
5874 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5875 return CHECKOP(type, padop);
5878 #endif /* USE_ITHREADS */
5881 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5883 Constructs, checks, and returns an op of any type that involves an
5884 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
5885 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
5886 reference; calling this function does not transfer ownership of any
5893 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5895 PERL_ARGS_ASSERT_NEWGVOP;
5898 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5900 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5905 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5907 Constructs, checks, and returns an op of any type that involves an
5908 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
5909 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
5910 must have been allocated using C<PerlMemShared_malloc>; the memory will
5911 be freed when the op is destroyed.
5917 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5920 const bool utf8 = cBOOL(flags & SVf_UTF8);
5925 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5926 || type == OP_RUNCV || type == OP_CUSTOM
5927 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5929 NewOp(1101, pvop, 1, PVOP);
5930 OpTYPE_set(pvop, type);
5932 pvop->op_next = (OP*)pvop;
5933 pvop->op_flags = (U8)flags;
5934 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5935 if (PL_opargs[type] & OA_RETSCALAR)
5937 if (PL_opargs[type] & OA_TARGET)
5938 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5939 return CHECKOP(type, pvop);
5943 Perl_package(pTHX_ OP *o)
5945 SV *const sv = cSVOPo->op_sv;
5947 PERL_ARGS_ASSERT_PACKAGE;
5949 SAVEGENERICSV(PL_curstash);
5950 save_item(PL_curstname);
5952 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5954 sv_setsv(PL_curstname, sv);
5956 PL_hints |= HINT_BLOCK_SCOPE;
5957 PL_parser->copline = NOLINE;
5963 Perl_package_version( pTHX_ OP *v )
5965 U32 savehints = PL_hints;
5966 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5967 PL_hints &= ~HINT_STRICT_VARS;
5968 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5969 PL_hints = savehints;
5974 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5979 SV *use_version = NULL;
5981 PERL_ARGS_ASSERT_UTILIZE;
5983 if (idop->op_type != OP_CONST)
5984 Perl_croak(aTHX_ "Module name must be constant");
5989 SV * const vesv = ((SVOP*)version)->op_sv;
5991 if (!arg && !SvNIOKp(vesv)) {
5998 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5999 Perl_croak(aTHX_ "Version number must be a constant number");
6001 /* Make copy of idop so we don't free it twice */
6002 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6004 /* Fake up a method call to VERSION */
6005 meth = newSVpvs_share("VERSION");
6006 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6007 op_append_elem(OP_LIST,
6008 op_prepend_elem(OP_LIST, pack, version),
6009 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6013 /* Fake up an import/unimport */
6014 if (arg && arg->op_type == OP_STUB) {
6015 imop = arg; /* no import on explicit () */
6017 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6018 imop = NULL; /* use 5.0; */
6020 use_version = ((SVOP*)idop)->op_sv;
6022 idop->op_private |= OPpCONST_NOVER;
6027 /* Make copy of idop so we don't free it twice */
6028 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6030 /* Fake up a method call to import/unimport */
6032 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6033 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6034 op_append_elem(OP_LIST,
6035 op_prepend_elem(OP_LIST, pack, arg),
6036 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6040 /* Fake up the BEGIN {}, which does its thing immediately. */
6042 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6045 op_append_elem(OP_LINESEQ,
6046 op_append_elem(OP_LINESEQ,
6047 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6048 newSTATEOP(0, NULL, veop)),
6049 newSTATEOP(0, NULL, imop) ));
6053 * feature bundle that corresponds to the required version. */
6054 use_version = sv_2mortal(new_version(use_version));
6055 S_enable_feature_bundle(aTHX_ use_version);
6057 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6058 if (vcmp(use_version,
6059 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6060 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6061 PL_hints |= HINT_STRICT_REFS;
6062 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6063 PL_hints |= HINT_STRICT_SUBS;
6064 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6065 PL_hints |= HINT_STRICT_VARS;
6067 /* otherwise they are off */
6069 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6070 PL_hints &= ~HINT_STRICT_REFS;
6071 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6072 PL_hints &= ~HINT_STRICT_SUBS;
6073 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6074 PL_hints &= ~HINT_STRICT_VARS;
6078 /* The "did you use incorrect case?" warning used to be here.
6079 * The problem is that on case-insensitive filesystems one
6080 * might get false positives for "use" (and "require"):
6081 * "use Strict" or "require CARP" will work. This causes
6082 * portability problems for the script: in case-strict
6083 * filesystems the script will stop working.
6085 * The "incorrect case" warning checked whether "use Foo"
6086 * imported "Foo" to your namespace, but that is wrong, too:
6087 * there is no requirement nor promise in the language that
6088 * a Foo.pm should or would contain anything in package "Foo".
6090 * There is very little Configure-wise that can be done, either:
6091 * the case-sensitivity of the build filesystem of Perl does not
6092 * help in guessing the case-sensitivity of the runtime environment.
6095 PL_hints |= HINT_BLOCK_SCOPE;
6096 PL_parser->copline = NOLINE;
6097 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6101 =head1 Embedding Functions
6103 =for apidoc load_module
6105 Loads the module whose name is pointed to by the string part of name.
6106 Note that the actual module name, not its filename, should be given.
6107 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
6108 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
6109 (or 0 for no flags). ver, if specified
6110 and not NULL, provides version semantics
6111 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
6112 arguments can be used to specify arguments to the module's import()
6113 method, similar to C<use Foo::Bar VERSION LIST>. They must be
6114 terminated with a final NULL pointer. Note that this list can only
6115 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
6116 Otherwise at least a single NULL pointer to designate the default
6117 import list is required.
6119 The reference count for each specified C<SV*> parameter is decremented.
6124 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6128 PERL_ARGS_ASSERT_LOAD_MODULE;
6130 va_start(args, ver);
6131 vload_module(flags, name, ver, &args);
6135 #ifdef PERL_IMPLICIT_CONTEXT
6137 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6141 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6142 va_start(args, ver);
6143 vload_module(flags, name, ver, &args);
6149 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6152 OP * const modname = newSVOP(OP_CONST, 0, name);
6154 PERL_ARGS_ASSERT_VLOAD_MODULE;
6156 modname->op_private |= OPpCONST_BARE;
6158 veop = newSVOP(OP_CONST, 0, ver);
6162 if (flags & PERL_LOADMOD_NOIMPORT) {
6163 imop = sawparens(newNULLLIST());
6165 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6166 imop = va_arg(*args, OP*);
6171 sv = va_arg(*args, SV*);
6173 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6174 sv = va_arg(*args, SV*);
6178 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6179 * that it has a PL_parser to play with while doing that, and also
6180 * that it doesn't mess with any existing parser, by creating a tmp
6181 * new parser with lex_start(). This won't actually be used for much,
6182 * since pp_require() will create another parser for the real work.
6183 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6186 SAVEVPTR(PL_curcop);
6187 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6188 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6189 veop, modname, imop);
6193 PERL_STATIC_INLINE OP *
6194 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6196 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6197 newLISTOP(OP_LIST, 0, arg,
6198 newUNOP(OP_RV2CV, 0,
6199 newGVOP(OP_GV, 0, gv))));
6203 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6208 PERL_ARGS_ASSERT_DOFILE;
6210 if (!force_builtin && (gv = gv_override("do", 2))) {
6211 doop = S_new_entersubop(aTHX_ gv, term);
6214 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6220 =head1 Optree construction
6222 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6224 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
6225 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6226 be set automatically, and, shifted up eight bits, the eight bits of
6227 C<op_private>, except that the bit with value 1 or 2 is automatically
6228 set as required. I<listval> and I<subscript> supply the parameters of
6229 the slice; they are consumed by this function and become part of the
6230 constructed op tree.
6236 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6238 return newBINOP(OP_LSLICE, flags,
6239 list(force_list(subscript, 1)),
6240 list(force_list(listval, 1)) );
6243 #define ASSIGN_LIST 1
6244 #define ASSIGN_REF 2
6247 S_assignment_type(pTHX_ const OP *o)
6256 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6257 o = cUNOPo->op_first;
6259 flags = o->op_flags;
6261 if (type == OP_COND_EXPR) {
6262 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6263 const I32 t = assignment_type(sib);
6264 const I32 f = assignment_type(OpSIBLING(sib));
6266 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6268 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6269 yyerror("Assignment to both a list and a scalar");
6273 if (type == OP_SREFGEN)
6275 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6276 type = kid->op_type;
6277 flags |= kid->op_flags;
6278 if (!(flags & OPf_PARENS)
6279 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6280 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6286 if (type == OP_LIST &&
6287 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6288 o->op_private & OPpLVAL_INTRO)
6291 if (type == OP_LIST || flags & OPf_PARENS ||
6292 type == OP_RV2AV || type == OP_RV2HV ||
6293 type == OP_ASLICE || type == OP_HSLICE ||
6294 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6297 if (type == OP_PADAV || type == OP_PADHV)
6300 if (type == OP_RV2SV)
6307 Helper function for newASSIGNOP to detect commonality between the
6308 lhs and the rhs. (It is actually called very indirectly. newASSIGNOP
6309 flags the op and the peephole optimizer calls this helper function
6310 if the flag is set.) Marks all variables with PL_generation. If it
6311 returns TRUE the assignment must be able to handle common variables.
6313 PL_generation sorcery:
6314 An assignment like ($a,$b) = ($c,$d) is easier than
6315 ($a,$b) = ($c,$a), since there is no need for temporary vars.
6316 To detect whether there are common vars, the global var
6317 PL_generation is incremented for each assign op we compile.
6318 Then, while compiling the assign op, we run through all the
6319 variables on both sides of the assignment, setting a spare slot
6320 in each of them to PL_generation. If any of them already have
6321 that value, we know we've got commonality. Also, if the
6322 generation number is already set to PERL_INT_MAX, then
6323 the variable is involved in aliasing, so we also have
6324 potential commonality in that case. We could use a
6325 single bit marker, but then we'd have to make 2 passes, first
6326 to clear the flag, then to test and set it. And that
6327 wouldn't help with aliasing, either. To find somewhere
6328 to store these values, evil chicanery is done with SvUVX().
6330 PERL_STATIC_INLINE bool
6331 S_aassign_common_vars(pTHX_ OP* o)
6334 for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
6335 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
6336 if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
6337 || curop->op_type == OP_AELEMFAST) {
6338 GV *gv = cGVOPx_gv(curop);
6340 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6342 GvASSIGN_GENERATION_set(gv, PL_generation);
6344 else if (curop->op_type == OP_PADSV ||
6345 curop->op_type == OP_PADAV ||
6346 curop->op_type == OP_PADHV ||
6347 curop->op_type == OP_AELEMFAST_LEX ||
6348 curop->op_type == OP_PADANY)
6351 if (PAD_COMPNAME_GEN(curop->op_targ)
6352 == (STRLEN)PL_generation
6353 || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6355 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
6358 else if (curop->op_type == OP_RV2CV)
6360 else if (curop->op_type == OP_RV2SV ||
6361 curop->op_type == OP_RV2AV ||
6362 curop->op_type == OP_RV2HV ||
6363 curop->op_type == OP_RV2GV) {
6364 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
6367 else if (curop->op_type == OP_PUSHRE) {
6370 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
6371 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
6374 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
6378 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6380 GvASSIGN_GENERATION_set(gv, PL_generation);
6382 else if (curop->op_targ)
6385 else if (curop->op_type == OP_PADRANGE)
6386 /* Ignore padrange; checking its siblings is sufficient. */
6391 else if (PL_opargs[curop->op_type] & OA_TARGLEX
6392 && curop->op_private & OPpTARGET_MY)
6395 if (curop->op_flags & OPf_KIDS) {
6396 if (aassign_common_vars(curop))
6403 /* This variant only handles lexical aliases. It is called when
6404 newASSIGNOP decides that we don’t have any common vars, as lexical ali-
6405 ases trump that decision. */
6406 PERL_STATIC_INLINE bool
6407 S_aassign_common_vars_aliases_only(pTHX_ OP *o)
6410 for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
6411 if ((curop->op_type == OP_PADSV ||
6412 curop->op_type == OP_PADAV ||
6413 curop->op_type == OP_PADHV ||
6414 curop->op_type == OP_AELEMFAST_LEX ||
6415 curop->op_type == OP_PADANY ||
6416 ( PL_opargs[curop->op_type] & OA_TARGLEX
6417 && curop->op_private & OPpTARGET_MY ))
6418 && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6421 if (curop->op_type == OP_PUSHRE && curop->op_targ
6422 && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6425 if (curop->op_flags & OPf_KIDS) {
6426 if (S_aassign_common_vars_aliases_only(aTHX_ curop))
6434 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6436 Constructs, checks, and returns an assignment op. I<left> and I<right>
6437 supply the parameters of the assignment; they are consumed by this
6438 function and become part of the constructed op tree.
6440 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6441 a suitable conditional optree is constructed. If I<optype> is the opcode
6442 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6443 performs the binary operation and assigns the result to the left argument.
6444 Either way, if I<optype> is non-zero then I<flags> has no effect.
6446 If I<optype> is zero, then a plain scalar or list assignment is
6447 constructed. Which type of assignment it is is automatically determined.
6448 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6449 will be set automatically, and, shifted up eight bits, the eight bits
6450 of C<op_private>, except that the bit with value 1 or 2 is automatically
6457 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6463 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6464 return newLOGOP(optype, 0,
6465 op_lvalue(scalar(left), optype),
6466 newUNOP(OP_SASSIGN, 0, scalar(right)));
6469 return newBINOP(optype, OPf_STACKED,
6470 op_lvalue(scalar(left), optype), scalar(right));
6474 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6475 static const char no_list_state[] = "Initialization of state variables"
6476 " in list context currently forbidden";
6478 bool maybe_common_vars = TRUE;
6480 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6481 left->op_private &= ~ OPpSLICEWARNING;
6484 left = op_lvalue(left, OP_AASSIGN);
6485 curop = list(force_list(left, 1));
6486 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6487 o->op_private = (U8)(0 | (flags >> 8));
6489 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6491 OP* lop = ((LISTOP*)left)->op_first;
6492 maybe_common_vars = FALSE;
6494 if (lop->op_type == OP_PADSV ||
6495 lop->op_type == OP_PADAV ||
6496 lop->op_type == OP_PADHV ||
6497 lop->op_type == OP_PADANY) {
6498 if (!(lop->op_private & OPpLVAL_INTRO))
6499 maybe_common_vars = TRUE;
6501 if (lop->op_private & OPpPAD_STATE) {
6502 if (left->op_private & OPpLVAL_INTRO) {
6503 /* Each variable in state($a, $b, $c) = ... */
6506 /* Each state variable in
6507 (state $a, my $b, our $c, $d, undef) = ... */
6509 yyerror(no_list_state);
6511 /* Each my variable in
6512 (state $a, my $b, our $c, $d, undef) = ... */
6514 } else if (lop->op_type == OP_UNDEF ||
6515 OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
6516 /* undef may be interesting in
6517 (state $a, undef, state $c) */
6519 /* Other ops in the list. */
6520 maybe_common_vars = TRUE;
6522 lop = OpSIBLING(lop);
6525 else if ((left->op_private & OPpLVAL_INTRO)
6526 && ( left->op_type == OP_PADSV
6527 || left->op_type == OP_PADAV
6528 || left->op_type == OP_PADHV
6529 || left->op_type == OP_PADANY))
6531 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
6532 if (left->op_private & OPpPAD_STATE) {
6533 /* All single variable list context state assignments, hence
6543 yyerror(no_list_state);
6547 if (maybe_common_vars) {
6548 /* The peephole optimizer will do the full check and pos-
6549 sibly turn this off. */
6550 o->op_private |= OPpASSIGN_COMMON;
6553 if (right && right->op_type == OP_SPLIT
6554 && !(right->op_flags & OPf_STACKED)) {
6555 OP* tmpop = ((LISTOP*)right)->op_first;
6556 PMOP * const pm = (PMOP*)tmpop;
6557 assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6560 !pm->op_pmreplrootu.op_pmtargetoff
6562 !pm->op_pmreplrootu.op_pmtargetgv
6566 if (!(left->op_private & OPpLVAL_INTRO) &&
6567 ( (left->op_type == OP_RV2AV &&
6568 (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6569 || left->op_type == OP_PADAV )
6571 if (tmpop != (OP *)pm) {
6573 pm->op_pmreplrootu.op_pmtargetoff
6574 = cPADOPx(tmpop)->op_padix;
6575 cPADOPx(tmpop)->op_padix = 0; /* steal it */
6577 pm->op_pmreplrootu.op_pmtargetgv
6578 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6579 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
6581 right->op_private |=
6582 left->op_private & OPpOUR_INTRO;
6585 pm->op_targ = left->op_targ;
6586 left->op_targ = 0; /* filch it */
6589 tmpop = cUNOPo->op_first; /* to list (nulled) */
6590 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6591 /* detach rest of siblings from o subtree,
6592 * and free subtree */
6593 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6594 op_free(o); /* blow off assign */
6595 right->op_flags &= ~OPf_WANT;
6596 /* "I don't know and I don't care." */
6599 else if (left->op_type == OP_RV2AV
6600 || left->op_type == OP_PADAV)
6602 /* Detach the array. */
6606 op_sibling_splice(cBINOPo->op_last,
6607 cUNOPx(cBINOPo->op_last)
6608 ->op_first, 1, NULL);
6609 assert(ary == left);
6610 /* Attach it to the split. */
6611 op_sibling_splice(right, cLISTOPx(right)->op_last,
6613 right->op_flags |= OPf_STACKED;
6614 /* Detach split and expunge aassign as above. */
6617 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6618 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6621 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6622 SV * const sv = *svp;
6623 if (SvIOK(sv) && SvIVX(sv) == 0)
6625 if (right->op_private & OPpSPLIT_IMPLIM) {
6626 /* our own SV, created in ck_split */
6628 sv_setiv(sv, PL_modcount+1);
6631 /* SV may belong to someone else */
6633 *svp = newSViv(PL_modcount+1);
6641 if (assign_type == ASSIGN_REF)
6642 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6644 right = newOP(OP_UNDEF, 0);
6645 if (right->op_type == OP_READLINE) {
6646 right->op_flags |= OPf_STACKED;
6647 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6651 o = newBINOP(OP_SASSIGN, flags,
6652 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6658 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6660 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6661 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6662 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6663 If I<label> is non-null, it supplies the name of a label to attach to
6664 the state op; this function takes ownership of the memory pointed at by
6665 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
6668 If I<o> is null, the state op is returned. Otherwise the state op is
6669 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
6670 is consumed by this function and becomes part of the returned op tree.
6676 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6679 const U32 seq = intro_my();
6680 const U32 utf8 = flags & SVf_UTF8;
6683 PL_parser->parsed_sub = 0;
6687 NewOp(1101, cop, 1, COP);
6688 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6689 OpTYPE_set(cop, OP_DBSTATE);
6692 OpTYPE_set(cop, OP_NEXTSTATE);
6694 cop->op_flags = (U8)flags;
6695 CopHINTS_set(cop, PL_hints);
6697 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6699 cop->op_next = (OP*)cop;
6702 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6703 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6705 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6707 PL_hints |= HINT_BLOCK_SCOPE;
6708 /* It seems that we need to defer freeing this pointer, as other parts
6709 of the grammar end up wanting to copy it after this op has been
6714 if (PL_parser->preambling != NOLINE) {
6715 CopLINE_set(cop, PL_parser->preambling);
6716 PL_parser->copline = NOLINE;
6718 else if (PL_parser->copline == NOLINE)
6719 CopLINE_set(cop, CopLINE(PL_curcop));
6721 CopLINE_set(cop, PL_parser->copline);
6722 PL_parser->copline = NOLINE;
6725 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6727 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6729 CopSTASH_set(cop, PL_curstash);
6731 if (cop->op_type == OP_DBSTATE) {
6732 /* this line can have a breakpoint - store the cop in IV */
6733 AV *av = CopFILEAVx(PL_curcop);
6735 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6736 if (svp && *svp != &PL_sv_undef ) {
6737 (void)SvIOK_on(*svp);
6738 SvIV_set(*svp, PTR2IV(cop));
6743 if (flags & OPf_SPECIAL)
6745 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6749 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6751 Constructs, checks, and returns a logical (flow control) op. I<type>
6752 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
6753 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6754 the eight bits of C<op_private>, except that the bit with value 1 is
6755 automatically set. I<first> supplies the expression controlling the
6756 flow, and I<other> supplies the side (alternate) chain of ops; they are
6757 consumed by this function and become part of the constructed op tree.
6763 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6765 PERL_ARGS_ASSERT_NEWLOGOP;
6767 return new_logop(type, flags, &first, &other);
6771 S_search_const(pTHX_ OP *o)
6773 PERL_ARGS_ASSERT_SEARCH_CONST;
6775 switch (o->op_type) {
6779 if (o->op_flags & OPf_KIDS)
6780 return search_const(cUNOPo->op_first);
6787 if (!(o->op_flags & OPf_KIDS))
6789 kid = cLISTOPo->op_first;
6791 switch (kid->op_type) {
6795 kid = OpSIBLING(kid);
6798 if (kid != cLISTOPo->op_last)
6804 kid = cLISTOPo->op_last;
6806 return search_const(kid);
6814 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6822 int prepend_not = 0;
6824 PERL_ARGS_ASSERT_NEW_LOGOP;
6829 /* [perl #59802]: Warn about things like "return $a or $b", which
6830 is parsed as "(return $a) or $b" rather than "return ($a or
6831 $b)". NB: This also applies to xor, which is why we do it
6834 switch (first->op_type) {
6838 /* XXX: Perhaps we should emit a stronger warning for these.
6839 Even with the high-precedence operator they don't seem to do
6842 But until we do, fall through here.
6848 /* XXX: Currently we allow people to "shoot themselves in the
6849 foot" by explicitly writing "(return $a) or $b".
6851 Warn unless we are looking at the result from folding or if
6852 the programmer explicitly grouped the operators like this.
6853 The former can occur with e.g.
6855 use constant FEATURE => ( $] >= ... );
6856 sub { not FEATURE and return or do_stuff(); }
6858 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6859 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6860 "Possible precedence issue with control flow operator");
6861 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6867 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6868 return newBINOP(type, flags, scalar(first), scalar(other));
6870 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6871 || type == OP_CUSTOM);
6873 scalarboolean(first);
6874 /* optimize AND and OR ops that have NOTs as children */
6875 if (first->op_type == OP_NOT
6876 && (first->op_flags & OPf_KIDS)
6877 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6878 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6880 if (type == OP_AND || type == OP_OR) {
6886 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6888 prepend_not = 1; /* prepend a NOT op later */
6892 /* search for a constant op that could let us fold the test */
6893 if ((cstop = search_const(first))) {
6894 if (cstop->op_private & OPpCONST_STRICT)
6895 no_bareword_allowed(cstop);
6896 else if ((cstop->op_private & OPpCONST_BARE))
6897 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6898 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6899 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6900 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6902 if (other->op_type == OP_CONST)
6903 other->op_private |= OPpCONST_SHORTCIRCUIT;
6905 if (other->op_type == OP_LEAVE)
6906 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6907 else if (other->op_type == OP_MATCH
6908 || other->op_type == OP_SUBST
6909 || other->op_type == OP_TRANSR
6910 || other->op_type == OP_TRANS)
6911 /* Mark the op as being unbindable with =~ */
6912 other->op_flags |= OPf_SPECIAL;
6914 other->op_folded = 1;
6918 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6919 const OP *o2 = other;
6920 if ( ! (o2->op_type == OP_LIST
6921 && (( o2 = cUNOPx(o2)->op_first))
6922 && o2->op_type == OP_PUSHMARK
6923 && (( o2 = OpSIBLING(o2))) )
6926 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6927 || o2->op_type == OP_PADHV)
6928 && o2->op_private & OPpLVAL_INTRO
6929 && !(o2->op_private & OPpPAD_STATE))
6931 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6932 "Deprecated use of my() in false conditional");
6936 if (cstop->op_type == OP_CONST)
6937 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6942 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6943 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6945 const OP * const k1 = ((UNOP*)first)->op_first;
6946 const OP * const k2 = OpSIBLING(k1);
6948 switch (first->op_type)
6951 if (k2 && k2->op_type == OP_READLINE
6952 && (k2->op_flags & OPf_STACKED)
6953 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6955 warnop = k2->op_type;
6960 if (k1->op_type == OP_READDIR
6961 || k1->op_type == OP_GLOB
6962 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6963 || k1->op_type == OP_EACH
6964 || k1->op_type == OP_AEACH)
6966 warnop = ((k1->op_type == OP_NULL)
6967 ? (OPCODE)k1->op_targ : k1->op_type);
6972 const line_t oldline = CopLINE(PL_curcop);
6973 /* This ensures that warnings are reported at the first line
6974 of the construction, not the last. */
6975 CopLINE_set(PL_curcop, PL_parser->copline);
6976 Perl_warner(aTHX_ packWARN(WARN_MISC),
6977 "Value of %s%s can be \"0\"; test with defined()",
6979 ((warnop == OP_READLINE || warnop == OP_GLOB)
6980 ? " construct" : "() operator"));
6981 CopLINE_set(PL_curcop, oldline);
6988 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6989 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6991 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6992 logop->op_flags |= (U8)flags;
6993 logop->op_private = (U8)(1 | (flags >> 8));
6995 /* establish postfix order */
6996 logop->op_next = LINKLIST(first);
6997 first->op_next = (OP*)logop;
6998 assert(!OpHAS_SIBLING(first));
6999 op_sibling_splice((OP*)logop, first, 0, other);
7001 CHECKOP(type,logop);
7003 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7004 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7012 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7014 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7015 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7016 will be set automatically, and, shifted up eight bits, the eight bits of
7017 C<op_private>, except that the bit with value 1 is automatically set.
7018 I<first> supplies the expression selecting between the two branches,
7019 and I<trueop> and I<falseop> supply the branches; they are consumed by
7020 this function and become part of the constructed op tree.
7026 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7034 PERL_ARGS_ASSERT_NEWCONDOP;
7037 return newLOGOP(OP_AND, 0, first, trueop);
7039 return newLOGOP(OP_OR, 0, first, falseop);
7041 scalarboolean(first);
7042 if ((cstop = search_const(first))) {
7043 /* Left or right arm of the conditional? */
7044 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7045 OP *live = left ? trueop : falseop;
7046 OP *const dead = left ? falseop : trueop;
7047 if (cstop->op_private & OPpCONST_BARE &&
7048 cstop->op_private & OPpCONST_STRICT) {
7049 no_bareword_allowed(cstop);
7053 if (live->op_type == OP_LEAVE)
7054 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7055 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7056 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7057 /* Mark the op as being unbindable with =~ */
7058 live->op_flags |= OPf_SPECIAL;
7059 live->op_folded = 1;
7062 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
7063 logop->op_flags |= (U8)flags;
7064 logop->op_private = (U8)(1 | (flags >> 8));
7065 logop->op_next = LINKLIST(falseop);
7067 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7070 /* establish postfix order */
7071 start = LINKLIST(first);
7072 first->op_next = (OP*)logop;
7074 /* make first, trueop, falseop siblings */
7075 op_sibling_splice((OP*)logop, first, 0, trueop);
7076 op_sibling_splice((OP*)logop, trueop, 0, falseop);
7078 o = newUNOP(OP_NULL, 0, (OP*)logop);
7080 trueop->op_next = falseop->op_next = o;
7087 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7089 Constructs and returns a C<range> op, with subordinate C<flip> and
7090 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
7091 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7092 for both the C<flip> and C<range> ops, except that the bit with value
7093 1 is automatically set. I<left> and I<right> supply the expressions
7094 controlling the endpoints of the range; they are consumed by this function
7095 and become part of the constructed op tree.
7101 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7109 PERL_ARGS_ASSERT_NEWRANGE;
7111 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
7112 range->op_flags = OPf_KIDS;
7113 leftstart = LINKLIST(left);
7114 range->op_private = (U8)(1 | (flags >> 8));
7116 /* make left and right siblings */
7117 op_sibling_splice((OP*)range, left, 0, right);
7119 range->op_next = (OP*)range;
7120 flip = newUNOP(OP_FLIP, flags, (OP*)range);
7121 flop = newUNOP(OP_FLOP, 0, flip);
7122 o = newUNOP(OP_NULL, 0, flop);
7124 range->op_next = leftstart;
7126 left->op_next = flip;
7127 right->op_next = flop;
7130 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7131 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7133 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7134 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7135 SvPADTMP_on(PAD_SV(flip->op_targ));
7137 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7138 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7140 /* check barewords before they might be optimized aways */
7141 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7142 no_bareword_allowed(left);
7143 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7144 no_bareword_allowed(right);
7147 if (!flip->op_private || !flop->op_private)
7148 LINKLIST(o); /* blow off optimizer unless constant */
7154 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7156 Constructs, checks, and returns an op tree expressing a loop. This is
7157 only a loop in the control flow through the op tree; it does not have
7158 the heavyweight loop structure that allows exiting the loop by C<last>
7159 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
7160 top-level op, except that some bits will be set automatically as required.
7161 I<expr> supplies the expression controlling loop iteration, and I<block>
7162 supplies the body of the loop; they are consumed by this function and
7163 become part of the constructed op tree. I<debuggable> is currently
7164 unused and should always be 1.
7170 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7174 const bool once = block && block->op_flags & OPf_SPECIAL &&
7175 block->op_type == OP_NULL;
7177 PERL_UNUSED_ARG(debuggable);
7181 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7182 || ( expr->op_type == OP_NOT
7183 && cUNOPx(expr)->op_first->op_type == OP_CONST
7184 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7187 /* Return the block now, so that S_new_logop does not try to
7189 return block; /* do {} while 0 does once */
7190 if (expr->op_type == OP_READLINE
7191 || expr->op_type == OP_READDIR
7192 || expr->op_type == OP_GLOB
7193 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7194 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7195 expr = newUNOP(OP_DEFINED, 0,
7196 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7197 } else if (expr->op_flags & OPf_KIDS) {
7198 const OP * const k1 = ((UNOP*)expr)->op_first;
7199 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7200 switch (expr->op_type) {
7202 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7203 && (k2->op_flags & OPf_STACKED)
7204 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7205 expr = newUNOP(OP_DEFINED, 0, expr);
7209 if (k1 && (k1->op_type == OP_READDIR
7210 || k1->op_type == OP_GLOB
7211 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7212 || k1->op_type == OP_EACH
7213 || k1->op_type == OP_AEACH))
7214 expr = newUNOP(OP_DEFINED, 0, expr);
7220 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7221 * op, in listop. This is wrong. [perl #27024] */
7223 block = newOP(OP_NULL, 0);
7224 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7225 o = new_logop(OP_AND, 0, &expr, &listop);
7232 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7234 if (once && o != listop)
7236 assert(cUNOPo->op_first->op_type == OP_AND
7237 || cUNOPo->op_first->op_type == OP_OR);
7238 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7242 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7244 o->op_flags |= flags;
7246 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7251 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7253 Constructs, checks, and returns an op tree expressing a C<while> loop.
7254 This is a heavyweight loop, with structure that allows exiting the loop
7255 by C<last> and suchlike.
7257 I<loop> is an optional preconstructed C<enterloop> op to use in the
7258 loop; if it is null then a suitable op will be constructed automatically.
7259 I<expr> supplies the loop's controlling expression. I<block> supplies the
7260 main body of the loop, and I<cont> optionally supplies a C<continue> block
7261 that operates as a second half of the body. All of these optree inputs
7262 are consumed by this function and become part of the constructed op tree.
7264 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7265 op and, shifted up eight bits, the eight bits of C<op_private> for
7266 the C<leaveloop> op, except that (in both cases) some bits will be set
7267 automatically. I<debuggable> is currently unused and should always be 1.
7268 I<has_my> can be supplied as true to force the
7269 loop body to be enclosed in its own scope.
7275 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7276 OP *expr, OP *block, OP *cont, I32 has_my)
7285 PERL_UNUSED_ARG(debuggable);
7288 if (expr->op_type == OP_READLINE
7289 || expr->op_type == OP_READDIR
7290 || expr->op_type == OP_GLOB
7291 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7292 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7293 expr = newUNOP(OP_DEFINED, 0,
7294 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7295 } else if (expr->op_flags & OPf_KIDS) {
7296 const OP * const k1 = ((UNOP*)expr)->op_first;
7297 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7298 switch (expr->op_type) {
7300 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7301 && (k2->op_flags & OPf_STACKED)
7302 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7303 expr = newUNOP(OP_DEFINED, 0, expr);
7307 if (k1 && (k1->op_type == OP_READDIR
7308 || k1->op_type == OP_GLOB
7309 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7310 || k1->op_type == OP_EACH
7311 || k1->op_type == OP_AEACH))
7312 expr = newUNOP(OP_DEFINED, 0, expr);
7319 block = newOP(OP_NULL, 0);
7320 else if (cont || has_my) {
7321 block = op_scope(block);
7325 next = LINKLIST(cont);
7328 OP * const unstack = newOP(OP_UNSTACK, 0);
7331 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7335 listop = op_append_list(OP_LINESEQ, block, cont);
7337 redo = LINKLIST(listop);
7341 o = new_logop(OP_AND, 0, &expr, &listop);
7342 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7344 return expr; /* listop already freed by new_logop */
7347 ((LISTOP*)listop)->op_last->op_next =
7348 (o == listop ? redo : LINKLIST(o));
7354 NewOp(1101,loop,1,LOOP);
7355 OpTYPE_set(loop, OP_ENTERLOOP);
7356 loop->op_private = 0;
7357 loop->op_next = (OP*)loop;
7360 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7362 loop->op_redoop = redo;
7363 loop->op_lastop = o;
7364 o->op_private |= loopflags;
7367 loop->op_nextop = next;
7369 loop->op_nextop = o;
7371 o->op_flags |= flags;
7372 o->op_private |= (flags >> 8);
7377 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7379 Constructs, checks, and returns an op tree expressing a C<foreach>
7380 loop (iteration through a list of values). This is a heavyweight loop,
7381 with structure that allows exiting the loop by C<last> and suchlike.
7383 I<sv> optionally supplies the variable that will be aliased to each
7384 item in turn; if null, it defaults to C<$_> (either lexical or global).
7385 I<expr> supplies the list of values to iterate over. I<block> supplies
7386 the main body of the loop, and I<cont> optionally supplies a C<continue>
7387 block that operates as a second half of the body. All of these optree
7388 inputs are consumed by this function and become part of the constructed
7391 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7392 op and, shifted up eight bits, the eight bits of C<op_private> for
7393 the C<leaveloop> op, except that (in both cases) some bits will be set
7400 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7405 PADOFFSET padoff = 0;
7409 PERL_ARGS_ASSERT_NEWFOROP;
7412 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7413 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7414 OpTYPE_set(sv, OP_RV2GV);
7416 /* The op_type check is needed to prevent a possible segfault
7417 * if the loop variable is undeclared and 'strict vars' is in
7418 * effect. This is illegal but is nonetheless parsed, so we
7419 * may reach this point with an OP_CONST where we're expecting
7422 if (cUNOPx(sv)->op_first->op_type == OP_GV
7423 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7424 iterpflags |= OPpITER_DEF;
7426 else if (sv->op_type == OP_PADSV) { /* private variable */
7427 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7428 padoff = sv->op_targ;
7432 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7434 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7437 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7439 PADNAME * const pn = PAD_COMPNAME(padoff);
7440 const char * const name = PadnamePV(pn);
7442 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7443 iterpflags |= OPpITER_DEF;
7447 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
7448 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7449 sv = newGVOP(OP_GV, 0, PL_defgv);
7454 iterpflags |= OPpITER_DEF;
7457 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7458 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7459 iterflags |= OPf_STACKED;
7461 else if (expr->op_type == OP_NULL &&
7462 (expr->op_flags & OPf_KIDS) &&
7463 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7465 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7466 * set the STACKED flag to indicate that these values are to be
7467 * treated as min/max values by 'pp_enteriter'.
7469 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7470 LOGOP* const range = (LOGOP*) flip->op_first;
7471 OP* const left = range->op_first;
7472 OP* const right = OpSIBLING(left);
7475 range->op_flags &= ~OPf_KIDS;
7476 /* detach range's children */
7477 op_sibling_splice((OP*)range, NULL, -1, NULL);
7479 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7480 listop->op_first->op_next = range->op_next;
7481 left->op_next = range->op_other;
7482 right->op_next = (OP*)listop;
7483 listop->op_next = listop->op_first;
7486 expr = (OP*)(listop);
7488 iterflags |= OPf_STACKED;
7491 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7494 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7495 op_append_elem(OP_LIST, list(expr),
7497 assert(!loop->op_next);
7498 /* for my $x () sets OPpLVAL_INTRO;
7499 * for our $x () sets OPpOUR_INTRO */
7500 loop->op_private = (U8)iterpflags;
7501 if (loop->op_slabbed
7502 && DIFF(loop, OpSLOT(loop)->opslot_next)
7503 < SIZE_TO_PSIZE(sizeof(LOOP)))
7506 NewOp(1234,tmp,1,LOOP);
7507 Copy(loop,tmp,1,LISTOP);
7508 #ifdef PERL_OP_PARENT
7509 assert(loop->op_last->op_sibparent == (OP*)loop);
7510 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7512 S_op_destroy(aTHX_ (OP*)loop);
7515 else if (!loop->op_slabbed)
7517 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7518 #ifdef PERL_OP_PARENT
7519 OpLASTSIB_set(loop->op_last, (OP*)loop);
7522 loop->op_targ = padoff;
7523 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7528 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7530 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7531 or C<last>). I<type> is the opcode. I<label> supplies the parameter
7532 determining the target of the op; it is consumed by this function and
7533 becomes part of the constructed op tree.
7539 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7543 PERL_ARGS_ASSERT_NEWLOOPEX;
7545 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7546 || type == OP_CUSTOM);
7548 if (type != OP_GOTO) {
7549 /* "last()" means "last" */
7550 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7551 o = newOP(type, OPf_SPECIAL);
7555 /* Check whether it's going to be a goto &function */
7556 if (label->op_type == OP_ENTERSUB
7557 && !(label->op_flags & OPf_STACKED))
7558 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7561 /* Check for a constant argument */
7562 if (label->op_type == OP_CONST) {
7563 SV * const sv = ((SVOP *)label)->op_sv;
7565 const char *s = SvPV_const(sv,l);
7566 if (l == strlen(s)) {
7568 SvUTF8(((SVOP*)label)->op_sv),
7570 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7574 /* If we have already created an op, we do not need the label. */
7577 else o = newUNOP(type, OPf_STACKED, label);
7579 PL_hints |= HINT_BLOCK_SCOPE;
7583 /* if the condition is a literal array or hash
7584 (or @{ ... } etc), make a reference to it.
7587 S_ref_array_or_hash(pTHX_ OP *cond)
7590 && (cond->op_type == OP_RV2AV
7591 || cond->op_type == OP_PADAV
7592 || cond->op_type == OP_RV2HV
7593 || cond->op_type == OP_PADHV))
7595 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7598 && (cond->op_type == OP_ASLICE
7599 || cond->op_type == OP_KVASLICE
7600 || cond->op_type == OP_HSLICE
7601 || cond->op_type == OP_KVHSLICE)) {
7603 /* anonlist now needs a list from this op, was previously used in
7605 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7606 cond->op_flags |= OPf_WANT_LIST;
7608 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7615 /* These construct the optree fragments representing given()
7618 entergiven and enterwhen are LOGOPs; the op_other pointer
7619 points up to the associated leave op. We need this so we
7620 can put it in the context and make break/continue work.
7621 (Also, of course, pp_enterwhen will jump straight to
7622 op_other if the match fails.)
7626 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7627 I32 enter_opcode, I32 leave_opcode,
7628 PADOFFSET entertarg)
7634 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7636 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7637 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
7638 enterop->op_private = 0;
7640 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7643 /* prepend cond if we have one */
7644 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7646 o->op_next = LINKLIST(cond);
7647 cond->op_next = (OP *) enterop;
7650 /* This is a default {} block */
7651 enterop->op_flags |= OPf_SPECIAL;
7652 o ->op_flags |= OPf_SPECIAL;
7654 o->op_next = (OP *) enterop;
7657 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7658 entergiven and enterwhen both
7661 enterop->op_next = LINKLIST(block);
7662 block->op_next = enterop->op_other = o;
7667 /* Does this look like a boolean operation? For these purposes
7668 a boolean operation is:
7669 - a subroutine call [*]
7670 - a logical connective
7671 - a comparison operator
7672 - a filetest operator, with the exception of -s -M -A -C
7673 - defined(), exists() or eof()
7674 - /$re/ or $foo =~ /$re/
7676 [*] possibly surprising
7679 S_looks_like_bool(pTHX_ const OP *o)
7681 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7683 switch(o->op_type) {
7686 return looks_like_bool(cLOGOPo->op_first);
7690 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7693 looks_like_bool(cLOGOPo->op_first)
7694 && looks_like_bool(sibl));
7700 o->op_flags & OPf_KIDS
7701 && looks_like_bool(cUNOPo->op_first));
7705 case OP_NOT: case OP_XOR:
7707 case OP_EQ: case OP_NE: case OP_LT:
7708 case OP_GT: case OP_LE: case OP_GE:
7710 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7711 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7713 case OP_SEQ: case OP_SNE: case OP_SLT:
7714 case OP_SGT: case OP_SLE: case OP_SGE:
7718 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7719 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7720 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7721 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7722 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7723 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7724 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7725 case OP_FTTEXT: case OP_FTBINARY:
7727 case OP_DEFINED: case OP_EXISTS:
7728 case OP_MATCH: case OP_EOF:
7735 /* Detect comparisons that have been optimized away */
7736 if (cSVOPo->op_sv == &PL_sv_yes
7737 || cSVOPo->op_sv == &PL_sv_no)
7750 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7752 Constructs, checks, and returns an op tree expressing a C<given> block.
7753 I<cond> supplies the expression that will be locally assigned to a lexical
7754 variable, and I<block> supplies the body of the C<given> construct; they
7755 are consumed by this function and become part of the constructed op tree.
7756 I<defsv_off> is the pad offset of the scalar lexical variable that will
7757 be affected. If it is 0, the global $_ will be used.
7763 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7765 PERL_ARGS_ASSERT_NEWGIVENOP;
7766 return newGIVWHENOP(
7767 ref_array_or_hash(cond),
7769 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7774 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7776 Constructs, checks, and returns an op tree expressing a C<when> block.
7777 I<cond> supplies the test expression, and I<block> supplies the block
7778 that will be executed if the test evaluates to true; they are consumed
7779 by this function and become part of the constructed op tree. I<cond>
7780 will be interpreted DWIMically, often as a comparison against C<$_>,
7781 and may be null to generate a C<default> block.
7787 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7789 const bool cond_llb = (!cond || looks_like_bool(cond));
7792 PERL_ARGS_ASSERT_NEWWHENOP;
7797 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7799 scalar(ref_array_or_hash(cond)));
7802 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7805 /* must not conflict with SVf_UTF8 */
7806 #define CV_CKPROTO_CURSTASH 0x1
7809 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7810 const STRLEN len, const U32 flags)
7812 SV *name = NULL, *msg;
7813 const char * cvp = SvROK(cv)
7814 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7815 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7818 STRLEN clen = CvPROTOLEN(cv), plen = len;
7820 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7822 if (p == NULL && cvp == NULL)
7825 if (!ckWARN_d(WARN_PROTOTYPE))
7829 p = S_strip_spaces(aTHX_ p, &plen);
7830 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7831 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7832 if (plen == clen && memEQ(cvp, p, plen))
7835 if (flags & SVf_UTF8) {
7836 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7840 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7846 msg = sv_newmortal();
7851 gv_efullname3(name = sv_newmortal(), gv, NULL);
7852 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7853 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7854 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7855 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7856 sv_catpvs(name, "::");
7858 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7859 assert (CvNAMED(SvRV_const(gv)));
7860 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7862 else sv_catsv(name, (SV *)gv);
7864 else name = (SV *)gv;
7866 sv_setpvs(msg, "Prototype mismatch:");
7868 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7870 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7871 UTF8fARG(SvUTF8(cv),clen,cvp)
7874 sv_catpvs(msg, ": none");
7875 sv_catpvs(msg, " vs ");
7877 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7879 sv_catpvs(msg, "none");
7880 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7883 static void const_sv_xsub(pTHX_ CV* cv);
7884 static void const_av_xsub(pTHX_ CV* cv);
7888 =head1 Optree Manipulation Functions
7890 =for apidoc cv_const_sv
7892 If C<cv> is a constant sub eligible for inlining, returns the constant
7893 value returned by the sub. Otherwise, returns NULL.
7895 Constant subs can be created with C<newCONSTSUB> or as described in
7896 L<perlsub/"Constant Functions">.
7901 Perl_cv_const_sv(const CV *const cv)
7906 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7908 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7909 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7914 Perl_cv_const_sv_or_av(const CV * const cv)
7918 if (SvROK(cv)) return SvRV((SV *)cv);
7919 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7920 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7923 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7924 * Can be called in 2 ways:
7927 * look for a single OP_CONST with attached value: return the value
7929 * allow_lex && !CvCONST(cv);
7931 * examine the clone prototype, and if contains only a single
7932 * OP_CONST, return the value; or if it contains a single PADSV ref-
7933 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7934 * a candidate for "constizing" at clone time, and return NULL.
7938 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7946 for (; o; o = o->op_next) {
7947 const OPCODE type = o->op_type;
7949 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7951 || type == OP_PUSHMARK)
7953 if (type == OP_DBSTATE)
7955 if (type == OP_LEAVESUB)
7959 if (type == OP_CONST && cSVOPo->op_sv)
7961 else if (type == OP_UNDEF && !o->op_private) {
7965 else if (allow_lex && type == OP_PADSV) {
7966 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7968 sv = &PL_sv_undef; /* an arbitrary non-null value */
7986 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7987 PADNAME * const name, SV ** const const_svp)
7994 if (CvFLAGS(PL_compcv)) {
7995 /* might have had built-in attrs applied */
7996 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7997 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7998 && ckWARN(WARN_MISC))
8000 /* protect against fatal warnings leaking compcv */
8001 SAVEFREESV(PL_compcv);
8002 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8003 SvREFCNT_inc_simple_void_NN(PL_compcv);
8006 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8007 & ~(CVf_LVALUE * pureperl));
8012 /* redundant check for speed: */
8013 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8014 const line_t oldline = CopLINE(PL_curcop);
8017 : sv_2mortal(newSVpvn_utf8(
8018 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8020 if (PL_parser && PL_parser->copline != NOLINE)
8021 /* This ensures that warnings are reported at the first
8022 line of a redefinition, not the last. */
8023 CopLINE_set(PL_curcop, PL_parser->copline);
8024 /* protect against fatal warnings leaking compcv */
8025 SAVEFREESV(PL_compcv);
8026 report_redefined_cv(namesv, cv, const_svp);
8027 SvREFCNT_inc_simple_void_NN(PL_compcv);
8028 CopLINE_set(PL_curcop, oldline);
8035 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8040 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8043 CV *compcv = PL_compcv;
8046 PADOFFSET pax = o->op_targ;
8047 CV *outcv = CvOUTSIDE(PL_compcv);
8050 bool reusable = FALSE;
8052 #ifdef PERL_DEBUG_READONLY_OPS
8053 OPSLAB *slab = NULL;
8056 PERL_ARGS_ASSERT_NEWMYSUB;
8058 /* Find the pad slot for storing the new sub.
8059 We cannot use PL_comppad, as it is the pad owned by the new sub. We
8060 need to look in CvOUTSIDE and find the pad belonging to the enclos-
8061 ing sub. And then we need to dig deeper if this is a lexical from
8063 my sub foo; sub { sub foo { } }
8066 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8067 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8068 pax = PARENT_PAD_INDEX(name);
8069 outcv = CvOUTSIDE(outcv);
8074 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8075 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8076 spot = (CV **)svspot;
8078 if (!(PL_parser && PL_parser->error_count))
8079 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8082 assert(proto->op_type == OP_CONST);
8083 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8084 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8094 if (PL_parser && PL_parser->error_count) {
8096 SvREFCNT_dec(PL_compcv);
8101 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8103 svspot = (SV **)(spot = &clonee);
8105 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8108 assert (SvTYPE(*spot) == SVt_PVCV);
8110 hek = CvNAME_HEK(*spot);
8114 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8115 CvNAME_HEK_set(*spot, hek =
8118 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8122 CvLEXICAL_on(*spot);
8124 cv = PadnamePROTOCV(name);
8125 svspot = (SV **)(spot = &PadnamePROTOCV(name));
8129 /* This makes sub {}; work as expected. */
8130 if (block->op_type == OP_STUB) {
8131 const line_t l = PL_parser->copline;
8133 block = newSTATEOP(0, NULL, 0);
8134 PL_parser->copline = l;
8136 block = CvLVALUE(compcv)
8137 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8138 ? newUNOP(OP_LEAVESUBLV, 0,
8139 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8140 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8141 start = LINKLIST(block);
8143 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8144 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8152 const bool exists = CvROOT(cv) || CvXSUB(cv);
8154 /* if the subroutine doesn't exist and wasn't pre-declared
8155 * with a prototype, assume it will be AUTOLOADed,
8156 * skipping the prototype check
8158 if (exists || SvPOK(cv))
8159 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8161 /* already defined? */
8163 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8166 if (attrs) goto attrs;
8167 /* just a "sub foo;" when &foo is already defined */
8172 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8178 SvREFCNT_inc_simple_void_NN(const_sv);
8179 SvFLAGS(const_sv) |= SVs_PADTMP;
8181 assert(!CvROOT(cv) && !CvCONST(cv));
8185 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8186 CvFILE_set_from_cop(cv, PL_curcop);
8187 CvSTASH_set(cv, PL_curstash);
8190 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8191 CvXSUBANY(cv).any_ptr = const_sv;
8192 CvXSUB(cv) = const_sv_xsub;
8196 CvFLAGS(cv) |= CvMETHOD(compcv);
8198 SvREFCNT_dec(compcv);
8202 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8203 determine whether this sub definition is in the same scope as its
8204 declaration. If this sub definition is inside an inner named pack-
8205 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8206 the package sub. So check PadnameOUTER(name) too.
8208 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8209 assert(!CvWEAKOUTSIDE(compcv));
8210 SvREFCNT_dec(CvOUTSIDE(compcv));
8211 CvWEAKOUTSIDE_on(compcv);
8213 /* XXX else do we have a circular reference? */
8214 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8215 /* transfer PL_compcv to cv */
8218 cv_flags_t preserved_flags =
8219 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8220 PADLIST *const temp_padl = CvPADLIST(cv);
8221 CV *const temp_cv = CvOUTSIDE(cv);
8222 const cv_flags_t other_flags =
8223 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8224 OP * const cvstart = CvSTART(cv);
8228 CvFLAGS(compcv) | preserved_flags;
8229 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8230 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8231 CvPADLIST_set(cv, CvPADLIST(compcv));
8232 CvOUTSIDE(compcv) = temp_cv;
8233 CvPADLIST_set(compcv, temp_padl);
8234 CvSTART(cv) = CvSTART(compcv);
8235 CvSTART(compcv) = cvstart;
8236 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8237 CvFLAGS(compcv) |= other_flags;
8239 if (CvFILE(cv) && CvDYNFILE(cv)) {
8240 Safefree(CvFILE(cv));
8243 /* inner references to compcv must be fixed up ... */
8244 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8245 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8246 ++PL_sub_generation;
8249 /* Might have had built-in attributes applied -- propagate them. */
8250 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8252 /* ... before we throw it away */
8253 SvREFCNT_dec(compcv);
8254 PL_compcv = compcv = cv;
8262 if (!CvNAME_HEK(cv)) {
8263 if (hek) (void)share_hek_hek(hek);
8267 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8268 hek = share_hek(PadnamePV(name)+1,
8269 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8272 CvNAME_HEK_set(cv, hek);
8274 if (const_sv) goto clone;
8276 CvFILE_set_from_cop(cv, PL_curcop);
8277 CvSTASH_set(cv, PL_curstash);
8280 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8281 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8287 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8288 the debugger could be able to set a breakpoint in, so signal to
8289 pp_entereval that it should not throw away any saved lines at scope
8292 PL_breakable_sub_gen++;
8294 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8295 OpREFCNT_set(CvROOT(cv), 1);
8296 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8297 itself has a refcount. */
8299 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8300 #ifdef PERL_DEBUG_READONLY_OPS
8301 slab = (OPSLAB *)CvSTART(cv);
8303 CvSTART(cv) = start;
8305 finalize_optree(CvROOT(cv));
8306 S_prune_chain_head(&CvSTART(cv));
8308 /* now that optimizer has done its work, adjust pad values */
8310 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8314 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8315 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8319 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8320 SV * const tmpstr = sv_newmortal();
8321 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8322 GV_ADDMULTI, SVt_PVHV);
8324 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8327 (long)CopLINE(PL_curcop));
8328 if (HvNAME_HEK(PL_curstash)) {
8329 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8330 sv_catpvs(tmpstr, "::");
8332 else sv_setpvs(tmpstr, "__ANON__::");
8333 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8334 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8335 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8336 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8337 hv = GvHVn(db_postponed);
8338 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8339 CV * const pcv = GvCV(db_postponed);
8345 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8353 assert(CvDEPTH(outcv));
8355 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8356 if (reusable) cv_clone_into(clonee, *spot);
8357 else *spot = cv_clone(clonee);
8358 SvREFCNT_dec_NN(clonee);
8361 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8362 PADOFFSET depth = CvDEPTH(outcv);
8365 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8367 *svspot = SvREFCNT_inc_simple_NN(cv);
8368 SvREFCNT_dec(oldcv);
8374 PL_parser->copline = NOLINE;
8376 #ifdef PERL_DEBUG_READONLY_OPS
8386 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8387 OP *block, bool o_is_gv)
8391 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8395 const bool ec = PL_parser && PL_parser->error_count;
8396 /* If the subroutine has no body, no attributes, and no builtin attributes
8397 then it's just a sub declaration, and we may be able to get away with
8398 storing with a placeholder scalar in the symbol table, rather than a
8399 full CV. If anything is present then it will take a full CV to
8401 const I32 gv_fetch_flags
8402 = ec ? GV_NOADD_NOINIT :
8403 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8404 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8406 const char * const name =
8407 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8409 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8410 bool evanescent = FALSE;
8412 #ifdef PERL_DEBUG_READONLY_OPS
8413 OPSLAB *slab = NULL;
8421 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8422 hek and CvSTASH pointer together can imply the GV. If the name
8423 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8424 CvSTASH, so forego the optimisation if we find any.
8425 Also, we may be called from load_module at run time, so
8426 PL_curstash (which sets CvSTASH) may not point to the stash the
8427 sub is stored in. */
8429 ec ? GV_NOADD_NOINIT
8430 : PL_curstash != CopSTASH(PL_curcop)
8431 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8433 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8434 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8436 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8437 SV * const sv = sv_newmortal();
8438 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8439 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8440 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8441 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8443 } else if (PL_curstash) {
8444 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8447 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8452 move_proto_attr(&proto, &attrs, gv);
8455 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8460 assert(proto->op_type == OP_CONST);
8461 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8462 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8476 if (name) SvREFCNT_dec(PL_compcv);
8477 else cv = PL_compcv;
8479 if (name && block) {
8480 const char *s = strrchr(name, ':');
8482 if (strEQ(s, "BEGIN")) {
8483 if (PL_in_eval & EVAL_KEEPERR)
8484 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8486 SV * const errsv = ERRSV;
8487 /* force display of errors found but not reported */
8488 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8489 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8496 if (!block && SvTYPE(gv) != SVt_PVGV) {
8497 /* If we are not defining a new sub and the existing one is not a
8499 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8500 /* We are applying attributes to an existing sub, so we need it
8501 upgraded if it is a constant. */
8502 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8503 gv_init_pvn(gv, PL_curstash, name, namlen,
8504 SVf_UTF8 * name_is_utf8);
8506 else { /* Maybe prototype now, and had at maximum
8507 a prototype or const/sub ref before. */
8508 if (SvTYPE(gv) > SVt_NULL) {
8509 cv_ckproto_len_flags((const CV *)gv,
8510 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8515 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8516 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8519 sv_setiv(MUTABLE_SV(gv), -1);
8522 SvREFCNT_dec(PL_compcv);
8523 cv = PL_compcv = NULL;
8528 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8532 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8537 /* This makes sub {}; work as expected. */
8538 if (block->op_type == OP_STUB) {
8539 const line_t l = PL_parser->copline;
8541 block = newSTATEOP(0, NULL, 0);
8542 PL_parser->copline = l;
8544 block = CvLVALUE(PL_compcv)
8545 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8546 && (!isGV(gv) || !GvASSUMECV(gv)))
8547 ? newUNOP(OP_LEAVESUBLV, 0,
8548 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8549 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8550 start = LINKLIST(block);
8552 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8554 S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
8561 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8563 cv_ckproto_len_flags((const CV *)gv,
8564 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8565 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8567 /* All the other code for sub redefinition warnings expects the
8568 clobbered sub to be a CV. Instead of making all those code
8569 paths more complex, just inline the RV version here. */
8570 const line_t oldline = CopLINE(PL_curcop);
8571 assert(IN_PERL_COMPILETIME);
8572 if (PL_parser && PL_parser->copline != NOLINE)
8573 /* This ensures that warnings are reported at the first
8574 line of a redefinition, not the last. */
8575 CopLINE_set(PL_curcop, PL_parser->copline);
8576 /* protect against fatal warnings leaking compcv */
8577 SAVEFREESV(PL_compcv);
8579 if (ckWARN(WARN_REDEFINE)
8580 || ( ckWARN_d(WARN_REDEFINE)
8581 && ( !const_sv || SvRV(gv) == const_sv
8582 || sv_cmp(SvRV(gv), const_sv) )))
8583 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8584 "Constant subroutine %"SVf" redefined",
8585 SVfARG(cSVOPo->op_sv));
8587 SvREFCNT_inc_simple_void_NN(PL_compcv);
8588 CopLINE_set(PL_curcop, oldline);
8589 SvREFCNT_dec(SvRV(gv));
8594 const bool exists = CvROOT(cv) || CvXSUB(cv);
8596 /* if the subroutine doesn't exist and wasn't pre-declared
8597 * with a prototype, assume it will be AUTOLOADed,
8598 * skipping the prototype check
8600 if (exists || SvPOK(cv))
8601 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8602 /* already defined (or promised)? */
8603 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8604 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8607 if (attrs) goto attrs;
8608 /* just a "sub foo;" when &foo is already defined */
8609 SAVEFREESV(PL_compcv);
8615 SvREFCNT_inc_simple_void_NN(const_sv);
8616 SvFLAGS(const_sv) |= SVs_PADTMP;
8618 assert(!CvROOT(cv) && !CvCONST(cv));
8620 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8621 CvXSUBANY(cv).any_ptr = const_sv;
8622 CvXSUB(cv) = const_sv_xsub;
8626 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8629 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8630 if (name && isGV(gv))
8632 cv = newCONSTSUB_flags(
8633 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8636 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8640 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8641 prepare_SV_for_RV((SV *)gv);
8645 SvRV_set(gv, const_sv);
8649 SvREFCNT_dec(PL_compcv);
8653 if (cv) { /* must reuse cv if autoloaded */
8654 /* transfer PL_compcv to cv */
8657 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8658 PADLIST *const temp_av = CvPADLIST(cv);
8659 CV *const temp_cv = CvOUTSIDE(cv);
8660 const cv_flags_t other_flags =
8661 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8662 OP * const cvstart = CvSTART(cv);
8666 assert(!CvCVGV_RC(cv));
8667 assert(CvGV(cv) == gv);
8672 PERL_HASH(hash, name, namlen);
8682 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8684 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8685 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8686 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8687 CvOUTSIDE(PL_compcv) = temp_cv;
8688 CvPADLIST_set(PL_compcv, temp_av);
8689 CvSTART(cv) = CvSTART(PL_compcv);
8690 CvSTART(PL_compcv) = cvstart;
8691 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8692 CvFLAGS(PL_compcv) |= other_flags;
8694 if (CvFILE(cv) && CvDYNFILE(cv)) {
8695 Safefree(CvFILE(cv));
8697 CvFILE_set_from_cop(cv, PL_curcop);
8698 CvSTASH_set(cv, PL_curstash);
8700 /* inner references to PL_compcv must be fixed up ... */
8701 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8702 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8703 ++PL_sub_generation;
8706 /* Might have had built-in attributes applied -- propagate them. */
8707 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8709 /* ... before we throw it away */
8710 SvREFCNT_dec(PL_compcv);
8715 if (name && isGV(gv)) {
8718 if (HvENAME_HEK(GvSTASH(gv)))
8719 /* sub Foo::bar { (shift)+1 } */
8720 gv_method_changed(gv);
8724 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8725 prepare_SV_for_RV((SV *)gv);
8729 SvRV_set(gv, (SV *)cv);
8733 if (isGV(gv)) CvGV_set(cv, gv);
8737 PERL_HASH(hash, name, namlen);
8738 CvNAME_HEK_set(cv, share_hek(name,
8744 CvFILE_set_from_cop(cv, PL_curcop);
8745 CvSTASH_set(cv, PL_curstash);
8749 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8750 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8756 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8757 the debugger could be able to set a breakpoint in, so signal to
8758 pp_entereval that it should not throw away any saved lines at scope
8761 PL_breakable_sub_gen++;
8763 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8764 OpREFCNT_set(CvROOT(cv), 1);
8765 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8766 itself has a refcount. */
8768 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8769 #ifdef PERL_DEBUG_READONLY_OPS
8770 slab = (OPSLAB *)CvSTART(cv);
8772 CvSTART(cv) = start;
8774 finalize_optree(CvROOT(cv));
8775 S_prune_chain_head(&CvSTART(cv));
8777 /* now that optimizer has done its work, adjust pad values */
8779 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8783 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8784 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8787 if (!name) SAVEFREESV(cv);
8788 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8789 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8792 if (block && has_name) {
8793 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8794 SV * const tmpstr = cv_name(cv,NULL,0);
8795 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8796 GV_ADDMULTI, SVt_PVHV);
8798 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8801 (long)CopLINE(PL_curcop));
8802 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8803 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8804 hv = GvHVn(db_postponed);
8805 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8806 CV * const pcv = GvCV(db_postponed);
8812 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8818 if (PL_parser && PL_parser->error_count)
8819 clear_special_blocks(name, gv, cv);
8822 process_special_blocks(floor, name, gv, cv);
8828 PL_parser->copline = NOLINE;
8831 #ifdef PERL_DEBUG_READONLY_OPS
8835 if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8836 pad_add_weakref(cv);
8842 S_clear_special_blocks(pTHX_ const char *const fullname,
8843 GV *const gv, CV *const cv) {
8847 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8849 colon = strrchr(fullname,':');
8850 name = colon ? colon + 1 : fullname;
8852 if ((*name == 'B' && strEQ(name, "BEGIN"))
8853 || (*name == 'E' && strEQ(name, "END"))
8854 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8855 || (*name == 'C' && strEQ(name, "CHECK"))
8856 || (*name == 'I' && strEQ(name, "INIT"))) {
8862 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8866 /* Returns true if the sub has been freed. */
8868 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8872 const char *const colon = strrchr(fullname,':');
8873 const char *const name = colon ? colon + 1 : fullname;
8875 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8878 if (strEQ(name, "BEGIN")) {
8879 const I32 oldscope = PL_scopestack_ix;
8882 if (floor) LEAVE_SCOPE(floor);
8884 PUSHSTACKi(PERLSI_REQUIRE);
8885 SAVECOPFILE(&PL_compiling);
8886 SAVECOPLINE(&PL_compiling);
8887 SAVEVPTR(PL_curcop);
8889 DEBUG_x( dump_sub(gv) );
8890 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8891 GvCV_set(gv,0); /* cv has been hijacked */
8892 call_list(oldscope, PL_beginav);
8896 return !PL_savebegin;
8902 if strEQ(name, "END") {
8903 DEBUG_x( dump_sub(gv) );
8904 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8907 } else if (*name == 'U') {
8908 if (strEQ(name, "UNITCHECK")) {
8909 /* It's never too late to run a unitcheck block */
8910 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8914 } else if (*name == 'C') {
8915 if (strEQ(name, "CHECK")) {
8917 /* diag_listed_as: Too late to run %s block */
8918 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8919 "Too late to run CHECK block");
8920 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8924 } else if (*name == 'I') {
8925 if (strEQ(name, "INIT")) {
8927 /* diag_listed_as: Too late to run %s block */
8928 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8929 "Too late to run INIT block");
8930 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8936 DEBUG_x( dump_sub(gv) );
8938 GvCV_set(gv,0); /* cv has been hijacked */
8944 =for apidoc newCONSTSUB
8946 See L</newCONSTSUB_flags>.
8952 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8954 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8958 =for apidoc newCONSTSUB_flags
8960 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8961 eligible for inlining at compile-time.
8963 Currently, the only useful value for C<flags> is SVf_UTF8.
8965 The newly created subroutine takes ownership of a reference to the passed in
8968 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8969 which won't be called if used as a destructor, but will suppress the overhead
8970 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8977 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8981 const char *const file = CopFILE(PL_curcop);
8985 if (IN_PERL_RUNTIME) {
8986 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8987 * an op shared between threads. Use a non-shared COP for our
8989 SAVEVPTR(PL_curcop);
8990 SAVECOMPILEWARNINGS();
8991 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8992 PL_curcop = &PL_compiling;
8994 SAVECOPLINE(PL_curcop);
8995 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8998 PL_hints &= ~HINT_BLOCK_SCOPE;
9001 SAVEGENERICSV(PL_curstash);
9002 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9005 /* Protect sv against leakage caused by fatal warnings. */
9006 if (sv) SAVEFREESV(sv);
9008 /* file becomes the CvFILE. For an XS, it's usually static storage,
9009 and so doesn't get free()d. (It's expected to be from the C pre-
9010 processor __FILE__ directive). But we need a dynamically allocated one,
9011 and we need it to get freed. */
9012 cv = newXS_len_flags(name, len,
9013 sv && SvTYPE(sv) == SVt_PVAV
9016 file ? file : "", "",
9017 &sv, XS_DYNAMIC_FILENAME | flags);
9018 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9027 =for apidoc U||newXS
9029 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
9030 static storage, as it is used directly as CvFILE(), without a copy being made.
9036 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9038 PERL_ARGS_ASSERT_NEWXS;
9039 return newXS_len_flags(
9040 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9045 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9046 const char *const filename, const char *const proto,
9049 PERL_ARGS_ASSERT_NEWXS_FLAGS;
9050 return newXS_len_flags(
9051 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9056 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9058 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9059 return newXS_len_flags(
9060 name, strlen(name), subaddr, NULL, NULL, NULL, 0
9065 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9066 XSUBADDR_t subaddr, const char *const filename,
9067 const char *const proto, SV **const_svp,
9071 bool interleave = FALSE;
9073 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9076 GV * const gv = gv_fetchpvn(
9077 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9078 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9079 sizeof("__ANON__::__ANON__") - 1,
9080 GV_ADDMULTI | flags, SVt_PVCV);
9082 if ((cv = (name ? GvCV(gv) : NULL))) {
9084 /* just a cached method */
9088 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9089 /* already defined (or promised) */
9090 /* Redundant check that allows us to avoid creating an SV
9091 most of the time: */
9092 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9093 report_redefined_cv(newSVpvn_flags(
9094 name,len,(flags&SVf_UTF8)|SVs_TEMP
9105 if (cv) /* must reuse cv if autoloaded */
9108 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9112 if (HvENAME_HEK(GvSTASH(gv)))
9113 gv_method_changed(gv); /* newXS */
9119 (void)gv_fetchfile(filename);
9120 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9121 if (flags & XS_DYNAMIC_FILENAME) {
9123 CvFILE(cv) = savepv(filename);
9125 /* NOTE: not copied, as it is expected to be an external constant string */
9126 CvFILE(cv) = (char *)filename;
9129 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9130 CvFILE(cv) = (char*)PL_xsubfilename;
9133 CvXSUB(cv) = subaddr;
9134 #ifndef PERL_IMPLICIT_CONTEXT
9135 CvHSCXT(cv) = &PL_stack_sp;
9141 process_special_blocks(0, name, gv, cv);
9144 } /* <- not a conditional branch */
9147 sv_setpv(MUTABLE_SV(cv), proto);
9148 if (interleave) LEAVE;
9153 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9155 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9157 PERL_ARGS_ASSERT_NEWSTUB;
9161 if (!fake && HvENAME_HEK(GvSTASH(gv)))
9162 gv_method_changed(gv);
9164 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9169 CvFILE_set_from_cop(cv, PL_curcop);
9170 CvSTASH_set(cv, PL_curstash);
9176 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9182 if (PL_parser && PL_parser->error_count) {
9188 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9189 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9192 if ((cv = GvFORM(gv))) {
9193 if (ckWARN(WARN_REDEFINE)) {
9194 const line_t oldline = CopLINE(PL_curcop);
9195 if (PL_parser && PL_parser->copline != NOLINE)
9196 CopLINE_set(PL_curcop, PL_parser->copline);
9198 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9199 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9201 /* diag_listed_as: Format %s redefined */
9202 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9203 "Format STDOUT redefined");
9205 CopLINE_set(PL_curcop, oldline);
9210 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9212 CvFILE_set_from_cop(cv, PL_curcop);
9215 pad_tidy(padtidy_FORMAT);
9216 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9217 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9218 OpREFCNT_set(CvROOT(cv), 1);
9219 CvSTART(cv) = LINKLIST(CvROOT(cv));
9220 CvROOT(cv)->op_next = 0;
9221 CALL_PEEP(CvSTART(cv));
9222 finalize_optree(CvROOT(cv));
9223 S_prune_chain_head(&CvSTART(cv));
9229 PL_parser->copline = NOLINE;
9231 PL_compiling.cop_seq = 0;
9235 Perl_newANONLIST(pTHX_ OP *o)
9237 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9241 Perl_newANONHASH(pTHX_ OP *o)
9243 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9247 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9249 return newANONATTRSUB(floor, proto, NULL, block);
9253 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9255 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9257 newSVOP(OP_ANONCODE, 0,
9259 if (CvANONCONST(cv))
9260 anoncode = newUNOP(OP_ANONCONST, 0,
9261 op_convert_list(OP_ENTERSUB,
9262 OPf_STACKED|OPf_WANT_SCALAR,
9264 return newUNOP(OP_REFGEN, 0, anoncode);
9268 Perl_oopsAV(pTHX_ OP *o)
9272 PERL_ARGS_ASSERT_OOPSAV;
9274 switch (o->op_type) {
9277 OpTYPE_set(o, OP_PADAV);
9278 return ref(o, OP_RV2AV);
9282 OpTYPE_set(o, OP_RV2AV);
9287 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9294 Perl_oopsHV(pTHX_ OP *o)
9298 PERL_ARGS_ASSERT_OOPSHV;
9300 switch (o->op_type) {
9303 OpTYPE_set(o, OP_PADHV);
9304 return ref(o, OP_RV2HV);
9308 OpTYPE_set(o, OP_RV2HV);
9313 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9320 Perl_newAVREF(pTHX_ OP *o)
9324 PERL_ARGS_ASSERT_NEWAVREF;
9326 if (o->op_type == OP_PADANY) {
9327 OpTYPE_set(o, OP_PADAV);
9330 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9331 Perl_croak(aTHX_ "Can't use an array as a reference");
9333 return newUNOP(OP_RV2AV, 0, scalar(o));
9337 Perl_newGVREF(pTHX_ I32 type, OP *o)
9339 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9340 return newUNOP(OP_NULL, 0, o);
9341 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9345 Perl_newHVREF(pTHX_ OP *o)
9349 PERL_ARGS_ASSERT_NEWHVREF;
9351 if (o->op_type == OP_PADANY) {
9352 OpTYPE_set(o, OP_PADHV);
9355 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9356 Perl_croak(aTHX_ "Can't use a hash as a reference");
9358 return newUNOP(OP_RV2HV, 0, scalar(o));
9362 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9364 if (o->op_type == OP_PADANY) {
9366 OpTYPE_set(o, OP_PADCV);
9368 return newUNOP(OP_RV2CV, flags, scalar(o));
9372 Perl_newSVREF(pTHX_ OP *o)
9376 PERL_ARGS_ASSERT_NEWSVREF;
9378 if (o->op_type == OP_PADANY) {
9379 OpTYPE_set(o, OP_PADSV);
9383 return newUNOP(OP_RV2SV, 0, scalar(o));
9386 /* Check routines. See the comments at the top of this file for details
9387 * on when these are called */
9390 Perl_ck_anoncode(pTHX_ OP *o)
9392 PERL_ARGS_ASSERT_CK_ANONCODE;
9394 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9395 cSVOPo->op_sv = NULL;
9400 S_io_hints(pTHX_ OP *o)
9402 #if O_BINARY != 0 || O_TEXT != 0
9404 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9406 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9409 const char *d = SvPV_const(*svp, len);
9410 const I32 mode = mode_from_discipline(d, len);
9411 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9413 if (mode & O_BINARY)
9414 o->op_private |= OPpOPEN_IN_RAW;
9418 o->op_private |= OPpOPEN_IN_CRLF;
9422 svp = hv_fetchs(table, "open_OUT", FALSE);
9425 const char *d = SvPV_const(*svp, len);
9426 const I32 mode = mode_from_discipline(d, len);
9427 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9429 if (mode & O_BINARY)
9430 o->op_private |= OPpOPEN_OUT_RAW;
9434 o->op_private |= OPpOPEN_OUT_CRLF;
9439 PERL_UNUSED_CONTEXT;
9445 Perl_ck_backtick(pTHX_ OP *o)
9450 PERL_ARGS_ASSERT_CK_BACKTICK;
9451 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9452 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9453 && (gv = gv_override("readpipe",8)))
9455 /* detach rest of siblings from o and its first child */
9456 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9457 newop = S_new_entersubop(aTHX_ gv, sibl);
9459 else if (!(o->op_flags & OPf_KIDS))
9460 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9465 S_io_hints(aTHX_ o);
9470 Perl_ck_bitop(pTHX_ OP *o)
9472 PERL_ARGS_ASSERT_CK_BITOP;
9474 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9476 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9477 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9478 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9479 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9480 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9481 "The bitwise feature is experimental");
9482 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9483 && OP_IS_INFIX_BIT(o->op_type))
9485 const OP * const left = cBINOPo->op_first;
9486 const OP * const right = OpSIBLING(left);
9487 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9488 (left->op_flags & OPf_PARENS) == 0) ||
9489 (OP_IS_NUMCOMPARE(right->op_type) &&
9490 (right->op_flags & OPf_PARENS) == 0))
9491 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9492 "Possible precedence problem on bitwise %s operator",
9493 o->op_type == OP_BIT_OR
9494 ||o->op_type == OP_NBIT_OR ? "|"
9495 : o->op_type == OP_BIT_AND
9496 ||o->op_type == OP_NBIT_AND ? "&"
9497 : o->op_type == OP_BIT_XOR
9498 ||o->op_type == OP_NBIT_XOR ? "^"
9499 : o->op_type == OP_SBIT_OR ? "|."
9500 : o->op_type == OP_SBIT_AND ? "&." : "^."
9506 PERL_STATIC_INLINE bool
9507 is_dollar_bracket(pTHX_ const OP * const o)
9510 PERL_UNUSED_CONTEXT;
9511 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9512 && (kid = cUNOPx(o)->op_first)
9513 && kid->op_type == OP_GV
9514 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9518 Perl_ck_cmp(pTHX_ OP *o)
9520 PERL_ARGS_ASSERT_CK_CMP;
9521 if (ckWARN(WARN_SYNTAX)) {
9522 const OP *kid = cUNOPo->op_first;
9525 ( is_dollar_bracket(aTHX_ kid)
9526 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9528 || ( kid->op_type == OP_CONST
9529 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9533 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9534 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9540 Perl_ck_concat(pTHX_ OP *o)
9542 const OP * const kid = cUNOPo->op_first;
9544 PERL_ARGS_ASSERT_CK_CONCAT;
9545 PERL_UNUSED_CONTEXT;
9547 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9548 !(kUNOP->op_first->op_flags & OPf_MOD))
9549 o->op_flags |= OPf_STACKED;
9554 Perl_ck_spair(pTHX_ OP *o)
9558 PERL_ARGS_ASSERT_CK_SPAIR;
9560 if (o->op_flags & OPf_KIDS) {
9564 const OPCODE type = o->op_type;
9565 o = modkids(ck_fun(o), type);
9566 kid = cUNOPo->op_first;
9567 kidkid = kUNOP->op_first;
9568 newop = OpSIBLING(kidkid);
9570 const OPCODE type = newop->op_type;
9571 if (OpHAS_SIBLING(newop))
9573 if (o->op_type == OP_REFGEN
9574 && ( type == OP_RV2CV
9575 || ( !(newop->op_flags & OPf_PARENS)
9576 && ( type == OP_RV2AV || type == OP_PADAV
9577 || type == OP_RV2HV || type == OP_PADHV))))
9578 NOOP; /* OK (allow srefgen for \@a and \%h) */
9579 else if (OP_GIMME(newop,0) != G_SCALAR)
9582 /* excise first sibling */
9583 op_sibling_splice(kid, NULL, 1, NULL);
9586 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9587 * and OP_CHOMP into OP_SCHOMP */
9588 o->op_ppaddr = PL_ppaddr[++o->op_type];
9593 Perl_ck_delete(pTHX_ OP *o)
9595 PERL_ARGS_ASSERT_CK_DELETE;
9599 if (o->op_flags & OPf_KIDS) {
9600 OP * const kid = cUNOPo->op_first;
9601 switch (kid->op_type) {
9603 o->op_flags |= OPf_SPECIAL;
9606 o->op_private |= OPpSLICE;
9609 o->op_flags |= OPf_SPECIAL;
9614 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9615 " use array slice");
9617 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9620 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9621 "element or slice");
9623 if (kid->op_private & OPpLVAL_INTRO)
9624 o->op_private |= OPpLVAL_INTRO;
9631 Perl_ck_eof(pTHX_ OP *o)
9633 PERL_ARGS_ASSERT_CK_EOF;
9635 if (o->op_flags & OPf_KIDS) {
9637 if (cLISTOPo->op_first->op_type == OP_STUB) {
9639 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9644 kid = cLISTOPo->op_first;
9645 if (kid->op_type == OP_RV2GV)
9646 kid->op_private |= OPpALLOW_FAKE;
9652 Perl_ck_eval(pTHX_ OP *o)
9656 PERL_ARGS_ASSERT_CK_EVAL;
9658 PL_hints |= HINT_BLOCK_SCOPE;
9659 if (o->op_flags & OPf_KIDS) {
9660 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9663 if (o->op_type == OP_ENTERTRY) {
9666 /* cut whole sibling chain free from o */
9667 op_sibling_splice(o, NULL, -1, NULL);
9670 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9672 /* establish postfix order */
9673 enter->op_next = (OP*)enter;
9675 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9676 OpTYPE_set(o, OP_LEAVETRY);
9677 enter->op_other = o;
9682 S_set_haseval(aTHX);
9686 const U8 priv = o->op_private;
9688 /* the newUNOP will recursively call ck_eval(), which will handle
9689 * all the stuff at the end of this function, like adding
9692 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9694 o->op_targ = (PADOFFSET)PL_hints;
9695 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9696 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9697 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9698 /* Store a copy of %^H that pp_entereval can pick up. */
9699 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9700 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9701 /* append hhop to only child */
9702 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9704 o->op_private |= OPpEVAL_HAS_HH;
9706 if (!(o->op_private & OPpEVAL_BYTES)
9707 && FEATURE_UNIEVAL_IS_ENABLED)
9708 o->op_private |= OPpEVAL_UNICODE;
9713 Perl_ck_exec(pTHX_ OP *o)
9715 PERL_ARGS_ASSERT_CK_EXEC;
9717 if (o->op_flags & OPf_STACKED) {
9720 kid = OpSIBLING(cUNOPo->op_first);
9721 if (kid->op_type == OP_RV2GV)
9730 Perl_ck_exists(pTHX_ OP *o)
9732 PERL_ARGS_ASSERT_CK_EXISTS;
9735 if (o->op_flags & OPf_KIDS) {
9736 OP * const kid = cUNOPo->op_first;
9737 if (kid->op_type == OP_ENTERSUB) {
9738 (void) ref(kid, o->op_type);
9739 if (kid->op_type != OP_RV2CV
9740 && !(PL_parser && PL_parser->error_count))
9742 "exists argument is not a subroutine name");
9743 o->op_private |= OPpEXISTS_SUB;
9745 else if (kid->op_type == OP_AELEM)
9746 o->op_flags |= OPf_SPECIAL;
9747 else if (kid->op_type != OP_HELEM)
9748 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9749 "element or a subroutine");
9756 Perl_ck_rvconst(pTHX_ OP *o)
9759 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9761 PERL_ARGS_ASSERT_CK_RVCONST;
9763 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9765 if (kid->op_type == OP_CONST) {
9768 SV * const kidsv = kid->op_sv;
9770 /* Is it a constant from cv_const_sv()? */
9771 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9774 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9775 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9776 const char *badthing;
9777 switch (o->op_type) {
9779 badthing = "a SCALAR";
9782 badthing = "an ARRAY";
9785 badthing = "a HASH";
9793 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9794 SVfARG(kidsv), badthing);
9797 * This is a little tricky. We only want to add the symbol if we
9798 * didn't add it in the lexer. Otherwise we get duplicate strict
9799 * warnings. But if we didn't add it in the lexer, we must at
9800 * least pretend like we wanted to add it even if it existed before,
9801 * or we get possible typo warnings. OPpCONST_ENTERED says
9802 * whether the lexer already added THIS instance of this symbol.
9804 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9805 gv = gv_fetchsv(kidsv,
9806 o->op_type == OP_RV2CV
9807 && o->op_private & OPpMAY_RETURN_CONSTANT
9809 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9812 : o->op_type == OP_RV2SV
9814 : o->op_type == OP_RV2AV
9816 : o->op_type == OP_RV2HV
9823 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9824 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9825 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9827 OpTYPE_set(kid, OP_GV);
9828 SvREFCNT_dec(kid->op_sv);
9830 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9831 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9832 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9833 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9834 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9836 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9838 kid->op_private = 0;
9839 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9847 Perl_ck_ftst(pTHX_ OP *o)
9850 const I32 type = o->op_type;
9852 PERL_ARGS_ASSERT_CK_FTST;
9854 if (o->op_flags & OPf_REF) {
9857 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9858 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9859 const OPCODE kidtype = kid->op_type;
9861 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9862 && !kid->op_folded) {
9863 OP * const newop = newGVOP(type, OPf_REF,
9864 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9868 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9869 o->op_private |= OPpFT_ACCESS;
9870 if (type != OP_STAT && type != OP_LSTAT
9871 && PL_check[kidtype] == Perl_ck_ftst
9872 && kidtype != OP_STAT && kidtype != OP_LSTAT
9874 o->op_private |= OPpFT_STACKED;
9875 kid->op_private |= OPpFT_STACKING;
9876 if (kidtype == OP_FTTTY && (
9877 !(kid->op_private & OPpFT_STACKED)
9878 || kid->op_private & OPpFT_AFTER_t
9880 o->op_private |= OPpFT_AFTER_t;
9885 if (type == OP_FTTTY)
9886 o = newGVOP(type, OPf_REF, PL_stdingv);
9888 o = newUNOP(type, 0, newDEFSVOP());
9894 Perl_ck_fun(pTHX_ OP *o)
9896 const int type = o->op_type;
9897 I32 oa = PL_opargs[type] >> OASHIFT;
9899 PERL_ARGS_ASSERT_CK_FUN;
9901 if (o->op_flags & OPf_STACKED) {
9902 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9905 return no_fh_allowed(o);
9908 if (o->op_flags & OPf_KIDS) {
9909 OP *prev_kid = NULL;
9910 OP *kid = cLISTOPo->op_first;
9912 bool seen_optional = FALSE;
9914 if (kid->op_type == OP_PUSHMARK ||
9915 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9918 kid = OpSIBLING(kid);
9920 if (kid && kid->op_type == OP_COREARGS) {
9921 bool optional = FALSE;
9924 if (oa & OA_OPTIONAL) optional = TRUE;
9927 if (optional) o->op_private |= numargs;
9932 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9933 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9935 /* append kid to chain */
9936 op_sibling_splice(o, prev_kid, 0, kid);
9938 seen_optional = TRUE;
9945 /* list seen where single (scalar) arg expected? */
9946 if (numargs == 1 && !(oa >> 4)
9947 && kid->op_type == OP_LIST && type != OP_SCALAR)
9949 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9951 if (type != OP_DELETE) scalar(kid);
9962 if ((type == OP_PUSH || type == OP_UNSHIFT)
9963 && !OpHAS_SIBLING(kid))
9964 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9965 "Useless use of %s with no values",
9968 if (kid->op_type == OP_CONST
9969 && ( !SvROK(cSVOPx_sv(kid))
9970 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9972 bad_type_pv(numargs, "array", o, kid);
9973 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9974 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9975 PL_op_desc[type]), 0);
9978 op_lvalue(kid, type);
9982 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9983 bad_type_pv(numargs, "hash", o, kid);
9984 op_lvalue(kid, type);
9988 /* replace kid with newop in chain */
9990 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9991 newop->op_next = newop;
9996 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9997 if (kid->op_type == OP_CONST &&
9998 (kid->op_private & OPpCONST_BARE))
10000 OP * const newop = newGVOP(OP_GV, 0,
10001 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10002 /* replace kid with newop in chain */
10003 op_sibling_splice(o, prev_kid, 1, newop);
10007 else if (kid->op_type == OP_READLINE) {
10008 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10009 bad_type_pv(numargs, "HANDLE", o, kid);
10012 I32 flags = OPf_SPECIAL;
10014 PADOFFSET targ = 0;
10016 /* is this op a FH constructor? */
10017 if (is_handle_constructor(o,numargs)) {
10018 const char *name = NULL;
10021 bool want_dollar = TRUE;
10024 /* Set a flag to tell rv2gv to vivify
10025 * need to "prove" flag does not mean something
10026 * else already - NI-S 1999/05/07
10029 if (kid->op_type == OP_PADSV) {
10031 = PAD_COMPNAME_SV(kid->op_targ);
10032 name = PadnamePV (pn);
10033 len = PadnameLEN(pn);
10034 name_utf8 = PadnameUTF8(pn);
10036 else if (kid->op_type == OP_RV2SV
10037 && kUNOP->op_first->op_type == OP_GV)
10039 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10041 len = GvNAMELEN(gv);
10042 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10044 else if (kid->op_type == OP_AELEM
10045 || kid->op_type == OP_HELEM)
10048 OP *op = ((BINOP*)kid)->op_first;
10052 const char * const a =
10053 kid->op_type == OP_AELEM ?
10055 if (((op->op_type == OP_RV2AV) ||
10056 (op->op_type == OP_RV2HV)) &&
10057 (firstop = ((UNOP*)op)->op_first) &&
10058 (firstop->op_type == OP_GV)) {
10059 /* packagevar $a[] or $h{} */
10060 GV * const gv = cGVOPx_gv(firstop);
10063 Perl_newSVpvf(aTHX_
10068 else if (op->op_type == OP_PADAV
10069 || op->op_type == OP_PADHV) {
10070 /* lexicalvar $a[] or $h{} */
10071 const char * const padname =
10072 PAD_COMPNAME_PV(op->op_targ);
10075 Perl_newSVpvf(aTHX_
10081 name = SvPV_const(tmpstr, len);
10082 name_utf8 = SvUTF8(tmpstr);
10083 sv_2mortal(tmpstr);
10087 name = "__ANONIO__";
10089 want_dollar = FALSE;
10091 op_lvalue(kid, type);
10095 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10096 namesv = PAD_SVl(targ);
10097 if (want_dollar && *name != '$')
10098 sv_setpvs(namesv, "$");
10100 sv_setpvs(namesv, "");
10101 sv_catpvn(namesv, name, len);
10102 if ( name_utf8 ) SvUTF8_on(namesv);
10106 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10108 kid->op_targ = targ;
10109 kid->op_private |= priv;
10115 if ((type == OP_UNDEF || type == OP_POS)
10116 && numargs == 1 && !(oa >> 4)
10117 && kid->op_type == OP_LIST)
10118 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10119 op_lvalue(scalar(kid), type);
10124 kid = OpSIBLING(kid);
10126 /* FIXME - should the numargs or-ing move after the too many
10127 * arguments check? */
10128 o->op_private |= numargs;
10130 return too_many_arguments_pv(o,OP_DESC(o), 0);
10133 else if (PL_opargs[type] & OA_DEFGV) {
10134 /* Ordering of these two is important to keep f_map.t passing. */
10136 return newUNOP(type, 0, newDEFSVOP());
10140 while (oa & OA_OPTIONAL)
10142 if (oa && oa != OA_LIST)
10143 return too_few_arguments_pv(o,OP_DESC(o), 0);
10149 Perl_ck_glob(pTHX_ OP *o)
10153 PERL_ARGS_ASSERT_CK_GLOB;
10156 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10157 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10159 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10163 * \ null - const(wildcard)
10168 * \ mark - glob - rv2cv
10169 * | \ gv(CORE::GLOBAL::glob)
10171 * \ null - const(wildcard)
10173 o->op_flags |= OPf_SPECIAL;
10174 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10175 o = S_new_entersubop(aTHX_ gv, o);
10176 o = newUNOP(OP_NULL, 0, o);
10177 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10180 else o->op_flags &= ~OPf_SPECIAL;
10181 #if !defined(PERL_EXTERNAL_GLOB)
10182 if (!PL_globhook) {
10184 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10185 newSVpvs("File::Glob"), NULL, NULL, NULL);
10188 #endif /* !PERL_EXTERNAL_GLOB */
10189 gv = (GV *)newSV(0);
10190 gv_init(gv, 0, "", 0, 0);
10192 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10193 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10199 Perl_ck_grep(pTHX_ OP *o)
10203 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10206 PERL_ARGS_ASSERT_CK_GREP;
10208 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10210 if (o->op_flags & OPf_STACKED) {
10211 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10212 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10213 return no_fh_allowed(o);
10214 o->op_flags &= ~OPf_STACKED;
10216 kid = OpSIBLING(cLISTOPo->op_first);
10217 if (type == OP_MAPWHILE)
10222 if (PL_parser && PL_parser->error_count)
10224 kid = OpSIBLING(cLISTOPo->op_first);
10225 if (kid->op_type != OP_NULL)
10226 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10227 kid = kUNOP->op_first;
10229 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10230 kid->op_next = (OP*)gwop;
10231 offset = pad_findmy_pvs("$_", 0);
10232 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
10233 o->op_private = gwop->op_private = 0;
10234 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10237 o->op_private = gwop->op_private = OPpGREP_LEX;
10238 gwop->op_targ = o->op_targ = offset;
10241 kid = OpSIBLING(cLISTOPo->op_first);
10242 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10243 op_lvalue(kid, OP_GREPSTART);
10249 Perl_ck_index(pTHX_ OP *o)
10251 PERL_ARGS_ASSERT_CK_INDEX;
10253 if (o->op_flags & OPf_KIDS) {
10254 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10256 kid = OpSIBLING(kid); /* get past "big" */
10257 if (kid && kid->op_type == OP_CONST) {
10258 const bool save_taint = TAINT_get;
10259 SV *sv = kSVOP->op_sv;
10260 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10262 sv_copypv(sv, kSVOP->op_sv);
10263 SvREFCNT_dec_NN(kSVOP->op_sv);
10266 if (SvOK(sv)) fbm_compile(sv, 0);
10267 TAINT_set(save_taint);
10268 #ifdef NO_TAINT_SUPPORT
10269 PERL_UNUSED_VAR(save_taint);
10277 Perl_ck_lfun(pTHX_ OP *o)
10279 const OPCODE type = o->op_type;
10281 PERL_ARGS_ASSERT_CK_LFUN;
10283 return modkids(ck_fun(o), type);
10287 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10289 PERL_ARGS_ASSERT_CK_DEFINED;
10291 if ((o->op_flags & OPf_KIDS)) {
10292 switch (cUNOPo->op_first->op_type) {
10295 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10296 " (Maybe you should just omit the defined()?)");
10300 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10301 " (Maybe you should just omit the defined()?)");
10312 Perl_ck_readline(pTHX_ OP *o)
10314 PERL_ARGS_ASSERT_CK_READLINE;
10316 if (o->op_flags & OPf_KIDS) {
10317 OP *kid = cLISTOPo->op_first;
10318 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10322 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10330 Perl_ck_rfun(pTHX_ OP *o)
10332 const OPCODE type = o->op_type;
10334 PERL_ARGS_ASSERT_CK_RFUN;
10336 return refkids(ck_fun(o), type);
10340 Perl_ck_listiob(pTHX_ OP *o)
10344 PERL_ARGS_ASSERT_CK_LISTIOB;
10346 kid = cLISTOPo->op_first;
10348 o = force_list(o, 1);
10349 kid = cLISTOPo->op_first;
10351 if (kid->op_type == OP_PUSHMARK)
10352 kid = OpSIBLING(kid);
10353 if (kid && o->op_flags & OPf_STACKED)
10354 kid = OpSIBLING(kid);
10355 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10356 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10357 && !kid->op_folded) {
10358 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10360 /* replace old const op with new OP_RV2GV parent */
10361 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10362 OP_RV2GV, OPf_REF);
10363 kid = OpSIBLING(kid);
10368 op_append_elem(o->op_type, o, newDEFSVOP());
10370 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10371 return listkids(o);
10375 Perl_ck_smartmatch(pTHX_ OP *o)
10378 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10379 if (0 == (o->op_flags & OPf_SPECIAL)) {
10380 OP *first = cBINOPo->op_first;
10381 OP *second = OpSIBLING(first);
10383 /* Implicitly take a reference to an array or hash */
10385 /* remove the original two siblings, then add back the
10386 * (possibly different) first and second sibs.
10388 op_sibling_splice(o, NULL, 1, NULL);
10389 op_sibling_splice(o, NULL, 1, NULL);
10390 first = ref_array_or_hash(first);
10391 second = ref_array_or_hash(second);
10392 op_sibling_splice(o, NULL, 0, second);
10393 op_sibling_splice(o, NULL, 0, first);
10395 /* Implicitly take a reference to a regular expression */
10396 if (first->op_type == OP_MATCH) {
10397 OpTYPE_set(first, OP_QR);
10399 if (second->op_type == OP_MATCH) {
10400 OpTYPE_set(second, OP_QR);
10409 S_maybe_targlex(pTHX_ OP *o)
10411 OP * const kid = cLISTOPo->op_first;
10412 /* has a disposable target? */
10413 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10414 && !(kid->op_flags & OPf_STACKED)
10415 /* Cannot steal the second time! */
10416 && !(kid->op_private & OPpTARGET_MY)
10419 OP * const kkid = OpSIBLING(kid);
10421 /* Can just relocate the target. */
10422 if (kkid && kkid->op_type == OP_PADSV
10423 && (!(kkid->op_private & OPpLVAL_INTRO)
10424 || kkid->op_private & OPpPAD_STATE))
10426 kid->op_targ = kkid->op_targ;
10428 /* Now we do not need PADSV and SASSIGN.
10429 * Detach kid and free the rest. */
10430 op_sibling_splice(o, NULL, 1, NULL);
10432 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10440 Perl_ck_sassign(pTHX_ OP *o)
10443 OP * const kid = cLISTOPo->op_first;
10445 PERL_ARGS_ASSERT_CK_SASSIGN;
10447 if (OpHAS_SIBLING(kid)) {
10448 OP *kkid = OpSIBLING(kid);
10449 /* For state variable assignment with attributes, kkid is a list op
10450 whose op_last is a padsv. */
10451 if ((kkid->op_type == OP_PADSV ||
10452 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10453 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10456 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10457 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10458 const PADOFFSET target = kkid->op_targ;
10459 OP *const other = newOP(OP_PADSV,
10461 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10462 OP *const first = newOP(OP_NULL, 0);
10464 newCONDOP(0, first, o, other);
10465 /* XXX targlex disabled for now; see ticket #124160
10466 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10468 OP *const condop = first->op_next;
10470 OpTYPE_set(condop, OP_ONCE);
10471 other->op_targ = target;
10472 nullop->op_flags |= OPf_WANT_SCALAR;
10474 /* Store the initializedness of state vars in a separate
10477 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10478 /* hijacking PADSTALE for uninitialized state variables */
10479 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10484 return S_maybe_targlex(aTHX_ o);
10488 Perl_ck_match(pTHX_ OP *o)
10490 PERL_ARGS_ASSERT_CK_MATCH;
10492 if (o->op_type != OP_QR && PL_compcv) {
10493 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
10494 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
10495 o->op_targ = offset;
10496 o->op_private |= OPpTARGET_MY;
10499 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10500 o->op_private |= OPpRUNTIME;
10505 Perl_ck_method(pTHX_ OP *o)
10507 SV *sv, *methsv, *rclass;
10508 const char* method;
10511 STRLEN len, nsplit = 0, i;
10513 OP * const kid = cUNOPo->op_first;
10515 PERL_ARGS_ASSERT_CK_METHOD;
10516 if (kid->op_type != OP_CONST) return o;
10520 /* replace ' with :: */
10521 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10523 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10526 method = SvPVX_const(sv);
10528 utf8 = SvUTF8(sv) ? -1 : 1;
10530 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10535 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10537 if (!nsplit) { /* $proto->method() */
10539 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10542 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10544 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10547 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10548 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10549 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10550 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10552 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10553 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10555 #ifdef USE_ITHREADS
10556 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10558 cMETHOPx(new_op)->op_rclass_sv = rclass;
10565 Perl_ck_null(pTHX_ OP *o)
10567 PERL_ARGS_ASSERT_CK_NULL;
10568 PERL_UNUSED_CONTEXT;
10573 Perl_ck_open(pTHX_ OP *o)
10575 PERL_ARGS_ASSERT_CK_OPEN;
10577 S_io_hints(aTHX_ o);
10579 /* In case of three-arg dup open remove strictness
10580 * from the last arg if it is a bareword. */
10581 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10582 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10586 if ((last->op_type == OP_CONST) && /* The bareword. */
10587 (last->op_private & OPpCONST_BARE) &&
10588 (last->op_private & OPpCONST_STRICT) &&
10589 (oa = OpSIBLING(first)) && /* The fh. */
10590 (oa = OpSIBLING(oa)) && /* The mode. */
10591 (oa->op_type == OP_CONST) &&
10592 SvPOK(((SVOP*)oa)->op_sv) &&
10593 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10594 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10595 (last == OpSIBLING(oa))) /* The bareword. */
10596 last->op_private &= ~OPpCONST_STRICT;
10602 Perl_ck_prototype(pTHX_ OP *o)
10604 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10605 if (!(o->op_flags & OPf_KIDS)) {
10607 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10613 Perl_ck_refassign(pTHX_ OP *o)
10615 OP * const right = cLISTOPo->op_first;
10616 OP * const left = OpSIBLING(right);
10617 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10620 PERL_ARGS_ASSERT_CK_REFASSIGN;
10622 assert (left->op_type == OP_SREFGEN);
10624 o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
10626 switch (varop->op_type) {
10628 o->op_private |= OPpLVREF_AV;
10631 o->op_private |= OPpLVREF_HV;
10634 o->op_targ = varop->op_targ;
10635 varop->op_targ = 0;
10636 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10639 o->op_private |= OPpLVREF_AV;
10641 NOT_REACHED; /* NOTREACHED */
10643 o->op_private |= OPpLVREF_HV;
10647 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10649 /* Point varop to its GV kid, detached. */
10650 varop = op_sibling_splice(varop, NULL, -1, NULL);
10654 OP * const kidparent =
10655 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10656 OP * const kid = cUNOPx(kidparent)->op_first;
10657 o->op_private |= OPpLVREF_CV;
10658 if (kid->op_type == OP_GV) {
10660 goto detach_and_stack;
10662 if (kid->op_type != OP_PADCV) goto bad;
10663 o->op_targ = kid->op_targ;
10669 o->op_private |= OPpLVREF_ELEM;
10672 /* Detach varop. */
10673 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10677 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10678 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10683 if (!FEATURE_REFALIASING_IS_ENABLED)
10685 "Experimental aliasing via reference not enabled");
10686 Perl_ck_warner_d(aTHX_
10687 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10688 "Aliasing via reference is experimental");
10690 o->op_flags |= OPf_STACKED;
10691 op_sibling_splice(o, right, 1, varop);
10694 o->op_flags &=~ OPf_STACKED;
10695 op_sibling_splice(o, right, 1, NULL);
10702 Perl_ck_repeat(pTHX_ OP *o)
10704 PERL_ARGS_ASSERT_CK_REPEAT;
10706 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10708 o->op_private |= OPpREPEAT_DOLIST;
10709 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10710 kids = force_list(kids, 1); /* promote it to a list */
10711 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10719 Perl_ck_require(pTHX_ OP *o)
10723 PERL_ARGS_ASSERT_CK_REQUIRE;
10725 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10726 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10731 if (kid->op_type == OP_CONST) {
10732 SV * const sv = kid->op_sv;
10733 U32 const was_readonly = SvREADONLY(sv);
10734 if (kid->op_private & OPpCONST_BARE) {
10738 if (was_readonly) {
10739 SvREADONLY_off(sv);
10741 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10746 for (; s < end; s++) {
10747 if (*s == ':' && s[1] == ':') {
10749 Move(s+2, s+1, end - s - 1, char);
10753 SvEND_set(sv, end);
10754 sv_catpvs(sv, ".pm");
10755 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10756 hek = share_hek(SvPVX(sv),
10757 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10759 sv_sethek(sv, hek);
10761 SvFLAGS(sv) |= was_readonly;
10763 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10766 if (SvREFCNT(sv) > 1) {
10767 kid->op_sv = newSVpvn_share(
10768 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10769 SvREFCNT_dec_NN(sv);
10773 if (was_readonly) SvREADONLY_off(sv);
10774 PERL_HASH(hash, s, len);
10776 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10778 sv_sethek(sv, hek);
10780 SvFLAGS(sv) |= was_readonly;
10786 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10787 /* handle override, if any */
10788 && (gv = gv_override("require", 7))) {
10790 if (o->op_flags & OPf_KIDS) {
10791 kid = cUNOPo->op_first;
10792 op_sibling_splice(o, NULL, -1, NULL);
10795 kid = newDEFSVOP();
10798 newop = S_new_entersubop(aTHX_ gv, kid);
10806 Perl_ck_return(pTHX_ OP *o)
10810 PERL_ARGS_ASSERT_CK_RETURN;
10812 kid = OpSIBLING(cLISTOPo->op_first);
10813 if (CvLVALUE(PL_compcv)) {
10814 for (; kid; kid = OpSIBLING(kid))
10815 op_lvalue(kid, OP_LEAVESUBLV);
10822 Perl_ck_select(pTHX_ OP *o)
10827 PERL_ARGS_ASSERT_CK_SELECT;
10829 if (o->op_flags & OPf_KIDS) {
10830 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10831 if (kid && OpHAS_SIBLING(kid)) {
10832 OpTYPE_set(o, OP_SSELECT);
10834 return fold_constants(op_integerize(op_std_init(o)));
10838 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10839 if (kid && kid->op_type == OP_RV2GV)
10840 kid->op_private &= ~HINT_STRICT_REFS;
10845 Perl_ck_shift(pTHX_ OP *o)
10847 const I32 type = o->op_type;
10849 PERL_ARGS_ASSERT_CK_SHIFT;
10851 if (!(o->op_flags & OPf_KIDS)) {
10854 if (!CvUNIQUE(PL_compcv)) {
10855 o->op_flags |= OPf_SPECIAL;
10859 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10861 return newUNOP(type, 0, scalar(argop));
10863 return scalar(ck_fun(o));
10867 Perl_ck_sort(pTHX_ OP *o)
10871 HV * const hinthv =
10872 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10875 PERL_ARGS_ASSERT_CK_SORT;
10878 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10880 const I32 sorthints = (I32)SvIV(*svp);
10881 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10882 o->op_private |= OPpSORT_QSORT;
10883 if ((sorthints & HINT_SORT_STABLE) != 0)
10884 o->op_private |= OPpSORT_STABLE;
10888 if (o->op_flags & OPf_STACKED)
10890 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10892 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10893 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10895 /* if the first arg is a code block, process it and mark sort as
10897 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10899 if (kid->op_type == OP_LEAVE)
10900 op_null(kid); /* wipe out leave */
10901 /* Prevent execution from escaping out of the sort block. */
10904 /* provide scalar context for comparison function/block */
10905 kid = scalar(firstkid);
10906 kid->op_next = kid;
10907 o->op_flags |= OPf_SPECIAL;
10909 else if (kid->op_type == OP_CONST
10910 && kid->op_private & OPpCONST_BARE) {
10914 const char * const name = SvPV(kSVOP_sv, len);
10916 assert (len < 256);
10917 Copy(name, tmpbuf+1, len, char);
10918 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10919 if (off != NOT_IN_PAD) {
10920 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10922 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10923 sv_catpvs(fq, "::");
10924 sv_catsv(fq, kSVOP_sv);
10925 SvREFCNT_dec_NN(kSVOP_sv);
10929 OP * const padop = newOP(OP_PADCV, 0);
10930 padop->op_targ = off;
10931 /* replace the const op with the pad op */
10932 op_sibling_splice(firstkid, NULL, 1, padop);
10938 firstkid = OpSIBLING(firstkid);
10941 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10942 /* provide list context for arguments */
10945 op_lvalue(kid, OP_GREPSTART);
10951 /* for sort { X } ..., where X is one of
10952 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10953 * elide the second child of the sort (the one containing X),
10954 * and set these flags as appropriate
10958 * Also, check and warn on lexical $a, $b.
10962 S_simplify_sort(pTHX_ OP *o)
10964 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10968 const char *gvname;
10971 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10973 kid = kUNOP->op_first; /* get past null */
10974 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10975 && kid->op_type != OP_LEAVE)
10977 kid = kLISTOP->op_last; /* get past scope */
10978 switch(kid->op_type) {
10982 if (!have_scopeop) goto padkids;
10987 k = kid; /* remember this node*/
10988 if (kBINOP->op_first->op_type != OP_RV2SV
10989 || kBINOP->op_last ->op_type != OP_RV2SV)
10992 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10993 then used in a comparison. This catches most, but not
10994 all cases. For instance, it catches
10995 sort { my($a); $a <=> $b }
10997 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10998 (although why you'd do that is anyone's guess).
11002 if (!ckWARN(WARN_SYNTAX)) return;
11003 kid = kBINOP->op_first;
11005 if (kid->op_type == OP_PADSV) {
11006 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11007 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11008 && ( PadnamePV(name)[1] == 'a'
11009 || PadnamePV(name)[1] == 'b' ))
11010 /* diag_listed_as: "my %s" used in sort comparison */
11011 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11012 "\"%s %s\" used in sort comparison",
11013 PadnameIsSTATE(name)
11018 } while ((kid = OpSIBLING(kid)));
11021 kid = kBINOP->op_first; /* get past cmp */
11022 if (kUNOP->op_first->op_type != OP_GV)
11024 kid = kUNOP->op_first; /* get past rv2sv */
11026 if (GvSTASH(gv) != PL_curstash)
11028 gvname = GvNAME(gv);
11029 if (*gvname == 'a' && gvname[1] == '\0')
11031 else if (*gvname == 'b' && gvname[1] == '\0')
11036 kid = k; /* back to cmp */
11037 /* already checked above that it is rv2sv */
11038 kid = kBINOP->op_last; /* down to 2nd arg */
11039 if (kUNOP->op_first->op_type != OP_GV)
11041 kid = kUNOP->op_first; /* get past rv2sv */
11043 if (GvSTASH(gv) != PL_curstash)
11045 gvname = GvNAME(gv);
11047 ? !(*gvname == 'a' && gvname[1] == '\0')
11048 : !(*gvname == 'b' && gvname[1] == '\0'))
11050 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11052 o->op_private |= OPpSORT_DESCEND;
11053 if (k->op_type == OP_NCMP)
11054 o->op_private |= OPpSORT_NUMERIC;
11055 if (k->op_type == OP_I_NCMP)
11056 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11057 kid = OpSIBLING(cLISTOPo->op_first);
11058 /* cut out and delete old block (second sibling) */
11059 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11064 Perl_ck_split(pTHX_ OP *o)
11069 PERL_ARGS_ASSERT_CK_SPLIT;
11071 if (o->op_flags & OPf_STACKED)
11072 return no_fh_allowed(o);
11074 kid = cLISTOPo->op_first;
11075 if (kid->op_type != OP_NULL)
11076 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
11077 /* delete leading NULL node, then add a CONST if no other nodes */
11078 op_sibling_splice(o, NULL, 1,
11079 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11081 kid = cLISTOPo->op_first;
11083 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11084 /* remove kid, and replace with new optree */
11085 op_sibling_splice(o, NULL, 1, NULL);
11086 /* OPf_SPECIAL is used to trigger split " " behavior */
11087 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
11088 op_sibling_splice(o, NULL, 0, kid);
11090 OpTYPE_set(kid, OP_PUSHRE);
11091 /* target implies @ary=..., so wipe it */
11094 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11095 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11096 "Use of /g modifier is meaningless in split");
11099 if (!OpHAS_SIBLING(kid))
11100 op_append_elem(OP_SPLIT, o, newDEFSVOP());
11102 kid = OpSIBLING(kid);
11106 if (!OpHAS_SIBLING(kid))
11108 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
11109 o->op_private |= OPpSPLIT_IMPLIM;
11111 assert(OpHAS_SIBLING(kid));
11113 kid = OpSIBLING(kid);
11116 if (OpHAS_SIBLING(kid))
11117 return too_many_arguments_pv(o,OP_DESC(o), 0);
11123 Perl_ck_stringify(pTHX_ OP *o)
11125 OP * const kid = OpSIBLING(cUNOPo->op_first);
11126 PERL_ARGS_ASSERT_CK_STRINGIFY;
11127 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11128 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
11129 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
11130 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11132 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11140 Perl_ck_join(pTHX_ OP *o)
11142 OP * const kid = OpSIBLING(cLISTOPo->op_first);
11144 PERL_ARGS_ASSERT_CK_JOIN;
11146 if (kid && kid->op_type == OP_MATCH) {
11147 if (ckWARN(WARN_SYNTAX)) {
11148 const REGEXP *re = PM_GETRE(kPMOP);
11150 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11151 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11152 : newSVpvs_flags( "STRING", SVs_TEMP );
11153 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11154 "/%"SVf"/ should probably be written as \"%"SVf"\"",
11155 SVfARG(msg), SVfARG(msg));
11159 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11160 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11161 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11162 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11164 const OP * const bairn = OpSIBLING(kid); /* the list */
11165 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11166 && OP_GIMME(bairn,0) == G_SCALAR)
11168 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11169 op_sibling_splice(o, kid, 1, NULL));
11179 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11181 Examines an op, which is expected to identify a subroutine at runtime,
11182 and attempts to determine at compile time which subroutine it identifies.
11183 This is normally used during Perl compilation to determine whether
11184 a prototype can be applied to a function call. I<cvop> is the op
11185 being considered, normally an C<rv2cv> op. A pointer to the identified
11186 subroutine is returned, if it could be determined statically, and a null
11187 pointer is returned if it was not possible to determine statically.
11189 Currently, the subroutine can be identified statically if the RV that the
11190 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11191 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11192 suitable if the constant value must be an RV pointing to a CV. Details of
11193 this process may change in future versions of Perl. If the C<rv2cv> op
11194 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11195 the subroutine statically: this flag is used to suppress compile-time
11196 magic on a subroutine call, forcing it to use default runtime behaviour.
11198 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11199 of a GV reference is modified. If a GV was examined and its CV slot was
11200 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11201 If the op is not optimised away, and the CV slot is later populated with
11202 a subroutine having a prototype, that flag eventually triggers the warning
11203 "called too early to check prototype".
11205 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11206 of returning a pointer to the subroutine it returns a pointer to the
11207 GV giving the most appropriate name for the subroutine in this context.
11208 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11209 (C<CvANON>) subroutine that is referenced through a GV it will be the
11210 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11211 A null pointer is returned as usual if there is no statically-determinable
11217 /* shared by toke.c:yylex */
11219 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11221 PADNAME *name = PAD_COMPNAME(off);
11222 CV *compcv = PL_compcv;
11223 while (PadnameOUTER(name)) {
11224 assert(PARENT_PAD_INDEX(name));
11225 compcv = CvOUTSIDE(compcv);
11226 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11227 [off = PARENT_PAD_INDEX(name)];
11229 assert(!PadnameIsOUR(name));
11230 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11231 return PadnamePROTOCV(name);
11233 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11237 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11242 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11243 if (flags & ~RV2CVOPCV_FLAG_MASK)
11244 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11245 if (cvop->op_type != OP_RV2CV)
11247 if (cvop->op_private & OPpENTERSUB_AMPER)
11249 if (!(cvop->op_flags & OPf_KIDS))
11251 rvop = cUNOPx(cvop)->op_first;
11252 switch (rvop->op_type) {
11254 gv = cGVOPx_gv(rvop);
11256 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11257 cv = MUTABLE_CV(SvRV(gv));
11261 if (flags & RV2CVOPCV_RETURN_STUB)
11267 if (flags & RV2CVOPCV_MARK_EARLY)
11268 rvop->op_private |= OPpEARLY_CV;
11273 SV *rv = cSVOPx_sv(rvop);
11276 cv = (CV*)SvRV(rv);
11280 cv = find_lexical_cv(rvop->op_targ);
11285 } NOT_REACHED; /* NOTREACHED */
11287 if (SvTYPE((SV*)cv) != SVt_PVCV)
11289 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11290 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11291 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11300 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11302 Performs the default fixup of the arguments part of an C<entersub>
11303 op tree. This consists of applying list context to each of the
11304 argument ops. This is the standard treatment used on a call marked
11305 with C<&>, or a method call, or a call through a subroutine reference,
11306 or any other call where the callee can't be identified at compile time,
11307 or a call where the callee has no prototype.
11313 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11316 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11317 aop = cUNOPx(entersubop)->op_first;
11318 if (!OpHAS_SIBLING(aop))
11319 aop = cUNOPx(aop)->op_first;
11320 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11322 op_lvalue(aop, OP_ENTERSUB);
11328 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11330 Performs the fixup of the arguments part of an C<entersub> op tree
11331 based on a subroutine prototype. This makes various modifications to
11332 the argument ops, from applying context up to inserting C<refgen> ops,
11333 and checking the number and syntactic types of arguments, as directed by
11334 the prototype. This is the standard treatment used on a subroutine call,
11335 not marked with C<&>, where the callee can be identified at compile time
11336 and has a prototype.
11338 I<protosv> supplies the subroutine prototype to be applied to the call.
11339 It may be a normal defined scalar, of which the string value will be used.
11340 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11341 that has been cast to C<SV*>) which has a prototype. The prototype
11342 supplied, in whichever form, does not need to match the actual callee
11343 referenced by the op tree.
11345 If the argument ops disagree with the prototype, for example by having
11346 an unacceptable number of arguments, a valid op tree is returned anyway.
11347 The error is reflected in the parser state, normally resulting in a single
11348 exception at the top level of parsing which covers all the compilation
11349 errors that occurred. In the error message, the callee is referred to
11350 by the name defined by the I<namegv> parameter.
11356 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11359 const char *proto, *proto_end;
11360 OP *aop, *prev, *cvop, *parent;
11363 I32 contextclass = 0;
11364 const char *e = NULL;
11365 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11366 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11367 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11368 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11369 if (SvTYPE(protosv) == SVt_PVCV)
11370 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11371 else proto = SvPV(protosv, proto_len);
11372 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11373 proto_end = proto + proto_len;
11374 parent = entersubop;
11375 aop = cUNOPx(entersubop)->op_first;
11376 if (!OpHAS_SIBLING(aop)) {
11378 aop = cUNOPx(aop)->op_first;
11381 aop = OpSIBLING(aop);
11382 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11383 while (aop != cvop) {
11386 if (proto >= proto_end)
11388 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11389 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11390 SVfARG(namesv)), SvUTF8(namesv));
11400 /* _ must be at the end */
11401 if (proto[1] && !strchr(";@%", proto[1]))
11417 if ( o3->op_type != OP_UNDEF
11418 && (o3->op_type != OP_SREFGEN
11419 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11421 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11423 bad_type_gv(arg, namegv, o3,
11424 arg == 1 ? "block or sub {}" : "sub {}");
11427 /* '*' allows any scalar type, including bareword */
11430 if (o3->op_type == OP_RV2GV)
11431 goto wrapref; /* autoconvert GLOB -> GLOBref */
11432 else if (o3->op_type == OP_CONST)
11433 o3->op_private &= ~OPpCONST_STRICT;
11439 if (o3->op_type == OP_RV2AV ||
11440 o3->op_type == OP_PADAV ||
11441 o3->op_type == OP_RV2HV ||
11442 o3->op_type == OP_PADHV
11448 case '[': case ']':
11455 switch (*proto++) {
11457 if (contextclass++ == 0) {
11458 e = strchr(proto, ']');
11459 if (!e || e == proto)
11467 if (contextclass) {
11468 const char *p = proto;
11469 const char *const end = proto;
11471 while (*--p != '[')
11472 /* \[$] accepts any scalar lvalue */
11474 && Perl_op_lvalue_flags(aTHX_
11476 OP_READ, /* not entersub */
11479 bad_type_gv(arg, namegv, o3,
11480 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11485 if (o3->op_type == OP_RV2GV)
11488 bad_type_gv(arg, namegv, o3, "symbol");
11491 if (o3->op_type == OP_ENTERSUB
11492 && !(o3->op_flags & OPf_STACKED))
11495 bad_type_gv(arg, namegv, o3, "subroutine");
11498 if (o3->op_type == OP_RV2SV ||
11499 o3->op_type == OP_PADSV ||
11500 o3->op_type == OP_HELEM ||
11501 o3->op_type == OP_AELEM)
11503 if (!contextclass) {
11504 /* \$ accepts any scalar lvalue */
11505 if (Perl_op_lvalue_flags(aTHX_
11507 OP_READ, /* not entersub */
11510 bad_type_gv(arg, namegv, o3, "scalar");
11514 if (o3->op_type == OP_RV2AV ||
11515 o3->op_type == OP_PADAV)
11517 o3->op_flags &=~ OPf_PARENS;
11521 bad_type_gv(arg, namegv, o3, "array");
11524 if (o3->op_type == OP_RV2HV ||
11525 o3->op_type == OP_PADHV)
11527 o3->op_flags &=~ OPf_PARENS;
11531 bad_type_gv(arg, namegv, o3, "hash");
11534 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11536 if (contextclass && e) {
11541 default: goto oops;
11551 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11552 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11557 op_lvalue(aop, OP_ENTERSUB);
11559 aop = OpSIBLING(aop);
11561 if (aop == cvop && *proto == '_') {
11562 /* generate an access to $_ */
11563 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11565 if (!optional && proto_end > proto &&
11566 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11568 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11569 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11570 SVfARG(namesv)), SvUTF8(namesv));
11576 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11578 Performs the fixup of the arguments part of an C<entersub> op tree either
11579 based on a subroutine prototype or using default list-context processing.
11580 This is the standard treatment used on a subroutine call, not marked
11581 with C<&>, where the callee can be identified at compile time.
11583 I<protosv> supplies the subroutine prototype to be applied to the call,
11584 or indicates that there is no prototype. It may be a normal scalar,
11585 in which case if it is defined then the string value will be used
11586 as a prototype, and if it is undefined then there is no prototype.
11587 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11588 that has been cast to C<SV*>), of which the prototype will be used if it
11589 has one. The prototype (or lack thereof) supplied, in whichever form,
11590 does not need to match the actual callee referenced by the op tree.
11592 If the argument ops disagree with the prototype, for example by having
11593 an unacceptable number of arguments, a valid op tree is returned anyway.
11594 The error is reflected in the parser state, normally resulting in a single
11595 exception at the top level of parsing which covers all the compilation
11596 errors that occurred. In the error message, the callee is referred to
11597 by the name defined by the I<namegv> parameter.
11603 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11604 GV *namegv, SV *protosv)
11606 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11607 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11608 return ck_entersub_args_proto(entersubop, namegv, protosv);
11610 return ck_entersub_args_list(entersubop);
11614 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11616 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11617 OP *aop = cUNOPx(entersubop)->op_first;
11619 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11623 if (!OpHAS_SIBLING(aop))
11624 aop = cUNOPx(aop)->op_first;
11625 aop = OpSIBLING(aop);
11626 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11628 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11630 op_free(entersubop);
11631 switch(GvNAME(namegv)[2]) {
11632 case 'F': return newSVOP(OP_CONST, 0,
11633 newSVpv(CopFILE(PL_curcop),0));
11634 case 'L': return newSVOP(
11636 Perl_newSVpvf(aTHX_
11637 "%"IVdf, (IV)CopLINE(PL_curcop)
11640 case 'P': return newSVOP(OP_CONST, 0,
11642 ? newSVhek(HvNAME_HEK(PL_curstash))
11647 NOT_REACHED; /* NOTREACHED */
11650 OP *prev, *cvop, *first, *parent;
11653 parent = entersubop;
11654 if (!OpHAS_SIBLING(aop)) {
11656 aop = cUNOPx(aop)->op_first;
11659 first = prev = aop;
11660 aop = OpSIBLING(aop);
11661 /* find last sibling */
11663 OpHAS_SIBLING(cvop);
11664 prev = cvop, cvop = OpSIBLING(cvop))
11666 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11667 /* Usually, OPf_SPECIAL on an op with no args means that it had
11668 * parens, but these have their own meaning for that flag: */
11669 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11670 && opnum != OP_DELETE && opnum != OP_EXISTS)
11671 flags |= OPf_SPECIAL;
11672 /* excise cvop from end of sibling chain */
11673 op_sibling_splice(parent, prev, 1, NULL);
11675 if (aop == cvop) aop = NULL;
11677 /* detach remaining siblings from the first sibling, then
11678 * dispose of original optree */
11681 op_sibling_splice(parent, first, -1, NULL);
11682 op_free(entersubop);
11684 if (opnum == OP_ENTEREVAL
11685 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11686 flags |= OPpEVAL_BYTES <<8;
11688 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11690 case OA_BASEOP_OR_UNOP:
11691 case OA_FILESTATOP:
11692 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11695 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11698 return opnum == OP_RUNCV
11699 ? newPVOP(OP_RUNCV,0,NULL)
11702 return op_convert_list(opnum,0,aop);
11705 NOT_REACHED; /* NOTREACHED */
11710 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11712 Retrieves the function that will be used to fix up a call to I<cv>.
11713 Specifically, the function is applied to an C<entersub> op tree for a
11714 subroutine call, not marked with C<&>, where the callee can be identified
11715 at compile time as I<cv>.
11717 The C-level function pointer is returned in I<*ckfun_p>, and an SV
11718 argument for it is returned in I<*ckobj_p>. The function is intended
11719 to be called in this manner:
11721 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11723 In this call, I<entersubop> is a pointer to the C<entersub> op,
11724 which may be replaced by the check function, and I<namegv> is a GV
11725 supplying the name that should be used by the check function to refer
11726 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11727 It is permitted to apply the check function in non-standard situations,
11728 such as to a call to a different subroutine or to a method call.
11730 By default, the function is
11731 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11732 and the SV parameter is I<cv> itself. This implements standard
11733 prototype processing. It can be changed, for a particular subroutine,
11734 by L</cv_set_call_checker>.
11740 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11744 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11746 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11747 *ckobj_p = callmg->mg_obj;
11748 if (flagsp) *flagsp = callmg->mg_flags;
11750 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11751 *ckobj_p = (SV*)cv;
11752 if (flagsp) *flagsp = 0;
11757 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11759 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11760 PERL_UNUSED_CONTEXT;
11761 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11765 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11767 Sets the function that will be used to fix up a call to I<cv>.
11768 Specifically, the function is applied to an C<entersub> op tree for a
11769 subroutine call, not marked with C<&>, where the callee can be identified
11770 at compile time as I<cv>.
11772 The C-level function pointer is supplied in I<ckfun>, and an SV argument
11773 for it is supplied in I<ckobj>. The function should be defined like this:
11775 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11777 It is intended to be called in this manner:
11779 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11781 In this call, I<entersubop> is a pointer to the C<entersub> op,
11782 which may be replaced by the check function, and I<namegv> supplies
11783 the name that should be used by the check function to refer
11784 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11785 It is permitted to apply the check function in non-standard situations,
11786 such as to a call to a different subroutine or to a method call.
11788 I<namegv> may not actually be a GV. For efficiency, perl may pass a
11789 CV or other SV instead. Whatever is passed can be used as the first
11790 argument to L</cv_name>. You can force perl to pass a GV by including
11791 C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
11793 The current setting for a particular CV can be retrieved by
11794 L</cv_get_call_checker>.
11796 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11798 The original form of L</cv_set_call_checker_flags>, which passes it the
11799 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11805 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11807 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11808 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11812 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11813 SV *ckobj, U32 flags)
11815 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11816 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11817 if (SvMAGICAL((SV*)cv))
11818 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11821 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11822 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11824 if (callmg->mg_flags & MGf_REFCOUNTED) {
11825 SvREFCNT_dec(callmg->mg_obj);
11826 callmg->mg_flags &= ~MGf_REFCOUNTED;
11828 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11829 callmg->mg_obj = ckobj;
11830 if (ckobj != (SV*)cv) {
11831 SvREFCNT_inc_simple_void_NN(ckobj);
11832 callmg->mg_flags |= MGf_REFCOUNTED;
11834 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11835 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11840 S_entersub_alloc_targ(pTHX_ OP * const o)
11842 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11843 o->op_private |= OPpENTERSUB_HASTARG;
11847 Perl_ck_subr(pTHX_ OP *o)
11852 SV **const_class = NULL;
11854 PERL_ARGS_ASSERT_CK_SUBR;
11856 aop = cUNOPx(o)->op_first;
11857 if (!OpHAS_SIBLING(aop))
11858 aop = cUNOPx(aop)->op_first;
11859 aop = OpSIBLING(aop);
11860 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11861 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11862 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11864 o->op_private &= ~1;
11865 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11866 if (PERLDB_SUB && PL_curstash != PL_debstash)
11867 o->op_private |= OPpENTERSUB_DB;
11868 switch (cvop->op_type) {
11870 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11874 case OP_METHOD_NAMED:
11875 case OP_METHOD_SUPER:
11876 case OP_METHOD_REDIR:
11877 case OP_METHOD_REDIR_SUPER:
11878 if (aop->op_type == OP_CONST) {
11879 aop->op_private &= ~OPpCONST_STRICT;
11880 const_class = &cSVOPx(aop)->op_sv;
11882 else if (aop->op_type == OP_LIST) {
11883 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11884 if (sib && sib->op_type == OP_CONST) {
11885 sib->op_private &= ~OPpCONST_STRICT;
11886 const_class = &cSVOPx(sib)->op_sv;
11889 /* make class name a shared cow string to speedup method calls */
11890 /* constant string might be replaced with object, f.e. bigint */
11891 if (const_class && SvPOK(*const_class)) {
11893 const char* str = SvPV(*const_class, len);
11895 SV* const shared = newSVpvn_share(
11896 str, SvUTF8(*const_class)
11897 ? -(SSize_t)len : (SSize_t)len,
11900 if (SvREADONLY(*const_class))
11901 SvREADONLY_on(shared);
11902 SvREFCNT_dec(*const_class);
11903 *const_class = shared;
11910 S_entersub_alloc_targ(aTHX_ o);
11911 return ck_entersub_args_list(o);
11913 Perl_call_checker ckfun;
11916 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11917 if (CvISXSUB(cv) || !CvROOT(cv))
11918 S_entersub_alloc_targ(aTHX_ o);
11920 /* The original call checker API guarantees that a GV will be
11921 be provided with the right name. So, if the old API was
11922 used (or the REQUIRE_GV flag was passed), we have to reify
11923 the CV’s GV, unless this is an anonymous sub. This is not
11924 ideal for lexical subs, as its stringification will include
11925 the package. But it is the best we can do. */
11926 if (flags & MGf_REQUIRE_GV) {
11927 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11930 else namegv = MUTABLE_GV(cv);
11931 /* After a syntax error in a lexical sub, the cv that
11932 rv2cv_op_cv returns may be a nameless stub. */
11933 if (!namegv) return ck_entersub_args_list(o);
11936 return ckfun(aTHX_ o, namegv, ckobj);
11941 Perl_ck_svconst(pTHX_ OP *o)
11943 SV * const sv = cSVOPo->op_sv;
11944 PERL_ARGS_ASSERT_CK_SVCONST;
11945 PERL_UNUSED_CONTEXT;
11946 #ifdef PERL_COPY_ON_WRITE
11947 /* Since the read-only flag may be used to protect a string buffer, we
11948 cannot do copy-on-write with existing read-only scalars that are not
11949 already copy-on-write scalars. To allow $_ = "hello" to do COW with
11950 that constant, mark the constant as COWable here, if it is not
11951 already read-only. */
11952 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11955 # ifdef PERL_DEBUG_READONLY_COW
11965 Perl_ck_trunc(pTHX_ OP *o)
11967 PERL_ARGS_ASSERT_CK_TRUNC;
11969 if (o->op_flags & OPf_KIDS) {
11970 SVOP *kid = (SVOP*)cUNOPo->op_first;
11972 if (kid->op_type == OP_NULL)
11973 kid = (SVOP*)OpSIBLING(kid);
11974 if (kid && kid->op_type == OP_CONST &&
11975 (kid->op_private & OPpCONST_BARE) &&
11978 o->op_flags |= OPf_SPECIAL;
11979 kid->op_private &= ~OPpCONST_STRICT;
11986 Perl_ck_substr(pTHX_ OP *o)
11988 PERL_ARGS_ASSERT_CK_SUBSTR;
11991 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11992 OP *kid = cLISTOPo->op_first;
11994 if (kid->op_type == OP_NULL)
11995 kid = OpSIBLING(kid);
11997 kid->op_flags |= OPf_MOD;
12004 Perl_ck_tell(pTHX_ OP *o)
12006 PERL_ARGS_ASSERT_CK_TELL;
12008 if (o->op_flags & OPf_KIDS) {
12009 OP *kid = cLISTOPo->op_first;
12010 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12011 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12017 Perl_ck_each(pTHX_ OP *o)
12020 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12021 const unsigned orig_type = o->op_type;
12023 PERL_ARGS_ASSERT_CK_EACH;
12026 switch (kid->op_type) {
12032 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
12033 : orig_type == OP_KEYS ? OP_AKEYS
12037 if (kid->op_private == OPpCONST_BARE
12038 || !SvROK(cSVOPx_sv(kid))
12039 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12040 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
12042 /* we let ck_fun handle it */
12045 Perl_croak_nocontext(
12046 "Experimental %s on scalar is now forbidden",
12047 PL_op_desc[orig_type]);
12055 Perl_ck_length(pTHX_ OP *o)
12057 PERL_ARGS_ASSERT_CK_LENGTH;
12061 if (ckWARN(WARN_SYNTAX)) {
12062 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12066 const bool hash = kid->op_type == OP_PADHV
12067 || kid->op_type == OP_RV2HV;
12068 switch (kid->op_type) {
12073 name = S_op_varname(aTHX_ kid);
12079 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12080 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
12082 SVfARG(name), hash ? "keys " : "", SVfARG(name)
12085 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12086 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12087 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12089 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12090 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12091 "length() used on @array (did you mean \"scalar(@array)\"?)");
12098 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12099 and modify the optree to make them work inplace */
12102 S_inplace_aassign(pTHX_ OP *o) {
12104 OP *modop, *modop_pushmark;
12106 OP *oleft, *oleft_pushmark;
12108 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12110 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12112 assert(cUNOPo->op_first->op_type == OP_NULL);
12113 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12114 assert(modop_pushmark->op_type == OP_PUSHMARK);
12115 modop = OpSIBLING(modop_pushmark);
12117 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12120 /* no other operation except sort/reverse */
12121 if (OpHAS_SIBLING(modop))
12124 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12125 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12127 if (modop->op_flags & OPf_STACKED) {
12128 /* skip sort subroutine/block */
12129 assert(oright->op_type == OP_NULL);
12130 oright = OpSIBLING(oright);
12133 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12134 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12135 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12136 oleft = OpSIBLING(oleft_pushmark);
12138 /* Check the lhs is an array */
12140 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12141 || OpHAS_SIBLING(oleft)
12142 || (oleft->op_private & OPpLVAL_INTRO)
12146 /* Only one thing on the rhs */
12147 if (OpHAS_SIBLING(oright))
12150 /* check the array is the same on both sides */
12151 if (oleft->op_type == OP_RV2AV) {
12152 if (oright->op_type != OP_RV2AV
12153 || !cUNOPx(oright)->op_first
12154 || cUNOPx(oright)->op_first->op_type != OP_GV
12155 || cUNOPx(oleft )->op_first->op_type != OP_GV
12156 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12157 cGVOPx_gv(cUNOPx(oright)->op_first)
12161 else if (oright->op_type != OP_PADAV
12162 || oright->op_targ != oleft->op_targ
12166 /* This actually is an inplace assignment */
12168 modop->op_private |= OPpSORT_INPLACE;
12170 /* transfer MODishness etc from LHS arg to RHS arg */
12171 oright->op_flags = oleft->op_flags;
12173 /* remove the aassign op and the lhs */
12175 op_null(oleft_pushmark);
12176 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12177 op_null(cUNOPx(oleft)->op_first);
12183 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12184 * that potentially represent a series of one or more aggregate derefs
12185 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12186 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12187 * additional ops left in too).
12189 * The caller will have already verified that the first few ops in the
12190 * chain following 'start' indicate a multideref candidate, and will have
12191 * set 'orig_o' to the point further on in the chain where the first index
12192 * expression (if any) begins. 'orig_action' specifies what type of
12193 * beginning has already been determined by the ops between start..orig_o
12194 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12196 * 'hints' contains any hints flags that need adding (currently just
12197 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12201 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12205 UNOP_AUX_item *arg_buf = NULL;
12206 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12207 int index_skip = -1; /* don't output index arg on this action */
12209 /* similar to regex compiling, do two passes; the first pass
12210 * determines whether the op chain is convertible and calculates the
12211 * buffer size; the second pass populates the buffer and makes any
12212 * changes necessary to ops (such as moving consts to the pad on
12213 * threaded builds).
12215 * NB: for things like Coverity, note that both passes take the same
12216 * path through the logic tree (except for 'if (pass)' bits), since
12217 * both passes are following the same op_next chain; and in
12218 * particular, if it would return early on the second pass, it would
12219 * already have returned early on the first pass.
12221 for (pass = 0; pass < 2; pass++) {
12223 UV action = orig_action;
12224 OP *first_elem_op = NULL; /* first seen aelem/helem */
12225 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12226 int action_count = 0; /* number of actions seen so far */
12227 int action_ix = 0; /* action_count % (actions per IV) */
12228 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12229 bool is_last = FALSE; /* no more derefs to follow */
12230 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12231 UNOP_AUX_item *arg = arg_buf;
12232 UNOP_AUX_item *action_ptr = arg_buf;
12235 action_ptr->uv = 0;
12239 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12240 case MDEREF_HV_gvhv_helem:
12241 next_is_hash = TRUE;
12243 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12244 case MDEREF_AV_gvav_aelem:
12246 #ifdef USE_ITHREADS
12247 arg->pad_offset = cPADOPx(start)->op_padix;
12248 /* stop it being swiped when nulled */
12249 cPADOPx(start)->op_padix = 0;
12251 arg->sv = cSVOPx(start)->op_sv;
12252 cSVOPx(start)->op_sv = NULL;
12258 case MDEREF_HV_padhv_helem:
12259 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12260 next_is_hash = TRUE;
12262 case MDEREF_AV_padav_aelem:
12263 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12265 arg->pad_offset = start->op_targ;
12266 /* we skip setting op_targ = 0 for now, since the intact
12267 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12268 reset_start_targ = TRUE;
12273 case MDEREF_HV_pop_rv2hv_helem:
12274 next_is_hash = TRUE;
12276 case MDEREF_AV_pop_rv2av_aelem:
12280 NOT_REACHED; /* NOTREACHED */
12285 /* look for another (rv2av/hv; get index;
12286 * aelem/helem/exists/delele) sequence */
12291 UV index_type = MDEREF_INDEX_none;
12293 if (action_count) {
12294 /* if this is not the first lookup, consume the rv2av/hv */
12296 /* for N levels of aggregate lookup, we normally expect
12297 * that the first N-1 [ah]elem ops will be flagged as
12298 * /DEREF (so they autovivifiy if necessary), and the last
12299 * lookup op not to be.
12300 * For other things (like @{$h{k1}{k2}}) extra scope or
12301 * leave ops can appear, so abandon the effort in that
12303 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12306 /* rv2av or rv2hv sKR/1 */
12308 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12309 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12310 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12313 /* at this point, we wouldn't expect any of these
12314 * possible private flags:
12315 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12316 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12318 ASSUME(!(o->op_private &
12319 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12321 hints = (o->op_private & OPpHINT_STRICT_REFS);
12323 /* make sure the type of the previous /DEREF matches the
12324 * type of the next lookup */
12325 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12328 action = next_is_hash
12329 ? MDEREF_HV_vivify_rv2hv_helem
12330 : MDEREF_AV_vivify_rv2av_aelem;
12334 /* if this is the second pass, and we're at the depth where
12335 * previously we encountered a non-simple index expression,
12336 * stop processing the index at this point */
12337 if (action_count != index_skip) {
12339 /* look for one or more simple ops that return an array
12340 * index or hash key */
12342 switch (o->op_type) {
12344 /* it may be a lexical var index */
12345 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12346 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12347 ASSUME(!(o->op_private &
12348 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12350 if ( OP_GIMME(o,0) == G_SCALAR
12351 && !(o->op_flags & (OPf_REF|OPf_MOD))
12352 && o->op_private == 0)
12355 arg->pad_offset = o->op_targ;
12357 index_type = MDEREF_INDEX_padsv;
12363 if (next_is_hash) {
12364 /* it's a constant hash index */
12365 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12366 /* "use constant foo => FOO; $h{+foo}" for
12367 * some weird FOO, can leave you with constants
12368 * that aren't simple strings. It's not worth
12369 * the extra hassle for those edge cases */
12374 OP * helem_op = o->op_next;
12376 ASSUME( helem_op->op_type == OP_HELEM
12377 || helem_op->op_type == OP_NULL);
12378 if (helem_op->op_type == OP_HELEM) {
12379 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12380 if ( helem_op->op_private & OPpLVAL_INTRO
12381 || rop->op_type != OP_RV2HV
12385 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12387 #ifdef USE_ITHREADS
12388 /* Relocate sv to the pad for thread safety */
12389 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12390 arg->pad_offset = o->op_targ;
12393 arg->sv = cSVOPx_sv(o);
12398 /* it's a constant array index */
12400 SV *ix_sv = cSVOPo->op_sv;
12405 if ( action_count == 0
12408 && ( action == MDEREF_AV_padav_aelem
12409 || action == MDEREF_AV_gvav_aelem)
12411 maybe_aelemfast = TRUE;
12415 SvREFCNT_dec_NN(cSVOPo->op_sv);
12419 /* we've taken ownership of the SV */
12420 cSVOPo->op_sv = NULL;
12422 index_type = MDEREF_INDEX_const;
12427 /* it may be a package var index */
12429 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12430 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12431 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12432 || o->op_private != 0
12437 if (kid->op_type != OP_RV2SV)
12440 ASSUME(!(kid->op_flags &
12441 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12442 |OPf_SPECIAL|OPf_PARENS)));
12443 ASSUME(!(kid->op_private &
12445 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12446 |OPpDEREF|OPpLVAL_INTRO)));
12447 if( (kid->op_flags &~ OPf_PARENS)
12448 != (OPf_WANT_SCALAR|OPf_KIDS)
12449 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12454 #ifdef USE_ITHREADS
12455 arg->pad_offset = cPADOPx(o)->op_padix;
12456 /* stop it being swiped when nulled */
12457 cPADOPx(o)->op_padix = 0;
12459 arg->sv = cSVOPx(o)->op_sv;
12460 cSVOPo->op_sv = NULL;
12464 index_type = MDEREF_INDEX_gvsv;
12469 } /* action_count != index_skip */
12471 action |= index_type;
12474 /* at this point we have either:
12475 * * detected what looks like a simple index expression,
12476 * and expect the next op to be an [ah]elem, or
12477 * an nulled [ah]elem followed by a delete or exists;
12478 * * found a more complex expression, so something other
12479 * than the above follows.
12482 /* possibly an optimised away [ah]elem (where op_next is
12483 * exists or delete) */
12484 if (o->op_type == OP_NULL)
12487 /* at this point we're looking for an OP_AELEM, OP_HELEM,
12488 * OP_EXISTS or OP_DELETE */
12490 /* if something like arybase (a.k.a $[ ) is in scope,
12491 * abandon optimisation attempt */
12492 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12493 && PL_check[o->op_type] != Perl_ck_null)
12496 if ( o->op_type != OP_AELEM
12497 || (o->op_private &
12498 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12500 maybe_aelemfast = FALSE;
12502 /* look for aelem/helem/exists/delete. If it's not the last elem
12503 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12504 * flags; if it's the last, then it mustn't have
12505 * OPpDEREF_AV/HV, but may have lots of other flags, like
12506 * OPpLVAL_INTRO etc
12509 if ( index_type == MDEREF_INDEX_none
12510 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
12511 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12515 /* we have aelem/helem/exists/delete with valid simple index */
12517 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12518 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
12519 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12522 ASSUME(!(o->op_flags &
12523 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12524 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12526 ok = (o->op_flags &~ OPf_PARENS)
12527 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12528 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12530 else if (o->op_type == OP_EXISTS) {
12531 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12532 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12533 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12534 ok = !(o->op_private & ~OPpARG1_MASK);
12536 else if (o->op_type == OP_DELETE) {
12537 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12538 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12539 ASSUME(!(o->op_private &
12540 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12541 /* don't handle slices or 'local delete'; the latter
12542 * is fairly rare, and has a complex runtime */
12543 ok = !(o->op_private & ~OPpARG1_MASK);
12544 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12545 /* skip handling run-tome error */
12546 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12549 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12550 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12551 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12552 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12553 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12554 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12559 if (!first_elem_op)
12563 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12568 action |= MDEREF_FLAG_last;
12572 /* at this point we have something that started
12573 * promisingly enough (with rv2av or whatever), but failed
12574 * to find a simple index followed by an
12575 * aelem/helem/exists/delete. If this is the first action,
12576 * give up; but if we've already seen at least one
12577 * aelem/helem, then keep them and add a new action with
12578 * MDEREF_INDEX_none, which causes it to do the vivify
12579 * from the end of the previous lookup, and do the deref,
12580 * but stop at that point. So $a[0][expr] will do one
12581 * av_fetch, vivify and deref, then continue executing at
12586 index_skip = action_count;
12587 action |= MDEREF_FLAG_last;
12591 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12594 /* if there's no space for the next action, create a new slot
12595 * for it *before* we start adding args for that action */
12596 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12603 } /* while !is_last */
12611 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12612 if (index_skip == -1) {
12613 mderef->op_flags = o->op_flags
12614 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12615 if (o->op_type == OP_EXISTS)
12616 mderef->op_private = OPpMULTIDEREF_EXISTS;
12617 else if (o->op_type == OP_DELETE)
12618 mderef->op_private = OPpMULTIDEREF_DELETE;
12620 mderef->op_private = o->op_private
12621 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12623 /* accumulate strictness from every level (although I don't think
12624 * they can actually vary) */
12625 mderef->op_private |= hints;
12627 /* integrate the new multideref op into the optree and the
12630 * In general an op like aelem or helem has two child
12631 * sub-trees: the aggregate expression (a_expr) and the
12632 * index expression (i_expr):
12638 * The a_expr returns an AV or HV, while the i-expr returns an
12639 * index. In general a multideref replaces most or all of a
12640 * multi-level tree, e.g.
12656 * With multideref, all the i_exprs will be simple vars or
12657 * constants, except that i_expr1 may be arbitrary in the case
12658 * of MDEREF_INDEX_none.
12660 * The bottom-most a_expr will be either:
12661 * 1) a simple var (so padXv or gv+rv2Xv);
12662 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
12663 * so a simple var with an extra rv2Xv;
12664 * 3) or an arbitrary expression.
12666 * 'start', the first op in the execution chain, will point to
12667 * 1),2): the padXv or gv op;
12668 * 3): the rv2Xv which forms the last op in the a_expr
12669 * execution chain, and the top-most op in the a_expr
12672 * For all cases, the 'start' node is no longer required,
12673 * but we can't free it since one or more external nodes
12674 * may point to it. E.g. consider
12675 * $h{foo} = $a ? $b : $c
12676 * Here, both the op_next and op_other branches of the
12677 * cond_expr point to the gv[*h] of the hash expression, so
12678 * we can't free the 'start' op.
12680 * For expr->[...], we need to save the subtree containing the
12681 * expression; for the other cases, we just need to save the
12683 * So in all cases, we null the start op and keep it around by
12684 * making it the child of the multideref op; for the expr->
12685 * case, the expr will be a subtree of the start node.
12687 * So in the simple 1,2 case the optree above changes to
12693 * ex-gv (or ex-padxv)
12695 * with the op_next chain being
12697 * -> ex-gv -> multideref -> op-following-ex-exists ->
12699 * In the 3 case, we have
12712 * -> rest-of-a_expr subtree ->
12713 * ex-rv2xv -> multideref -> op-following-ex-exists ->
12716 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
12717 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
12718 * multideref attached as the child, e.g.
12724 * ex-rv2av - i_expr1
12732 /* if we free this op, don't free the pad entry */
12733 if (reset_start_targ)
12734 start->op_targ = 0;
12737 /* Cut the bit we need to save out of the tree and attach to
12738 * the multideref op, then free the rest of the tree */
12740 /* find parent of node to be detached (for use by splice) */
12742 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
12743 || orig_action == MDEREF_HV_pop_rv2hv_helem)
12745 /* there is an arbitrary expression preceding us, e.g.
12746 * expr->[..]? so we need to save the 'expr' subtree */
12747 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
12748 p = cUNOPx(p)->op_first;
12749 ASSUME( start->op_type == OP_RV2AV
12750 || start->op_type == OP_RV2HV);
12753 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
12754 * above for exists/delete. */
12755 while ( (p->op_flags & OPf_KIDS)
12756 && cUNOPx(p)->op_first != start
12758 p = cUNOPx(p)->op_first;
12760 ASSUME(cUNOPx(p)->op_first == start);
12762 /* detach from main tree, and re-attach under the multideref */
12763 op_sibling_splice(mderef, NULL, 0,
12764 op_sibling_splice(p, NULL, 1, NULL));
12767 start->op_next = mderef;
12769 mderef->op_next = index_skip == -1 ? o->op_next : o;
12771 /* excise and free the original tree, and replace with
12772 * the multideref op */
12773 p = op_sibling_splice(top_op, NULL, -1, mderef);
12782 Size_t size = arg - arg_buf;
12784 if (maybe_aelemfast && action_count == 1)
12787 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
12788 sizeof(UNOP_AUX_item) * (size + 1));
12789 /* for dumping etc: store the length in a hidden first slot;
12790 * we set the op_aux pointer to the second slot */
12791 arg_buf->uv = size;
12794 } /* for (pass = ...) */
12799 /* mechanism for deferring recursion in rpeep() */
12801 #define MAX_DEFERRED 4
12805 if (defer_ix == (MAX_DEFERRED-1)) { \
12806 OP **defer = defer_queue[defer_base]; \
12807 CALL_RPEEP(*defer); \
12808 S_prune_chain_head(defer); \
12809 defer_base = (defer_base + 1) % MAX_DEFERRED; \
12812 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
12815 #define IS_AND_OP(o) (o->op_type == OP_AND)
12816 #define IS_OR_OP(o) (o->op_type == OP_OR)
12819 /* A peephole optimizer. We visit the ops in the order they're to execute.
12820 * See the comments at the top of this file for more details about when
12821 * peep() is called */
12824 Perl_rpeep(pTHX_ OP *o)
12828 OP* oldoldop = NULL;
12829 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
12830 int defer_base = 0;
12835 if (!o || o->op_opt)
12839 SAVEVPTR(PL_curcop);
12840 for (;; o = o->op_next) {
12841 if (o && o->op_opt)
12844 while (defer_ix >= 0) {
12846 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
12847 CALL_RPEEP(*defer);
12848 S_prune_chain_head(defer);
12854 /* By default, this op has now been optimised. A couple of cases below
12855 clear this again. */
12859 /* look for a series of 1 or more aggregate derefs, e.g.
12860 * $a[1]{foo}[$i]{$k}
12861 * and replace with a single OP_MULTIDEREF op.
12862 * Each index must be either a const, or a simple variable,
12864 * First, look for likely combinations of starting ops,
12865 * corresponding to (global and lexical variants of)
12867 * $r->[...] $r->{...}
12868 * (preceding expression)->[...]
12869 * (preceding expression)->{...}
12870 * and if so, call maybe_multideref() to do a full inspection
12871 * of the op chain and if appropriate, replace with an
12879 switch (o2->op_type) {
12881 /* $pkg[..] : gv[*pkg]
12882 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
12884 /* Fail if there are new op flag combinations that we're
12885 * not aware of, rather than:
12886 * * silently failing to optimise, or
12887 * * silently optimising the flag away.
12888 * If this ASSUME starts failing, examine what new flag
12889 * has been added to the op, and decide whether the
12890 * optimisation should still occur with that flag, then
12891 * update the code accordingly. This applies to all the
12892 * other ASSUMEs in the block of code too.
12894 ASSUME(!(o2->op_flags &
12895 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
12896 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
12900 if (o2->op_type == OP_RV2AV) {
12901 action = MDEREF_AV_gvav_aelem;
12905 if (o2->op_type == OP_RV2HV) {
12906 action = MDEREF_HV_gvhv_helem;
12910 if (o2->op_type != OP_RV2SV)
12913 /* at this point we've seen gv,rv2sv, so the only valid
12914 * construct left is $pkg->[] or $pkg->{} */
12916 ASSUME(!(o2->op_flags & OPf_STACKED));
12917 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12918 != (OPf_WANT_SCALAR|OPf_MOD))
12921 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
12922 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
12923 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
12925 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
12926 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
12930 if (o2->op_type == OP_RV2AV) {
12931 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
12934 if (o2->op_type == OP_RV2HV) {
12935 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
12941 /* $lex->[...]: padsv[$lex] sM/DREFAV */
12943 ASSUME(!(o2->op_flags &
12944 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
12945 if ((o2->op_flags &
12946 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12947 != (OPf_WANT_SCALAR|OPf_MOD))
12950 ASSUME(!(o2->op_private &
12951 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12952 /* skip if state or intro, or not a deref */
12953 if ( o2->op_private != OPpDEREF_AV
12954 && o2->op_private != OPpDEREF_HV)
12958 if (o2->op_type == OP_RV2AV) {
12959 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
12962 if (o2->op_type == OP_RV2HV) {
12963 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
12970 /* $lex[..]: padav[@lex:1,2] sR *
12971 * or $lex{..}: padhv[%lex:1,2] sR */
12972 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
12973 OPf_REF|OPf_SPECIAL)));
12974 if ((o2->op_flags &
12975 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12976 != (OPf_WANT_SCALAR|OPf_REF))
12978 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
12980 /* OPf_PARENS isn't currently used in this case;
12981 * if that changes, let us know! */
12982 ASSUME(!(o2->op_flags & OPf_PARENS));
12984 /* at this point, we wouldn't expect any of the remaining
12985 * possible private flags:
12986 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
12987 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
12989 * OPpSLICEWARNING shouldn't affect runtime
12991 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
12993 action = o2->op_type == OP_PADAV
12994 ? MDEREF_AV_padav_aelem
12995 : MDEREF_HV_padhv_helem;
12997 S_maybe_multideref(aTHX_ o, o2, action, 0);
13003 action = o2->op_type == OP_RV2AV
13004 ? MDEREF_AV_pop_rv2av_aelem
13005 : MDEREF_HV_pop_rv2hv_helem;
13008 /* (expr)->[...]: rv2av sKR/1;
13009 * (expr)->{...}: rv2hv sKR/1; */
13011 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13013 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13014 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13015 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13018 /* at this point, we wouldn't expect any of these
13019 * possible private flags:
13020 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13021 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13023 ASSUME(!(o2->op_private &
13024 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13026 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13030 S_maybe_multideref(aTHX_ o, o2, action, hints);
13039 switch (o->op_type) {
13041 PL_curcop = ((COP*)o); /* for warnings */
13044 PL_curcop = ((COP*)o); /* for warnings */
13046 /* Optimise a "return ..." at the end of a sub to just be "...".
13047 * This saves 2 ops. Before:
13048 * 1 <;> nextstate(main 1 -e:1) v ->2
13049 * 4 <@> return K ->5
13050 * 2 <0> pushmark s ->3
13051 * - <1> ex-rv2sv sK/1 ->4
13052 * 3 <#> gvsv[*cat] s ->4
13055 * - <@> return K ->-
13056 * - <0> pushmark s ->2
13057 * - <1> ex-rv2sv sK/1 ->-
13058 * 2 <$> gvsv(*cat) s ->3
13061 OP *next = o->op_next;
13062 OP *sibling = OpSIBLING(o);
13063 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13064 && OP_TYPE_IS(sibling, OP_RETURN)
13065 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13066 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13067 ||OP_TYPE_IS(sibling->op_next->op_next,
13069 && cUNOPx(sibling)->op_first == next
13070 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13073 /* Look through the PUSHMARK's siblings for one that
13074 * points to the RETURN */
13075 OP *top = OpSIBLING(next);
13076 while (top && top->op_next) {
13077 if (top->op_next == sibling) {
13078 top->op_next = sibling->op_next;
13079 o->op_next = next->op_next;
13082 top = OpSIBLING(top);
13087 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13089 * This latter form is then suitable for conversion into padrange
13090 * later on. Convert:
13092 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13096 * nextstate1 -> listop -> nextstate3
13098 * pushmark -> padop1 -> padop2
13100 if (o->op_next && (
13101 o->op_next->op_type == OP_PADSV
13102 || o->op_next->op_type == OP_PADAV
13103 || o->op_next->op_type == OP_PADHV
13105 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13106 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13107 && o->op_next->op_next->op_next && (
13108 o->op_next->op_next->op_next->op_type == OP_PADSV
13109 || o->op_next->op_next->op_next->op_type == OP_PADAV
13110 || o->op_next->op_next->op_next->op_type == OP_PADHV
13112 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13113 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13114 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13115 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13117 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13120 ns2 = pad1->op_next;
13121 pad2 = ns2->op_next;
13122 ns3 = pad2->op_next;
13124 /* we assume here that the op_next chain is the same as
13125 * the op_sibling chain */
13126 assert(OpSIBLING(o) == pad1);
13127 assert(OpSIBLING(pad1) == ns2);
13128 assert(OpSIBLING(ns2) == pad2);
13129 assert(OpSIBLING(pad2) == ns3);
13131 /* excise and delete ns2 */
13132 op_sibling_splice(NULL, pad1, 1, NULL);
13135 /* excise pad1 and pad2 */
13136 op_sibling_splice(NULL, o, 2, NULL);
13138 /* create new listop, with children consisting of:
13139 * a new pushmark, pad1, pad2. */
13140 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13141 newop->op_flags |= OPf_PARENS;
13142 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13144 /* insert newop between o and ns3 */
13145 op_sibling_splice(NULL, o, 0, newop);
13147 /*fixup op_next chain */
13148 newpm = cUNOPx(newop)->op_first; /* pushmark */
13149 o ->op_next = newpm;
13150 newpm->op_next = pad1;
13151 pad1 ->op_next = pad2;
13152 pad2 ->op_next = newop; /* listop */
13153 newop->op_next = ns3;
13155 /* Ensure pushmark has this flag if padops do */
13156 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13157 newpm->op_flags |= OPf_MOD;
13163 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13164 to carry two labels. For now, take the easier option, and skip
13165 this optimisation if the first NEXTSTATE has a label. */
13166 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13167 OP *nextop = o->op_next;
13168 while (nextop && nextop->op_type == OP_NULL)
13169 nextop = nextop->op_next;
13171 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13174 oldop->op_next = nextop;
13175 /* Skip (old)oldop assignment since the current oldop's
13176 op_next already points to the next op. */
13183 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13184 if (o->op_next->op_private & OPpTARGET_MY) {
13185 if (o->op_flags & OPf_STACKED) /* chained concats */
13186 break; /* ignore_optimization */
13188 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13189 o->op_targ = o->op_next->op_targ;
13190 o->op_next->op_targ = 0;
13191 o->op_private |= OPpTARGET_MY;
13194 op_null(o->op_next);
13198 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13199 break; /* Scalar stub must produce undef. List stub is noop */
13203 if (o->op_targ == OP_NEXTSTATE
13204 || o->op_targ == OP_DBSTATE)
13206 PL_curcop = ((COP*)o);
13208 /* XXX: We avoid setting op_seq here to prevent later calls
13209 to rpeep() from mistakenly concluding that optimisation
13210 has already occurred. This doesn't fix the real problem,
13211 though (See 20010220.007). AMS 20010719 */
13212 /* op_seq functionality is now replaced by op_opt */
13220 oldop->op_next = o->op_next;
13234 convert repeat into a stub with no kids.
13236 if (o->op_next->op_type == OP_CONST
13237 || ( o->op_next->op_type == OP_PADSV
13238 && !(o->op_next->op_private & OPpLVAL_INTRO))
13239 || ( o->op_next->op_type == OP_GV
13240 && o->op_next->op_next->op_type == OP_RV2SV
13241 && !(o->op_next->op_next->op_private
13242 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13244 const OP *kid = o->op_next->op_next;
13245 if (o->op_next->op_type == OP_GV)
13246 kid = kid->op_next;
13247 /* kid is now the ex-list. */
13248 if (kid->op_type == OP_NULL
13249 && (kid = kid->op_next)->op_type == OP_CONST
13250 /* kid is now the repeat count. */
13251 && kid->op_next->op_type == OP_REPEAT
13252 && kid->op_next->op_private & OPpREPEAT_DOLIST
13253 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13254 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13256 o = kid->op_next; /* repeat */
13258 oldop->op_next = o;
13259 op_free(cBINOPo->op_first);
13260 op_free(cBINOPo->op_last );
13261 o->op_flags &=~ OPf_KIDS;
13262 /* stub is a baseop; repeat is a binop */
13263 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13264 OpTYPE_set(o, OP_STUB);
13270 /* Convert a series of PAD ops for my vars plus support into a
13271 * single padrange op. Basically
13273 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13275 * becomes, depending on circumstances, one of
13277 * padrange ----------------------------------> (list) -> rest
13278 * padrange --------------------------------------------> rest
13280 * where all the pad indexes are sequential and of the same type
13282 * We convert the pushmark into a padrange op, then skip
13283 * any other pad ops, and possibly some trailing ops.
13284 * Note that we don't null() the skipped ops, to make it
13285 * easier for Deparse to undo this optimisation (and none of
13286 * the skipped ops are holding any resourses). It also makes
13287 * it easier for find_uninit_var(), as it can just ignore
13288 * padrange, and examine the original pad ops.
13292 OP *followop = NULL; /* the op that will follow the padrange op */
13295 PADOFFSET base = 0; /* init only to stop compiler whining */
13296 bool gvoid = 0; /* init only to stop compiler whining */
13297 bool defav = 0; /* seen (...) = @_ */
13298 bool reuse = 0; /* reuse an existing padrange op */
13300 /* look for a pushmark -> gv[_] -> rv2av */
13305 if ( p->op_type == OP_GV
13306 && cGVOPx_gv(p) == PL_defgv
13307 && (rv2av = p->op_next)
13308 && rv2av->op_type == OP_RV2AV
13309 && !(rv2av->op_flags & OPf_REF)
13310 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13311 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13313 q = rv2av->op_next;
13314 if (q->op_type == OP_NULL)
13316 if (q->op_type == OP_PUSHMARK) {
13326 /* scan for PAD ops */
13328 for (p = p->op_next; p; p = p->op_next) {
13329 if (p->op_type == OP_NULL)
13332 if (( p->op_type != OP_PADSV
13333 && p->op_type != OP_PADAV
13334 && p->op_type != OP_PADHV
13336 /* any private flag other than INTRO? e.g. STATE */
13337 || (p->op_private & ~OPpLVAL_INTRO)
13341 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13343 if ( p->op_type == OP_PADAV
13345 && p->op_next->op_type == OP_CONST
13346 && p->op_next->op_next
13347 && p->op_next->op_next->op_type == OP_AELEM
13351 /* for 1st padop, note what type it is and the range
13352 * start; for the others, check that it's the same type
13353 * and that the targs are contiguous */
13355 intro = (p->op_private & OPpLVAL_INTRO);
13357 gvoid = OP_GIMME(p,0) == G_VOID;
13360 if ((p->op_private & OPpLVAL_INTRO) != intro)
13362 /* Note that you'd normally expect targs to be
13363 * contiguous in my($a,$b,$c), but that's not the case
13364 * when external modules start doing things, e.g.
13365 i* Function::Parameters */
13366 if (p->op_targ != base + count)
13368 assert(p->op_targ == base + count);
13369 /* Either all the padops or none of the padops should
13370 be in void context. Since we only do the optimisa-
13371 tion for av/hv when the aggregate itself is pushed
13372 on to the stack (one item), there is no need to dis-
13373 tinguish list from scalar context. */
13374 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13378 /* for AV, HV, only when we're not flattening */
13379 if ( p->op_type != OP_PADSV
13381 && !(p->op_flags & OPf_REF)
13385 if (count >= OPpPADRANGE_COUNTMASK)
13388 /* there's a biggest base we can fit into a
13389 * SAVEt_CLEARPADRANGE in pp_padrange */
13390 if (intro && base >
13391 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
13394 /* Success! We've got another valid pad op to optimise away */
13396 followop = p->op_next;
13399 if (count < 1 || (count == 1 && !defav))
13402 /* pp_padrange in specifically compile-time void context
13403 * skips pushing a mark and lexicals; in all other contexts
13404 * (including unknown till runtime) it pushes a mark and the
13405 * lexicals. We must be very careful then, that the ops we
13406 * optimise away would have exactly the same effect as the
13408 * In particular in void context, we can only optimise to
13409 * a padrange if see see the complete sequence
13410 * pushmark, pad*v, ...., list
13411 * which has the net effect of of leaving the markstack as it
13412 * was. Not pushing on to the stack (whereas padsv does touch
13413 * the stack) makes no difference in void context.
13417 if (followop->op_type == OP_LIST
13418 && OP_GIMME(followop,0) == G_VOID
13421 followop = followop->op_next; /* skip OP_LIST */
13423 /* consolidate two successive my(...);'s */
13426 && oldoldop->op_type == OP_PADRANGE
13427 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13428 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13429 && !(oldoldop->op_flags & OPf_SPECIAL)
13432 assert(oldoldop->op_next == oldop);
13433 assert( oldop->op_type == OP_NEXTSTATE
13434 || oldop->op_type == OP_DBSTATE);
13435 assert(oldop->op_next == o);
13438 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13440 /* Do not assume pad offsets for $c and $d are con-
13445 if ( oldoldop->op_targ + old_count == base
13446 && old_count < OPpPADRANGE_COUNTMASK - count) {
13447 base = oldoldop->op_targ;
13448 count += old_count;
13453 /* if there's any immediately following singleton
13454 * my var's; then swallow them and the associated
13456 * my ($a,$b); my $c; my $d;
13458 * my ($a,$b,$c,$d);
13461 while ( ((p = followop->op_next))
13462 && ( p->op_type == OP_PADSV
13463 || p->op_type == OP_PADAV
13464 || p->op_type == OP_PADHV)
13465 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13466 && (p->op_private & OPpLVAL_INTRO) == intro
13467 && !(p->op_private & ~OPpLVAL_INTRO)
13469 && ( p->op_next->op_type == OP_NEXTSTATE
13470 || p->op_next->op_type == OP_DBSTATE)
13471 && count < OPpPADRANGE_COUNTMASK
13472 && base + count == p->op_targ
13475 followop = p->op_next;
13483 assert(oldoldop->op_type == OP_PADRANGE);
13484 oldoldop->op_next = followop;
13485 oldoldop->op_private = (intro | count);
13491 /* Convert the pushmark into a padrange.
13492 * To make Deparse easier, we guarantee that a padrange was
13493 * *always* formerly a pushmark */
13494 assert(o->op_type == OP_PUSHMARK);
13495 o->op_next = followop;
13496 OpTYPE_set(o, OP_PADRANGE);
13498 /* bit 7: INTRO; bit 6..0: count */
13499 o->op_private = (intro | count);
13500 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13501 | gvoid * OPf_WANT_VOID
13502 | (defav ? OPf_SPECIAL : 0));
13510 /* Skip over state($x) in void context. */
13511 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13512 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13514 oldop->op_next = o->op_next;
13515 goto redo_nextstate;
13517 if (o->op_type != OP_PADAV)
13521 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13522 OP* const pop = (o->op_type == OP_PADAV) ?
13523 o->op_next : o->op_next->op_next;
13525 if (pop && pop->op_type == OP_CONST &&
13526 ((PL_op = pop->op_next)) &&
13527 pop->op_next->op_type == OP_AELEM &&
13528 !(pop->op_next->op_private &
13529 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13530 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13533 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13534 no_bareword_allowed(pop);
13535 if (o->op_type == OP_GV)
13536 op_null(o->op_next);
13537 op_null(pop->op_next);
13539 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13540 o->op_next = pop->op_next->op_next;
13541 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13542 o->op_private = (U8)i;
13543 if (o->op_type == OP_GV) {
13546 o->op_type = OP_AELEMFAST;
13549 o->op_type = OP_AELEMFAST_LEX;
13551 if (o->op_type != OP_GV)
13555 /* Remove $foo from the op_next chain in void context. */
13557 && ( o->op_next->op_type == OP_RV2SV
13558 || o->op_next->op_type == OP_RV2AV
13559 || o->op_next->op_type == OP_RV2HV )
13560 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13561 && !(o->op_next->op_private & OPpLVAL_INTRO))
13563 oldop->op_next = o->op_next->op_next;
13564 /* Reprocess the previous op if it is a nextstate, to
13565 allow double-nextstate optimisation. */
13567 if (oldop->op_type == OP_NEXTSTATE) {
13576 else if (o->op_next->op_type == OP_RV2SV) {
13577 if (!(o->op_next->op_private & OPpDEREF)) {
13578 op_null(o->op_next);
13579 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13581 o->op_next = o->op_next->op_next;
13582 OpTYPE_set(o, OP_GVSV);
13585 else if (o->op_next->op_type == OP_READLINE
13586 && o->op_next->op_next->op_type == OP_CONCAT
13587 && (o->op_next->op_next->op_flags & OPf_STACKED))
13589 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13590 OpTYPE_set(o, OP_RCATLINE);
13591 o->op_flags |= OPf_STACKED;
13592 op_null(o->op_next->op_next);
13593 op_null(o->op_next);
13598 #define HV_OR_SCALARHV(op) \
13599 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13601 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13602 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
13603 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
13604 ? cUNOPx(op)->op_first \
13608 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13609 fop->op_private |= OPpTRUEBOOL;
13615 fop = cLOGOP->op_first;
13616 sop = OpSIBLING(fop);
13617 while (cLOGOP->op_other->op_type == OP_NULL)
13618 cLOGOP->op_other = cLOGOP->op_other->op_next;
13619 while (o->op_next && ( o->op_type == o->op_next->op_type
13620 || o->op_next->op_type == OP_NULL))
13621 o->op_next = o->op_next->op_next;
13623 /* if we're an OR and our next is a AND in void context, we'll
13624 follow it's op_other on short circuit, same for reverse.
13625 We can't do this with OP_DOR since if it's true, its return
13626 value is the underlying value which must be evaluated
13630 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13631 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13633 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13635 o->op_next = ((LOGOP*)o->op_next)->op_other;
13637 DEFER(cLOGOP->op_other);
13640 fop = HV_OR_SCALARHV(fop);
13641 if (sop) sop = HV_OR_SCALARHV(sop);
13646 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
13647 while (nop && nop->op_next) {
13648 switch (nop->op_next->op_type) {
13653 lop = nop = nop->op_next;
13656 nop = nop->op_next;
13665 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13666 || o->op_type == OP_AND )
13667 fop->op_private |= OPpTRUEBOOL;
13668 else if (!(lop->op_flags & OPf_WANT))
13669 fop->op_private |= OPpMAYBE_TRUEBOOL;
13671 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13673 sop->op_private |= OPpTRUEBOOL;
13680 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
13681 fop->op_private |= OPpTRUEBOOL;
13682 #undef HV_OR_SCALARHV
13683 /* GERONIMO! */ /* FALLTHROUGH */
13692 while (cLOGOP->op_other->op_type == OP_NULL)
13693 cLOGOP->op_other = cLOGOP->op_other->op_next;
13694 DEFER(cLOGOP->op_other);
13699 while (cLOOP->op_redoop->op_type == OP_NULL)
13700 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
13701 while (cLOOP->op_nextop->op_type == OP_NULL)
13702 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
13703 while (cLOOP->op_lastop->op_type == OP_NULL)
13704 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
13705 /* a while(1) loop doesn't have an op_next that escapes the
13706 * loop, so we have to explicitly follow the op_lastop to
13707 * process the rest of the code */
13708 DEFER(cLOOP->op_lastop);
13712 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
13713 DEFER(cLOGOPo->op_other);
13717 assert(!(cPMOP->op_pmflags & PMf_ONCE));
13718 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
13719 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
13720 cPMOP->op_pmstashstartu.op_pmreplstart
13721 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
13722 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
13728 if (o->op_flags & OPf_SPECIAL) {
13729 /* first arg is a code block */
13730 OP * const nullop = OpSIBLING(cLISTOP->op_first);
13731 OP * kid = cUNOPx(nullop)->op_first;
13733 assert(nullop->op_type == OP_NULL);
13734 assert(kid->op_type == OP_SCOPE
13735 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
13736 /* since OP_SORT doesn't have a handy op_other-style
13737 * field that can point directly to the start of the code
13738 * block, store it in the otherwise-unused op_next field
13739 * of the top-level OP_NULL. This will be quicker at
13740 * run-time, and it will also allow us to remove leading
13741 * OP_NULLs by just messing with op_nexts without
13742 * altering the basic op_first/op_sibling layout. */
13743 kid = kLISTOP->op_first;
13745 (kid->op_type == OP_NULL
13746 && ( kid->op_targ == OP_NEXTSTATE
13747 || kid->op_targ == OP_DBSTATE ))
13748 || kid->op_type == OP_STUB
13749 || kid->op_type == OP_ENTER);
13750 nullop->op_next = kLISTOP->op_next;
13751 DEFER(nullop->op_next);
13754 /* check that RHS of sort is a single plain array */
13755 oright = cUNOPo->op_first;
13756 if (!oright || oright->op_type != OP_PUSHMARK)
13759 if (o->op_private & OPpSORT_INPLACE)
13762 /* reverse sort ... can be optimised. */
13763 if (!OpHAS_SIBLING(cUNOPo)) {
13764 /* Nothing follows us on the list. */
13765 OP * const reverse = o->op_next;
13767 if (reverse->op_type == OP_REVERSE &&
13768 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
13769 OP * const pushmark = cUNOPx(reverse)->op_first;
13770 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
13771 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
13772 /* reverse -> pushmark -> sort */
13773 o->op_private |= OPpSORT_REVERSE;
13775 pushmark->op_next = oright->op_next;
13785 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
13787 LISTOP *enter, *exlist;
13789 if (o->op_private & OPpSORT_INPLACE)
13792 enter = (LISTOP *) o->op_next;
13795 if (enter->op_type == OP_NULL) {
13796 enter = (LISTOP *) enter->op_next;
13800 /* for $a (...) will have OP_GV then OP_RV2GV here.
13801 for (...) just has an OP_GV. */
13802 if (enter->op_type == OP_GV) {
13803 gvop = (OP *) enter;
13804 enter = (LISTOP *) enter->op_next;
13807 if (enter->op_type == OP_RV2GV) {
13808 enter = (LISTOP *) enter->op_next;
13814 if (enter->op_type != OP_ENTERITER)
13817 iter = enter->op_next;
13818 if (!iter || iter->op_type != OP_ITER)
13821 expushmark = enter->op_first;
13822 if (!expushmark || expushmark->op_type != OP_NULL
13823 || expushmark->op_targ != OP_PUSHMARK)
13826 exlist = (LISTOP *) OpSIBLING(expushmark);
13827 if (!exlist || exlist->op_type != OP_NULL
13828 || exlist->op_targ != OP_LIST)
13831 if (exlist->op_last != o) {
13832 /* Mmm. Was expecting to point back to this op. */
13835 theirmark = exlist->op_first;
13836 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
13839 if (OpSIBLING(theirmark) != o) {
13840 /* There's something between the mark and the reverse, eg
13841 for (1, reverse (...))
13846 ourmark = ((LISTOP *)o)->op_first;
13847 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
13850 ourlast = ((LISTOP *)o)->op_last;
13851 if (!ourlast || ourlast->op_next != o)
13854 rv2av = OpSIBLING(ourmark);
13855 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
13856 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
13857 /* We're just reversing a single array. */
13858 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
13859 enter->op_flags |= OPf_STACKED;
13862 /* We don't have control over who points to theirmark, so sacrifice
13864 theirmark->op_next = ourmark->op_next;
13865 theirmark->op_flags = ourmark->op_flags;
13866 ourlast->op_next = gvop ? gvop : (OP *) enter;
13869 enter->op_private |= OPpITER_REVERSED;
13870 iter->op_private |= OPpITER_REVERSED;
13877 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
13878 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
13883 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
13884 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
13887 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
13889 sv = newRV((SV *)PL_compcv);
13893 OpTYPE_set(o, OP_CONST);
13894 o->op_flags |= OPf_SPECIAL;
13895 cSVOPo->op_sv = sv;
13900 if (OP_GIMME(o,0) == G_VOID
13901 || ( o->op_next->op_type == OP_LINESEQ
13902 && ( o->op_next->op_next->op_type == OP_LEAVESUB
13903 || ( o->op_next->op_next->op_type == OP_RETURN
13904 && !CvLVALUE(PL_compcv)))))
13906 OP *right = cBINOP->op_first;
13925 OP *left = OpSIBLING(right);
13926 if (left->op_type == OP_SUBSTR
13927 && (left->op_private & 7) < 4) {
13929 /* cut out right */
13930 op_sibling_splice(o, NULL, 1, NULL);
13931 /* and insert it as second child of OP_SUBSTR */
13932 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
13934 left->op_private |= OPpSUBSTR_REPL_FIRST;
13936 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13943 /* We do the common-vars check here, rather than in newASSIGNOP
13944 (as formerly), so that all lexical vars that get aliased are
13945 marked as such before we do the check. */
13946 /* There can’t be common vars if the lhs is a stub. */
13947 if (OpSIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
13948 == cLISTOPx(cBINOPo->op_last)->op_last
13949 && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
13951 o->op_private &=~ OPpASSIGN_COMMON;
13954 if (o->op_private & OPpASSIGN_COMMON) {
13955 /* See the comment before S_aassign_common_vars concerning
13956 PL_generation sorcery. */
13958 if (!aassign_common_vars(o))
13959 o->op_private &=~ OPpASSIGN_COMMON;
13961 else if (S_aassign_common_vars_aliases_only(aTHX_ o))
13962 o->op_private |= OPpASSIGN_COMMON;
13966 Perl_cpeep_t cpeep =
13967 XopENTRYCUSTOM(o, xop_peep);
13969 cpeep(aTHX_ o, oldop);
13974 /* did we just null the current op? If so, re-process it to handle
13975 * eliding "empty" ops from the chain */
13976 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
13989 Perl_peep(pTHX_ OP *o)
13995 =head1 Custom Operators
13997 =for apidoc Ao||custom_op_xop
13998 Return the XOP structure for a given custom op. This macro should be
13999 considered internal to OP_NAME and the other access macros: use them instead.
14000 This macro does call a function. Prior
14001 to 5.19.6, this was implemented as a
14008 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14014 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14016 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14017 assert(o->op_type == OP_CUSTOM);
14019 /* This is wrong. It assumes a function pointer can be cast to IV,
14020 * which isn't guaranteed, but this is what the old custom OP code
14021 * did. In principle it should be safer to Copy the bytes of the
14022 * pointer into a PV: since the new interface is hidden behind
14023 * functions, this can be changed later if necessary. */
14024 /* Change custom_op_xop if this ever happens */
14025 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14028 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14030 /* assume noone will have just registered a desc */
14031 if (!he && PL_custom_op_names &&
14032 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14037 /* XXX does all this need to be shared mem? */
14038 Newxz(xop, 1, XOP);
14039 pv = SvPV(HeVAL(he), l);
14040 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14041 if (PL_custom_op_descs &&
14042 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14044 pv = SvPV(HeVAL(he), l);
14045 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14047 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14051 xop = (XOP *)&xop_null;
14053 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14057 if(field == XOPe_xop_ptr) {
14060 const U32 flags = XopFLAGS(xop);
14061 if(flags & field) {
14063 case XOPe_xop_name:
14064 any.xop_name = xop->xop_name;
14066 case XOPe_xop_desc:
14067 any.xop_desc = xop->xop_desc;
14069 case XOPe_xop_class:
14070 any.xop_class = xop->xop_class;
14072 case XOPe_xop_peep:
14073 any.xop_peep = xop->xop_peep;
14076 NOT_REACHED; /* NOTREACHED */
14081 case XOPe_xop_name:
14082 any.xop_name = XOPd_xop_name;
14084 case XOPe_xop_desc:
14085 any.xop_desc = XOPd_xop_desc;
14087 case XOPe_xop_class:
14088 any.xop_class = XOPd_xop_class;
14090 case XOPe_xop_peep:
14091 any.xop_peep = XOPd_xop_peep;
14094 NOT_REACHED; /* NOTREACHED */
14099 /* Some gcc releases emit a warning for this function:
14100 * op.c: In function 'Perl_custom_op_get_field':
14101 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14102 * Whether this is true, is currently unknown. */
14108 =for apidoc Ao||custom_op_register
14109 Register a custom op. See L<perlguts/"Custom Operators">.
14115 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14119 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14121 /* see the comment in custom_op_xop */
14122 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14124 if (!PL_custom_ops)
14125 PL_custom_ops = newHV();
14127 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14128 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14133 =for apidoc core_prototype
14135 This function assigns the prototype of the named core function to C<sv>, or
14136 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
14137 NULL if the core function has no prototype. C<code> is a code as returned
14138 by C<keyword()>. It must not be equal to 0.
14144 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14147 int i = 0, n = 0, seen_question = 0, defgv = 0;
14149 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14150 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14151 bool nullret = FALSE;
14153 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14157 if (!sv) sv = sv_newmortal();
14159 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14161 switch (code < 0 ? -code : code) {
14162 case KEY_and : case KEY_chop: case KEY_chomp:
14163 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14164 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14165 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14166 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14167 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14168 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14169 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14170 case KEY_x : case KEY_xor :
14171 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14172 case KEY_glob: retsetpvs("_;", OP_GLOB);
14173 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
14174 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
14175 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
14176 case KEY_push: retsetpvs("\\@@", OP_PUSH);
14177 case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
14178 case KEY_pop: retsetpvs(";\\@", OP_POP);
14179 case KEY_shift: retsetpvs(";\\@", OP_SHIFT);
14180 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14182 retsetpvs("\\@;$$@", OP_SPLICE);
14183 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14185 case KEY_evalbytes:
14186 name = "entereval"; break;
14194 while (i < MAXO) { /* The slow way. */
14195 if (strEQ(name, PL_op_name[i])
14196 || strEQ(name, PL_op_desc[i]))
14198 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14205 defgv = PL_opargs[i] & OA_DEFGV;
14206 oa = PL_opargs[i] >> OASHIFT;
14208 if (oa & OA_OPTIONAL && !seen_question && (
14209 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14214 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14215 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14216 /* But globs are already references (kinda) */
14217 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14221 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14222 && !scalar_mod_type(NULL, i)) {
14227 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14231 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14232 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14233 str[n-1] = '_'; defgv = 0;
14237 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14239 sv_setpvn(sv, str, n - 1);
14240 if (opnum) *opnum = i;
14245 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14248 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14251 PERL_ARGS_ASSERT_CORESUB_OP;
14255 return op_append_elem(OP_LINESEQ,
14258 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14262 case OP_SELECT: /* which represents OP_SSELECT as well */
14267 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14268 newSVOP(OP_CONST, 0, newSVuv(1))
14270 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14272 coresub_op(coreargssv, 0, OP_SELECT)
14276 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14278 return op_append_elem(
14281 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14282 ? OPpOFFBYONE << 8 : 0)
14284 case OA_BASEOP_OR_UNOP:
14285 if (opnum == OP_ENTEREVAL) {
14286 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14287 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14289 else o = newUNOP(opnum,0,argop);
14290 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14293 if (is_handle_constructor(o, 1))
14294 argop->op_private |= OPpCOREARGS_DEREF1;
14295 if (scalar_mod_type(NULL, opnum))
14296 argop->op_private |= OPpCOREARGS_SCALARMOD;
14300 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14301 if (is_handle_constructor(o, 2))
14302 argop->op_private |= OPpCOREARGS_DEREF2;
14303 if (opnum == OP_SUBSTR) {
14304 o->op_private |= OPpMAYBE_LVSUB;
14313 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14314 SV * const *new_const_svp)
14316 const char *hvname;
14317 bool is_const = !!CvCONST(old_cv);
14318 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14320 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14322 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14324 /* They are 2 constant subroutines generated from
14325 the same constant. This probably means that
14326 they are really the "same" proxy subroutine
14327 instantiated in 2 places. Most likely this is
14328 when a constant is exported twice. Don't warn.
14331 (ckWARN(WARN_REDEFINE)
14333 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14334 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14335 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14336 strEQ(hvname, "autouse"))
14340 && ckWARN_d(WARN_REDEFINE)
14341 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14344 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14346 ? "Constant subroutine %"SVf" redefined"
14347 : "Subroutine %"SVf" redefined",
14352 =head1 Hook manipulation
14354 These functions provide convenient and thread-safe means of manipulating
14361 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14363 Puts a C function into the chain of check functions for a specified op
14364 type. This is the preferred way to manipulate the L</PL_check> array.
14365 I<opcode> specifies which type of op is to be affected. I<new_checker>
14366 is a pointer to the C function that is to be added to that opcode's
14367 check chain, and I<old_checker_p> points to the storage location where a
14368 pointer to the next function in the chain will be stored. The value of
14369 I<new_pointer> is written into the L</PL_check> array, while the value
14370 previously stored there is written to I<*old_checker_p>.
14372 The function should be defined like this:
14374 static OP *new_checker(pTHX_ OP *op) { ... }
14376 It is intended to be called in this manner:
14378 new_checker(aTHX_ op)
14380 I<old_checker_p> should be defined like this:
14382 static Perl_check_t old_checker_p;
14384 L</PL_check> is global to an entire process, and a module wishing to
14385 hook op checking may find itself invoked more than once per process,
14386 typically in different threads. To handle that situation, this function
14387 is idempotent. The location I<*old_checker_p> must initially (once
14388 per process) contain a null pointer. A C variable of static duration
14389 (declared at file scope, typically also marked C<static> to give
14390 it internal linkage) will be implicitly initialised appropriately,
14391 if it does not have an explicit initialiser. This function will only
14392 actually modify the check chain if it finds I<*old_checker_p> to be null.
14393 This function is also thread safe on the small scale. It uses appropriate
14394 locking to avoid race conditions in accessing L</PL_check>.
14396 When this function is called, the function referenced by I<new_checker>
14397 must be ready to be called, except for I<*old_checker_p> being unfilled.
14398 In a threading situation, I<new_checker> may be called immediately,
14399 even before this function has returned. I<*old_checker_p> will always
14400 be appropriately set before I<new_checker> is called. If I<new_checker>
14401 decides not to do anything special with an op that it is given (which
14402 is the usual case for most uses of op check hooking), it must chain the
14403 check function referenced by I<*old_checker_p>.
14405 If you want to influence compilation of calls to a specific subroutine,
14406 then use L</cv_set_call_checker> rather than hooking checking of all
14413 Perl_wrap_op_checker(pTHX_ Optype opcode,
14414 Perl_check_t new_checker, Perl_check_t *old_checker_p)
14418 PERL_UNUSED_CONTEXT;
14419 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14420 if (*old_checker_p) return;
14421 OP_CHECK_MUTEX_LOCK;
14422 if (!*old_checker_p) {
14423 *old_checker_p = PL_check[opcode];
14424 PL_check[opcode] = new_checker;
14426 OP_CHECK_MUTEX_UNLOCK;
14431 /* Efficient sub that returns a constant scalar value. */
14433 const_sv_xsub(pTHX_ CV* cv)
14436 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14437 PERL_UNUSED_ARG(items);
14447 const_av_xsub(pTHX_ CV* cv)
14450 AV * const av = MUTABLE_AV(XSANY.any_ptr);
14458 if (SvRMAGICAL(av))
14459 Perl_croak(aTHX_ "Magical list constants are not supported");
14460 if (GIMME_V != G_ARRAY) {
14462 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14465 EXTEND(SP, AvFILLp(av)+1);
14466 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14467 XSRETURN(AvFILLp(av)+1);
14471 * ex: set ts=8 sts=4 sw=4 et: