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] == '_' && 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);
611 /* allocate a spare slot and store the name in that slot */
613 off = pad_add_name_pvn(name, len,
614 (is_our ? padadd_OUR :
615 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
616 PL_parser->in_my_stash,
618 /* $_ is always in main::, even with our */
619 ? (PL_curstash && !memEQs(name,len,"$_")
625 /* anon sub prototypes contains state vars should always be cloned,
626 * otherwise the state var would be shared between anon subs */
628 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
629 CvCLONE_on(PL_compcv);
635 =head1 Optree Manipulation Functions
637 =for apidoc alloccopstash
639 Available only under threaded builds, this function allocates an entry in
640 C<PL_stashpad> for the stash passed to it.
647 Perl_alloccopstash(pTHX_ HV *hv)
649 PADOFFSET off = 0, o = 1;
650 bool found_slot = FALSE;
652 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
654 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
656 for (; o < PL_stashpadmax; ++o) {
657 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
658 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
659 found_slot = TRUE, off = o;
662 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
663 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
664 off = PL_stashpadmax;
665 PL_stashpadmax += 10;
668 PL_stashpad[PL_stashpadix = off] = hv;
673 /* free the body of an op without examining its contents.
674 * Always use this rather than FreeOp directly */
677 S_op_destroy(pTHX_ OP *o)
685 =for apidoc Am|void|op_free|OP *o
687 Free an op. Only use this when an op is no longer linked to from any
694 Perl_op_free(pTHX_ OP *o)
698 SSize_t defer_ix = -1;
699 SSize_t defer_stack_alloc = 0;
700 OP **defer_stack = NULL;
704 /* Though ops may be freed twice, freeing the op after its slab is a
706 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
707 /* During the forced freeing of ops after compilation failure, kidops
708 may be freed before their parents. */
709 if (!o || o->op_type == OP_FREED)
714 /* an op should only ever acquire op_private flags that we know about.
715 * If this fails, you may need to fix something in regen/op_private */
716 if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
717 assert(!(o->op_private & ~PL_op_private_valid[type]));
720 if (o->op_private & OPpREFCOUNTED) {
731 refcnt = OpREFCNT_dec(o);
734 /* Need to find and remove any pattern match ops from the list
735 we maintain for reset(). */
736 find_and_forget_pmops(o);
746 /* Call the op_free hook if it has been set. Do it now so that it's called
747 * at the right time for refcounted ops, but still before all of the kids
751 if (o->op_flags & OPf_KIDS) {
753 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
754 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
755 if (!kid || kid->op_type == OP_FREED)
756 /* During the forced freeing of ops after
757 compilation failure, kidops may be freed before
760 if (!(kid->op_flags & OPf_KIDS))
761 /* If it has no kids, just free it now */
768 type = (OPCODE)o->op_targ;
771 Slab_to_rw(OpSLAB(o));
773 /* COP* is not cleared by op_clear() so that we may track line
774 * numbers etc even after null() */
775 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
781 #ifdef DEBUG_LEAKING_SCALARS
785 } while ( (o = POP_DEFERRED_OP()) );
787 Safefree(defer_stack);
790 /* S_op_clear_gv(): free a GV attached to an OP */
793 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
795 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
799 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
800 || o->op_type == OP_MULTIDEREF)
803 ? ((GV*)PAD_SVl(*ixp)) : NULL;
805 ? (GV*)(*svp) : NULL;
807 /* It's possible during global destruction that the GV is freed
808 before the optree. Whilst the SvREFCNT_inc is happy to bump from
809 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
810 will trigger an assertion failure, because the entry to sv_clear
811 checks that the scalar is not already freed. A check of for
812 !SvIS_FREED(gv) turns out to be invalid, because during global
813 destruction the reference count can be forced down to zero
814 (with SVf_BREAK set). In which case raising to 1 and then
815 dropping to 0 triggers cleanup before it should happen. I
816 *think* that this might actually be a general, systematic,
817 weakness of the whole idea of SVf_BREAK, in that code *is*
818 allowed to raise and lower references during global destruction,
819 so any *valid* code that happens to do this during global
820 destruction might well trigger premature cleanup. */
821 bool still_valid = gv && SvREFCNT(gv);
824 SvREFCNT_inc_simple_void(gv);
827 pad_swipe(*ixp, TRUE);
835 int try_downgrade = SvREFCNT(gv) == 2;
838 gv_try_downgrade(gv);
844 Perl_op_clear(pTHX_ OP *o)
849 PERL_ARGS_ASSERT_OP_CLEAR;
851 switch (o->op_type) {
852 case OP_NULL: /* Was holding old type, if any. */
855 case OP_ENTEREVAL: /* Was holding hints. */
859 if (!(o->op_flags & OPf_REF)
860 || (PL_check[o->op_type] != Perl_ck_ftst))
867 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
869 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
872 case OP_METHOD_REDIR:
873 case OP_METHOD_REDIR_SUPER:
875 if (cMETHOPx(o)->op_rclass_targ) {
876 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
877 cMETHOPx(o)->op_rclass_targ = 0;
880 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
881 cMETHOPx(o)->op_rclass_sv = NULL;
883 case OP_METHOD_NAMED:
884 case OP_METHOD_SUPER:
885 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
886 cMETHOPx(o)->op_u.op_meth_sv = NULL;
889 pad_swipe(o->op_targ, 1);
896 SvREFCNT_dec(cSVOPo->op_sv);
897 cSVOPo->op_sv = NULL;
900 Even if op_clear does a pad_free for the target of the op,
901 pad_free doesn't actually remove the sv that exists in the pad;
902 instead it lives on. This results in that it could be reused as
903 a target later on when the pad was reallocated.
906 pad_swipe(o->op_targ,1);
916 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
921 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
922 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
924 if (cPADOPo->op_padix > 0) {
925 pad_swipe(cPADOPo->op_padix, TRUE);
926 cPADOPo->op_padix = 0;
929 SvREFCNT_dec(cSVOPo->op_sv);
930 cSVOPo->op_sv = NULL;
934 PerlMemShared_free(cPVOPo->op_pv);
935 cPVOPo->op_pv = NULL;
939 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
943 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
944 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
947 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
953 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
954 op_free(cPMOPo->op_code_list);
955 cPMOPo->op_code_list = NULL;
957 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
958 /* we use the same protection as the "SAFE" version of the PM_ macros
959 * here since sv_clean_all might release some PMOPs
960 * after PL_regex_padav has been cleared
961 * and the clearing of PL_regex_padav needs to
962 * happen before sv_clean_all
965 if(PL_regex_pad) { /* We could be in destruction */
966 const IV offset = (cPMOPo)->op_pmoffset;
967 ReREFCNT_dec(PM_GETRE(cPMOPo));
968 PL_regex_pad[offset] = &PL_sv_undef;
969 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
973 ReREFCNT_dec(PM_GETRE(cPMOPo));
974 PM_SETRE(cPMOPo, NULL);
981 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
982 UV actions = items->uv;
984 bool is_hash = FALSE;
987 switch (actions & MDEREF_ACTION_MASK) {
990 actions = (++items)->uv;
993 case MDEREF_HV_padhv_helem:
995 case MDEREF_AV_padav_aelem:
996 pad_free((++items)->pad_offset);
999 case MDEREF_HV_gvhv_helem:
1001 case MDEREF_AV_gvav_aelem:
1003 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1005 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1009 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1011 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1013 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1015 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1017 goto do_vivify_rv2xv_elem;
1019 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1021 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1022 pad_free((++items)->pad_offset);
1023 goto do_vivify_rv2xv_elem;
1025 case MDEREF_HV_pop_rv2hv_helem:
1026 case MDEREF_HV_vivify_rv2hv_helem:
1028 do_vivify_rv2xv_elem:
1029 case MDEREF_AV_pop_rv2av_aelem:
1030 case MDEREF_AV_vivify_rv2av_aelem:
1032 switch (actions & MDEREF_INDEX_MASK) {
1033 case MDEREF_INDEX_none:
1036 case MDEREF_INDEX_const:
1040 pad_swipe((++items)->pad_offset, 1);
1042 SvREFCNT_dec((++items)->sv);
1048 case MDEREF_INDEX_padsv:
1049 pad_free((++items)->pad_offset);
1051 case MDEREF_INDEX_gvsv:
1053 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1055 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1060 if (actions & MDEREF_FLAG_last)
1073 actions >>= MDEREF_SHIFT;
1076 /* start of malloc is at op_aux[-1], where the length is
1078 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1083 if (o->op_targ > 0) {
1084 pad_free(o->op_targ);
1090 S_cop_free(pTHX_ COP* cop)
1092 PERL_ARGS_ASSERT_COP_FREE;
1095 if (! specialWARN(cop->cop_warnings))
1096 PerlMemShared_free(cop->cop_warnings);
1097 cophh_free(CopHINTHASH_get(cop));
1098 if (PL_curcop == cop)
1103 S_forget_pmop(pTHX_ PMOP *const o
1106 HV * const pmstash = PmopSTASH(o);
1108 PERL_ARGS_ASSERT_FORGET_PMOP;
1110 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1111 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1113 PMOP **const array = (PMOP**) mg->mg_ptr;
1114 U32 count = mg->mg_len / sizeof(PMOP**);
1118 if (array[i] == o) {
1119 /* Found it. Move the entry at the end to overwrite it. */
1120 array[i] = array[--count];
1121 mg->mg_len = count * sizeof(PMOP**);
1122 /* Could realloc smaller at this point always, but probably
1123 not worth it. Probably worth free()ing if we're the
1126 Safefree(mg->mg_ptr);
1139 S_find_and_forget_pmops(pTHX_ OP *o)
1141 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1143 if (o->op_flags & OPf_KIDS) {
1144 OP *kid = cUNOPo->op_first;
1146 switch (kid->op_type) {
1151 forget_pmop((PMOP*)kid);
1153 find_and_forget_pmops(kid);
1154 kid = OpSIBLING(kid);
1160 =for apidoc Am|void|op_null|OP *o
1162 Neutralizes an op when it is no longer needed, but is still linked to from
1169 Perl_op_null(pTHX_ OP *o)
1173 PERL_ARGS_ASSERT_OP_NULL;
1175 if (o->op_type == OP_NULL)
1178 o->op_targ = o->op_type;
1179 OpTYPE_set(o, OP_NULL);
1183 Perl_op_refcnt_lock(pTHX)
1188 PERL_UNUSED_CONTEXT;
1193 Perl_op_refcnt_unlock(pTHX)
1198 PERL_UNUSED_CONTEXT;
1204 =for apidoc op_sibling_splice
1206 A general function for editing the structure of an existing chain of
1207 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1208 you to delete zero or more sequential nodes, replacing them with zero or
1209 more different nodes. Performs the necessary op_first/op_last
1210 housekeeping on the parent node and op_sibling manipulation on the
1211 children. The last deleted node will be marked as as the last node by
1212 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1214 Note that op_next is not manipulated, and nodes are not freed; that is the
1215 responsibility of the caller. It also won't create a new list op for an
1216 empty list etc; use higher-level functions like op_append_elem() for that.
1218 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1219 the splicing doesn't affect the first or last op in the chain.
1221 C<start> is the node preceding the first node to be spliced. Node(s)
1222 following it will be deleted, and ops will be inserted after it. If it is
1223 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1226 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1227 If -1 or greater than or equal to the number of remaining kids, all
1228 remaining kids are deleted.
1230 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1231 If C<NULL>, no nodes are inserted.
1233 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1238 action before after returns
1239 ------ ----- ----- -------
1242 splice(P, A, 2, X-Y-Z) | | B-C
1246 splice(P, NULL, 1, X-Y) | | A
1250 splice(P, NULL, 3, NULL) | | A-B-C
1254 splice(P, B, 0, X-Y) | | NULL
1258 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1259 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1265 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1269 OP *last_del = NULL;
1270 OP *last_ins = NULL;
1273 first = OpSIBLING(start);
1277 first = cLISTOPx(parent)->op_first;
1279 assert(del_count >= -1);
1281 if (del_count && first) {
1283 while (--del_count && OpHAS_SIBLING(last_del))
1284 last_del = OpSIBLING(last_del);
1285 rest = OpSIBLING(last_del);
1286 OpLASTSIB_set(last_del, NULL);
1293 while (OpHAS_SIBLING(last_ins))
1294 last_ins = OpSIBLING(last_ins);
1295 OpMAYBESIB_set(last_ins, rest, NULL);
1301 OpMAYBESIB_set(start, insert, NULL);
1306 cLISTOPx(parent)->op_first = insert;
1308 parent->op_flags |= OPf_KIDS;
1310 parent->op_flags &= ~OPf_KIDS;
1314 /* update op_last etc */
1321 /* ought to use OP_CLASS(parent) here, but that can't handle
1322 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1324 type = parent->op_type;
1325 if (type == OP_CUSTOM) {
1327 type = XopENTRYCUSTOM(parent, xop_class);
1330 if (type == OP_NULL)
1331 type = parent->op_targ;
1332 type = PL_opargs[type] & OA_CLASS_MASK;
1335 lastop = last_ins ? last_ins : start ? start : NULL;
1336 if ( type == OA_BINOP
1337 || type == OA_LISTOP
1341 cLISTOPx(parent)->op_last = lastop;
1344 OpLASTSIB_set(lastop, parent);
1346 return last_del ? first : NULL;
1349 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1353 #ifdef PERL_OP_PARENT
1356 =for apidoc op_parent
1358 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1359 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1365 Perl_op_parent(OP *o)
1367 PERL_ARGS_ASSERT_OP_PARENT;
1368 while (OpHAS_SIBLING(o))
1370 return o->op_sibparent;
1376 /* replace the sibling following start with a new UNOP, which becomes
1377 * the parent of the original sibling; e.g.
1379 * op_sibling_newUNOP(P, A, unop-args...)
1387 * where U is the new UNOP.
1389 * parent and start args are the same as for op_sibling_splice();
1390 * type and flags args are as newUNOP().
1392 * Returns the new UNOP.
1396 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1400 kid = op_sibling_splice(parent, start, 1, NULL);
1401 newop = newUNOP(type, flags, kid);
1402 op_sibling_splice(parent, start, 0, newop);
1407 /* lowest-level newLOGOP-style function - just allocates and populates
1408 * the struct. Higher-level stuff should be done by S_new_logop() /
1409 * newLOGOP(). This function exists mainly to avoid op_first assignment
1410 * being spread throughout this file.
1414 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1419 NewOp(1101, logop, 1, LOGOP);
1420 OpTYPE_set(logop, type);
1421 logop->op_first = first;
1422 logop->op_other = other;
1423 logop->op_flags = OPf_KIDS;
1424 while (kid && OpHAS_SIBLING(kid))
1425 kid = OpSIBLING(kid);
1427 OpLASTSIB_set(kid, (OP*)logop);
1432 /* Contextualizers */
1435 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1437 Applies a syntactic context to an op tree representing an expression.
1438 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1439 or C<G_VOID> to specify the context to apply. The modified op tree
1446 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1448 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1450 case G_SCALAR: return scalar(o);
1451 case G_ARRAY: return list(o);
1452 case G_VOID: return scalarvoid(o);
1454 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1461 =for apidoc Am|OP*|op_linklist|OP *o
1462 This function is the implementation of the L</LINKLIST> macro. It should
1463 not be called directly.
1469 Perl_op_linklist(pTHX_ OP *o)
1473 PERL_ARGS_ASSERT_OP_LINKLIST;
1478 /* establish postfix order */
1479 first = cUNOPo->op_first;
1482 o->op_next = LINKLIST(first);
1485 OP *sibl = OpSIBLING(kid);
1487 kid->op_next = LINKLIST(sibl);
1502 S_scalarkids(pTHX_ OP *o)
1504 if (o && o->op_flags & OPf_KIDS) {
1506 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1513 S_scalarboolean(pTHX_ OP *o)
1515 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1517 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1518 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1519 if (ckWARN(WARN_SYNTAX)) {
1520 const line_t oldline = CopLINE(PL_curcop);
1522 if (PL_parser && PL_parser->copline != NOLINE) {
1523 /* This ensures that warnings are reported at the first line
1524 of the conditional, not the last. */
1525 CopLINE_set(PL_curcop, PL_parser->copline);
1527 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1528 CopLINE_set(PL_curcop, oldline);
1535 S_op_varname(pTHX_ const OP *o)
1538 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1539 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1541 const char funny = o->op_type == OP_PADAV
1542 || o->op_type == OP_RV2AV ? '@' : '%';
1543 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1545 if (cUNOPo->op_first->op_type != OP_GV
1546 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1548 return varname(gv, funny, 0, NULL, 0, 1);
1551 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1556 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1557 { /* or not so pretty :-) */
1558 if (o->op_type == OP_CONST) {
1560 if (SvPOK(*retsv)) {
1562 *retsv = sv_newmortal();
1563 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1564 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1566 else if (!SvOK(*retsv))
1569 else *retpv = "...";
1573 S_scalar_slice_warning(pTHX_ const OP *o)
1577 o->op_type == OP_HSLICE ? '{' : '[';
1579 o->op_type == OP_HSLICE ? '}' : ']';
1581 SV *keysv = NULL; /* just to silence compiler warnings */
1582 const char *key = NULL;
1584 if (!(o->op_private & OPpSLICEWARNING))
1586 if (PL_parser && PL_parser->error_count)
1587 /* This warning can be nonsensical when there is a syntax error. */
1590 kid = cLISTOPo->op_first;
1591 kid = OpSIBLING(kid); /* get past pushmark */
1592 /* weed out false positives: any ops that can return lists */
1593 switch (kid->op_type) {
1619 /* Don't warn if we have a nulled list either. */
1620 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1623 assert(OpSIBLING(kid));
1624 name = S_op_varname(aTHX_ OpSIBLING(kid));
1625 if (!name) /* XS module fiddling with the op tree */
1627 S_op_pretty(aTHX_ kid, &keysv, &key);
1628 assert(SvPOK(name));
1629 sv_chop(name,SvPVX(name)+1);
1631 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1632 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1633 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1635 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1636 lbrack, key, rbrack);
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%"SVf"%c better written as $%"
1642 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1643 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1647 Perl_scalar(pTHX_ OP *o)
1651 /* assumes no premature commitment */
1652 if (!o || (PL_parser && PL_parser->error_count)
1653 || (o->op_flags & OPf_WANT)
1654 || o->op_type == OP_RETURN)
1659 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1661 switch (o->op_type) {
1663 scalar(cBINOPo->op_first);
1664 if (o->op_private & OPpREPEAT_DOLIST) {
1665 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1666 assert(kid->op_type == OP_PUSHMARK);
1667 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1668 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1669 o->op_private &=~ OPpREPEAT_DOLIST;
1676 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1686 if (o->op_flags & OPf_KIDS) {
1687 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1693 kid = cLISTOPo->op_first;
1695 kid = OpSIBLING(kid);
1698 OP *sib = OpSIBLING(kid);
1699 if (sib && kid->op_type != OP_LEAVEWHEN
1700 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1701 || ( sib->op_targ != OP_NEXTSTATE
1702 && sib->op_targ != OP_DBSTATE )))
1708 PL_curcop = &PL_compiling;
1713 kid = cLISTOPo->op_first;
1716 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1721 /* Warn about scalar context */
1722 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1723 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1726 const char *key = NULL;
1728 /* This warning can be nonsensical when there is a syntax error. */
1729 if (PL_parser && PL_parser->error_count)
1732 if (!ckWARN(WARN_SYNTAX)) break;
1734 kid = cLISTOPo->op_first;
1735 kid = OpSIBLING(kid); /* get past pushmark */
1736 assert(OpSIBLING(kid));
1737 name = S_op_varname(aTHX_ OpSIBLING(kid));
1738 if (!name) /* XS module fiddling with the op tree */
1740 S_op_pretty(aTHX_ kid, &keysv, &key);
1741 assert(SvPOK(name));
1742 sv_chop(name,SvPVX(name)+1);
1744 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1745 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1746 "%%%"SVf"%c%s%c in scalar context better written "
1748 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1749 lbrack, key, rbrack);
1751 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1752 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1753 "%%%"SVf"%c%"SVf"%c in scalar context better "
1754 "written as $%"SVf"%c%"SVf"%c",
1755 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1756 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1763 Perl_scalarvoid(pTHX_ OP *arg)
1769 SSize_t defer_stack_alloc = 0;
1770 SSize_t defer_ix = -1;
1771 OP **defer_stack = NULL;
1774 PERL_ARGS_ASSERT_SCALARVOID;
1777 SV *useless_sv = NULL;
1778 const char* useless = NULL;
1780 if (o->op_type == OP_NEXTSTATE
1781 || o->op_type == OP_DBSTATE
1782 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1783 || o->op_targ == OP_DBSTATE)))
1784 PL_curcop = (COP*)o; /* for warning below */
1786 /* assumes no premature commitment */
1787 want = o->op_flags & OPf_WANT;
1788 if ((want && want != OPf_WANT_SCALAR)
1789 || (PL_parser && PL_parser->error_count)
1790 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1795 if ((o->op_private & OPpTARGET_MY)
1796 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1798 /* newASSIGNOP has already applied scalar context, which we
1799 leave, as if this op is inside SASSIGN. */
1803 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1805 switch (o->op_type) {
1807 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1811 if (o->op_flags & OPf_STACKED)
1813 if (o->op_type == OP_REPEAT)
1814 scalar(cBINOPo->op_first);
1817 if (o->op_private == 4)
1852 case OP_GETSOCKNAME:
1853 case OP_GETPEERNAME:
1858 case OP_GETPRIORITY:
1883 useless = OP_DESC(o);
1893 case OP_AELEMFAST_LEX:
1897 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1898 /* Otherwise it's "Useless use of grep iterator" */
1899 useless = OP_DESC(o);
1903 kid = cLISTOPo->op_first;
1904 if (kid && kid->op_type == OP_PUSHRE
1906 && !(o->op_flags & OPf_STACKED)
1908 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1910 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1913 useless = OP_DESC(o);
1917 kid = cUNOPo->op_first;
1918 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1919 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1922 useless = "negative pattern binding (!~)";
1926 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1927 useless = "non-destructive substitution (s///r)";
1931 useless = "non-destructive transliteration (tr///r)";
1938 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1939 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1940 useless = "a variable";
1945 if (cSVOPo->op_private & OPpCONST_STRICT)
1946 no_bareword_allowed(o);
1948 if (ckWARN(WARN_VOID)) {
1950 /* don't warn on optimised away booleans, eg
1951 * use constant Foo, 5; Foo || print; */
1952 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1954 /* the constants 0 and 1 are permitted as they are
1955 conventionally used as dummies in constructs like
1956 1 while some_condition_with_side_effects; */
1957 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1959 else if (SvPOK(sv)) {
1960 SV * const dsv = newSVpvs("");
1962 = Perl_newSVpvf(aTHX_
1964 pv_pretty(dsv, SvPVX_const(sv),
1965 SvCUR(sv), 32, NULL, NULL,
1967 | PERL_PV_ESCAPE_NOCLEAR
1968 | PERL_PV_ESCAPE_UNI_DETECT));
1969 SvREFCNT_dec_NN(dsv);
1971 else if (SvOK(sv)) {
1972 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1975 useless = "a constant (undef)";
1978 op_null(o); /* don't execute or even remember it */
1982 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
1986 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
1990 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
1994 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
1999 UNOP *refgen, *rv2cv;
2002 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2005 rv2gv = ((BINOP *)o)->op_last;
2006 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2009 refgen = (UNOP *)((BINOP *)o)->op_first;
2011 if (!refgen || (refgen->op_type != OP_REFGEN
2012 && refgen->op_type != OP_SREFGEN))
2015 exlist = (LISTOP *)refgen->op_first;
2016 if (!exlist || exlist->op_type != OP_NULL
2017 || exlist->op_targ != OP_LIST)
2020 if (exlist->op_first->op_type != OP_PUSHMARK
2021 && exlist->op_first != exlist->op_last)
2024 rv2cv = (UNOP*)exlist->op_last;
2026 if (rv2cv->op_type != OP_RV2CV)
2029 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2030 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2031 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2033 o->op_private |= OPpASSIGN_CV_TO_GV;
2034 rv2gv->op_private |= OPpDONT_INIT_GV;
2035 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2047 kid = cLOGOPo->op_first;
2048 if (kid->op_type == OP_NOT
2049 && (kid->op_flags & OPf_KIDS)) {
2050 if (o->op_type == OP_AND) {
2051 OpTYPE_set(o, OP_OR);
2053 OpTYPE_set(o, OP_AND);
2063 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2064 if (!(kid->op_flags & OPf_KIDS))
2071 if (o->op_flags & OPf_STACKED)
2078 if (!(o->op_flags & OPf_KIDS))
2089 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2090 if (!(kid->op_flags & OPf_KIDS))
2096 /* If the first kid after pushmark is something that the padrange
2097 optimisation would reject, then null the list and the pushmark.
2099 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2100 && ( !(kid = OpSIBLING(kid))
2101 || ( kid->op_type != OP_PADSV
2102 && kid->op_type != OP_PADAV
2103 && kid->op_type != OP_PADHV)
2104 || kid->op_private & ~OPpLVAL_INTRO
2105 || !(kid = OpSIBLING(kid))
2106 || ( kid->op_type != OP_PADSV
2107 && kid->op_type != OP_PADAV
2108 && kid->op_type != OP_PADHV)
2109 || kid->op_private & ~OPpLVAL_INTRO)
2111 op_null(cUNOPo->op_first); /* NULL the pushmark */
2112 op_null(o); /* NULL the list */
2124 /* mortalise it, in case warnings are fatal. */
2125 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2126 "Useless use of %"SVf" in void context",
2127 SVfARG(sv_2mortal(useless_sv)));
2130 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2131 "Useless use of %s in void context",
2134 } while ( (o = POP_DEFERRED_OP()) );
2136 Safefree(defer_stack);
2142 S_listkids(pTHX_ OP *o)
2144 if (o && o->op_flags & OPf_KIDS) {
2146 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2153 Perl_list(pTHX_ OP *o)
2157 /* assumes no premature commitment */
2158 if (!o || (o->op_flags & OPf_WANT)
2159 || (PL_parser && PL_parser->error_count)
2160 || o->op_type == OP_RETURN)
2165 if ((o->op_private & OPpTARGET_MY)
2166 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2168 return o; /* As if inside SASSIGN */
2171 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2173 switch (o->op_type) {
2175 list(cBINOPo->op_first);
2178 if (o->op_private & OPpREPEAT_DOLIST
2179 && !(o->op_flags & OPf_STACKED))
2181 list(cBINOPo->op_first);
2182 kid = cBINOPo->op_last;
2183 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2184 && SvIVX(kSVOP_sv) == 1)
2186 op_null(o); /* repeat */
2187 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2189 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2196 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2204 if (!(o->op_flags & OPf_KIDS))
2206 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2207 list(cBINOPo->op_first);
2208 return gen_constant_list(o);
2214 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2215 op_null(cUNOPo->op_first); /* NULL the pushmark */
2216 op_null(o); /* NULL the list */
2221 kid = cLISTOPo->op_first;
2223 kid = OpSIBLING(kid);
2226 OP *sib = OpSIBLING(kid);
2227 if (sib && kid->op_type != OP_LEAVEWHEN)
2233 PL_curcop = &PL_compiling;
2237 kid = cLISTOPo->op_first;
2244 S_scalarseq(pTHX_ OP *o)
2247 const OPCODE type = o->op_type;
2249 if (type == OP_LINESEQ || type == OP_SCOPE ||
2250 type == OP_LEAVE || type == OP_LEAVETRY)
2253 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2254 if ((sib = OpSIBLING(kid))
2255 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2256 || ( sib->op_targ != OP_NEXTSTATE
2257 && sib->op_targ != OP_DBSTATE )))
2262 PL_curcop = &PL_compiling;
2264 o->op_flags &= ~OPf_PARENS;
2265 if (PL_hints & HINT_BLOCK_SCOPE)
2266 o->op_flags |= OPf_PARENS;
2269 o = newOP(OP_STUB, 0);
2274 S_modkids(pTHX_ OP *o, I32 type)
2276 if (o && o->op_flags & OPf_KIDS) {
2278 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2279 op_lvalue(kid, type);
2285 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2286 * const fields. Also, convert CONST keys to HEK-in-SVs.
2287 * rop is the op that retrieves the hash;
2288 * key_op is the first key
2292 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2298 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2300 if (rop->op_first->op_type == OP_PADSV)
2301 /* @$hash{qw(keys here)} */
2302 rop = (UNOP*)rop->op_first;
2304 /* @{$hash}{qw(keys here)} */
2305 if (rop->op_first->op_type == OP_SCOPE
2306 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2308 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2315 lexname = NULL; /* just to silence compiler warnings */
2316 fields = NULL; /* just to silence compiler warnings */
2320 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2321 SvPAD_TYPED(lexname))
2322 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2323 && isGV(*fields) && GvHV(*fields);
2325 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2327 if (key_op->op_type != OP_CONST)
2329 svp = cSVOPx_svp(key_op);
2331 /* Make the CONST have a shared SV */
2332 if ( !SvIsCOW_shared_hash(sv = *svp)
2333 && SvTYPE(sv) < SVt_PVMG
2338 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2339 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2340 SvREFCNT_dec_NN(sv);
2345 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2347 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2348 "in variable %"PNf" of type %"HEKf,
2349 SVfARG(*svp), PNfARG(lexname),
2350 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2357 =for apidoc finalize_optree
2359 This function finalizes the optree. Should be called directly after
2360 the complete optree is built. It does some additional
2361 checking which can't be done in the normal C<ck_>xxx functions and makes
2362 the tree thread-safe.
2367 Perl_finalize_optree(pTHX_ OP* o)
2369 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2372 SAVEVPTR(PL_curcop);
2380 /* Relocate sv to the pad for thread safety.
2381 * Despite being a "constant", the SV is written to,
2382 * for reference counts, sv_upgrade() etc. */
2383 PERL_STATIC_INLINE void
2384 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2387 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2389 ix = pad_alloc(OP_CONST, SVf_READONLY);
2390 SvREFCNT_dec(PAD_SVl(ix));
2391 PAD_SETSV(ix, *svp);
2392 /* XXX I don't know how this isn't readonly already. */
2393 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2401 S_finalize_op(pTHX_ OP* o)
2403 PERL_ARGS_ASSERT_FINALIZE_OP;
2406 switch (o->op_type) {
2409 PL_curcop = ((COP*)o); /* for warnings */
2412 if (OpHAS_SIBLING(o)) {
2413 OP *sib = OpSIBLING(o);
2414 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2415 && ckWARN(WARN_EXEC)
2416 && OpHAS_SIBLING(sib))
2418 const OPCODE type = OpSIBLING(sib)->op_type;
2419 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2420 const line_t oldline = CopLINE(PL_curcop);
2421 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2422 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2423 "Statement unlikely to be reached");
2424 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2425 "\t(Maybe you meant system() when you said exec()?)\n");
2426 CopLINE_set(PL_curcop, oldline);
2433 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2434 GV * const gv = cGVOPo_gv;
2435 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2436 /* XXX could check prototype here instead of just carping */
2437 SV * const sv = sv_newmortal();
2438 gv_efullname3(sv, gv, NULL);
2439 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2440 "%"SVf"() called too early to check prototype",
2447 if (cSVOPo->op_private & OPpCONST_STRICT)
2448 no_bareword_allowed(o);
2452 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2457 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2458 case OP_METHOD_NAMED:
2459 case OP_METHOD_SUPER:
2460 case OP_METHOD_REDIR:
2461 case OP_METHOD_REDIR_SUPER:
2462 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2471 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2474 rop = (UNOP*)((BINOP*)o)->op_first;
2479 S_scalar_slice_warning(aTHX_ o);
2483 kid = OpSIBLING(cLISTOPo->op_first);
2484 if (/* I bet there's always a pushmark... */
2485 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2486 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2491 key_op = (SVOP*)(kid->op_type == OP_CONST
2493 : OpSIBLING(kLISTOP->op_first));
2495 rop = (UNOP*)((LISTOP*)o)->op_last;
2498 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2500 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2504 S_scalar_slice_warning(aTHX_ o);
2508 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2509 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2516 if (o->op_flags & OPf_KIDS) {
2520 /* check that op_last points to the last sibling, and that
2521 * the last op_sibling/op_sibparent field points back to the
2522 * parent, and that the only ops with KIDS are those which are
2523 * entitled to them */
2524 U32 type = o->op_type;
2528 if (type == OP_NULL) {
2530 /* ck_glob creates a null UNOP with ex-type GLOB
2531 * (which is a list op. So pretend it wasn't a listop */
2532 if (type == OP_GLOB)
2535 family = PL_opargs[type] & OA_CLASS_MASK;
2537 has_last = ( family == OA_BINOP
2538 || family == OA_LISTOP
2539 || family == OA_PMOP
2540 || family == OA_LOOP
2542 assert( has_last /* has op_first and op_last, or ...
2543 ... has (or may have) op_first: */
2544 || family == OA_UNOP
2545 || family == OA_UNOP_AUX
2546 || family == OA_LOGOP
2547 || family == OA_BASEOP_OR_UNOP
2548 || family == OA_FILESTATOP
2549 || family == OA_LOOPEXOP
2550 || family == OA_METHOP
2551 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2552 || type == OP_SASSIGN
2553 || type == OP_CUSTOM
2554 || type == OP_NULL /* new_logop does this */
2557 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2558 # ifdef PERL_OP_PARENT
2559 if (!OpHAS_SIBLING(kid)) {
2561 assert(kid == cLISTOPo->op_last);
2562 assert(kid->op_sibparent == o);
2565 if (has_last && !OpHAS_SIBLING(kid))
2566 assert(kid == cLISTOPo->op_last);
2571 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2577 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2579 Propagate lvalue ("modifiable") context to an op and its children.
2580 C<type> represents the context type, roughly based on the type of op that
2581 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2582 because it has no op type of its own (it is signalled by a flag on
2585 This function detects things that can't be modified, such as C<$x+1>, and
2586 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2587 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2589 It also flags things that need to behave specially in an lvalue context,
2590 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2596 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2599 PadnameLVALUE_on(pn);
2600 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2603 assert(CvPADLIST(cv));
2605 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2606 assert(PadnameLEN(pn));
2607 PadnameLVALUE_on(pn);
2612 S_vivifies(const OPCODE type)
2615 case OP_RV2AV: case OP_ASLICE:
2616 case OP_RV2HV: case OP_KVASLICE:
2617 case OP_RV2SV: case OP_HSLICE:
2618 case OP_AELEMFAST: case OP_KVHSLICE:
2627 S_lvref(pTHX_ OP *o, I32 type)
2631 switch (o->op_type) {
2633 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2634 kid = OpSIBLING(kid))
2635 S_lvref(aTHX_ kid, type);
2640 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2641 o->op_flags |= OPf_STACKED;
2642 if (o->op_flags & OPf_PARENS) {
2643 if (o->op_private & OPpLVAL_INTRO) {
2644 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2645 "localized parenthesized array in list assignment"));
2649 OpTYPE_set(o, OP_LVAVREF);
2650 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2651 o->op_flags |= OPf_MOD|OPf_REF;
2654 o->op_private |= OPpLVREF_AV;
2657 kid = cUNOPo->op_first;
2658 if (kid->op_type == OP_NULL)
2659 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2661 o->op_private = OPpLVREF_CV;
2662 if (kid->op_type == OP_GV)
2663 o->op_flags |= OPf_STACKED;
2664 else if (kid->op_type == OP_PADCV) {
2665 o->op_targ = kid->op_targ;
2667 op_free(cUNOPo->op_first);
2668 cUNOPo->op_first = NULL;
2669 o->op_flags &=~ OPf_KIDS;
2674 if (o->op_flags & OPf_PARENS) {
2676 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2677 "parenthesized hash in list assignment"));
2680 o->op_private |= OPpLVREF_HV;
2684 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2685 o->op_flags |= OPf_STACKED;
2688 if (o->op_flags & OPf_PARENS) goto parenhash;
2689 o->op_private |= OPpLVREF_HV;
2692 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2695 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2696 if (o->op_flags & OPf_PARENS) goto slurpy;
2697 o->op_private |= OPpLVREF_AV;
2701 o->op_private |= OPpLVREF_ELEM;
2702 o->op_flags |= OPf_STACKED;
2706 OpTYPE_set(o, OP_LVREFSLICE);
2707 o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2710 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2712 else if (!(o->op_flags & OPf_KIDS))
2714 if (o->op_targ != OP_LIST) {
2715 S_lvref(aTHX_ cBINOPo->op_first, type);
2720 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2721 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2722 S_lvref(aTHX_ kid, type);
2726 if (o->op_flags & OPf_PARENS)
2731 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2732 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2733 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2738 OpTYPE_set(o, OP_LVREF);
2740 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2741 if (type == OP_ENTERLOOP)
2742 o->op_private |= OPpLVREF_ITER;
2746 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2750 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2753 if (!o || (PL_parser && PL_parser->error_count))
2756 if ((o->op_private & OPpTARGET_MY)
2757 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2762 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2764 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2766 switch (o->op_type) {
2771 if ((o->op_flags & OPf_PARENS))
2775 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2776 !(o->op_flags & OPf_STACKED)) {
2777 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
2778 assert(cUNOPo->op_first->op_type == OP_NULL);
2779 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2782 else { /* lvalue subroutine call */
2783 o->op_private |= OPpLVAL_INTRO;
2784 PL_modcount = RETURN_UNLIMITED_NUMBER;
2785 if (type == OP_GREPSTART || type == OP_ENTERSUB
2786 || type == OP_REFGEN || type == OP_LEAVESUBLV) {
2787 /* Potential lvalue context: */
2788 o->op_private |= OPpENTERSUB_INARGS;
2791 else { /* Compile-time error message: */
2792 OP *kid = cUNOPo->op_first;
2796 if (kid->op_type != OP_PUSHMARK) {
2797 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2799 "panic: unexpected lvalue entersub "
2800 "args: type/targ %ld:%"UVuf,
2801 (long)kid->op_type, (UV)kid->op_targ);
2802 kid = kLISTOP->op_first;
2804 while (OpHAS_SIBLING(kid))
2805 kid = OpSIBLING(kid);
2806 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2807 break; /* Postpone until runtime */
2810 kid = kUNOP->op_first;
2811 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2812 kid = kUNOP->op_first;
2813 if (kid->op_type == OP_NULL)
2815 "Unexpected constant lvalue entersub "
2816 "entry via type/targ %ld:%"UVuf,
2817 (long)kid->op_type, (UV)kid->op_targ);
2818 if (kid->op_type != OP_GV) {
2825 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2826 ? MUTABLE_CV(SvRV(gv))
2837 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2838 /* grep, foreach, subcalls, refgen */
2839 if (type == OP_GREPSTART || type == OP_ENTERSUB
2840 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2842 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2843 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2845 : (o->op_type == OP_ENTERSUB
2846 ? "non-lvalue subroutine call"
2848 type ? PL_op_desc[type] : "local"));
2861 case OP_RIGHT_SHIFT:
2870 if (!(o->op_flags & OPf_STACKED))
2876 if (o->op_flags & OPf_STACKED) {
2880 if (!(o->op_private & OPpREPEAT_DOLIST))
2883 const I32 mods = PL_modcount;
2884 modkids(cBINOPo->op_first, type);
2885 if (type != OP_AASSIGN)
2887 kid = cBINOPo->op_last;
2888 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2889 const IV iv = SvIV(kSVOP_sv);
2890 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2892 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2895 PL_modcount = RETURN_UNLIMITED_NUMBER;
2901 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2902 op_lvalue(kid, type);
2907 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2908 PL_modcount = RETURN_UNLIMITED_NUMBER;
2909 return o; /* Treat \(@foo) like ordinary list. */
2913 if (scalar_mod_type(o, type))
2915 ref(cUNOPo->op_first, o->op_type);
2922 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2923 if (type == OP_LEAVESUBLV && (
2924 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2925 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2927 o->op_private |= OPpMAYBE_LVSUB;
2931 PL_modcount = RETURN_UNLIMITED_NUMBER;
2935 if (type == OP_LEAVESUBLV)
2936 o->op_private |= OPpMAYBE_LVSUB;
2939 PL_hints |= HINT_BLOCK_SCOPE;
2940 if (type == OP_LEAVESUBLV)
2941 o->op_private |= OPpMAYBE_LVSUB;
2945 ref(cUNOPo->op_first, o->op_type);
2949 PL_hints |= HINT_BLOCK_SCOPE;
2959 case OP_AELEMFAST_LEX:
2966 PL_modcount = RETURN_UNLIMITED_NUMBER;
2967 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2968 return o; /* Treat \(@foo) like ordinary list. */
2969 if (scalar_mod_type(o, type))
2971 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2972 && type == OP_LEAVESUBLV)
2973 o->op_private |= OPpMAYBE_LVSUB;
2977 if (!type) /* local() */
2978 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
2979 PNfARG(PAD_COMPNAME(o->op_targ)));
2980 if (!(o->op_private & OPpLVAL_INTRO)
2981 || ( type != OP_SASSIGN && type != OP_AASSIGN
2982 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
2983 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
2991 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2995 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3001 if (type == OP_LEAVESUBLV)
3002 o->op_private |= OPpMAYBE_LVSUB;
3003 if (o->op_flags & OPf_KIDS)
3004 op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3009 ref(cBINOPo->op_first, o->op_type);
3010 if (type == OP_ENTERSUB &&
3011 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3012 o->op_private |= OPpLVAL_DEFER;
3013 if (type == OP_LEAVESUBLV)
3014 o->op_private |= OPpMAYBE_LVSUB;
3021 o->op_private |= OPpLVALUE;
3027 if (o->op_flags & OPf_KIDS)
3028 op_lvalue(cLISTOPo->op_last, type);
3033 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3035 else if (!(o->op_flags & OPf_KIDS))
3037 if (o->op_targ != OP_LIST) {
3038 op_lvalue(cBINOPo->op_first, type);
3044 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3045 /* elements might be in void context because the list is
3046 in scalar context or because they are attribute sub calls */
3047 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3048 op_lvalue(kid, type);
3056 if (type == OP_LEAVESUBLV
3057 || !S_vivifies(cLOGOPo->op_first->op_type))
3058 op_lvalue(cLOGOPo->op_first, type);
3059 if (type == OP_LEAVESUBLV
3060 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3061 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3065 if (type != OP_AASSIGN && type != OP_SASSIGN
3066 && type != OP_ENTERLOOP)
3068 /* Don’t bother applying lvalue context to the ex-list. */
3069 kid = cUNOPx(cUNOPo->op_first)->op_first;
3070 assert (!OpHAS_SIBLING(kid));
3073 if (type != OP_AASSIGN) goto nomod;
3074 kid = cUNOPo->op_first;
3077 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3078 S_lvref(aTHX_ kid, type);
3079 if (!PL_parser || PL_parser->error_count == ec) {
3080 if (!FEATURE_REFALIASING_IS_ENABLED)
3082 "Experimental aliasing via reference not enabled");
3083 Perl_ck_warner_d(aTHX_
3084 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3085 "Aliasing via reference is experimental");
3088 if (o->op_type == OP_REFGEN)
3089 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3094 kid = cLISTOPo->op_first;
3095 if (kid && kid->op_type == OP_PUSHRE &&
3097 || o->op_flags & OPf_STACKED
3099 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3101 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3104 /* This is actually @array = split. */
3105 PL_modcount = RETURN_UNLIMITED_NUMBER;
3111 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3115 /* [20011101.069] File test operators interpret OPf_REF to mean that
3116 their argument is a filehandle; thus \stat(".") should not set
3118 if (type == OP_REFGEN &&
3119 PL_check[o->op_type] == Perl_ck_ftst)
3122 if (type != OP_LEAVESUBLV)
3123 o->op_flags |= OPf_MOD;
3125 if (type == OP_AASSIGN || type == OP_SASSIGN)
3126 o->op_flags |= OPf_SPECIAL|OPf_REF;
3127 else if (!type) { /* local() */
3130 o->op_private |= OPpLVAL_INTRO;
3131 o->op_flags &= ~OPf_SPECIAL;
3132 PL_hints |= HINT_BLOCK_SCOPE;
3137 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3138 "Useless localization of %s", OP_DESC(o));
3141 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3142 && type != OP_LEAVESUBLV)
3143 o->op_flags |= OPf_REF;
3148 S_scalar_mod_type(const OP *o, I32 type)
3153 if (o && o->op_type == OP_RV2GV)
3177 case OP_RIGHT_SHIFT:
3198 S_is_handle_constructor(const OP *o, I32 numargs)
3200 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3202 switch (o->op_type) {
3210 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3223 S_refkids(pTHX_ OP *o, I32 type)
3225 if (o && o->op_flags & OPf_KIDS) {
3227 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3234 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3239 PERL_ARGS_ASSERT_DOREF;
3241 if (PL_parser && PL_parser->error_count)
3244 switch (o->op_type) {
3246 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3247 !(o->op_flags & OPf_STACKED)) {
3248 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3249 assert(cUNOPo->op_first->op_type == OP_NULL);
3250 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3251 o->op_flags |= OPf_SPECIAL;
3253 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3254 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3255 : type == OP_RV2HV ? OPpDEREF_HV
3257 o->op_flags |= OPf_MOD;
3263 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3264 doref(kid, type, set_op_ref);
3267 if (type == OP_DEFINED)
3268 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3269 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3272 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3273 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3274 : type == OP_RV2HV ? OPpDEREF_HV
3276 o->op_flags |= OPf_MOD;
3283 o->op_flags |= OPf_REF;
3286 if (type == OP_DEFINED)
3287 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3288 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3294 o->op_flags |= OPf_REF;
3299 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3301 doref(cBINOPo->op_first, type, set_op_ref);
3305 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3306 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3307 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3308 : type == OP_RV2HV ? OPpDEREF_HV
3310 o->op_flags |= OPf_MOD;
3320 if (!(o->op_flags & OPf_KIDS))
3322 doref(cLISTOPo->op_last, type, set_op_ref);
3332 S_dup_attrlist(pTHX_ OP *o)
3336 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3338 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3339 * where the first kid is OP_PUSHMARK and the remaining ones
3340 * are OP_CONST. We need to push the OP_CONST values.
3342 if (o->op_type == OP_CONST)
3343 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3345 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3347 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3348 if (o->op_type == OP_CONST)
3349 rop = op_append_elem(OP_LIST, rop,
3350 newSVOP(OP_CONST, o->op_flags,
3351 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3358 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3360 PERL_ARGS_ASSERT_APPLY_ATTRS;
3362 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3364 /* fake up C<use attributes $pkg,$rv,@attrs> */
3366 #define ATTRSMODULE "attributes"
3367 #define ATTRSMODULE_PM "attributes.pm"
3370 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3371 newSVpvs(ATTRSMODULE),
3373 op_prepend_elem(OP_LIST,
3374 newSVOP(OP_CONST, 0, stashsv),
3375 op_prepend_elem(OP_LIST,
3376 newSVOP(OP_CONST, 0,
3378 dup_attrlist(attrs))));
3383 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3385 OP *pack, *imop, *arg;
3386 SV *meth, *stashsv, **svp;
3388 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3393 assert(target->op_type == OP_PADSV ||
3394 target->op_type == OP_PADHV ||
3395 target->op_type == OP_PADAV);
3397 /* Ensure that attributes.pm is loaded. */
3398 /* Don't force the C<use> if we don't need it. */
3399 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3400 if (svp && *svp != &PL_sv_undef)
3401 NOOP; /* already in %INC */
3403 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3404 newSVpvs(ATTRSMODULE), NULL);
3406 /* Need package name for method call. */
3407 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3409 /* Build up the real arg-list. */
3410 stashsv = newSVhek(HvNAME_HEK(stash));
3412 arg = newOP(OP_PADSV, 0);
3413 arg->op_targ = target->op_targ;
3414 arg = op_prepend_elem(OP_LIST,
3415 newSVOP(OP_CONST, 0, stashsv),
3416 op_prepend_elem(OP_LIST,
3417 newUNOP(OP_REFGEN, 0,
3419 dup_attrlist(attrs)));
3421 /* Fake up a method call to import */
3422 meth = newSVpvs_share("import");
3423 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3424 op_append_elem(OP_LIST,
3425 op_prepend_elem(OP_LIST, pack, arg),
3426 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3428 /* Combine the ops. */
3429 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3433 =notfor apidoc apply_attrs_string
3435 Attempts to apply a list of attributes specified by the C<attrstr> and
3436 C<len> arguments to the subroutine identified by the C<cv> argument which
3437 is expected to be associated with the package identified by the C<stashpv>
3438 argument (see L<attributes>). It gets this wrong, though, in that it
3439 does not correctly identify the boundaries of the individual attribute
3440 specifications within C<attrstr>. This is not really intended for the
3441 public API, but has to be listed here for systems such as AIX which
3442 need an explicit export list for symbols. (It's called from XS code
3443 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3444 to respect attribute syntax properly would be welcome.
3450 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3451 const char *attrstr, STRLEN len)
3455 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3458 len = strlen(attrstr);
3462 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3464 const char * const sstr = attrstr;
3465 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3466 attrs = op_append_elem(OP_LIST, attrs,
3467 newSVOP(OP_CONST, 0,
3468 newSVpvn(sstr, attrstr-sstr)));
3472 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3473 newSVpvs(ATTRSMODULE),
3474 NULL, op_prepend_elem(OP_LIST,
3475 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3476 op_prepend_elem(OP_LIST,
3477 newSVOP(OP_CONST, 0,
3478 newRV(MUTABLE_SV(cv))),
3483 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3485 OP *new_proto = NULL;
3490 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3496 if (o->op_type == OP_CONST) {
3497 pv = SvPV(cSVOPo_sv, pvlen);
3498 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3499 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3500 SV ** const tmpo = cSVOPx_svp(o);
3501 SvREFCNT_dec(cSVOPo_sv);
3506 } else if (o->op_type == OP_LIST) {
3508 assert(o->op_flags & OPf_KIDS);
3509 lasto = cLISTOPo->op_first;
3510 assert(lasto->op_type == OP_PUSHMARK);
3511 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3512 if (o->op_type == OP_CONST) {
3513 pv = SvPV(cSVOPo_sv, pvlen);
3514 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3515 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3516 SV ** const tmpo = cSVOPx_svp(o);
3517 SvREFCNT_dec(cSVOPo_sv);
3519 if (new_proto && ckWARN(WARN_MISC)) {
3521 const char * newp = SvPV(cSVOPo_sv, new_len);
3522 Perl_warner(aTHX_ packWARN(WARN_MISC),
3523 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3524 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3530 /* excise new_proto from the list */
3531 op_sibling_splice(*attrs, lasto, 1, NULL);
3538 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3539 would get pulled in with no real need */
3540 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3549 svname = sv_newmortal();
3550 gv_efullname3(svname, name, NULL);
3552 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3553 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3555 svname = (SV *)name;
3556 if (ckWARN(WARN_ILLEGALPROTO))
3557 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3558 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3559 STRLEN old_len, new_len;
3560 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3561 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3563 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3564 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3566 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3567 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3577 S_cant_declare(pTHX_ OP *o)
3579 if (o->op_type == OP_NULL
3580 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3581 o = cUNOPo->op_first;
3582 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3583 o->op_type == OP_NULL
3584 && o->op_flags & OPf_SPECIAL
3587 PL_parser->in_my == KEY_our ? "our" :
3588 PL_parser->in_my == KEY_state ? "state" :
3593 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3596 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3598 PERL_ARGS_ASSERT_MY_KID;
3600 if (!o || (PL_parser && PL_parser->error_count))
3605 if (type == OP_LIST) {
3607 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3608 my_kid(kid, attrs, imopsp);
3610 } else if (type == OP_UNDEF || type == OP_STUB) {
3612 } else if (type == OP_RV2SV || /* "our" declaration */
3614 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3615 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3616 S_cant_declare(aTHX_ o);
3618 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3620 PL_parser->in_my = FALSE;
3621 PL_parser->in_my_stash = NULL;
3622 apply_attrs(GvSTASH(gv),
3623 (type == OP_RV2SV ? GvSV(gv) :
3624 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3625 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3628 o->op_private |= OPpOUR_INTRO;
3631 else if (type != OP_PADSV &&
3634 type != OP_PUSHMARK)
3636 S_cant_declare(aTHX_ o);
3639 else if (attrs && type != OP_PUSHMARK) {
3643 PL_parser->in_my = FALSE;
3644 PL_parser->in_my_stash = NULL;
3646 /* check for C<my Dog $spot> when deciding package */
3647 stash = PAD_COMPNAME_TYPE(o->op_targ);
3649 stash = PL_curstash;
3650 apply_attrs_my(stash, o, attrs, imopsp);
3652 o->op_flags |= OPf_MOD;
3653 o->op_private |= OPpLVAL_INTRO;
3655 o->op_private |= OPpPAD_STATE;
3660 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3663 int maybe_scalar = 0;
3665 PERL_ARGS_ASSERT_MY_ATTRS;
3667 /* [perl #17376]: this appears to be premature, and results in code such as
3668 C< our(%x); > executing in list mode rather than void mode */
3670 if (o->op_flags & OPf_PARENS)
3680 o = my_kid(o, attrs, &rops);
3682 if (maybe_scalar && o->op_type == OP_PADSV) {
3683 o = scalar(op_append_list(OP_LIST, rops, o));
3684 o->op_private |= OPpLVAL_INTRO;
3687 /* The listop in rops might have a pushmark at the beginning,
3688 which will mess up list assignment. */
3689 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3690 if (rops->op_type == OP_LIST &&
3691 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3693 OP * const pushmark = lrops->op_first;
3694 /* excise pushmark */
3695 op_sibling_splice(rops, NULL, 1, NULL);
3698 o = op_append_list(OP_LIST, o, rops);
3701 PL_parser->in_my = FALSE;
3702 PL_parser->in_my_stash = NULL;
3707 Perl_sawparens(pTHX_ OP *o)
3709 PERL_UNUSED_CONTEXT;
3711 o->op_flags |= OPf_PARENS;
3716 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3720 const OPCODE ltype = left->op_type;
3721 const OPCODE rtype = right->op_type;
3723 PERL_ARGS_ASSERT_BIND_MATCH;
3725 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3726 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3728 const char * const desc
3730 rtype == OP_SUBST || rtype == OP_TRANS
3731 || rtype == OP_TRANSR
3733 ? (int)rtype : OP_MATCH];
3734 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3736 S_op_varname(aTHX_ left);
3738 Perl_warner(aTHX_ packWARN(WARN_MISC),
3739 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3740 desc, SVfARG(name), SVfARG(name));
3742 const char * const sample = (isary
3743 ? "@array" : "%hash");
3744 Perl_warner(aTHX_ packWARN(WARN_MISC),
3745 "Applying %s to %s will act on scalar(%s)",
3746 desc, sample, sample);
3750 if (rtype == OP_CONST &&
3751 cSVOPx(right)->op_private & OPpCONST_BARE &&
3752 cSVOPx(right)->op_private & OPpCONST_STRICT)
3754 no_bareword_allowed(right);
3757 /* !~ doesn't make sense with /r, so error on it for now */
3758 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3760 /* diag_listed_as: Using !~ with %s doesn't make sense */
3761 yyerror("Using !~ with s///r doesn't make sense");
3762 if (rtype == OP_TRANSR && type == OP_NOT)
3763 /* diag_listed_as: Using !~ with %s doesn't make sense */
3764 yyerror("Using !~ with tr///r doesn't make sense");
3766 ismatchop = (rtype == OP_MATCH ||
3767 rtype == OP_SUBST ||
3768 rtype == OP_TRANS || rtype == OP_TRANSR)
3769 && !(right->op_flags & OPf_SPECIAL);
3770 if (ismatchop && right->op_private & OPpTARGET_MY) {
3772 right->op_private &= ~OPpTARGET_MY;
3774 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3775 if (left->op_type == OP_PADSV
3776 && !(left->op_private & OPpLVAL_INTRO))
3778 right->op_targ = left->op_targ;
3783 right->op_flags |= OPf_STACKED;
3784 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3785 ! (rtype == OP_TRANS &&
3786 right->op_private & OPpTRANS_IDENTICAL) &&
3787 ! (rtype == OP_SUBST &&
3788 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3789 left = op_lvalue(left, rtype);
3790 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3791 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3793 o = op_prepend_elem(rtype, scalar(left), right);
3796 return newUNOP(OP_NOT, 0, scalar(o));
3800 return bind_match(type, left,
3801 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3805 Perl_invert(pTHX_ OP *o)
3809 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3813 =for apidoc Amx|OP *|op_scope|OP *o
3815 Wraps up an op tree with some additional ops so that at runtime a dynamic
3816 scope will be created. The original ops run in the new dynamic scope,
3817 and then, provided that they exit normally, the scope will be unwound.
3818 The additional ops used to create and unwind the dynamic scope will
3819 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3820 instead if the ops are simple enough to not need the full dynamic scope
3827 Perl_op_scope(pTHX_ OP *o)
3831 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3832 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3833 OpTYPE_set(o, OP_LEAVE);
3835 else if (o->op_type == OP_LINESEQ) {
3837 OpTYPE_set(o, OP_SCOPE);
3838 kid = ((LISTOP*)o)->op_first;
3839 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3842 /* The following deals with things like 'do {1 for 1}' */
3843 kid = OpSIBLING(kid);
3845 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3850 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3856 Perl_op_unscope(pTHX_ OP *o)
3858 if (o && o->op_type == OP_LINESEQ) {
3859 OP *kid = cLISTOPo->op_first;
3860 for(; kid; kid = OpSIBLING(kid))
3861 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3868 =for apidoc Am|int|block_start|int full
3870 Handles compile-time scope entry.
3871 Arranges for hints to be restored on block
3872 exit and also handles pad sequence numbers to make lexical variables scope
3873 right. Returns a savestack index for use with C<block_end>.
3879 Perl_block_start(pTHX_ int full)
3881 const int retval = PL_savestack_ix;
3883 PL_compiling.cop_seq = PL_cop_seqmax;
3885 pad_block_start(full);
3887 PL_hints &= ~HINT_BLOCK_SCOPE;
3888 SAVECOMPILEWARNINGS();
3889 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3890 SAVEI32(PL_compiling.cop_seq);
3891 PL_compiling.cop_seq = 0;
3893 CALL_BLOCK_HOOKS(bhk_start, full);
3899 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3901 Handles compile-time scope exit. C<floor>
3902 is the savestack index returned by
3903 C<block_start>, and C<seq> is the body of the block. Returns the block,
3910 Perl_block_end(pTHX_ I32 floor, OP *seq)
3912 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3913 OP* retval = scalarseq(seq);
3916 /* XXX Is the null PL_parser check necessary here? */
3917 assert(PL_parser); /* Let’s find out under debugging builds. */
3918 if (PL_parser && PL_parser->parsed_sub) {
3919 o = newSTATEOP(0, NULL, NULL);
3921 retval = op_append_elem(OP_LINESEQ, retval, o);
3924 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3928 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3932 /* pad_leavemy has created a sequence of introcv ops for all my
3933 subs declared in the block. We have to replicate that list with
3934 clonecv ops, to deal with this situation:
3939 sub s1 { state sub foo { \&s2 } }
3942 Originally, I was going to have introcv clone the CV and turn
3943 off the stale flag. Since &s1 is declared before &s2, the
3944 introcv op for &s1 is executed (on sub entry) before the one for
3945 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3946 cloned, since it is a state sub) closes over &s2 and expects
3947 to see it in its outer CV’s pad. If the introcv op clones &s1,
3948 then &s2 is still marked stale. Since &s1 is not active, and
3949 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3950 ble will not stay shared’ warning. Because it is the same stub
3951 that will be used when the introcv op for &s2 is executed, clos-
3952 ing over it is safe. Hence, we have to turn off the stale flag
3953 on all lexical subs in the block before we clone any of them.
3954 Hence, having introcv clone the sub cannot work. So we create a
3955 list of ops like this:
3979 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3980 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3981 for (;; kid = OpSIBLING(kid)) {
3982 OP *newkid = newOP(OP_CLONECV, 0);
3983 newkid->op_targ = kid->op_targ;
3984 o = op_append_elem(OP_LINESEQ, o, newkid);
3985 if (kid == last) break;
3987 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3990 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3996 =head1 Compile-time scope hooks
3998 =for apidoc Aox||blockhook_register
4000 Register a set of hooks to be called when the Perl lexical scope changes
4001 at compile time. See L<perlguts/"Compile-time scope hooks">.
4007 Perl_blockhook_register(pTHX_ BHK *hk)
4009 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4011 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4015 Perl_newPROG(pTHX_ OP *o)
4017 PERL_ARGS_ASSERT_NEWPROG;
4024 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4025 ((PL_in_eval & EVAL_KEEPERR)
4026 ? OPf_SPECIAL : 0), o);
4028 cx = &cxstack[cxstack_ix];
4029 assert(CxTYPE(cx) == CXt_EVAL);
4031 if ((cx->blk_gimme & G_WANT) == G_VOID)
4032 scalarvoid(PL_eval_root);
4033 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4036 scalar(PL_eval_root);
4038 PL_eval_start = op_linklist(PL_eval_root);
4039 PL_eval_root->op_private |= OPpREFCOUNTED;
4040 OpREFCNT_set(PL_eval_root, 1);
4041 PL_eval_root->op_next = 0;
4042 i = PL_savestack_ix;
4045 CALL_PEEP(PL_eval_start);
4046 finalize_optree(PL_eval_root);
4047 S_prune_chain_head(&PL_eval_start);
4049 PL_savestack_ix = i;
4052 if (o->op_type == OP_STUB) {
4053 /* This block is entered if nothing is compiled for the main
4054 program. This will be the case for an genuinely empty main
4055 program, or one which only has BEGIN blocks etc, so already
4058 Historically (5.000) the guard above was !o. However, commit
4059 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4060 c71fccf11fde0068, changed perly.y so that newPROG() is now
4061 called with the output of block_end(), which returns a new
4062 OP_STUB for the case of an empty optree. ByteLoader (and
4063 maybe other things) also take this path, because they set up
4064 PL_main_start and PL_main_root directly, without generating an
4067 If the parsing the main program aborts (due to parse errors,
4068 or due to BEGIN or similar calling exit), then newPROG()
4069 isn't even called, and hence this code path and its cleanups
4070 are skipped. This shouldn't make a make a difference:
4071 * a non-zero return from perl_parse is a failure, and
4072 perl_destruct() should be called immediately.
4073 * however, if exit(0) is called during the parse, then
4074 perl_parse() returns 0, and perl_run() is called. As
4075 PL_main_start will be NULL, perl_run() will return
4076 promptly, and the exit code will remain 0.
4079 PL_comppad_name = 0;
4081 S_op_destroy(aTHX_ o);
4084 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4085 PL_curcop = &PL_compiling;
4086 PL_main_start = LINKLIST(PL_main_root);
4087 PL_main_root->op_private |= OPpREFCOUNTED;
4088 OpREFCNT_set(PL_main_root, 1);
4089 PL_main_root->op_next = 0;
4090 CALL_PEEP(PL_main_start);
4091 finalize_optree(PL_main_root);
4092 S_prune_chain_head(&PL_main_start);
4093 cv_forget_slab(PL_compcv);
4096 /* Register with debugger */
4098 CV * const cv = get_cvs("DB::postponed", 0);
4102 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4104 call_sv(MUTABLE_SV(cv), G_DISCARD);
4111 Perl_localize(pTHX_ OP *o, I32 lex)
4113 PERL_ARGS_ASSERT_LOCALIZE;
4115 if (o->op_flags & OPf_PARENS)
4116 /* [perl #17376]: this appears to be premature, and results in code such as
4117 C< our(%x); > executing in list mode rather than void mode */
4124 if ( PL_parser->bufptr > PL_parser->oldbufptr
4125 && PL_parser->bufptr[-1] == ','
4126 && ckWARN(WARN_PARENTHESIS))
4128 char *s = PL_parser->bufptr;
4131 /* some heuristics to detect a potential error */
4132 while (*s && (strchr(", \t\n", *s)))
4136 if (*s && strchr("@$%*", *s) && *++s
4137 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4140 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4142 while (*s && (strchr(", \t\n", *s)))
4148 if (sigil && (*s == ';' || *s == '=')) {
4149 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4150 "Parentheses missing around \"%s\" list",
4152 ? (PL_parser->in_my == KEY_our
4154 : PL_parser->in_my == KEY_state
4164 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4165 PL_parser->in_my = FALSE;
4166 PL_parser->in_my_stash = NULL;
4171 Perl_jmaybe(pTHX_ OP *o)
4173 PERL_ARGS_ASSERT_JMAYBE;
4175 if (o->op_type == OP_LIST) {
4177 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4178 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4183 PERL_STATIC_INLINE OP *
4184 S_op_std_init(pTHX_ OP *o)
4186 I32 type = o->op_type;
4188 PERL_ARGS_ASSERT_OP_STD_INIT;
4190 if (PL_opargs[type] & OA_RETSCALAR)
4192 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4193 o->op_targ = pad_alloc(type, SVs_PADTMP);
4198 PERL_STATIC_INLINE OP *
4199 S_op_integerize(pTHX_ OP *o)
4201 I32 type = o->op_type;
4203 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4205 /* integerize op. */
4206 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4209 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4212 if (type == OP_NEGATE)
4213 /* XXX might want a ck_negate() for this */
4214 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4220 S_fold_constants(pTHX_ OP *o)
4225 VOL I32 type = o->op_type;
4231 SV * const oldwarnhook = PL_warnhook;
4232 SV * const olddiehook = PL_diehook;
4234 U8 oldwarn = PL_dowarn;
4237 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4239 if (!(PL_opargs[type] & OA_FOLDCONST))
4248 #ifdef USE_LOCALE_CTYPE
4249 if (IN_LC_COMPILETIME(LC_CTYPE))
4258 #ifdef USE_LOCALE_COLLATE
4259 if (IN_LC_COMPILETIME(LC_COLLATE))
4264 /* XXX what about the numeric ops? */
4265 #ifdef USE_LOCALE_NUMERIC
4266 if (IN_LC_COMPILETIME(LC_NUMERIC))
4271 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4272 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4275 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4276 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4278 const char *s = SvPVX_const(sv);
4279 while (s < SvEND(sv)) {
4280 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4287 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4290 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4291 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4295 if (PL_parser && PL_parser->error_count)
4296 goto nope; /* Don't try to run w/ errors */
4298 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4299 const OPCODE type = curop->op_type;
4300 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4302 type != OP_SCALAR &&
4304 type != OP_PUSHMARK)
4310 curop = LINKLIST(o);
4311 old_next = o->op_next;
4315 oldscope = PL_scopestack_ix;
4316 create_eval_scope(G_FAKINGEVAL);
4318 /* Verify that we don't need to save it: */
4319 assert(PL_curcop == &PL_compiling);
4320 StructCopy(&PL_compiling, ¬_compiling, COP);
4321 PL_curcop = ¬_compiling;
4322 /* The above ensures that we run with all the correct hints of the
4323 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4324 assert(IN_PERL_RUNTIME);
4325 PL_warnhook = PERL_WARNHOOK_FATAL;
4329 /* Effective $^W=1. */
4330 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4331 PL_dowarn |= G_WARN_ON;
4336 sv = *(PL_stack_sp--);
4337 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4338 pad_swipe(o->op_targ, FALSE);
4340 else if (SvTEMP(sv)) { /* grab mortal temp? */
4341 SvREFCNT_inc_simple_void(sv);
4344 else { assert(SvIMMORTAL(sv)); }
4347 /* Something tried to die. Abandon constant folding. */
4348 /* Pretend the error never happened. */
4350 o->op_next = old_next;
4354 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4355 PL_warnhook = oldwarnhook;
4356 PL_diehook = olddiehook;
4357 /* XXX note that this croak may fail as we've already blown away
4358 * the stack - eg any nested evals */
4359 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4362 PL_dowarn = oldwarn;
4363 PL_warnhook = oldwarnhook;
4364 PL_diehook = olddiehook;
4365 PL_curcop = &PL_compiling;
4367 if (PL_scopestack_ix > oldscope)
4368 delete_eval_scope();
4373 /* OP_STRINGIFY and constant folding are used to implement qq.
4374 Here the constant folding is an implementation detail that we
4375 want to hide. If the stringify op is itself already marked
4376 folded, however, then it is actually a folded join. */
4377 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4382 else if (!SvIMMORTAL(sv)) {
4386 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4387 if (!is_stringify) newop->op_folded = 1;
4395 S_gen_constant_list(pTHX_ OP *o)
4399 const SSize_t oldtmps_floor = PL_tmps_floor;
4404 if (PL_parser && PL_parser->error_count)
4405 return o; /* Don't attempt to run with errors */
4407 curop = LINKLIST(o);
4410 S_prune_chain_head(&curop);
4412 Perl_pp_pushmark(aTHX);
4415 assert (!(curop->op_flags & OPf_SPECIAL));
4416 assert(curop->op_type == OP_RANGE);
4417 Perl_pp_anonlist(aTHX);
4418 PL_tmps_floor = oldtmps_floor;
4420 OpTYPE_set(o, OP_RV2AV);
4421 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4422 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4423 o->op_opt = 0; /* needs to be revisited in rpeep() */
4424 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4426 /* replace subtree with an OP_CONST */
4427 curop = ((UNOP*)o)->op_first;
4428 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4431 if (AvFILLp(av) != -1)
4432 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4435 SvREADONLY_on(*svp);
4442 =head1 Optree Manipulation Functions
4445 /* List constructors */
4448 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4450 Append an item to the list of ops contained directly within a list-type
4451 op, returning the lengthened list. C<first> is the list-type op,
4452 and C<last> is the op to append to the list. C<optype> specifies the
4453 intended opcode for the list. If C<first> is not already a list of the
4454 right type, it will be upgraded into one. If either C<first> or C<last>
4455 is null, the other is returned unchanged.
4461 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4469 if (first->op_type != (unsigned)type
4470 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4472 return newLISTOP(type, 0, first, last);
4475 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4476 first->op_flags |= OPf_KIDS;
4481 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4483 Concatenate the lists of ops contained directly within two list-type ops,
4484 returning the combined list. C<first> and C<last> are the list-type ops
4485 to concatenate. C<optype> specifies the intended opcode for the list.
4486 If either C<first> or C<last> is not already a list of the right type,
4487 it will be upgraded into one. If either C<first> or C<last> is null,
4488 the other is returned unchanged.
4494 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4502 if (first->op_type != (unsigned)type)
4503 return op_prepend_elem(type, first, last);
4505 if (last->op_type != (unsigned)type)
4506 return op_append_elem(type, first, last);
4508 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4509 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4510 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4511 first->op_flags |= (last->op_flags & OPf_KIDS);
4513 S_op_destroy(aTHX_ last);
4519 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4521 Prepend an item to the list of ops contained directly within a list-type
4522 op, returning the lengthened list. C<first> is the op to prepend to the
4523 list, and C<last> is the list-type op. C<optype> specifies the intended
4524 opcode for the list. If C<last> is not already a list of the right type,
4525 it will be upgraded into one. If either C<first> or C<last> is null,
4526 the other is returned unchanged.
4532 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4540 if (last->op_type == (unsigned)type) {
4541 if (type == OP_LIST) { /* already a PUSHMARK there */
4542 /* insert 'first' after pushmark */
4543 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4544 if (!(first->op_flags & OPf_PARENS))
4545 last->op_flags &= ~OPf_PARENS;
4548 op_sibling_splice(last, NULL, 0, first);
4549 last->op_flags |= OPf_KIDS;
4553 return newLISTOP(type, 0, first, last);
4557 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4559 Converts C<o> into a list op if it is not one already, and then converts it
4560 into the specified C<type>, calling its check function, allocating a target if
4561 it needs one, and folding constants.
4563 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4564 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4565 C<op_convert_list> to make it the right type.
4571 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4574 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4575 if (!o || o->op_type != OP_LIST)
4576 o = force_list(o, 0);
4579 o->op_flags &= ~OPf_WANT;
4580 o->op_private &= ~OPpLVAL_INTRO;
4583 if (!(PL_opargs[type] & OA_MARK))
4584 op_null(cLISTOPo->op_first);
4586 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4587 if (kid2 && kid2->op_type == OP_COREARGS) {
4588 op_null(cLISTOPo->op_first);
4589 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4593 OpTYPE_set(o, type);
4594 o->op_flags |= flags;
4595 if (flags & OPf_FOLDED)
4598 o = CHECKOP(type, o);
4599 if (o->op_type != (unsigned)type)
4602 return fold_constants(op_integerize(op_std_init(o)));
4609 =head1 Optree construction
4611 =for apidoc Am|OP *|newNULLLIST
4613 Constructs, checks, and returns a new C<stub> op, which represents an
4614 empty list expression.
4620 Perl_newNULLLIST(pTHX)
4622 return newOP(OP_STUB, 0);
4625 /* promote o and any siblings to be a list if its not already; i.e.
4633 * pushmark - o - A - B
4635 * If nullit it true, the list op is nulled.
4639 S_force_list(pTHX_ OP *o, bool nullit)
4641 if (!o || o->op_type != OP_LIST) {
4644 /* manually detach any siblings then add them back later */
4645 rest = OpSIBLING(o);
4646 OpLASTSIB_set(o, NULL);
4648 o = newLISTOP(OP_LIST, 0, o, NULL);
4650 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4658 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4660 Constructs, checks, and returns an op of any list type. C<type> is
4661 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4662 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
4663 supply up to two ops to be direct children of the list op; they are
4664 consumed by this function and become part of the constructed op tree.
4666 For most list operators, the check function expects all the kid ops to be
4667 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4668 appropriate. What you want to do in that case is create an op of type
4669 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4670 See L</op_convert_list> for more information.
4677 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4682 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4683 || type == OP_CUSTOM);
4685 NewOp(1101, listop, 1, LISTOP);
4687 OpTYPE_set(listop, type);
4690 listop->op_flags = (U8)flags;
4694 else if (!first && last)
4697 OpMORESIB_set(first, last);
4698 listop->op_first = first;
4699 listop->op_last = last;
4700 if (type == OP_LIST) {
4701 OP* const pushop = newOP(OP_PUSHMARK, 0);
4702 OpMORESIB_set(pushop, first);
4703 listop->op_first = pushop;
4704 listop->op_flags |= OPf_KIDS;
4706 listop->op_last = pushop;
4708 if (listop->op_last)
4709 OpLASTSIB_set(listop->op_last, (OP*)listop);
4711 return CHECKOP(type, listop);
4715 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4717 Constructs, checks, and returns an op of any base type (any type that
4718 has no extra fields). C<type> is the opcode. C<flags> gives the
4719 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4726 Perl_newOP(pTHX_ I32 type, I32 flags)
4731 if (type == -OP_ENTEREVAL) {
4732 type = OP_ENTEREVAL;
4733 flags |= OPpEVAL_BYTES<<8;
4736 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4737 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4738 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4739 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4741 NewOp(1101, o, 1, OP);
4742 OpTYPE_set(o, type);
4743 o->op_flags = (U8)flags;
4746 o->op_private = (U8)(0 | (flags >> 8));
4747 if (PL_opargs[type] & OA_RETSCALAR)
4749 if (PL_opargs[type] & OA_TARGET)
4750 o->op_targ = pad_alloc(type, SVs_PADTMP);
4751 return CHECKOP(type, o);
4755 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4757 Constructs, checks, and returns an op of any unary type. C<type> is
4758 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4759 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4760 bits, the eight bits of C<op_private>, except that the bit with value 1
4761 is automatically set. C<first> supplies an optional op to be the direct
4762 child of the unary op; it is consumed by this function and become part
4763 of the constructed op tree.
4769 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4774 if (type == -OP_ENTEREVAL) {
4775 type = OP_ENTEREVAL;
4776 flags |= OPpEVAL_BYTES<<8;
4779 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4780 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4781 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4782 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4783 || type == OP_SASSIGN
4784 || type == OP_ENTERTRY
4785 || type == OP_CUSTOM
4786 || type == OP_NULL );
4789 first = newOP(OP_STUB, 0);
4790 if (PL_opargs[type] & OA_MARK)
4791 first = force_list(first, 1);
4793 NewOp(1101, unop, 1, UNOP);
4794 OpTYPE_set(unop, type);
4795 unop->op_first = first;
4796 unop->op_flags = (U8)(flags | OPf_KIDS);
4797 unop->op_private = (U8)(1 | (flags >> 8));
4799 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4800 OpLASTSIB_set(first, (OP*)unop);
4802 unop = (UNOP*) CHECKOP(type, unop);
4806 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4810 =for apidoc newUNOP_AUX
4812 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4813 initialised to C<aux>
4819 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4824 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4825 || type == OP_CUSTOM);
4827 NewOp(1101, unop, 1, UNOP_AUX);
4828 unop->op_type = (OPCODE)type;
4829 unop->op_ppaddr = PL_ppaddr[type];
4830 unop->op_first = first;
4831 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4832 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4835 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4836 OpLASTSIB_set(first, (OP*)unop);
4838 unop = (UNOP_AUX*) CHECKOP(type, unop);
4840 return op_std_init((OP *) unop);
4844 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4846 Constructs, checks, and returns an op of method type with a method name
4847 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
4848 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4849 and, shifted up eight bits, the eight bits of C<op_private>, except that
4850 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
4851 op which evaluates method name; it is consumed by this function and
4852 become part of the constructed op tree.
4853 Supported optypes: C<OP_METHOD>.
4859 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4863 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4864 || type == OP_CUSTOM);
4866 NewOp(1101, methop, 1, METHOP);
4868 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4869 methop->op_flags = (U8)(flags | OPf_KIDS);
4870 methop->op_u.op_first = dynamic_meth;
4871 methop->op_private = (U8)(1 | (flags >> 8));
4873 if (!OpHAS_SIBLING(dynamic_meth))
4874 OpLASTSIB_set(dynamic_meth, (OP*)methop);
4878 methop->op_flags = (U8)(flags & ~OPf_KIDS);
4879 methop->op_u.op_meth_sv = const_meth;
4880 methop->op_private = (U8)(0 | (flags >> 8));
4881 methop->op_next = (OP*)methop;
4885 methop->op_rclass_targ = 0;
4887 methop->op_rclass_sv = NULL;
4890 OpTYPE_set(methop, type);
4891 return CHECKOP(type, methop);
4895 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4896 PERL_ARGS_ASSERT_NEWMETHOP;
4897 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4901 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4903 Constructs, checks, and returns an op of method type with a constant
4904 method name. C<type> is the opcode. C<flags> gives the eight bits of
4905 C<op_flags>, and, shifted up eight bits, the eight bits of
4906 C<op_private>. C<const_meth> supplies a constant method name;
4907 it must be a shared COW string.
4908 Supported optypes: C<OP_METHOD_NAMED>.
4914 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4915 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4916 return newMETHOP_internal(type, flags, NULL, const_meth);
4920 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4922 Constructs, checks, and returns an op of any binary type. C<type>
4923 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
4924 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4925 the eight bits of C<op_private>, except that the bit with value 1 or
4926 2 is automatically set as required. C<first> and C<last> supply up to
4927 two ops to be the direct children of the binary op; they are consumed
4928 by this function and become part of the constructed op tree.
4934 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4939 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4940 || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
4942 NewOp(1101, binop, 1, BINOP);
4945 first = newOP(OP_NULL, 0);
4947 OpTYPE_set(binop, type);
4948 binop->op_first = first;
4949 binop->op_flags = (U8)(flags | OPf_KIDS);
4952 binop->op_private = (U8)(1 | (flags >> 8));
4955 binop->op_private = (U8)(2 | (flags >> 8));
4956 OpMORESIB_set(first, last);
4959 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
4960 OpLASTSIB_set(last, (OP*)binop);
4962 binop->op_last = OpSIBLING(binop->op_first);
4964 OpLASTSIB_set(binop->op_last, (OP*)binop);
4966 binop = (BINOP*)CHECKOP(type, binop);
4967 if (binop->op_next || binop->op_type != (OPCODE)type)
4970 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4973 static int uvcompare(const void *a, const void *b)
4974 __attribute__nonnull__(1)
4975 __attribute__nonnull__(2)
4976 __attribute__pure__;
4977 static int uvcompare(const void *a, const void *b)
4979 if (*((const UV *)a) < (*(const UV *)b))
4981 if (*((const UV *)a) > (*(const UV *)b))
4983 if (*((const UV *)a+1) < (*(const UV *)b+1))
4985 if (*((const UV *)a+1) > (*(const UV *)b+1))
4991 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4993 SV * const tstr = ((SVOP*)expr)->op_sv;
4995 ((SVOP*)repl)->op_sv;
4998 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4999 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5005 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5006 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5007 I32 del = o->op_private & OPpTRANS_DELETE;
5010 PERL_ARGS_ASSERT_PMTRANS;
5012 PL_hints |= HINT_BLOCK_SCOPE;
5015 o->op_private |= OPpTRANS_FROM_UTF;
5018 o->op_private |= OPpTRANS_TO_UTF;
5020 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5021 SV* const listsv = newSVpvs("# comment\n");
5023 const U8* tend = t + tlen;
5024 const U8* rend = r + rlen;
5040 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5041 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5044 const U32 flags = UTF8_ALLOW_DEFAULT;
5048 t = tsave = bytes_to_utf8(t, &len);
5051 if (!to_utf && rlen) {
5053 r = rsave = bytes_to_utf8(r, &len);
5057 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5058 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5062 U8 tmpbuf[UTF8_MAXBYTES+1];
5065 Newx(cp, 2*tlen, UV);
5067 transv = newSVpvs("");
5069 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5071 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5073 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5077 cp[2*i+1] = cp[2*i];
5081 qsort(cp, i, 2*sizeof(UV), uvcompare);
5082 for (j = 0; j < i; j++) {
5084 diff = val - nextmin;
5086 t = uvchr_to_utf8(tmpbuf,nextmin);
5087 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5089 U8 range_mark = ILLEGAL_UTF8_BYTE;
5090 t = uvchr_to_utf8(tmpbuf, val - 1);
5091 sv_catpvn(transv, (char *)&range_mark, 1);
5092 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5099 t = uvchr_to_utf8(tmpbuf,nextmin);
5100 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5102 U8 range_mark = ILLEGAL_UTF8_BYTE;
5103 sv_catpvn(transv, (char *)&range_mark, 1);
5105 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5106 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5107 t = (const U8*)SvPVX_const(transv);
5108 tlen = SvCUR(transv);
5112 else if (!rlen && !del) {
5113 r = t; rlen = tlen; rend = tend;
5116 if ((!rlen && !del) || t == r ||
5117 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5119 o->op_private |= OPpTRANS_IDENTICAL;
5123 while (t < tend || tfirst <= tlast) {
5124 /* see if we need more "t" chars */
5125 if (tfirst > tlast) {
5126 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5128 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5130 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5137 /* now see if we need more "r" chars */
5138 if (rfirst > rlast) {
5140 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5142 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5144 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5153 rfirst = rlast = 0xffffffff;
5157 /* now see which range will peter out first, if either. */
5158 tdiff = tlast - tfirst;
5159 rdiff = rlast - rfirst;
5160 tcount += tdiff + 1;
5161 rcount += rdiff + 1;
5168 if (rfirst == 0xffffffff) {
5169 diff = tdiff; /* oops, pretend rdiff is infinite */
5171 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5172 (long)tfirst, (long)tlast);
5174 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5178 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5179 (long)tfirst, (long)(tfirst + diff),
5182 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5183 (long)tfirst, (long)rfirst);
5185 if (rfirst + diff > max)
5186 max = rfirst + diff;
5188 grows = (tfirst < rfirst &&
5189 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5201 else if (max > 0xff)
5206 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5208 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5209 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5210 PAD_SETSV(cPADOPo->op_padix, swash);
5212 SvREADONLY_on(swash);
5214 cSVOPo->op_sv = swash;
5216 SvREFCNT_dec(listsv);
5217 SvREFCNT_dec(transv);
5219 if (!del && havefinal && rlen)
5220 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5221 newSVuv((UV)final), 0);
5230 else if (rlast == 0xffffffff)
5236 tbl = (short*)PerlMemShared_calloc(
5237 (o->op_private & OPpTRANS_COMPLEMENT) &&
5238 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5240 cPVOPo->op_pv = (char*)tbl;
5242 for (i = 0; i < (I32)tlen; i++)
5244 for (i = 0, j = 0; i < 256; i++) {
5246 if (j >= (I32)rlen) {
5255 if (i < 128 && r[j] >= 128)
5265 o->op_private |= OPpTRANS_IDENTICAL;
5267 else if (j >= (I32)rlen)
5272 PerlMemShared_realloc(tbl,
5273 (0x101+rlen-j) * sizeof(short));
5274 cPVOPo->op_pv = (char*)tbl;
5276 tbl[0x100] = (short)(rlen - j);
5277 for (i=0; i < (I32)rlen - j; i++)
5278 tbl[0x101+i] = r[j+i];
5282 if (!rlen && !del) {
5285 o->op_private |= OPpTRANS_IDENTICAL;
5287 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5288 o->op_private |= OPpTRANS_IDENTICAL;
5290 for (i = 0; i < 256; i++)
5292 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5293 if (j >= (I32)rlen) {
5295 if (tbl[t[i]] == -1)
5301 if (tbl[t[i]] == -1) {
5302 if (t[i] < 128 && r[j] >= 128)
5310 if(del && rlen == tlen) {
5311 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5312 } else if(rlen > tlen && !complement) {
5313 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5317 o->op_private |= OPpTRANS_GROWS;
5325 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5327 Constructs, checks, and returns an op of any pattern matching type.
5328 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
5329 and, shifted up eight bits, the eight bits of C<op_private>.
5335 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5340 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5341 || type == OP_CUSTOM);
5343 NewOp(1101, pmop, 1, PMOP);
5344 OpTYPE_set(pmop, type);
5345 pmop->op_flags = (U8)flags;
5346 pmop->op_private = (U8)(0 | (flags >> 8));
5347 if (PL_opargs[type] & OA_RETSCALAR)
5350 if (PL_hints & HINT_RE_TAINT)
5351 pmop->op_pmflags |= PMf_RETAINT;
5352 #ifdef USE_LOCALE_CTYPE
5353 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5354 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5359 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5361 if (PL_hints & HINT_RE_FLAGS) {
5362 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5363 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5365 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5366 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5367 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5369 if (reflags && SvOK(reflags)) {
5370 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5376 assert(SvPOK(PL_regex_pad[0]));
5377 if (SvCUR(PL_regex_pad[0])) {
5378 /* Pop off the "packed" IV from the end. */
5379 SV *const repointer_list = PL_regex_pad[0];
5380 const char *p = SvEND(repointer_list) - sizeof(IV);
5381 const IV offset = *((IV*)p);
5383 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5385 SvEND_set(repointer_list, p);
5387 pmop->op_pmoffset = offset;
5388 /* This slot should be free, so assert this: */
5389 assert(PL_regex_pad[offset] == &PL_sv_undef);
5391 SV * const repointer = &PL_sv_undef;
5392 av_push(PL_regex_padav, repointer);
5393 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5394 PL_regex_pad = AvARRAY(PL_regex_padav);
5398 return CHECKOP(type, pmop);
5406 /* Any pad names in scope are potentially lvalues. */
5407 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5408 PADNAME *pn = PAD_COMPNAME_SV(i);
5409 if (!pn || !PadnameLEN(pn))
5411 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5412 S_mark_padname_lvalue(aTHX_ pn);
5416 /* Given some sort of match op o, and an expression expr containing a
5417 * pattern, either compile expr into a regex and attach it to o (if it's
5418 * constant), or convert expr into a runtime regcomp op sequence (if it's
5421 * isreg indicates that the pattern is part of a regex construct, eg
5422 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5423 * split "pattern", which aren't. In the former case, expr will be a list
5424 * if the pattern contains more than one term (eg /a$b/).
5426 * When the pattern has been compiled within a new anon CV (for
5427 * qr/(?{...})/ ), then floor indicates the savestack level just before
5428 * the new sub was created
5432 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5436 I32 repl_has_vars = 0;
5437 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5438 bool is_compiletime;
5441 PERL_ARGS_ASSERT_PMRUNTIME;
5444 return pmtrans(o, expr, repl);
5447 /* find whether we have any runtime or code elements;
5448 * at the same time, temporarily set the op_next of each DO block;
5449 * then when we LINKLIST, this will cause the DO blocks to be excluded
5450 * from the op_next chain (and from having LINKLIST recursively
5451 * applied to them). We fix up the DOs specially later */
5455 if (expr->op_type == OP_LIST) {
5457 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5458 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5460 assert(!o->op_next);
5461 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5462 assert(PL_parser && PL_parser->error_count);
5463 /* This can happen with qr/ (?{(^{})/. Just fake up
5464 the op we were expecting to see, to avoid crashing
5466 op_sibling_splice(expr, o, 0,
5467 newSVOP(OP_CONST, 0, &PL_sv_no));
5469 o->op_next = OpSIBLING(o);
5471 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5475 else if (expr->op_type != OP_CONST)
5480 /* fix up DO blocks; treat each one as a separate little sub;
5481 * also, mark any arrays as LIST/REF */
5483 if (expr->op_type == OP_LIST) {
5485 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5487 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5488 assert( !(o->op_flags & OPf_WANT));
5489 /* push the array rather than its contents. The regex
5490 * engine will retrieve and join the elements later */
5491 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5495 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5497 o->op_next = NULL; /* undo temporary hack from above */
5500 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5501 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5503 assert(leaveop->op_first->op_type == OP_ENTER);
5504 assert(OpHAS_SIBLING(leaveop->op_first));
5505 o->op_next = OpSIBLING(leaveop->op_first);
5507 assert(leaveop->op_flags & OPf_KIDS);
5508 assert(leaveop->op_last->op_next == (OP*)leaveop);
5509 leaveop->op_next = NULL; /* stop on last op */
5510 op_null((OP*)leaveop);
5514 OP *scope = cLISTOPo->op_first;
5515 assert(scope->op_type == OP_SCOPE);
5516 assert(scope->op_flags & OPf_KIDS);
5517 scope->op_next = NULL; /* stop on last op */
5520 /* have to peep the DOs individually as we've removed it from
5521 * the op_next chain */
5523 S_prune_chain_head(&(o->op_next));
5525 /* runtime finalizes as part of finalizing whole tree */
5529 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5530 assert( !(expr->op_flags & OPf_WANT));
5531 /* push the array rather than its contents. The regex
5532 * engine will retrieve and join the elements later */
5533 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5536 PL_hints |= HINT_BLOCK_SCOPE;
5538 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5540 if (is_compiletime) {
5541 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5542 regexp_engine const *eng = current_re_engine();
5544 if (o->op_flags & OPf_SPECIAL)
5545 rx_flags |= RXf_SPLIT;
5547 if (!has_code || !eng->op_comp) {
5548 /* compile-time simple constant pattern */
5550 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5551 /* whoops! we guessed that a qr// had a code block, but we
5552 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5553 * that isn't required now. Note that we have to be pretty
5554 * confident that nothing used that CV's pad while the
5555 * regex was parsed, except maybe op targets for \Q etc.
5556 * If there were any op targets, though, they should have
5557 * been stolen by constant folding.
5561 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5562 while (++i <= AvFILLp(PL_comppad)) {
5563 assert(!PL_curpad[i]);
5566 /* But we know that one op is using this CV's slab. */
5567 cv_forget_slab(PL_compcv);
5569 pm->op_pmflags &= ~PMf_HAS_CV;
5574 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5575 rx_flags, pm->op_pmflags)
5576 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5577 rx_flags, pm->op_pmflags)
5582 /* compile-time pattern that includes literal code blocks */
5583 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5586 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5589 if (pm->op_pmflags & PMf_HAS_CV) {
5591 /* this QR op (and the anon sub we embed it in) is never
5592 * actually executed. It's just a placeholder where we can
5593 * squirrel away expr in op_code_list without the peephole
5594 * optimiser etc processing it for a second time */
5595 OP *qr = newPMOP(OP_QR, 0);
5596 ((PMOP*)qr)->op_code_list = expr;
5598 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5599 SvREFCNT_inc_simple_void(PL_compcv);
5600 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5601 ReANY(re)->qr_anoncv = cv;
5603 /* attach the anon CV to the pad so that
5604 * pad_fixup_inner_anons() can find it */
5605 (void)pad_add_anon(cv, o->op_type);
5606 SvREFCNT_inc_simple_void(cv);
5609 pm->op_code_list = expr;
5614 /* runtime pattern: build chain of regcomp etc ops */
5616 PADOFFSET cv_targ = 0;
5618 reglist = isreg && expr->op_type == OP_LIST;
5623 pm->op_code_list = expr;
5624 /* don't free op_code_list; its ops are embedded elsewhere too */
5625 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5628 if (o->op_flags & OPf_SPECIAL)
5629 pm->op_pmflags |= PMf_SPLIT;
5631 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5632 * to allow its op_next to be pointed past the regcomp and
5633 * preceding stacking ops;
5634 * OP_REGCRESET is there to reset taint before executing the
5636 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5637 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5639 if (pm->op_pmflags & PMf_HAS_CV) {
5640 /* we have a runtime qr with literal code. This means
5641 * that the qr// has been wrapped in a new CV, which
5642 * means that runtime consts, vars etc will have been compiled
5643 * against a new pad. So... we need to execute those ops
5644 * within the environment of the new CV. So wrap them in a call
5645 * to a new anon sub. i.e. for
5649 * we build an anon sub that looks like
5651 * sub { "a", $b, '(?{...})' }
5653 * and call it, passing the returned list to regcomp.
5654 * Or to put it another way, the list of ops that get executed
5658 * ------ -------------------
5659 * pushmark (for regcomp)
5660 * pushmark (for entersub)
5664 * regcreset regcreset
5666 * const("a") const("a")
5668 * const("(?{...})") const("(?{...})")
5673 SvREFCNT_inc_simple_void(PL_compcv);
5674 CvLVALUE_on(PL_compcv);
5675 /* these lines are just an unrolled newANONATTRSUB */
5676 expr = newSVOP(OP_ANONCODE, 0,
5677 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5678 cv_targ = expr->op_targ;
5679 expr = newUNOP(OP_REFGEN, 0, expr);
5681 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5684 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5685 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5686 | (reglist ? OPf_STACKED : 0);
5687 rcop->op_targ = cv_targ;
5689 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5690 if (PL_hints & HINT_RE_EVAL)
5691 S_set_haseval(aTHX);
5693 /* establish postfix order */
5694 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5696 rcop->op_next = expr;
5697 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5700 rcop->op_next = LINKLIST(expr);
5701 expr->op_next = (OP*)rcop;
5704 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5710 /* If we are looking at s//.../e with a single statement, get past
5711 the implicit do{}. */
5712 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5713 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5714 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5717 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5718 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5719 && !OpHAS_SIBLING(sib))
5722 if (curop->op_type == OP_CONST)
5724 else if (( (curop->op_type == OP_RV2SV ||
5725 curop->op_type == OP_RV2AV ||
5726 curop->op_type == OP_RV2HV ||
5727 curop->op_type == OP_RV2GV)
5728 && cUNOPx(curop)->op_first
5729 && cUNOPx(curop)->op_first->op_type == OP_GV )
5730 || curop->op_type == OP_PADSV
5731 || curop->op_type == OP_PADAV
5732 || curop->op_type == OP_PADHV
5733 || curop->op_type == OP_PADANY) {
5741 || !RX_PRELEN(PM_GETRE(pm))
5742 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5744 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5745 op_prepend_elem(o->op_type, scalar(repl), o);
5748 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5749 rcop->op_private = 1;
5751 /* establish postfix order */
5752 rcop->op_next = LINKLIST(repl);
5753 repl->op_next = (OP*)rcop;
5755 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5756 assert(!(pm->op_pmflags & PMf_ONCE));
5757 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5766 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5768 Constructs, checks, and returns an op of any type that involves an
5769 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
5770 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
5771 takes ownership of one reference to it.
5777 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5782 PERL_ARGS_ASSERT_NEWSVOP;
5784 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5785 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5786 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5787 || type == OP_CUSTOM);
5789 NewOp(1101, svop, 1, SVOP);
5790 OpTYPE_set(svop, type);
5792 svop->op_next = (OP*)svop;
5793 svop->op_flags = (U8)flags;
5794 svop->op_private = (U8)(0 | (flags >> 8));
5795 if (PL_opargs[type] & OA_RETSCALAR)
5797 if (PL_opargs[type] & OA_TARGET)
5798 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5799 return CHECKOP(type, svop);
5803 =for apidoc Am|OP *|newDEFSVOP|
5805 Constructs and returns an op to access C<$_>.
5811 Perl_newDEFSVOP(pTHX)
5813 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5819 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5821 Constructs, checks, and returns an op of any type that involves a
5822 reference to a pad element. C<type> is the opcode. C<flags> gives the
5823 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5824 is populated with C<sv>; this function takes ownership of one reference
5827 This function only exists if Perl has been compiled to use ithreads.
5833 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5838 PERL_ARGS_ASSERT_NEWPADOP;
5840 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5841 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5842 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5843 || type == OP_CUSTOM);
5845 NewOp(1101, padop, 1, PADOP);
5846 OpTYPE_set(padop, type);
5848 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5849 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5850 PAD_SETSV(padop->op_padix, sv);
5852 padop->op_next = (OP*)padop;
5853 padop->op_flags = (U8)flags;
5854 if (PL_opargs[type] & OA_RETSCALAR)
5856 if (PL_opargs[type] & OA_TARGET)
5857 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5858 return CHECKOP(type, padop);
5861 #endif /* USE_ITHREADS */
5864 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5866 Constructs, checks, and returns an op of any type that involves an
5867 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
5868 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
5869 reference; calling this function does not transfer ownership of any
5876 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5878 PERL_ARGS_ASSERT_NEWGVOP;
5881 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5883 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5888 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5890 Constructs, checks, and returns an op of any type that involves an
5891 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
5892 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
5893 must have been allocated using C<PerlMemShared_malloc>; the memory will
5894 be freed when the op is destroyed.
5900 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5903 const bool utf8 = cBOOL(flags & SVf_UTF8);
5908 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5909 || type == OP_RUNCV || type == OP_CUSTOM
5910 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5912 NewOp(1101, pvop, 1, PVOP);
5913 OpTYPE_set(pvop, type);
5915 pvop->op_next = (OP*)pvop;
5916 pvop->op_flags = (U8)flags;
5917 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5918 if (PL_opargs[type] & OA_RETSCALAR)
5920 if (PL_opargs[type] & OA_TARGET)
5921 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5922 return CHECKOP(type, pvop);
5926 Perl_package(pTHX_ OP *o)
5928 SV *const sv = cSVOPo->op_sv;
5930 PERL_ARGS_ASSERT_PACKAGE;
5932 SAVEGENERICSV(PL_curstash);
5933 save_item(PL_curstname);
5935 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5937 sv_setsv(PL_curstname, sv);
5939 PL_hints |= HINT_BLOCK_SCOPE;
5940 PL_parser->copline = NOLINE;
5946 Perl_package_version( pTHX_ OP *v )
5948 U32 savehints = PL_hints;
5949 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5950 PL_hints &= ~HINT_STRICT_VARS;
5951 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5952 PL_hints = savehints;
5957 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5962 SV *use_version = NULL;
5964 PERL_ARGS_ASSERT_UTILIZE;
5966 if (idop->op_type != OP_CONST)
5967 Perl_croak(aTHX_ "Module name must be constant");
5972 SV * const vesv = ((SVOP*)version)->op_sv;
5974 if (!arg && !SvNIOKp(vesv)) {
5981 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5982 Perl_croak(aTHX_ "Version number must be a constant number");
5984 /* Make copy of idop so we don't free it twice */
5985 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5987 /* Fake up a method call to VERSION */
5988 meth = newSVpvs_share("VERSION");
5989 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5990 op_append_elem(OP_LIST,
5991 op_prepend_elem(OP_LIST, pack, version),
5992 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5996 /* Fake up an import/unimport */
5997 if (arg && arg->op_type == OP_STUB) {
5998 imop = arg; /* no import on explicit () */
6000 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6001 imop = NULL; /* use 5.0; */
6003 use_version = ((SVOP*)idop)->op_sv;
6005 idop->op_private |= OPpCONST_NOVER;
6010 /* Make copy of idop so we don't free it twice */
6011 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6013 /* Fake up a method call to import/unimport */
6015 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6016 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6017 op_append_elem(OP_LIST,
6018 op_prepend_elem(OP_LIST, pack, arg),
6019 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6023 /* Fake up the BEGIN {}, which does its thing immediately. */
6025 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6028 op_append_elem(OP_LINESEQ,
6029 op_append_elem(OP_LINESEQ,
6030 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6031 newSTATEOP(0, NULL, veop)),
6032 newSTATEOP(0, NULL, imop) ));
6036 * feature bundle that corresponds to the required version. */
6037 use_version = sv_2mortal(new_version(use_version));
6038 S_enable_feature_bundle(aTHX_ use_version);
6040 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6041 if (vcmp(use_version,
6042 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6043 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6044 PL_hints |= HINT_STRICT_REFS;
6045 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6046 PL_hints |= HINT_STRICT_SUBS;
6047 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6048 PL_hints |= HINT_STRICT_VARS;
6050 /* otherwise they are off */
6052 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6053 PL_hints &= ~HINT_STRICT_REFS;
6054 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6055 PL_hints &= ~HINT_STRICT_SUBS;
6056 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6057 PL_hints &= ~HINT_STRICT_VARS;
6061 /* The "did you use incorrect case?" warning used to be here.
6062 * The problem is that on case-insensitive filesystems one
6063 * might get false positives for "use" (and "require"):
6064 * "use Strict" or "require CARP" will work. This causes
6065 * portability problems for the script: in case-strict
6066 * filesystems the script will stop working.
6068 * The "incorrect case" warning checked whether "use Foo"
6069 * imported "Foo" to your namespace, but that is wrong, too:
6070 * there is no requirement nor promise in the language that
6071 * a Foo.pm should or would contain anything in package "Foo".
6073 * There is very little Configure-wise that can be done, either:
6074 * the case-sensitivity of the build filesystem of Perl does not
6075 * help in guessing the case-sensitivity of the runtime environment.
6078 PL_hints |= HINT_BLOCK_SCOPE;
6079 PL_parser->copline = NOLINE;
6080 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6084 =head1 Embedding Functions
6086 =for apidoc load_module
6088 Loads the module whose name is pointed to by the string part of name.
6089 Note that the actual module name, not its filename, should be given.
6090 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
6091 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6092 (or 0 for no flags). ver, if specified
6093 and not NULL, provides version semantics
6094 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
6095 arguments can be used to specify arguments to the module's C<import()>
6096 method, similar to C<use Foo::Bar VERSION LIST>. They must be
6097 terminated with a final C<NULL> pointer. Note that this list can only
6098 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6099 Otherwise at least a single C<NULL> pointer to designate the default
6100 import list is required.
6102 The reference count for each specified C<SV*> parameter is decremented.
6107 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6111 PERL_ARGS_ASSERT_LOAD_MODULE;
6113 va_start(args, ver);
6114 vload_module(flags, name, ver, &args);
6118 #ifdef PERL_IMPLICIT_CONTEXT
6120 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6124 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6125 va_start(args, ver);
6126 vload_module(flags, name, ver, &args);
6132 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6135 OP * const modname = newSVOP(OP_CONST, 0, name);
6137 PERL_ARGS_ASSERT_VLOAD_MODULE;
6139 modname->op_private |= OPpCONST_BARE;
6141 veop = newSVOP(OP_CONST, 0, ver);
6145 if (flags & PERL_LOADMOD_NOIMPORT) {
6146 imop = sawparens(newNULLLIST());
6148 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6149 imop = va_arg(*args, OP*);
6154 sv = va_arg(*args, SV*);
6156 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6157 sv = va_arg(*args, SV*);
6161 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6162 * that it has a PL_parser to play with while doing that, and also
6163 * that it doesn't mess with any existing parser, by creating a tmp
6164 * new parser with lex_start(). This won't actually be used for much,
6165 * since pp_require() will create another parser for the real work.
6166 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6169 SAVEVPTR(PL_curcop);
6170 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6171 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6172 veop, modname, imop);
6176 PERL_STATIC_INLINE OP *
6177 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6179 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6180 newLISTOP(OP_LIST, 0, arg,
6181 newUNOP(OP_RV2CV, 0,
6182 newGVOP(OP_GV, 0, gv))));
6186 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6191 PERL_ARGS_ASSERT_DOFILE;
6193 if (!force_builtin && (gv = gv_override("do", 2))) {
6194 doop = S_new_entersubop(aTHX_ gv, term);
6197 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6203 =head1 Optree construction
6205 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6207 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
6208 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6209 be set automatically, and, shifted up eight bits, the eight bits of
6210 C<op_private>, except that the bit with value 1 or 2 is automatically
6211 set as required. C<listval> and C<subscript> supply the parameters of
6212 the slice; they are consumed by this function and become part of the
6213 constructed op tree.
6219 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6221 return newBINOP(OP_LSLICE, flags,
6222 list(force_list(subscript, 1)),
6223 list(force_list(listval, 1)) );
6226 #define ASSIGN_LIST 1
6227 #define ASSIGN_REF 2
6230 S_assignment_type(pTHX_ const OP *o)
6239 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6240 o = cUNOPo->op_first;
6242 flags = o->op_flags;
6244 if (type == OP_COND_EXPR) {
6245 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6246 const I32 t = assignment_type(sib);
6247 const I32 f = assignment_type(OpSIBLING(sib));
6249 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6251 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6252 yyerror("Assignment to both a list and a scalar");
6256 if (type == OP_SREFGEN)
6258 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6259 type = kid->op_type;
6260 flags |= kid->op_flags;
6261 if (!(flags & OPf_PARENS)
6262 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6263 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6269 if (type == OP_LIST &&
6270 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6271 o->op_private & OPpLVAL_INTRO)
6274 if (type == OP_LIST || flags & OPf_PARENS ||
6275 type == OP_RV2AV || type == OP_RV2HV ||
6276 type == OP_ASLICE || type == OP_HSLICE ||
6277 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6280 if (type == OP_PADAV || type == OP_PADHV)
6283 if (type == OP_RV2SV)
6291 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6293 Constructs, checks, and returns an assignment op. C<left> and C<right>
6294 supply the parameters of the assignment; they are consumed by this
6295 function and become part of the constructed op tree.
6297 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6298 a suitable conditional optree is constructed. If C<optype> is the opcode
6299 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6300 performs the binary operation and assigns the result to the left argument.
6301 Either way, if C<optype> is non-zero then C<flags> has no effect.
6303 If C<optype> is zero, then a plain scalar or list assignment is
6304 constructed. Which type of assignment it is is automatically determined.
6305 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6306 will be set automatically, and, shifted up eight bits, the eight bits
6307 of C<op_private>, except that the bit with value 1 or 2 is automatically
6314 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6320 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6321 return newLOGOP(optype, 0,
6322 op_lvalue(scalar(left), optype),
6323 newUNOP(OP_SASSIGN, 0, scalar(right)));
6326 return newBINOP(optype, OPf_STACKED,
6327 op_lvalue(scalar(left), optype), scalar(right));
6331 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6332 static const char no_list_state[] = "Initialization of state variables"
6333 " in list context currently forbidden";
6336 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6337 left->op_private &= ~ OPpSLICEWARNING;
6340 left = op_lvalue(left, OP_AASSIGN);
6341 curop = list(force_list(left, 1));
6342 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6343 o->op_private = (U8)(0 | (flags >> 8));
6345 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6347 OP* lop = ((LISTOP*)left)->op_first;
6349 if ((lop->op_type == OP_PADSV ||
6350 lop->op_type == OP_PADAV ||
6351 lop->op_type == OP_PADHV ||
6352 lop->op_type == OP_PADANY)
6353 && (lop->op_private & OPpPAD_STATE)
6355 yyerror(no_list_state);
6356 lop = OpSIBLING(lop);
6359 else if ( (left->op_private & OPpLVAL_INTRO)
6360 && (left->op_private & OPpPAD_STATE)
6361 && ( left->op_type == OP_PADSV
6362 || left->op_type == OP_PADAV
6363 || left->op_type == OP_PADHV
6364 || left->op_type == OP_PADANY)
6366 /* All single variable list context state assignments, hence
6376 yyerror(no_list_state);
6379 if (right && right->op_type == OP_SPLIT
6380 && !(right->op_flags & OPf_STACKED)) {
6381 OP* tmpop = ((LISTOP*)right)->op_first;
6382 PMOP * const pm = (PMOP*)tmpop;
6383 assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6386 !pm->op_pmreplrootu.op_pmtargetoff
6388 !pm->op_pmreplrootu.op_pmtargetgv
6392 if (!(left->op_private & OPpLVAL_INTRO) &&
6393 ( (left->op_type == OP_RV2AV &&
6394 (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6395 || left->op_type == OP_PADAV )
6397 if (tmpop != (OP *)pm) {
6399 pm->op_pmreplrootu.op_pmtargetoff
6400 = cPADOPx(tmpop)->op_padix;
6401 cPADOPx(tmpop)->op_padix = 0; /* steal it */
6403 pm->op_pmreplrootu.op_pmtargetgv
6404 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6405 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
6407 right->op_private |=
6408 left->op_private & OPpOUR_INTRO;
6411 pm->op_targ = left->op_targ;
6412 left->op_targ = 0; /* filch it */
6415 tmpop = cUNOPo->op_first; /* to list (nulled) */
6416 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6417 /* detach rest of siblings from o subtree,
6418 * and free subtree */
6419 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6420 op_free(o); /* blow off assign */
6421 right->op_flags &= ~OPf_WANT;
6422 /* "I don't know and I don't care." */
6425 else if (left->op_type == OP_RV2AV
6426 || left->op_type == OP_PADAV)
6428 /* Detach the array. */
6432 op_sibling_splice(cBINOPo->op_last,
6433 cUNOPx(cBINOPo->op_last)
6434 ->op_first, 1, NULL);
6435 assert(ary == left);
6436 /* Attach it to the split. */
6437 op_sibling_splice(right, cLISTOPx(right)->op_last,
6439 right->op_flags |= OPf_STACKED;
6440 /* Detach split and expunge aassign as above. */
6443 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6444 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6447 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6448 SV * const sv = *svp;
6449 if (SvIOK(sv) && SvIVX(sv) == 0)
6451 if (right->op_private & OPpSPLIT_IMPLIM) {
6452 /* our own SV, created in ck_split */
6454 sv_setiv(sv, PL_modcount+1);
6457 /* SV may belong to someone else */
6459 *svp = newSViv(PL_modcount+1);
6467 if (assign_type == ASSIGN_REF)
6468 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6470 right = newOP(OP_UNDEF, 0);
6471 if (right->op_type == OP_READLINE) {
6472 right->op_flags |= OPf_STACKED;
6473 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6477 o = newBINOP(OP_SASSIGN, flags,
6478 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6484 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6486 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6487 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6488 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6489 If C<label> is non-null, it supplies the name of a label to attach to
6490 the state op; this function takes ownership of the memory pointed at by
6491 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
6494 If C<o> is null, the state op is returned. Otherwise the state op is
6495 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
6496 is consumed by this function and becomes part of the returned op tree.
6502 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6505 const U32 seq = intro_my();
6506 const U32 utf8 = flags & SVf_UTF8;
6509 PL_parser->parsed_sub = 0;
6513 NewOp(1101, cop, 1, COP);
6514 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6515 OpTYPE_set(cop, OP_DBSTATE);
6518 OpTYPE_set(cop, OP_NEXTSTATE);
6520 cop->op_flags = (U8)flags;
6521 CopHINTS_set(cop, PL_hints);
6523 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6525 cop->op_next = (OP*)cop;
6528 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6529 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6531 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6533 PL_hints |= HINT_BLOCK_SCOPE;
6534 /* It seems that we need to defer freeing this pointer, as other parts
6535 of the grammar end up wanting to copy it after this op has been
6540 if (PL_parser->preambling != NOLINE) {
6541 CopLINE_set(cop, PL_parser->preambling);
6542 PL_parser->copline = NOLINE;
6544 else if (PL_parser->copline == NOLINE)
6545 CopLINE_set(cop, CopLINE(PL_curcop));
6547 CopLINE_set(cop, PL_parser->copline);
6548 PL_parser->copline = NOLINE;
6551 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6553 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6555 CopSTASH_set(cop, PL_curstash);
6557 if (cop->op_type == OP_DBSTATE) {
6558 /* this line can have a breakpoint - store the cop in IV */
6559 AV *av = CopFILEAVx(PL_curcop);
6561 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6562 if (svp && *svp != &PL_sv_undef ) {
6563 (void)SvIOK_on(*svp);
6564 SvIV_set(*svp, PTR2IV(cop));
6569 if (flags & OPf_SPECIAL)
6571 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6575 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6577 Constructs, checks, and returns a logical (flow control) op. C<type>
6578 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6579 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6580 the eight bits of C<op_private>, except that the bit with value 1 is
6581 automatically set. C<first> supplies the expression controlling the
6582 flow, and C<other> supplies the side (alternate) chain of ops; they are
6583 consumed by this function and become part of the constructed op tree.
6589 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6591 PERL_ARGS_ASSERT_NEWLOGOP;
6593 return new_logop(type, flags, &first, &other);
6597 S_search_const(pTHX_ OP *o)
6599 PERL_ARGS_ASSERT_SEARCH_CONST;
6601 switch (o->op_type) {
6605 if (o->op_flags & OPf_KIDS)
6606 return search_const(cUNOPo->op_first);
6613 if (!(o->op_flags & OPf_KIDS))
6615 kid = cLISTOPo->op_first;
6617 switch (kid->op_type) {
6621 kid = OpSIBLING(kid);
6624 if (kid != cLISTOPo->op_last)
6630 kid = cLISTOPo->op_last;
6632 return search_const(kid);
6640 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6648 int prepend_not = 0;
6650 PERL_ARGS_ASSERT_NEW_LOGOP;
6655 /* [perl #59802]: Warn about things like "return $a or $b", which
6656 is parsed as "(return $a) or $b" rather than "return ($a or
6657 $b)". NB: This also applies to xor, which is why we do it
6660 switch (first->op_type) {
6664 /* XXX: Perhaps we should emit a stronger warning for these.
6665 Even with the high-precedence operator they don't seem to do
6668 But until we do, fall through here.
6674 /* XXX: Currently we allow people to "shoot themselves in the
6675 foot" by explicitly writing "(return $a) or $b".
6677 Warn unless we are looking at the result from folding or if
6678 the programmer explicitly grouped the operators like this.
6679 The former can occur with e.g.
6681 use constant FEATURE => ( $] >= ... );
6682 sub { not FEATURE and return or do_stuff(); }
6684 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6685 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6686 "Possible precedence issue with control flow operator");
6687 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6693 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6694 return newBINOP(type, flags, scalar(first), scalar(other));
6696 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6697 || type == OP_CUSTOM);
6699 scalarboolean(first);
6700 /* optimize AND and OR ops that have NOTs as children */
6701 if (first->op_type == OP_NOT
6702 && (first->op_flags & OPf_KIDS)
6703 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6704 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6706 if (type == OP_AND || type == OP_OR) {
6712 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6714 prepend_not = 1; /* prepend a NOT op later */
6718 /* search for a constant op that could let us fold the test */
6719 if ((cstop = search_const(first))) {
6720 if (cstop->op_private & OPpCONST_STRICT)
6721 no_bareword_allowed(cstop);
6722 else if ((cstop->op_private & OPpCONST_BARE))
6723 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6724 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6725 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6726 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6728 if (other->op_type == OP_CONST)
6729 other->op_private |= OPpCONST_SHORTCIRCUIT;
6731 if (other->op_type == OP_LEAVE)
6732 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6733 else if (other->op_type == OP_MATCH
6734 || other->op_type == OP_SUBST
6735 || other->op_type == OP_TRANSR
6736 || other->op_type == OP_TRANS)
6737 /* Mark the op as being unbindable with =~ */
6738 other->op_flags |= OPf_SPECIAL;
6740 other->op_folded = 1;
6744 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6745 const OP *o2 = other;
6746 if ( ! (o2->op_type == OP_LIST
6747 && (( o2 = cUNOPx(o2)->op_first))
6748 && o2->op_type == OP_PUSHMARK
6749 && (( o2 = OpSIBLING(o2))) )
6752 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6753 || o2->op_type == OP_PADHV)
6754 && o2->op_private & OPpLVAL_INTRO
6755 && !(o2->op_private & OPpPAD_STATE))
6757 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6758 "Deprecated use of my() in false conditional");
6762 if (cstop->op_type == OP_CONST)
6763 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6768 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6769 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6771 const OP * const k1 = ((UNOP*)first)->op_first;
6772 const OP * const k2 = OpSIBLING(k1);
6774 switch (first->op_type)
6777 if (k2 && k2->op_type == OP_READLINE
6778 && (k2->op_flags & OPf_STACKED)
6779 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6781 warnop = k2->op_type;
6786 if (k1->op_type == OP_READDIR
6787 || k1->op_type == OP_GLOB
6788 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6789 || k1->op_type == OP_EACH
6790 || k1->op_type == OP_AEACH)
6792 warnop = ((k1->op_type == OP_NULL)
6793 ? (OPCODE)k1->op_targ : k1->op_type);
6798 const line_t oldline = CopLINE(PL_curcop);
6799 /* This ensures that warnings are reported at the first line
6800 of the construction, not the last. */
6801 CopLINE_set(PL_curcop, PL_parser->copline);
6802 Perl_warner(aTHX_ packWARN(WARN_MISC),
6803 "Value of %s%s can be \"0\"; test with defined()",
6805 ((warnop == OP_READLINE || warnop == OP_GLOB)
6806 ? " construct" : "() operator"));
6807 CopLINE_set(PL_curcop, oldline);
6814 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6815 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6817 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6818 logop->op_flags |= (U8)flags;
6819 logop->op_private = (U8)(1 | (flags >> 8));
6821 /* establish postfix order */
6822 logop->op_next = LINKLIST(first);
6823 first->op_next = (OP*)logop;
6824 assert(!OpHAS_SIBLING(first));
6825 op_sibling_splice((OP*)logop, first, 0, other);
6827 CHECKOP(type,logop);
6829 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
6830 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
6838 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6840 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6841 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6842 will be set automatically, and, shifted up eight bits, the eight bits of
6843 C<op_private>, except that the bit with value 1 is automatically set.
6844 C<first> supplies the expression selecting between the two branches,
6845 and C<trueop> and C<falseop> supply the branches; they are consumed by
6846 this function and become part of the constructed op tree.
6852 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6860 PERL_ARGS_ASSERT_NEWCONDOP;
6863 return newLOGOP(OP_AND, 0, first, trueop);
6865 return newLOGOP(OP_OR, 0, first, falseop);
6867 scalarboolean(first);
6868 if ((cstop = search_const(first))) {
6869 /* Left or right arm of the conditional? */
6870 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6871 OP *live = left ? trueop : falseop;
6872 OP *const dead = left ? falseop : trueop;
6873 if (cstop->op_private & OPpCONST_BARE &&
6874 cstop->op_private & OPpCONST_STRICT) {
6875 no_bareword_allowed(cstop);
6879 if (live->op_type == OP_LEAVE)
6880 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6881 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6882 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6883 /* Mark the op as being unbindable with =~ */
6884 live->op_flags |= OPf_SPECIAL;
6885 live->op_folded = 1;
6888 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6889 logop->op_flags |= (U8)flags;
6890 logop->op_private = (U8)(1 | (flags >> 8));
6891 logop->op_next = LINKLIST(falseop);
6893 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6896 /* establish postfix order */
6897 start = LINKLIST(first);
6898 first->op_next = (OP*)logop;
6900 /* make first, trueop, falseop siblings */
6901 op_sibling_splice((OP*)logop, first, 0, trueop);
6902 op_sibling_splice((OP*)logop, trueop, 0, falseop);
6904 o = newUNOP(OP_NULL, 0, (OP*)logop);
6906 trueop->op_next = falseop->op_next = o;
6913 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6915 Constructs and returns a C<range> op, with subordinate C<flip> and
6916 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
6917 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6918 for both the C<flip> and C<range> ops, except that the bit with value
6919 1 is automatically set. C<left> and C<right> supply the expressions
6920 controlling the endpoints of the range; they are consumed by this function
6921 and become part of the constructed op tree.
6927 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6935 PERL_ARGS_ASSERT_NEWRANGE;
6937 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6938 range->op_flags = OPf_KIDS;
6939 leftstart = LINKLIST(left);
6940 range->op_private = (U8)(1 | (flags >> 8));
6942 /* make left and right siblings */
6943 op_sibling_splice((OP*)range, left, 0, right);
6945 range->op_next = (OP*)range;
6946 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6947 flop = newUNOP(OP_FLOP, 0, flip);
6948 o = newUNOP(OP_NULL, 0, flop);
6950 range->op_next = leftstart;
6952 left->op_next = flip;
6953 right->op_next = flop;
6956 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
6957 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6959 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
6960 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6961 SvPADTMP_on(PAD_SV(flip->op_targ));
6963 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6964 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6966 /* check barewords before they might be optimized aways */
6967 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6968 no_bareword_allowed(left);
6969 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6970 no_bareword_allowed(right);
6973 if (!flip->op_private || !flop->op_private)
6974 LINKLIST(o); /* blow off optimizer unless constant */
6980 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6982 Constructs, checks, and returns an op tree expressing a loop. This is
6983 only a loop in the control flow through the op tree; it does not have
6984 the heavyweight loop structure that allows exiting the loop by C<last>
6985 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
6986 top-level op, except that some bits will be set automatically as required.
6987 C<expr> supplies the expression controlling loop iteration, and C<block>
6988 supplies the body of the loop; they are consumed by this function and
6989 become part of the constructed op tree. C<debuggable> is currently
6990 unused and should always be 1.
6996 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7000 const bool once = block && block->op_flags & OPf_SPECIAL &&
7001 block->op_type == OP_NULL;
7003 PERL_UNUSED_ARG(debuggable);
7007 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7008 || ( expr->op_type == OP_NOT
7009 && cUNOPx(expr)->op_first->op_type == OP_CONST
7010 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7013 /* Return the block now, so that S_new_logop does not try to
7015 return block; /* do {} while 0 does once */
7016 if (expr->op_type == OP_READLINE
7017 || expr->op_type == OP_READDIR
7018 || expr->op_type == OP_GLOB
7019 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7020 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7021 expr = newUNOP(OP_DEFINED, 0,
7022 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7023 } else if (expr->op_flags & OPf_KIDS) {
7024 const OP * const k1 = ((UNOP*)expr)->op_first;
7025 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7026 switch (expr->op_type) {
7028 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7029 && (k2->op_flags & OPf_STACKED)
7030 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7031 expr = newUNOP(OP_DEFINED, 0, expr);
7035 if (k1 && (k1->op_type == OP_READDIR
7036 || k1->op_type == OP_GLOB
7037 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7038 || k1->op_type == OP_EACH
7039 || k1->op_type == OP_AEACH))
7040 expr = newUNOP(OP_DEFINED, 0, expr);
7046 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7047 * op, in listop. This is wrong. [perl #27024] */
7049 block = newOP(OP_NULL, 0);
7050 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7051 o = new_logop(OP_AND, 0, &expr, &listop);
7058 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7060 if (once && o != listop)
7062 assert(cUNOPo->op_first->op_type == OP_AND
7063 || cUNOPo->op_first->op_type == OP_OR);
7064 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7068 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7070 o->op_flags |= flags;
7072 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7077 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7079 Constructs, checks, and returns an op tree expressing a C<while> loop.
7080 This is a heavyweight loop, with structure that allows exiting the loop
7081 by C<last> and suchlike.
7083 C<loop> is an optional preconstructed C<enterloop> op to use in the
7084 loop; if it is null then a suitable op will be constructed automatically.
7085 C<expr> supplies the loop's controlling expression. C<block> supplies the
7086 main body of the loop, and C<cont> optionally supplies a C<continue> block
7087 that operates as a second half of the body. All of these optree inputs
7088 are consumed by this function and become part of the constructed op tree.
7090 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7091 op and, shifted up eight bits, the eight bits of C<op_private> for
7092 the C<leaveloop> op, except that (in both cases) some bits will be set
7093 automatically. C<debuggable> is currently unused and should always be 1.
7094 C<has_my> can be supplied as true to force the
7095 loop body to be enclosed in its own scope.
7101 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7102 OP *expr, OP *block, OP *cont, I32 has_my)
7111 PERL_UNUSED_ARG(debuggable);
7114 if (expr->op_type == OP_READLINE
7115 || expr->op_type == OP_READDIR
7116 || expr->op_type == OP_GLOB
7117 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7118 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7119 expr = newUNOP(OP_DEFINED, 0,
7120 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7121 } else if (expr->op_flags & OPf_KIDS) {
7122 const OP * const k1 = ((UNOP*)expr)->op_first;
7123 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7124 switch (expr->op_type) {
7126 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7127 && (k2->op_flags & OPf_STACKED)
7128 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7129 expr = newUNOP(OP_DEFINED, 0, expr);
7133 if (k1 && (k1->op_type == OP_READDIR
7134 || k1->op_type == OP_GLOB
7135 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7136 || k1->op_type == OP_EACH
7137 || k1->op_type == OP_AEACH))
7138 expr = newUNOP(OP_DEFINED, 0, expr);
7145 block = newOP(OP_NULL, 0);
7146 else if (cont || has_my) {
7147 block = op_scope(block);
7151 next = LINKLIST(cont);
7154 OP * const unstack = newOP(OP_UNSTACK, 0);
7157 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7161 listop = op_append_list(OP_LINESEQ, block, cont);
7163 redo = LINKLIST(listop);
7167 o = new_logop(OP_AND, 0, &expr, &listop);
7168 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7170 return expr; /* listop already freed by new_logop */
7173 ((LISTOP*)listop)->op_last->op_next =
7174 (o == listop ? redo : LINKLIST(o));
7180 NewOp(1101,loop,1,LOOP);
7181 OpTYPE_set(loop, OP_ENTERLOOP);
7182 loop->op_private = 0;
7183 loop->op_next = (OP*)loop;
7186 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7188 loop->op_redoop = redo;
7189 loop->op_lastop = o;
7190 o->op_private |= loopflags;
7193 loop->op_nextop = next;
7195 loop->op_nextop = o;
7197 o->op_flags |= flags;
7198 o->op_private |= (flags >> 8);
7203 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7205 Constructs, checks, and returns an op tree expressing a C<foreach>
7206 loop (iteration through a list of values). This is a heavyweight loop,
7207 with structure that allows exiting the loop by C<last> and suchlike.
7209 C<sv> optionally supplies the variable that will be aliased to each
7210 item in turn; if null, it defaults to C<$_>.
7211 C<expr> supplies the list of values to iterate over. C<block> supplies
7212 the main body of the loop, and C<cont> optionally supplies a C<continue>
7213 block that operates as a second half of the body. All of these optree
7214 inputs are consumed by this function and become part of the constructed
7217 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7218 op and, shifted up eight bits, the eight bits of C<op_private> for
7219 the C<leaveloop> op, except that (in both cases) some bits will be set
7226 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7231 PADOFFSET padoff = 0;
7235 PERL_ARGS_ASSERT_NEWFOROP;
7238 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7239 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7240 OpTYPE_set(sv, OP_RV2GV);
7242 /* The op_type check is needed to prevent a possible segfault
7243 * if the loop variable is undeclared and 'strict vars' is in
7244 * effect. This is illegal but is nonetheless parsed, so we
7245 * may reach this point with an OP_CONST where we're expecting
7248 if (cUNOPx(sv)->op_first->op_type == OP_GV
7249 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7250 iterpflags |= OPpITER_DEF;
7252 else if (sv->op_type == OP_PADSV) { /* private variable */
7253 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7254 padoff = sv->op_targ;
7258 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7260 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7263 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7265 PADNAME * const pn = PAD_COMPNAME(padoff);
7266 const char * const name = PadnamePV(pn);
7268 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7269 iterpflags |= OPpITER_DEF;
7273 sv = newGVOP(OP_GV, 0, PL_defgv);
7274 iterpflags |= OPpITER_DEF;
7277 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7278 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7279 iterflags |= OPf_STACKED;
7281 else if (expr->op_type == OP_NULL &&
7282 (expr->op_flags & OPf_KIDS) &&
7283 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7285 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7286 * set the STACKED flag to indicate that these values are to be
7287 * treated as min/max values by 'pp_enteriter'.
7289 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7290 LOGOP* const range = (LOGOP*) flip->op_first;
7291 OP* const left = range->op_first;
7292 OP* const right = OpSIBLING(left);
7295 range->op_flags &= ~OPf_KIDS;
7296 /* detach range's children */
7297 op_sibling_splice((OP*)range, NULL, -1, NULL);
7299 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7300 listop->op_first->op_next = range->op_next;
7301 left->op_next = range->op_other;
7302 right->op_next = (OP*)listop;
7303 listop->op_next = listop->op_first;
7306 expr = (OP*)(listop);
7308 iterflags |= OPf_STACKED;
7311 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7314 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7315 op_append_elem(OP_LIST, list(expr),
7317 assert(!loop->op_next);
7318 /* for my $x () sets OPpLVAL_INTRO;
7319 * for our $x () sets OPpOUR_INTRO */
7320 loop->op_private = (U8)iterpflags;
7321 if (loop->op_slabbed
7322 && DIFF(loop, OpSLOT(loop)->opslot_next)
7323 < SIZE_TO_PSIZE(sizeof(LOOP)))
7326 NewOp(1234,tmp,1,LOOP);
7327 Copy(loop,tmp,1,LISTOP);
7328 #ifdef PERL_OP_PARENT
7329 assert(loop->op_last->op_sibparent == (OP*)loop);
7330 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7332 S_op_destroy(aTHX_ (OP*)loop);
7335 else if (!loop->op_slabbed)
7337 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7338 #ifdef PERL_OP_PARENT
7339 OpLASTSIB_set(loop->op_last, (OP*)loop);
7342 loop->op_targ = padoff;
7343 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7348 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7350 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7351 or C<last>). C<type> is the opcode. C<label> supplies the parameter
7352 determining the target of the op; it is consumed by this function and
7353 becomes part of the constructed op tree.
7359 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7363 PERL_ARGS_ASSERT_NEWLOOPEX;
7365 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7366 || type == OP_CUSTOM);
7368 if (type != OP_GOTO) {
7369 /* "last()" means "last" */
7370 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7371 o = newOP(type, OPf_SPECIAL);
7375 /* Check whether it's going to be a goto &function */
7376 if (label->op_type == OP_ENTERSUB
7377 && !(label->op_flags & OPf_STACKED))
7378 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7381 /* Check for a constant argument */
7382 if (label->op_type == OP_CONST) {
7383 SV * const sv = ((SVOP *)label)->op_sv;
7385 const char *s = SvPV_const(sv,l);
7386 if (l == strlen(s)) {
7388 SvUTF8(((SVOP*)label)->op_sv),
7390 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7394 /* If we have already created an op, we do not need the label. */
7397 else o = newUNOP(type, OPf_STACKED, label);
7399 PL_hints |= HINT_BLOCK_SCOPE;
7403 /* if the condition is a literal array or hash
7404 (or @{ ... } etc), make a reference to it.
7407 S_ref_array_or_hash(pTHX_ OP *cond)
7410 && (cond->op_type == OP_RV2AV
7411 || cond->op_type == OP_PADAV
7412 || cond->op_type == OP_RV2HV
7413 || cond->op_type == OP_PADHV))
7415 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7418 && (cond->op_type == OP_ASLICE
7419 || cond->op_type == OP_KVASLICE
7420 || cond->op_type == OP_HSLICE
7421 || cond->op_type == OP_KVHSLICE)) {
7423 /* anonlist now needs a list from this op, was previously used in
7425 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7426 cond->op_flags |= OPf_WANT_LIST;
7428 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7435 /* These construct the optree fragments representing given()
7438 entergiven and enterwhen are LOGOPs; the op_other pointer
7439 points up to the associated leave op. We need this so we
7440 can put it in the context and make break/continue work.
7441 (Also, of course, pp_enterwhen will jump straight to
7442 op_other if the match fails.)
7446 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7447 I32 enter_opcode, I32 leave_opcode,
7448 PADOFFSET entertarg)
7454 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7455 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7457 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7458 enterop->op_targ = 0;
7459 enterop->op_private = 0;
7461 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7464 /* prepend cond if we have one */
7465 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7467 o->op_next = LINKLIST(cond);
7468 cond->op_next = (OP *) enterop;
7471 /* This is a default {} block */
7472 enterop->op_flags |= OPf_SPECIAL;
7473 o ->op_flags |= OPf_SPECIAL;
7475 o->op_next = (OP *) enterop;
7478 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7479 entergiven and enterwhen both
7482 enterop->op_next = LINKLIST(block);
7483 block->op_next = enterop->op_other = o;
7488 /* Does this look like a boolean operation? For these purposes
7489 a boolean operation is:
7490 - a subroutine call [*]
7491 - a logical connective
7492 - a comparison operator
7493 - a filetest operator, with the exception of -s -M -A -C
7494 - defined(), exists() or eof()
7495 - /$re/ or $foo =~ /$re/
7497 [*] possibly surprising
7500 S_looks_like_bool(pTHX_ const OP *o)
7502 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7504 switch(o->op_type) {
7507 return looks_like_bool(cLOGOPo->op_first);
7511 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7514 looks_like_bool(cLOGOPo->op_first)
7515 && looks_like_bool(sibl));
7521 o->op_flags & OPf_KIDS
7522 && looks_like_bool(cUNOPo->op_first));
7526 case OP_NOT: case OP_XOR:
7528 case OP_EQ: case OP_NE: case OP_LT:
7529 case OP_GT: case OP_LE: case OP_GE:
7531 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7532 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7534 case OP_SEQ: case OP_SNE: case OP_SLT:
7535 case OP_SGT: case OP_SLE: case OP_SGE:
7539 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7540 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7541 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7542 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7543 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7544 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7545 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7546 case OP_FTTEXT: case OP_FTBINARY:
7548 case OP_DEFINED: case OP_EXISTS:
7549 case OP_MATCH: case OP_EOF:
7556 /* Detect comparisons that have been optimized away */
7557 if (cSVOPo->op_sv == &PL_sv_yes
7558 || cSVOPo->op_sv == &PL_sv_no)
7571 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7573 Constructs, checks, and returns an op tree expressing a C<given> block.
7574 C<cond> supplies the expression that will be locally assigned to a lexical
7575 variable, and C<block> supplies the body of the C<given> construct; they
7576 are consumed by this function and become part of the constructed op tree.
7577 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7583 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7585 PERL_ARGS_ASSERT_NEWGIVENOP;
7586 PERL_UNUSED_ARG(defsv_off);
7589 return newGIVWHENOP(
7590 ref_array_or_hash(cond),
7592 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7597 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7599 Constructs, checks, and returns an op tree expressing a C<when> block.
7600 C<cond> supplies the test expression, and C<block> supplies the block
7601 that will be executed if the test evaluates to true; they are consumed
7602 by this function and become part of the constructed op tree. C<cond>
7603 will be interpreted DWIMically, often as a comparison against C<$_>,
7604 and may be null to generate a C<default> block.
7610 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7612 const bool cond_llb = (!cond || looks_like_bool(cond));
7615 PERL_ARGS_ASSERT_NEWWHENOP;
7620 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7622 scalar(ref_array_or_hash(cond)));
7625 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7628 /* must not conflict with SVf_UTF8 */
7629 #define CV_CKPROTO_CURSTASH 0x1
7632 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7633 const STRLEN len, const U32 flags)
7635 SV *name = NULL, *msg;
7636 const char * cvp = SvROK(cv)
7637 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7638 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7641 STRLEN clen = CvPROTOLEN(cv), plen = len;
7643 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7645 if (p == NULL && cvp == NULL)
7648 if (!ckWARN_d(WARN_PROTOTYPE))
7652 p = S_strip_spaces(aTHX_ p, &plen);
7653 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7654 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7655 if (plen == clen && memEQ(cvp, p, plen))
7658 if (flags & SVf_UTF8) {
7659 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7663 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7669 msg = sv_newmortal();
7674 gv_efullname3(name = sv_newmortal(), gv, NULL);
7675 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7676 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7677 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7678 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7679 sv_catpvs(name, "::");
7681 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7682 assert (CvNAMED(SvRV_const(gv)));
7683 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7685 else sv_catsv(name, (SV *)gv);
7687 else name = (SV *)gv;
7689 sv_setpvs(msg, "Prototype mismatch:");
7691 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7693 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7694 UTF8fARG(SvUTF8(cv),clen,cvp)
7697 sv_catpvs(msg, ": none");
7698 sv_catpvs(msg, " vs ");
7700 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7702 sv_catpvs(msg, "none");
7703 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7706 static void const_sv_xsub(pTHX_ CV* cv);
7707 static void const_av_xsub(pTHX_ CV* cv);
7711 =head1 Optree Manipulation Functions
7713 =for apidoc cv_const_sv
7715 If C<cv> is a constant sub eligible for inlining, returns the constant
7716 value returned by the sub. Otherwise, returns C<NULL>.
7718 Constant subs can be created with C<newCONSTSUB> or as described in
7719 L<perlsub/"Constant Functions">.
7724 Perl_cv_const_sv(const CV *const cv)
7729 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7731 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7732 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7737 Perl_cv_const_sv_or_av(const CV * const cv)
7741 if (SvROK(cv)) return SvRV((SV *)cv);
7742 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7743 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7746 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7747 * Can be called in 2 ways:
7750 * look for a single OP_CONST with attached value: return the value
7752 * allow_lex && !CvCONST(cv);
7754 * examine the clone prototype, and if contains only a single
7755 * OP_CONST, return the value; or if it contains a single PADSV ref-
7756 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7757 * a candidate for "constizing" at clone time, and return NULL.
7761 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7769 for (; o; o = o->op_next) {
7770 const OPCODE type = o->op_type;
7772 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7774 || type == OP_PUSHMARK)
7776 if (type == OP_DBSTATE)
7778 if (type == OP_LEAVESUB)
7782 if (type == OP_CONST && cSVOPo->op_sv)
7784 else if (type == OP_UNDEF && !o->op_private) {
7788 else if (allow_lex && type == OP_PADSV) {
7789 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7791 sv = &PL_sv_undef; /* an arbitrary non-null value */
7809 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7810 PADNAME * const name, SV ** const const_svp)
7817 if (CvFLAGS(PL_compcv)) {
7818 /* might have had built-in attrs applied */
7819 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7820 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7821 && ckWARN(WARN_MISC))
7823 /* protect against fatal warnings leaking compcv */
7824 SAVEFREESV(PL_compcv);
7825 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7826 SvREFCNT_inc_simple_void_NN(PL_compcv);
7829 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7830 & ~(CVf_LVALUE * pureperl));
7835 /* redundant check for speed: */
7836 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7837 const line_t oldline = CopLINE(PL_curcop);
7840 : sv_2mortal(newSVpvn_utf8(
7841 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7843 if (PL_parser && PL_parser->copline != NOLINE)
7844 /* This ensures that warnings are reported at the first
7845 line of a redefinition, not the last. */
7846 CopLINE_set(PL_curcop, PL_parser->copline);
7847 /* protect against fatal warnings leaking compcv */
7848 SAVEFREESV(PL_compcv);
7849 report_redefined_cv(namesv, cv, const_svp);
7850 SvREFCNT_inc_simple_void_NN(PL_compcv);
7851 CopLINE_set(PL_curcop, oldline);
7858 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7863 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7866 CV *compcv = PL_compcv;
7869 PADOFFSET pax = o->op_targ;
7870 CV *outcv = CvOUTSIDE(PL_compcv);
7873 bool reusable = FALSE;
7875 #ifdef PERL_DEBUG_READONLY_OPS
7876 OPSLAB *slab = NULL;
7879 PERL_ARGS_ASSERT_NEWMYSUB;
7881 /* Find the pad slot for storing the new sub.
7882 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7883 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7884 ing sub. And then we need to dig deeper if this is a lexical from
7886 my sub foo; sub { sub foo { } }
7889 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7890 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7891 pax = PARENT_PAD_INDEX(name);
7892 outcv = CvOUTSIDE(outcv);
7897 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7898 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7899 spot = (CV **)svspot;
7901 if (!(PL_parser && PL_parser->error_count))
7902 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
7905 assert(proto->op_type == OP_CONST);
7906 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7907 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7917 if (PL_parser && PL_parser->error_count) {
7919 SvREFCNT_dec(PL_compcv);
7924 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7926 svspot = (SV **)(spot = &clonee);
7928 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7931 assert (SvTYPE(*spot) == SVt_PVCV);
7933 hek = CvNAME_HEK(*spot);
7937 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7938 CvNAME_HEK_set(*spot, hek =
7941 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
7945 CvLEXICAL_on(*spot);
7947 cv = PadnamePROTOCV(name);
7948 svspot = (SV **)(spot = &PadnamePROTOCV(name));
7952 /* This makes sub {}; work as expected. */
7953 if (block->op_type == OP_STUB) {
7954 const line_t l = PL_parser->copline;
7956 block = newSTATEOP(0, NULL, 0);
7957 PL_parser->copline = l;
7959 block = CvLVALUE(compcv)
7960 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
7961 ? newUNOP(OP_LEAVESUBLV, 0,
7962 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7963 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7964 start = LINKLIST(block);
7966 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
7967 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
7975 const bool exists = CvROOT(cv) || CvXSUB(cv);
7977 /* if the subroutine doesn't exist and wasn't pre-declared
7978 * with a prototype, assume it will be AUTOLOADed,
7979 * skipping the prototype check
7981 if (exists || SvPOK(cv))
7982 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
7984 /* already defined? */
7986 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
7989 if (attrs) goto attrs;
7990 /* just a "sub foo;" when &foo is already defined */
7995 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8001 SvREFCNT_inc_simple_void_NN(const_sv);
8002 SvFLAGS(const_sv) |= SVs_PADTMP;
8004 assert(!CvROOT(cv) && !CvCONST(cv));
8008 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8009 CvFILE_set_from_cop(cv, PL_curcop);
8010 CvSTASH_set(cv, PL_curstash);
8013 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8014 CvXSUBANY(cv).any_ptr = const_sv;
8015 CvXSUB(cv) = const_sv_xsub;
8019 CvFLAGS(cv) |= CvMETHOD(compcv);
8021 SvREFCNT_dec(compcv);
8025 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8026 determine whether this sub definition is in the same scope as its
8027 declaration. If this sub definition is inside an inner named pack-
8028 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8029 the package sub. So check PadnameOUTER(name) too.
8031 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8032 assert(!CvWEAKOUTSIDE(compcv));
8033 SvREFCNT_dec(CvOUTSIDE(compcv));
8034 CvWEAKOUTSIDE_on(compcv);
8036 /* XXX else do we have a circular reference? */
8037 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8038 /* transfer PL_compcv to cv */
8041 cv_flags_t preserved_flags =
8042 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8043 PADLIST *const temp_padl = CvPADLIST(cv);
8044 CV *const temp_cv = CvOUTSIDE(cv);
8045 const cv_flags_t other_flags =
8046 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8047 OP * const cvstart = CvSTART(cv);
8051 CvFLAGS(compcv) | preserved_flags;
8052 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8053 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8054 CvPADLIST_set(cv, CvPADLIST(compcv));
8055 CvOUTSIDE(compcv) = temp_cv;
8056 CvPADLIST_set(compcv, temp_padl);
8057 CvSTART(cv) = CvSTART(compcv);
8058 CvSTART(compcv) = cvstart;
8059 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8060 CvFLAGS(compcv) |= other_flags;
8062 if (CvFILE(cv) && CvDYNFILE(cv)) {
8063 Safefree(CvFILE(cv));
8066 /* inner references to compcv must be fixed up ... */
8067 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8068 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8069 ++PL_sub_generation;
8072 /* Might have had built-in attributes applied -- propagate them. */
8073 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8075 /* ... before we throw it away */
8076 SvREFCNT_dec(compcv);
8077 PL_compcv = compcv = cv;
8085 if (!CvNAME_HEK(cv)) {
8086 if (hek) (void)share_hek_hek(hek);
8090 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8091 hek = share_hek(PadnamePV(name)+1,
8092 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8095 CvNAME_HEK_set(cv, hek);
8097 if (const_sv) goto clone;
8099 CvFILE_set_from_cop(cv, PL_curcop);
8100 CvSTASH_set(cv, PL_curstash);
8103 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8104 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8110 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8111 the debugger could be able to set a breakpoint in, so signal to
8112 pp_entereval that it should not throw away any saved lines at scope
8115 PL_breakable_sub_gen++;
8117 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8118 OpREFCNT_set(CvROOT(cv), 1);
8119 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8120 itself has a refcount. */
8122 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8123 #ifdef PERL_DEBUG_READONLY_OPS
8124 slab = (OPSLAB *)CvSTART(cv);
8126 CvSTART(cv) = start;
8128 finalize_optree(CvROOT(cv));
8129 S_prune_chain_head(&CvSTART(cv));
8131 /* now that optimizer has done its work, adjust pad values */
8133 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8137 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8138 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8142 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8143 SV * const tmpstr = sv_newmortal();
8144 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8145 GV_ADDMULTI, SVt_PVHV);
8147 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8150 (long)CopLINE(PL_curcop));
8151 if (HvNAME_HEK(PL_curstash)) {
8152 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8153 sv_catpvs(tmpstr, "::");
8155 else sv_setpvs(tmpstr, "__ANON__::");
8156 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8157 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8158 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8159 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8160 hv = GvHVn(db_postponed);
8161 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8162 CV * const pcv = GvCV(db_postponed);
8168 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8176 assert(CvDEPTH(outcv));
8178 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8179 if (reusable) cv_clone_into(clonee, *spot);
8180 else *spot = cv_clone(clonee);
8181 SvREFCNT_dec_NN(clonee);
8184 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8185 PADOFFSET depth = CvDEPTH(outcv);
8188 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8190 *svspot = SvREFCNT_inc_simple_NN(cv);
8191 SvREFCNT_dec(oldcv);
8197 PL_parser->copline = NOLINE;
8199 #ifdef PERL_DEBUG_READONLY_OPS
8209 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8210 OP *block, bool o_is_gv)
8214 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8218 const bool ec = PL_parser && PL_parser->error_count;
8219 /* If the subroutine has no body, no attributes, and no builtin attributes
8220 then it's just a sub declaration, and we may be able to get away with
8221 storing with a placeholder scalar in the symbol table, rather than a
8222 full CV. If anything is present then it will take a full CV to
8224 const I32 gv_fetch_flags
8225 = ec ? GV_NOADD_NOINIT :
8226 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8227 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8229 const char * const name =
8230 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8232 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8233 bool evanescent = FALSE;
8235 #ifdef PERL_DEBUG_READONLY_OPS
8236 OPSLAB *slab = NULL;
8244 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8245 hek and CvSTASH pointer together can imply the GV. If the name
8246 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8247 CvSTASH, so forego the optimisation if we find any.
8248 Also, we may be called from load_module at run time, so
8249 PL_curstash (which sets CvSTASH) may not point to the stash the
8250 sub is stored in. */
8252 ec ? GV_NOADD_NOINIT
8253 : PL_curstash != CopSTASH(PL_curcop)
8254 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8256 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8257 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8259 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8260 SV * const sv = sv_newmortal();
8261 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8262 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8263 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8264 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8266 } else if (PL_curstash) {
8267 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8270 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8275 move_proto_attr(&proto, &attrs, gv);
8278 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8283 assert(proto->op_type == OP_CONST);
8284 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8285 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8299 if (name) SvREFCNT_dec(PL_compcv);
8300 else cv = PL_compcv;
8302 if (name && block) {
8303 const char *s = strrchr(name, ':');
8305 if (strEQ(s, "BEGIN")) {
8306 if (PL_in_eval & EVAL_KEEPERR)
8307 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8309 SV * const errsv = ERRSV;
8310 /* force display of errors found but not reported */
8311 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8312 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8319 if (!block && SvTYPE(gv) != SVt_PVGV) {
8320 /* If we are not defining a new sub and the existing one is not a
8322 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8323 /* We are applying attributes to an existing sub, so we need it
8324 upgraded if it is a constant. */
8325 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8326 gv_init_pvn(gv, PL_curstash, name, namlen,
8327 SVf_UTF8 * name_is_utf8);
8329 else { /* Maybe prototype now, and had at maximum
8330 a prototype or const/sub ref before. */
8331 if (SvTYPE(gv) > SVt_NULL) {
8332 cv_ckproto_len_flags((const CV *)gv,
8333 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8338 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8339 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8342 sv_setiv(MUTABLE_SV(gv), -1);
8345 SvREFCNT_dec(PL_compcv);
8346 cv = PL_compcv = NULL;
8351 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8355 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8360 /* This makes sub {}; work as expected. */
8361 if (block->op_type == OP_STUB) {
8362 const line_t l = PL_parser->copline;
8364 block = newSTATEOP(0, NULL, 0);
8365 PL_parser->copline = l;
8367 block = CvLVALUE(PL_compcv)
8368 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8369 && (!isGV(gv) || !GvASSUMECV(gv)))
8370 ? newUNOP(OP_LEAVESUBLV, 0,
8371 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8372 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8373 start = LINKLIST(block);
8375 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8377 S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
8384 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8386 cv_ckproto_len_flags((const CV *)gv,
8387 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8388 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8390 /* All the other code for sub redefinition warnings expects the
8391 clobbered sub to be a CV. Instead of making all those code
8392 paths more complex, just inline the RV version here. */
8393 const line_t oldline = CopLINE(PL_curcop);
8394 assert(IN_PERL_COMPILETIME);
8395 if (PL_parser && PL_parser->copline != NOLINE)
8396 /* This ensures that warnings are reported at the first
8397 line of a redefinition, not the last. */
8398 CopLINE_set(PL_curcop, PL_parser->copline);
8399 /* protect against fatal warnings leaking compcv */
8400 SAVEFREESV(PL_compcv);
8402 if (ckWARN(WARN_REDEFINE)
8403 || ( ckWARN_d(WARN_REDEFINE)
8404 && ( !const_sv || SvRV(gv) == const_sv
8405 || sv_cmp(SvRV(gv), const_sv) )))
8406 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8407 "Constant subroutine %"SVf" redefined",
8408 SVfARG(cSVOPo->op_sv));
8410 SvREFCNT_inc_simple_void_NN(PL_compcv);
8411 CopLINE_set(PL_curcop, oldline);
8412 SvREFCNT_dec(SvRV(gv));
8417 const bool exists = CvROOT(cv) || CvXSUB(cv);
8419 /* if the subroutine doesn't exist and wasn't pre-declared
8420 * with a prototype, assume it will be AUTOLOADed,
8421 * skipping the prototype check
8423 if (exists || SvPOK(cv))
8424 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8425 /* already defined (or promised)? */
8426 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8427 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8430 if (attrs) goto attrs;
8431 /* just a "sub foo;" when &foo is already defined */
8432 SAVEFREESV(PL_compcv);
8438 SvREFCNT_inc_simple_void_NN(const_sv);
8439 SvFLAGS(const_sv) |= SVs_PADTMP;
8441 assert(!CvROOT(cv) && !CvCONST(cv));
8443 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8444 CvXSUBANY(cv).any_ptr = const_sv;
8445 CvXSUB(cv) = const_sv_xsub;
8449 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8452 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8453 if (name && isGV(gv))
8455 cv = newCONSTSUB_flags(
8456 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8459 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8463 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8464 prepare_SV_for_RV((SV *)gv);
8468 SvRV_set(gv, const_sv);
8472 SvREFCNT_dec(PL_compcv);
8476 if (cv) { /* must reuse cv if autoloaded */
8477 /* transfer PL_compcv to cv */
8480 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8481 PADLIST *const temp_av = CvPADLIST(cv);
8482 CV *const temp_cv = CvOUTSIDE(cv);
8483 const cv_flags_t other_flags =
8484 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8485 OP * const cvstart = CvSTART(cv);
8489 assert(!CvCVGV_RC(cv));
8490 assert(CvGV(cv) == gv);
8495 PERL_HASH(hash, name, namlen);
8505 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8507 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8508 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8509 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8510 CvOUTSIDE(PL_compcv) = temp_cv;
8511 CvPADLIST_set(PL_compcv, temp_av);
8512 CvSTART(cv) = CvSTART(PL_compcv);
8513 CvSTART(PL_compcv) = cvstart;
8514 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8515 CvFLAGS(PL_compcv) |= other_flags;
8517 if (CvFILE(cv) && CvDYNFILE(cv)) {
8518 Safefree(CvFILE(cv));
8520 CvFILE_set_from_cop(cv, PL_curcop);
8521 CvSTASH_set(cv, PL_curstash);
8523 /* inner references to PL_compcv must be fixed up ... */
8524 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8525 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8526 ++PL_sub_generation;
8529 /* Might have had built-in attributes applied -- propagate them. */
8530 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8532 /* ... before we throw it away */
8533 SvREFCNT_dec(PL_compcv);
8538 if (name && isGV(gv)) {
8541 if (HvENAME_HEK(GvSTASH(gv)))
8542 /* sub Foo::bar { (shift)+1 } */
8543 gv_method_changed(gv);
8547 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8548 prepare_SV_for_RV((SV *)gv);
8552 SvRV_set(gv, (SV *)cv);
8556 if (isGV(gv)) CvGV_set(cv, gv);
8560 PERL_HASH(hash, name, namlen);
8561 CvNAME_HEK_set(cv, share_hek(name,
8567 CvFILE_set_from_cop(cv, PL_curcop);
8568 CvSTASH_set(cv, PL_curstash);
8572 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8573 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8579 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8580 the debugger could be able to set a breakpoint in, so signal to
8581 pp_entereval that it should not throw away any saved lines at scope
8584 PL_breakable_sub_gen++;
8586 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8587 OpREFCNT_set(CvROOT(cv), 1);
8588 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8589 itself has a refcount. */
8591 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8592 #ifdef PERL_DEBUG_READONLY_OPS
8593 slab = (OPSLAB *)CvSTART(cv);
8595 CvSTART(cv) = start;
8597 finalize_optree(CvROOT(cv));
8598 S_prune_chain_head(&CvSTART(cv));
8600 /* now that optimizer has done its work, adjust pad values */
8602 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8606 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8607 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8610 if (!name) SAVEFREESV(cv);
8611 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8612 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8615 if (block && has_name) {
8616 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8617 SV * const tmpstr = cv_name(cv,NULL,0);
8618 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8619 GV_ADDMULTI, SVt_PVHV);
8621 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8624 (long)CopLINE(PL_curcop));
8625 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8626 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8627 hv = GvHVn(db_postponed);
8628 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8629 CV * const pcv = GvCV(db_postponed);
8635 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8641 if (PL_parser && PL_parser->error_count)
8642 clear_special_blocks(name, gv, cv);
8645 process_special_blocks(floor, name, gv, cv);
8651 PL_parser->copline = NOLINE;
8654 #ifdef PERL_DEBUG_READONLY_OPS
8658 if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8659 pad_add_weakref(cv);
8665 S_clear_special_blocks(pTHX_ const char *const fullname,
8666 GV *const gv, CV *const cv) {
8670 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8672 colon = strrchr(fullname,':');
8673 name = colon ? colon + 1 : fullname;
8675 if ((*name == 'B' && strEQ(name, "BEGIN"))
8676 || (*name == 'E' && strEQ(name, "END"))
8677 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8678 || (*name == 'C' && strEQ(name, "CHECK"))
8679 || (*name == 'I' && strEQ(name, "INIT"))) {
8685 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8689 /* Returns true if the sub has been freed. */
8691 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8695 const char *const colon = strrchr(fullname,':');
8696 const char *const name = colon ? colon + 1 : fullname;
8698 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8701 if (strEQ(name, "BEGIN")) {
8702 const I32 oldscope = PL_scopestack_ix;
8705 if (floor) LEAVE_SCOPE(floor);
8707 PUSHSTACKi(PERLSI_REQUIRE);
8708 SAVECOPFILE(&PL_compiling);
8709 SAVECOPLINE(&PL_compiling);
8710 SAVEVPTR(PL_curcop);
8712 DEBUG_x( dump_sub(gv) );
8713 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8714 GvCV_set(gv,0); /* cv has been hijacked */
8715 call_list(oldscope, PL_beginav);
8719 return !PL_savebegin;
8725 if strEQ(name, "END") {
8726 DEBUG_x( dump_sub(gv) );
8727 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8730 } else if (*name == 'U') {
8731 if (strEQ(name, "UNITCHECK")) {
8732 /* It's never too late to run a unitcheck block */
8733 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8737 } else if (*name == 'C') {
8738 if (strEQ(name, "CHECK")) {
8740 /* diag_listed_as: Too late to run %s block */
8741 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8742 "Too late to run CHECK block");
8743 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8747 } else if (*name == 'I') {
8748 if (strEQ(name, "INIT")) {
8750 /* diag_listed_as: Too late to run %s block */
8751 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8752 "Too late to run INIT block");
8753 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8759 DEBUG_x( dump_sub(gv) );
8761 GvCV_set(gv,0); /* cv has been hijacked */
8767 =for apidoc newCONSTSUB
8769 See L</newCONSTSUB_flags>.
8775 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8777 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8781 =for apidoc newCONSTSUB_flags
8783 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
8784 eligible for inlining at compile-time.
8786 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
8788 The newly created subroutine takes ownership of a reference to the passed in
8791 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
8792 which won't be called if used as a destructor, but will suppress the overhead
8793 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8800 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8804 const char *const file = CopFILE(PL_curcop);
8808 if (IN_PERL_RUNTIME) {
8809 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8810 * an op shared between threads. Use a non-shared COP for our
8812 SAVEVPTR(PL_curcop);
8813 SAVECOMPILEWARNINGS();
8814 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8815 PL_curcop = &PL_compiling;
8817 SAVECOPLINE(PL_curcop);
8818 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8821 PL_hints &= ~HINT_BLOCK_SCOPE;
8824 SAVEGENERICSV(PL_curstash);
8825 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8828 /* Protect sv against leakage caused by fatal warnings. */
8829 if (sv) SAVEFREESV(sv);
8831 /* file becomes the CvFILE. For an XS, it's usually static storage,
8832 and so doesn't get free()d. (It's expected to be from the C pre-
8833 processor __FILE__ directive). But we need a dynamically allocated one,
8834 and we need it to get freed. */
8835 cv = newXS_len_flags(name, len,
8836 sv && SvTYPE(sv) == SVt_PVAV
8839 file ? file : "", "",
8840 &sv, XS_DYNAMIC_FILENAME | flags);
8841 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8850 =for apidoc U||newXS
8852 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
8853 static storage, as it is used directly as CvFILE(), without a copy being made.
8859 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8861 PERL_ARGS_ASSERT_NEWXS;
8862 return newXS_len_flags(
8863 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8868 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8869 const char *const filename, const char *const proto,
8872 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8873 return newXS_len_flags(
8874 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8879 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
8881 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
8882 return newXS_len_flags(
8883 name, strlen(name), subaddr, NULL, NULL, NULL, 0
8888 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8889 XSUBADDR_t subaddr, const char *const filename,
8890 const char *const proto, SV **const_svp,
8894 bool interleave = FALSE;
8896 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8899 GV * const gv = gv_fetchpvn(
8900 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8901 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8902 sizeof("__ANON__::__ANON__") - 1,
8903 GV_ADDMULTI | flags, SVt_PVCV);
8905 if ((cv = (name ? GvCV(gv) : NULL))) {
8907 /* just a cached method */
8911 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8912 /* already defined (or promised) */
8913 /* Redundant check that allows us to avoid creating an SV
8914 most of the time: */
8915 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8916 report_redefined_cv(newSVpvn_flags(
8917 name,len,(flags&SVf_UTF8)|SVs_TEMP
8928 if (cv) /* must reuse cv if autoloaded */
8931 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8935 if (HvENAME_HEK(GvSTASH(gv)))
8936 gv_method_changed(gv); /* newXS */
8942 /* XSUBs can't be perl lang/perl5db.pl debugged
8943 if (PERLDB_LINE_OR_SAVESRC)
8944 (void)gv_fetchfile(filename); */
8945 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8946 if (flags & XS_DYNAMIC_FILENAME) {
8948 CvFILE(cv) = savepv(filename);
8950 /* NOTE: not copied, as it is expected to be an external constant string */
8951 CvFILE(cv) = (char *)filename;
8954 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
8955 CvFILE(cv) = (char*)PL_xsubfilename;
8958 CvXSUB(cv) = subaddr;
8959 #ifndef PERL_IMPLICIT_CONTEXT
8960 CvHSCXT(cv) = &PL_stack_sp;
8966 process_special_blocks(0, name, gv, cv);
8969 } /* <- not a conditional branch */
8972 sv_setpv(MUTABLE_SV(cv), proto);
8973 if (interleave) LEAVE;
8978 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8980 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8982 PERL_ARGS_ASSERT_NEWSTUB;
8986 if (!fake && HvENAME_HEK(GvSTASH(gv)))
8987 gv_method_changed(gv);
8989 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8994 CvFILE_set_from_cop(cv, PL_curcop);
8995 CvSTASH_set(cv, PL_curstash);
9001 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9007 if (PL_parser && PL_parser->error_count) {
9013 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9014 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9017 if ((cv = GvFORM(gv))) {
9018 if (ckWARN(WARN_REDEFINE)) {
9019 const line_t oldline = CopLINE(PL_curcop);
9020 if (PL_parser && PL_parser->copline != NOLINE)
9021 CopLINE_set(PL_curcop, PL_parser->copline);
9023 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9024 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9026 /* diag_listed_as: Format %s redefined */
9027 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9028 "Format STDOUT redefined");
9030 CopLINE_set(PL_curcop, oldline);
9035 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9037 CvFILE_set_from_cop(cv, PL_curcop);
9040 pad_tidy(padtidy_FORMAT);
9041 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9042 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9043 OpREFCNT_set(CvROOT(cv), 1);
9044 CvSTART(cv) = LINKLIST(CvROOT(cv));
9045 CvROOT(cv)->op_next = 0;
9046 CALL_PEEP(CvSTART(cv));
9047 finalize_optree(CvROOT(cv));
9048 S_prune_chain_head(&CvSTART(cv));
9054 PL_parser->copline = NOLINE;
9056 PL_compiling.cop_seq = 0;
9060 Perl_newANONLIST(pTHX_ OP *o)
9062 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9066 Perl_newANONHASH(pTHX_ OP *o)
9068 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9072 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9074 return newANONATTRSUB(floor, proto, NULL, block);
9078 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9080 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9082 newSVOP(OP_ANONCODE, 0,
9084 if (CvANONCONST(cv))
9085 anoncode = newUNOP(OP_ANONCONST, 0,
9086 op_convert_list(OP_ENTERSUB,
9087 OPf_STACKED|OPf_WANT_SCALAR,
9089 return newUNOP(OP_REFGEN, 0, anoncode);
9093 Perl_oopsAV(pTHX_ OP *o)
9097 PERL_ARGS_ASSERT_OOPSAV;
9099 switch (o->op_type) {
9102 OpTYPE_set(o, OP_PADAV);
9103 return ref(o, OP_RV2AV);
9107 OpTYPE_set(o, OP_RV2AV);
9112 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9119 Perl_oopsHV(pTHX_ OP *o)
9123 PERL_ARGS_ASSERT_OOPSHV;
9125 switch (o->op_type) {
9128 OpTYPE_set(o, OP_PADHV);
9129 return ref(o, OP_RV2HV);
9133 OpTYPE_set(o, OP_RV2HV);
9138 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9145 Perl_newAVREF(pTHX_ OP *o)
9149 PERL_ARGS_ASSERT_NEWAVREF;
9151 if (o->op_type == OP_PADANY) {
9152 OpTYPE_set(o, OP_PADAV);
9155 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9156 Perl_croak(aTHX_ "Can't use an array as a reference");
9158 return newUNOP(OP_RV2AV, 0, scalar(o));
9162 Perl_newGVREF(pTHX_ I32 type, OP *o)
9164 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9165 return newUNOP(OP_NULL, 0, o);
9166 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9170 Perl_newHVREF(pTHX_ OP *o)
9174 PERL_ARGS_ASSERT_NEWHVREF;
9176 if (o->op_type == OP_PADANY) {
9177 OpTYPE_set(o, OP_PADHV);
9180 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9181 Perl_croak(aTHX_ "Can't use a hash as a reference");
9183 return newUNOP(OP_RV2HV, 0, scalar(o));
9187 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9189 if (o->op_type == OP_PADANY) {
9191 OpTYPE_set(o, OP_PADCV);
9193 return newUNOP(OP_RV2CV, flags, scalar(o));
9197 Perl_newSVREF(pTHX_ OP *o)
9201 PERL_ARGS_ASSERT_NEWSVREF;
9203 if (o->op_type == OP_PADANY) {
9204 OpTYPE_set(o, OP_PADSV);
9208 return newUNOP(OP_RV2SV, 0, scalar(o));
9211 /* Check routines. See the comments at the top of this file for details
9212 * on when these are called */
9215 Perl_ck_anoncode(pTHX_ OP *o)
9217 PERL_ARGS_ASSERT_CK_ANONCODE;
9219 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9220 cSVOPo->op_sv = NULL;
9225 S_io_hints(pTHX_ OP *o)
9227 #if O_BINARY != 0 || O_TEXT != 0
9229 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9231 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9234 const char *d = SvPV_const(*svp, len);
9235 const I32 mode = mode_from_discipline(d, len);
9236 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9238 if (mode & O_BINARY)
9239 o->op_private |= OPpOPEN_IN_RAW;
9243 o->op_private |= OPpOPEN_IN_CRLF;
9247 svp = hv_fetchs(table, "open_OUT", FALSE);
9250 const char *d = SvPV_const(*svp, len);
9251 const I32 mode = mode_from_discipline(d, len);
9252 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9254 if (mode & O_BINARY)
9255 o->op_private |= OPpOPEN_OUT_RAW;
9259 o->op_private |= OPpOPEN_OUT_CRLF;
9264 PERL_UNUSED_CONTEXT;
9270 Perl_ck_backtick(pTHX_ OP *o)
9275 PERL_ARGS_ASSERT_CK_BACKTICK;
9276 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9277 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9278 && (gv = gv_override("readpipe",8)))
9280 /* detach rest of siblings from o and its first child */
9281 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9282 newop = S_new_entersubop(aTHX_ gv, sibl);
9284 else if (!(o->op_flags & OPf_KIDS))
9285 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9290 S_io_hints(aTHX_ o);
9295 Perl_ck_bitop(pTHX_ OP *o)
9297 PERL_ARGS_ASSERT_CK_BITOP;
9299 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9301 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9302 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9303 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9304 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9305 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9306 "The bitwise feature is experimental");
9307 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9308 && OP_IS_INFIX_BIT(o->op_type))
9310 const OP * const left = cBINOPo->op_first;
9311 const OP * const right = OpSIBLING(left);
9312 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9313 (left->op_flags & OPf_PARENS) == 0) ||
9314 (OP_IS_NUMCOMPARE(right->op_type) &&
9315 (right->op_flags & OPf_PARENS) == 0))
9316 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9317 "Possible precedence problem on bitwise %s operator",
9318 o->op_type == OP_BIT_OR
9319 ||o->op_type == OP_NBIT_OR ? "|"
9320 : o->op_type == OP_BIT_AND
9321 ||o->op_type == OP_NBIT_AND ? "&"
9322 : o->op_type == OP_BIT_XOR
9323 ||o->op_type == OP_NBIT_XOR ? "^"
9324 : o->op_type == OP_SBIT_OR ? "|."
9325 : o->op_type == OP_SBIT_AND ? "&." : "^."
9331 PERL_STATIC_INLINE bool
9332 is_dollar_bracket(pTHX_ const OP * const o)
9335 PERL_UNUSED_CONTEXT;
9336 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9337 && (kid = cUNOPx(o)->op_first)
9338 && kid->op_type == OP_GV
9339 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9343 Perl_ck_cmp(pTHX_ OP *o)
9345 PERL_ARGS_ASSERT_CK_CMP;
9346 if (ckWARN(WARN_SYNTAX)) {
9347 const OP *kid = cUNOPo->op_first;
9350 ( is_dollar_bracket(aTHX_ kid)
9351 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9353 || ( kid->op_type == OP_CONST
9354 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9358 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9359 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9365 Perl_ck_concat(pTHX_ OP *o)
9367 const OP * const kid = cUNOPo->op_first;
9369 PERL_ARGS_ASSERT_CK_CONCAT;
9370 PERL_UNUSED_CONTEXT;
9372 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9373 !(kUNOP->op_first->op_flags & OPf_MOD))
9374 o->op_flags |= OPf_STACKED;
9379 Perl_ck_spair(pTHX_ OP *o)
9383 PERL_ARGS_ASSERT_CK_SPAIR;
9385 if (o->op_flags & OPf_KIDS) {
9389 const OPCODE type = o->op_type;
9390 o = modkids(ck_fun(o), type);
9391 kid = cUNOPo->op_first;
9392 kidkid = kUNOP->op_first;
9393 newop = OpSIBLING(kidkid);
9395 const OPCODE type = newop->op_type;
9396 if (OpHAS_SIBLING(newop))
9398 if (o->op_type == OP_REFGEN
9399 && ( type == OP_RV2CV
9400 || ( !(newop->op_flags & OPf_PARENS)
9401 && ( type == OP_RV2AV || type == OP_PADAV
9402 || type == OP_RV2HV || type == OP_PADHV))))
9403 NOOP; /* OK (allow srefgen for \@a and \%h) */
9404 else if (OP_GIMME(newop,0) != G_SCALAR)
9407 /* excise first sibling */
9408 op_sibling_splice(kid, NULL, 1, NULL);
9411 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9412 * and OP_CHOMP into OP_SCHOMP */
9413 o->op_ppaddr = PL_ppaddr[++o->op_type];
9418 Perl_ck_delete(pTHX_ OP *o)
9420 PERL_ARGS_ASSERT_CK_DELETE;
9424 if (o->op_flags & OPf_KIDS) {
9425 OP * const kid = cUNOPo->op_first;
9426 switch (kid->op_type) {
9428 o->op_flags |= OPf_SPECIAL;
9431 o->op_private |= OPpSLICE;
9434 o->op_flags |= OPf_SPECIAL;
9439 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9440 " use array slice");
9442 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9445 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9446 "element or slice");
9448 if (kid->op_private & OPpLVAL_INTRO)
9449 o->op_private |= OPpLVAL_INTRO;
9456 Perl_ck_eof(pTHX_ OP *o)
9458 PERL_ARGS_ASSERT_CK_EOF;
9460 if (o->op_flags & OPf_KIDS) {
9462 if (cLISTOPo->op_first->op_type == OP_STUB) {
9464 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9469 kid = cLISTOPo->op_first;
9470 if (kid->op_type == OP_RV2GV)
9471 kid->op_private |= OPpALLOW_FAKE;
9477 Perl_ck_eval(pTHX_ OP *o)
9481 PERL_ARGS_ASSERT_CK_EVAL;
9483 PL_hints |= HINT_BLOCK_SCOPE;
9484 if (o->op_flags & OPf_KIDS) {
9485 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9488 if (o->op_type == OP_ENTERTRY) {
9491 /* cut whole sibling chain free from o */
9492 op_sibling_splice(o, NULL, -1, NULL);
9495 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9497 /* establish postfix order */
9498 enter->op_next = (OP*)enter;
9500 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9501 OpTYPE_set(o, OP_LEAVETRY);
9502 enter->op_other = o;
9507 S_set_haseval(aTHX);
9511 const U8 priv = o->op_private;
9513 /* the newUNOP will recursively call ck_eval(), which will handle
9514 * all the stuff at the end of this function, like adding
9517 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9519 o->op_targ = (PADOFFSET)PL_hints;
9520 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9521 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9522 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9523 /* Store a copy of %^H that pp_entereval can pick up. */
9524 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9525 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9526 /* append hhop to only child */
9527 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9529 o->op_private |= OPpEVAL_HAS_HH;
9531 if (!(o->op_private & OPpEVAL_BYTES)
9532 && FEATURE_UNIEVAL_IS_ENABLED)
9533 o->op_private |= OPpEVAL_UNICODE;
9538 Perl_ck_exec(pTHX_ OP *o)
9540 PERL_ARGS_ASSERT_CK_EXEC;
9542 if (o->op_flags & OPf_STACKED) {
9545 kid = OpSIBLING(cUNOPo->op_first);
9546 if (kid->op_type == OP_RV2GV)
9555 Perl_ck_exists(pTHX_ OP *o)
9557 PERL_ARGS_ASSERT_CK_EXISTS;
9560 if (o->op_flags & OPf_KIDS) {
9561 OP * const kid = cUNOPo->op_first;
9562 if (kid->op_type == OP_ENTERSUB) {
9563 (void) ref(kid, o->op_type);
9564 if (kid->op_type != OP_RV2CV
9565 && !(PL_parser && PL_parser->error_count))
9567 "exists argument is not a subroutine name");
9568 o->op_private |= OPpEXISTS_SUB;
9570 else if (kid->op_type == OP_AELEM)
9571 o->op_flags |= OPf_SPECIAL;
9572 else if (kid->op_type != OP_HELEM)
9573 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9574 "element or a subroutine");
9581 Perl_ck_rvconst(pTHX_ OP *o)
9584 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9586 PERL_ARGS_ASSERT_CK_RVCONST;
9588 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9590 if (kid->op_type == OP_CONST) {
9593 SV * const kidsv = kid->op_sv;
9595 /* Is it a constant from cv_const_sv()? */
9596 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9599 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9600 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9601 const char *badthing;
9602 switch (o->op_type) {
9604 badthing = "a SCALAR";
9607 badthing = "an ARRAY";
9610 badthing = "a HASH";
9618 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9619 SVfARG(kidsv), badthing);
9622 * This is a little tricky. We only want to add the symbol if we
9623 * didn't add it in the lexer. Otherwise we get duplicate strict
9624 * warnings. But if we didn't add it in the lexer, we must at
9625 * least pretend like we wanted to add it even if it existed before,
9626 * or we get possible typo warnings. OPpCONST_ENTERED says
9627 * whether the lexer already added THIS instance of this symbol.
9629 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9630 gv = gv_fetchsv(kidsv,
9631 o->op_type == OP_RV2CV
9632 && o->op_private & OPpMAY_RETURN_CONSTANT
9634 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9637 : o->op_type == OP_RV2SV
9639 : o->op_type == OP_RV2AV
9641 : o->op_type == OP_RV2HV
9648 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9649 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9650 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9652 OpTYPE_set(kid, OP_GV);
9653 SvREFCNT_dec(kid->op_sv);
9655 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9656 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9657 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9658 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9659 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9661 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9663 kid->op_private = 0;
9664 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9672 Perl_ck_ftst(pTHX_ OP *o)
9675 const I32 type = o->op_type;
9677 PERL_ARGS_ASSERT_CK_FTST;
9679 if (o->op_flags & OPf_REF) {
9682 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9683 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9684 const OPCODE kidtype = kid->op_type;
9686 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9687 && !kid->op_folded) {
9688 OP * const newop = newGVOP(type, OPf_REF,
9689 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9694 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9695 o->op_private |= OPpFT_ACCESS;
9696 if (type != OP_STAT && type != OP_LSTAT
9697 && PL_check[kidtype] == Perl_ck_ftst
9698 && kidtype != OP_STAT && kidtype != OP_LSTAT
9700 o->op_private |= OPpFT_STACKED;
9701 kid->op_private |= OPpFT_STACKING;
9702 if (kidtype == OP_FTTTY && (
9703 !(kid->op_private & OPpFT_STACKED)
9704 || kid->op_private & OPpFT_AFTER_t
9706 o->op_private |= OPpFT_AFTER_t;
9711 if (type == OP_FTTTY)
9712 o = newGVOP(type, OPf_REF, PL_stdingv);
9714 o = newUNOP(type, 0, newDEFSVOP());
9720 Perl_ck_fun(pTHX_ OP *o)
9722 const int type = o->op_type;
9723 I32 oa = PL_opargs[type] >> OASHIFT;
9725 PERL_ARGS_ASSERT_CK_FUN;
9727 if (o->op_flags & OPf_STACKED) {
9728 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9731 return no_fh_allowed(o);
9734 if (o->op_flags & OPf_KIDS) {
9735 OP *prev_kid = NULL;
9736 OP *kid = cLISTOPo->op_first;
9738 bool seen_optional = FALSE;
9740 if (kid->op_type == OP_PUSHMARK ||
9741 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9744 kid = OpSIBLING(kid);
9746 if (kid && kid->op_type == OP_COREARGS) {
9747 bool optional = FALSE;
9750 if (oa & OA_OPTIONAL) optional = TRUE;
9753 if (optional) o->op_private |= numargs;
9758 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9759 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9761 /* append kid to chain */
9762 op_sibling_splice(o, prev_kid, 0, kid);
9764 seen_optional = TRUE;
9771 /* list seen where single (scalar) arg expected? */
9772 if (numargs == 1 && !(oa >> 4)
9773 && kid->op_type == OP_LIST && type != OP_SCALAR)
9775 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9777 if (type != OP_DELETE) scalar(kid);
9788 if ((type == OP_PUSH || type == OP_UNSHIFT)
9789 && !OpHAS_SIBLING(kid))
9790 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9791 "Useless use of %s with no values",
9794 if (kid->op_type == OP_CONST
9795 && ( !SvROK(cSVOPx_sv(kid))
9796 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9798 bad_type_pv(numargs, "array", o, kid);
9799 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9800 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9801 PL_op_desc[type]), 0);
9804 op_lvalue(kid, type);
9808 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9809 bad_type_pv(numargs, "hash", o, kid);
9810 op_lvalue(kid, type);
9814 /* replace kid with newop in chain */
9816 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9817 newop->op_next = newop;
9822 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9823 if (kid->op_type == OP_CONST &&
9824 (kid->op_private & OPpCONST_BARE))
9826 OP * const newop = newGVOP(OP_GV, 0,
9827 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9828 /* replace kid with newop in chain */
9829 op_sibling_splice(o, prev_kid, 1, newop);
9833 else if (kid->op_type == OP_READLINE) {
9834 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9835 bad_type_pv(numargs, "HANDLE", o, kid);
9838 I32 flags = OPf_SPECIAL;
9842 /* is this op a FH constructor? */
9843 if (is_handle_constructor(o,numargs)) {
9844 const char *name = NULL;
9847 bool want_dollar = TRUE;
9850 /* Set a flag to tell rv2gv to vivify
9851 * need to "prove" flag does not mean something
9852 * else already - NI-S 1999/05/07
9855 if (kid->op_type == OP_PADSV) {
9857 = PAD_COMPNAME_SV(kid->op_targ);
9858 name = PadnamePV (pn);
9859 len = PadnameLEN(pn);
9860 name_utf8 = PadnameUTF8(pn);
9862 else if (kid->op_type == OP_RV2SV
9863 && kUNOP->op_first->op_type == OP_GV)
9865 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9867 len = GvNAMELEN(gv);
9868 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9870 else if (kid->op_type == OP_AELEM
9871 || kid->op_type == OP_HELEM)
9874 OP *op = ((BINOP*)kid)->op_first;
9878 const char * const a =
9879 kid->op_type == OP_AELEM ?
9881 if (((op->op_type == OP_RV2AV) ||
9882 (op->op_type == OP_RV2HV)) &&
9883 (firstop = ((UNOP*)op)->op_first) &&
9884 (firstop->op_type == OP_GV)) {
9885 /* packagevar $a[] or $h{} */
9886 GV * const gv = cGVOPx_gv(firstop);
9894 else if (op->op_type == OP_PADAV
9895 || op->op_type == OP_PADHV) {
9896 /* lexicalvar $a[] or $h{} */
9897 const char * const padname =
9898 PAD_COMPNAME_PV(op->op_targ);
9907 name = SvPV_const(tmpstr, len);
9908 name_utf8 = SvUTF8(tmpstr);
9913 name = "__ANONIO__";
9915 want_dollar = FALSE;
9917 op_lvalue(kid, type);
9921 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9922 namesv = PAD_SVl(targ);
9923 if (want_dollar && *name != '$')
9924 sv_setpvs(namesv, "$");
9926 sv_setpvs(namesv, "");
9927 sv_catpvn(namesv, name, len);
9928 if ( name_utf8 ) SvUTF8_on(namesv);
9932 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9934 kid->op_targ = targ;
9935 kid->op_private |= priv;
9941 if ((type == OP_UNDEF || type == OP_POS)
9942 && numargs == 1 && !(oa >> 4)
9943 && kid->op_type == OP_LIST)
9944 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9945 op_lvalue(scalar(kid), type);
9950 kid = OpSIBLING(kid);
9952 /* FIXME - should the numargs or-ing move after the too many
9953 * arguments check? */
9954 o->op_private |= numargs;
9956 return too_many_arguments_pv(o,OP_DESC(o), 0);
9959 else if (PL_opargs[type] & OA_DEFGV) {
9960 /* Ordering of these two is important to keep f_map.t passing. */
9962 return newUNOP(type, 0, newDEFSVOP());
9966 while (oa & OA_OPTIONAL)
9968 if (oa && oa != OA_LIST)
9969 return too_few_arguments_pv(o,OP_DESC(o), 0);
9975 Perl_ck_glob(pTHX_ OP *o)
9979 PERL_ARGS_ASSERT_CK_GLOB;
9982 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
9983 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9985 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
9989 * \ null - const(wildcard)
9994 * \ mark - glob - rv2cv
9995 * | \ gv(CORE::GLOBAL::glob)
9997 * \ null - const(wildcard)
9999 o->op_flags |= OPf_SPECIAL;
10000 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10001 o = S_new_entersubop(aTHX_ gv, o);
10002 o = newUNOP(OP_NULL, 0, o);
10003 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10006 else o->op_flags &= ~OPf_SPECIAL;
10007 #if !defined(PERL_EXTERNAL_GLOB)
10008 if (!PL_globhook) {
10010 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10011 newSVpvs("File::Glob"), NULL, NULL, NULL);
10014 #endif /* !PERL_EXTERNAL_GLOB */
10015 gv = (GV *)newSV(0);
10016 gv_init(gv, 0, "", 0, 0);
10018 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10019 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10025 Perl_ck_grep(pTHX_ OP *o)
10029 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10031 PERL_ARGS_ASSERT_CK_GREP;
10033 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10035 if (o->op_flags & OPf_STACKED) {
10036 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10037 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10038 return no_fh_allowed(o);
10039 o->op_flags &= ~OPf_STACKED;
10041 kid = OpSIBLING(cLISTOPo->op_first);
10042 if (type == OP_MAPWHILE)
10047 if (PL_parser && PL_parser->error_count)
10049 kid = OpSIBLING(cLISTOPo->op_first);
10050 if (kid->op_type != OP_NULL)
10051 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10052 kid = kUNOP->op_first;
10054 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10055 kid->op_next = (OP*)gwop;
10056 o->op_private = gwop->op_private = 0;
10057 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10059 kid = OpSIBLING(cLISTOPo->op_first);
10060 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10061 op_lvalue(kid, OP_GREPSTART);
10067 Perl_ck_index(pTHX_ OP *o)
10069 PERL_ARGS_ASSERT_CK_INDEX;
10071 if (o->op_flags & OPf_KIDS) {
10072 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10074 kid = OpSIBLING(kid); /* get past "big" */
10075 if (kid && kid->op_type == OP_CONST) {
10076 const bool save_taint = TAINT_get;
10077 SV *sv = kSVOP->op_sv;
10078 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10080 sv_copypv(sv, kSVOP->op_sv);
10081 SvREFCNT_dec_NN(kSVOP->op_sv);
10084 if (SvOK(sv)) fbm_compile(sv, 0);
10085 TAINT_set(save_taint);
10086 #ifdef NO_TAINT_SUPPORT
10087 PERL_UNUSED_VAR(save_taint);
10095 Perl_ck_lfun(pTHX_ OP *o)
10097 const OPCODE type = o->op_type;
10099 PERL_ARGS_ASSERT_CK_LFUN;
10101 return modkids(ck_fun(o), type);
10105 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10107 PERL_ARGS_ASSERT_CK_DEFINED;
10109 if ((o->op_flags & OPf_KIDS)) {
10110 switch (cUNOPo->op_first->op_type) {
10113 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10114 " (Maybe you should just omit the defined()?)");
10118 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10119 " (Maybe you should just omit the defined()?)");
10130 Perl_ck_readline(pTHX_ OP *o)
10132 PERL_ARGS_ASSERT_CK_READLINE;
10134 if (o->op_flags & OPf_KIDS) {
10135 OP *kid = cLISTOPo->op_first;
10136 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10140 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10148 Perl_ck_rfun(pTHX_ OP *o)
10150 const OPCODE type = o->op_type;
10152 PERL_ARGS_ASSERT_CK_RFUN;
10154 return refkids(ck_fun(o), type);
10158 Perl_ck_listiob(pTHX_ OP *o)
10162 PERL_ARGS_ASSERT_CK_LISTIOB;
10164 kid = cLISTOPo->op_first;
10166 o = force_list(o, 1);
10167 kid = cLISTOPo->op_first;
10169 if (kid->op_type == OP_PUSHMARK)
10170 kid = OpSIBLING(kid);
10171 if (kid && o->op_flags & OPf_STACKED)
10172 kid = OpSIBLING(kid);
10173 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10174 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10175 && !kid->op_folded) {
10176 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10178 /* replace old const op with new OP_RV2GV parent */
10179 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10180 OP_RV2GV, OPf_REF);
10181 kid = OpSIBLING(kid);
10186 op_append_elem(o->op_type, o, newDEFSVOP());
10188 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10189 return listkids(o);
10193 Perl_ck_smartmatch(pTHX_ OP *o)
10196 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10197 if (0 == (o->op_flags & OPf_SPECIAL)) {
10198 OP *first = cBINOPo->op_first;
10199 OP *second = OpSIBLING(first);
10201 /* Implicitly take a reference to an array or hash */
10203 /* remove the original two siblings, then add back the
10204 * (possibly different) first and second sibs.
10206 op_sibling_splice(o, NULL, 1, NULL);
10207 op_sibling_splice(o, NULL, 1, NULL);
10208 first = ref_array_or_hash(first);
10209 second = ref_array_or_hash(second);
10210 op_sibling_splice(o, NULL, 0, second);
10211 op_sibling_splice(o, NULL, 0, first);
10213 /* Implicitly take a reference to a regular expression */
10214 if (first->op_type == OP_MATCH) {
10215 OpTYPE_set(first, OP_QR);
10217 if (second->op_type == OP_MATCH) {
10218 OpTYPE_set(second, OP_QR);
10227 S_maybe_targlex(pTHX_ OP *o)
10229 OP * const kid = cLISTOPo->op_first;
10230 /* has a disposable target? */
10231 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10232 && !(kid->op_flags & OPf_STACKED)
10233 /* Cannot steal the second time! */
10234 && !(kid->op_private & OPpTARGET_MY)
10237 OP * const kkid = OpSIBLING(kid);
10239 /* Can just relocate the target. */
10240 if (kkid && kkid->op_type == OP_PADSV
10241 && (!(kkid->op_private & OPpLVAL_INTRO)
10242 || kkid->op_private & OPpPAD_STATE))
10244 kid->op_targ = kkid->op_targ;
10246 /* Now we do not need PADSV and SASSIGN.
10247 * Detach kid and free the rest. */
10248 op_sibling_splice(o, NULL, 1, NULL);
10250 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10258 Perl_ck_sassign(pTHX_ OP *o)
10261 OP * const kid = cLISTOPo->op_first;
10263 PERL_ARGS_ASSERT_CK_SASSIGN;
10265 if (OpHAS_SIBLING(kid)) {
10266 OP *kkid = OpSIBLING(kid);
10267 /* For state variable assignment with attributes, kkid is a list op
10268 whose op_last is a padsv. */
10269 if ((kkid->op_type == OP_PADSV ||
10270 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10271 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10274 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10275 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10276 const PADOFFSET target = kkid->op_targ;
10277 OP *const other = newOP(OP_PADSV,
10279 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10280 OP *const first = newOP(OP_NULL, 0);
10282 newCONDOP(0, first, o, other);
10283 /* XXX targlex disabled for now; see ticket #124160
10284 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10286 OP *const condop = first->op_next;
10288 OpTYPE_set(condop, OP_ONCE);
10289 other->op_targ = target;
10290 nullop->op_flags |= OPf_WANT_SCALAR;
10292 /* Store the initializedness of state vars in a separate
10295 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10296 /* hijacking PADSTALE for uninitialized state variables */
10297 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10302 return S_maybe_targlex(aTHX_ o);
10306 Perl_ck_match(pTHX_ OP *o)
10308 PERL_UNUSED_CONTEXT;
10309 PERL_ARGS_ASSERT_CK_MATCH;
10311 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10312 o->op_private |= OPpRUNTIME;
10317 Perl_ck_method(pTHX_ OP *o)
10319 SV *sv, *methsv, *rclass;
10320 const char* method;
10323 STRLEN len, nsplit = 0, i;
10325 OP * const kid = cUNOPo->op_first;
10327 PERL_ARGS_ASSERT_CK_METHOD;
10328 if (kid->op_type != OP_CONST) return o;
10332 /* replace ' with :: */
10333 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10335 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10338 method = SvPVX_const(sv);
10340 utf8 = SvUTF8(sv) ? -1 : 1;
10342 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10347 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10349 if (!nsplit) { /* $proto->method() */
10351 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10354 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10356 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10359 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10360 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10361 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10362 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10364 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10365 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10367 #ifdef USE_ITHREADS
10368 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10370 cMETHOPx(new_op)->op_rclass_sv = rclass;
10377 Perl_ck_null(pTHX_ OP *o)
10379 PERL_ARGS_ASSERT_CK_NULL;
10380 PERL_UNUSED_CONTEXT;
10385 Perl_ck_open(pTHX_ OP *o)
10387 PERL_ARGS_ASSERT_CK_OPEN;
10389 S_io_hints(aTHX_ o);
10391 /* In case of three-arg dup open remove strictness
10392 * from the last arg if it is a bareword. */
10393 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10394 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10398 if ((last->op_type == OP_CONST) && /* The bareword. */
10399 (last->op_private & OPpCONST_BARE) &&
10400 (last->op_private & OPpCONST_STRICT) &&
10401 (oa = OpSIBLING(first)) && /* The fh. */
10402 (oa = OpSIBLING(oa)) && /* The mode. */
10403 (oa->op_type == OP_CONST) &&
10404 SvPOK(((SVOP*)oa)->op_sv) &&
10405 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10406 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10407 (last == OpSIBLING(oa))) /* The bareword. */
10408 last->op_private &= ~OPpCONST_STRICT;
10414 Perl_ck_prototype(pTHX_ OP *o)
10416 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10417 if (!(o->op_flags & OPf_KIDS)) {
10419 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10425 Perl_ck_refassign(pTHX_ OP *o)
10427 OP * const right = cLISTOPo->op_first;
10428 OP * const left = OpSIBLING(right);
10429 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10432 PERL_ARGS_ASSERT_CK_REFASSIGN;
10434 assert (left->op_type == OP_SREFGEN);
10437 /* we use OPpPAD_STATE in refassign to mean either of those things,
10438 * and the code assumes the two flags occupy the same bit position
10439 * in the various ops below */
10440 assert(OPpPAD_STATE == OPpOUR_INTRO);
10442 switch (varop->op_type) {
10444 o->op_private |= OPpLVREF_AV;
10447 o->op_private |= OPpLVREF_HV;
10451 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10452 o->op_targ = varop->op_targ;
10453 varop->op_targ = 0;
10454 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10458 o->op_private |= OPpLVREF_AV;
10460 NOT_REACHED; /* NOTREACHED */
10462 o->op_private |= OPpLVREF_HV;
10466 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10467 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10469 /* Point varop to its GV kid, detached. */
10470 varop = op_sibling_splice(varop, NULL, -1, NULL);
10474 OP * const kidparent =
10475 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10476 OP * const kid = cUNOPx(kidparent)->op_first;
10477 o->op_private |= OPpLVREF_CV;
10478 if (kid->op_type == OP_GV) {
10480 goto detach_and_stack;
10482 if (kid->op_type != OP_PADCV) goto bad;
10483 o->op_targ = kid->op_targ;
10489 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10490 o->op_private |= OPpLVREF_ELEM;
10493 /* Detach varop. */
10494 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10498 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10499 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10504 if (!FEATURE_REFALIASING_IS_ENABLED)
10506 "Experimental aliasing via reference not enabled");
10507 Perl_ck_warner_d(aTHX_
10508 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10509 "Aliasing via reference is experimental");
10511 o->op_flags |= OPf_STACKED;
10512 op_sibling_splice(o, right, 1, varop);
10515 o->op_flags &=~ OPf_STACKED;
10516 op_sibling_splice(o, right, 1, NULL);
10523 Perl_ck_repeat(pTHX_ OP *o)
10525 PERL_ARGS_ASSERT_CK_REPEAT;
10527 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10529 o->op_private |= OPpREPEAT_DOLIST;
10530 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10531 kids = force_list(kids, 1); /* promote it to a list */
10532 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10540 Perl_ck_require(pTHX_ OP *o)
10544 PERL_ARGS_ASSERT_CK_REQUIRE;
10546 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10547 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10552 if (kid->op_type == OP_CONST) {
10553 SV * const sv = kid->op_sv;
10554 U32 const was_readonly = SvREADONLY(sv);
10555 if (kid->op_private & OPpCONST_BARE) {
10559 if (was_readonly) {
10560 SvREADONLY_off(sv);
10562 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10567 for (; s < end; s++) {
10568 if (*s == ':' && s[1] == ':') {
10570 Move(s+2, s+1, end - s - 1, char);
10574 SvEND_set(sv, end);
10575 sv_catpvs(sv, ".pm");
10576 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10577 hek = share_hek(SvPVX(sv),
10578 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10580 sv_sethek(sv, hek);
10582 SvFLAGS(sv) |= was_readonly;
10584 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10587 if (SvREFCNT(sv) > 1) {
10588 kid->op_sv = newSVpvn_share(
10589 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10590 SvREFCNT_dec_NN(sv);
10594 if (was_readonly) SvREADONLY_off(sv);
10595 PERL_HASH(hash, s, len);
10597 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10599 sv_sethek(sv, hek);
10601 SvFLAGS(sv) |= was_readonly;
10607 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10608 /* handle override, if any */
10609 && (gv = gv_override("require", 7))) {
10611 if (o->op_flags & OPf_KIDS) {
10612 kid = cUNOPo->op_first;
10613 op_sibling_splice(o, NULL, -1, NULL);
10616 kid = newDEFSVOP();
10619 newop = S_new_entersubop(aTHX_ gv, kid);
10627 Perl_ck_return(pTHX_ OP *o)
10631 PERL_ARGS_ASSERT_CK_RETURN;
10633 kid = OpSIBLING(cLISTOPo->op_first);
10634 if (CvLVALUE(PL_compcv)) {
10635 for (; kid; kid = OpSIBLING(kid))
10636 op_lvalue(kid, OP_LEAVESUBLV);
10643 Perl_ck_select(pTHX_ OP *o)
10648 PERL_ARGS_ASSERT_CK_SELECT;
10650 if (o->op_flags & OPf_KIDS) {
10651 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10652 if (kid && OpHAS_SIBLING(kid)) {
10653 OpTYPE_set(o, OP_SSELECT);
10655 return fold_constants(op_integerize(op_std_init(o)));
10659 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10660 if (kid && kid->op_type == OP_RV2GV)
10661 kid->op_private &= ~HINT_STRICT_REFS;
10666 Perl_ck_shift(pTHX_ OP *o)
10668 const I32 type = o->op_type;
10670 PERL_ARGS_ASSERT_CK_SHIFT;
10672 if (!(o->op_flags & OPf_KIDS)) {
10675 if (!CvUNIQUE(PL_compcv)) {
10676 o->op_flags |= OPf_SPECIAL;
10680 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10682 return newUNOP(type, 0, scalar(argop));
10684 return scalar(ck_fun(o));
10688 Perl_ck_sort(pTHX_ OP *o)
10692 HV * const hinthv =
10693 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10696 PERL_ARGS_ASSERT_CK_SORT;
10699 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10701 const I32 sorthints = (I32)SvIV(*svp);
10702 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10703 o->op_private |= OPpSORT_QSORT;
10704 if ((sorthints & HINT_SORT_STABLE) != 0)
10705 o->op_private |= OPpSORT_STABLE;
10709 if (o->op_flags & OPf_STACKED)
10711 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10713 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10714 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10716 /* if the first arg is a code block, process it and mark sort as
10718 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10720 if (kid->op_type == OP_LEAVE)
10721 op_null(kid); /* wipe out leave */
10722 /* Prevent execution from escaping out of the sort block. */
10725 /* provide scalar context for comparison function/block */
10726 kid = scalar(firstkid);
10727 kid->op_next = kid;
10728 o->op_flags |= OPf_SPECIAL;
10730 else if (kid->op_type == OP_CONST
10731 && kid->op_private & OPpCONST_BARE) {
10735 const char * const name = SvPV(kSVOP_sv, len);
10737 assert (len < 256);
10738 Copy(name, tmpbuf+1, len, char);
10739 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10740 if (off != NOT_IN_PAD) {
10741 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10743 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10744 sv_catpvs(fq, "::");
10745 sv_catsv(fq, kSVOP_sv);
10746 SvREFCNT_dec_NN(kSVOP_sv);
10750 OP * const padop = newOP(OP_PADCV, 0);
10751 padop->op_targ = off;
10752 /* replace the const op with the pad op */
10753 op_sibling_splice(firstkid, NULL, 1, padop);
10759 firstkid = OpSIBLING(firstkid);
10762 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10763 /* provide list context for arguments */
10766 op_lvalue(kid, OP_GREPSTART);
10772 /* for sort { X } ..., where X is one of
10773 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10774 * elide the second child of the sort (the one containing X),
10775 * and set these flags as appropriate
10779 * Also, check and warn on lexical $a, $b.
10783 S_simplify_sort(pTHX_ OP *o)
10785 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10789 const char *gvname;
10792 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10794 kid = kUNOP->op_first; /* get past null */
10795 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10796 && kid->op_type != OP_LEAVE)
10798 kid = kLISTOP->op_last; /* get past scope */
10799 switch(kid->op_type) {
10803 if (!have_scopeop) goto padkids;
10808 k = kid; /* remember this node*/
10809 if (kBINOP->op_first->op_type != OP_RV2SV
10810 || kBINOP->op_last ->op_type != OP_RV2SV)
10813 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10814 then used in a comparison. This catches most, but not
10815 all cases. For instance, it catches
10816 sort { my($a); $a <=> $b }
10818 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10819 (although why you'd do that is anyone's guess).
10823 if (!ckWARN(WARN_SYNTAX)) return;
10824 kid = kBINOP->op_first;
10826 if (kid->op_type == OP_PADSV) {
10827 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
10828 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
10829 && ( PadnamePV(name)[1] == 'a'
10830 || PadnamePV(name)[1] == 'b' ))
10831 /* diag_listed_as: "my %s" used in sort comparison */
10832 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10833 "\"%s %s\" used in sort comparison",
10834 PadnameIsSTATE(name)
10839 } while ((kid = OpSIBLING(kid)));
10842 kid = kBINOP->op_first; /* get past cmp */
10843 if (kUNOP->op_first->op_type != OP_GV)
10845 kid = kUNOP->op_first; /* get past rv2sv */
10847 if (GvSTASH(gv) != PL_curstash)
10849 gvname = GvNAME(gv);
10850 if (*gvname == 'a' && gvname[1] == '\0')
10852 else if (*gvname == 'b' && gvname[1] == '\0')
10857 kid = k; /* back to cmp */
10858 /* already checked above that it is rv2sv */
10859 kid = kBINOP->op_last; /* down to 2nd arg */
10860 if (kUNOP->op_first->op_type != OP_GV)
10862 kid = kUNOP->op_first; /* get past rv2sv */
10864 if (GvSTASH(gv) != PL_curstash)
10866 gvname = GvNAME(gv);
10868 ? !(*gvname == 'a' && gvname[1] == '\0')
10869 : !(*gvname == 'b' && gvname[1] == '\0'))
10871 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10873 o->op_private |= OPpSORT_DESCEND;
10874 if (k->op_type == OP_NCMP)
10875 o->op_private |= OPpSORT_NUMERIC;
10876 if (k->op_type == OP_I_NCMP)
10877 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10878 kid = OpSIBLING(cLISTOPo->op_first);
10879 /* cut out and delete old block (second sibling) */
10880 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10885 Perl_ck_split(pTHX_ OP *o)
10890 PERL_ARGS_ASSERT_CK_SPLIT;
10892 if (o->op_flags & OPf_STACKED)
10893 return no_fh_allowed(o);
10895 kid = cLISTOPo->op_first;
10896 if (kid->op_type != OP_NULL)
10897 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10898 /* delete leading NULL node, then add a CONST if no other nodes */
10899 op_sibling_splice(o, NULL, 1,
10900 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10902 kid = cLISTOPo->op_first;
10904 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10905 /* remove kid, and replace with new optree */
10906 op_sibling_splice(o, NULL, 1, NULL);
10907 /* OPf_SPECIAL is used to trigger split " " behavior */
10908 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
10909 op_sibling_splice(o, NULL, 0, kid);
10911 OpTYPE_set(kid, OP_PUSHRE);
10912 /* target implies @ary=..., so wipe it */
10915 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10916 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10917 "Use of /g modifier is meaningless in split");
10920 if (!OpHAS_SIBLING(kid))
10921 op_append_elem(OP_SPLIT, o, newDEFSVOP());
10923 kid = OpSIBLING(kid);
10927 if (!OpHAS_SIBLING(kid))
10929 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10930 o->op_private |= OPpSPLIT_IMPLIM;
10932 assert(OpHAS_SIBLING(kid));
10934 kid = OpSIBLING(kid);
10937 if (OpHAS_SIBLING(kid))
10938 return too_many_arguments_pv(o,OP_DESC(o), 0);
10944 Perl_ck_stringify(pTHX_ OP *o)
10946 OP * const kid = OpSIBLING(cUNOPo->op_first);
10947 PERL_ARGS_ASSERT_CK_STRINGIFY;
10948 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
10949 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
10950 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
10951 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
10953 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10961 Perl_ck_join(pTHX_ OP *o)
10963 OP * const kid = OpSIBLING(cLISTOPo->op_first);
10965 PERL_ARGS_ASSERT_CK_JOIN;
10967 if (kid && kid->op_type == OP_MATCH) {
10968 if (ckWARN(WARN_SYNTAX)) {
10969 const REGEXP *re = PM_GETRE(kPMOP);
10971 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10972 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10973 : newSVpvs_flags( "STRING", SVs_TEMP );
10974 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10975 "/%"SVf"/ should probably be written as \"%"SVf"\"",
10976 SVfARG(msg), SVfARG(msg));
10980 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
10981 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
10982 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
10983 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
10985 const OP * const bairn = OpSIBLING(kid); /* the list */
10986 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
10987 && OP_GIMME(bairn,0) == G_SCALAR)
10989 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
10990 op_sibling_splice(o, kid, 1, NULL));
11000 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11002 Examines an op, which is expected to identify a subroutine at runtime,
11003 and attempts to determine at compile time which subroutine it identifies.
11004 This is normally used during Perl compilation to determine whether
11005 a prototype can be applied to a function call. C<cvop> is the op
11006 being considered, normally an C<rv2cv> op. A pointer to the identified
11007 subroutine is returned, if it could be determined statically, and a null
11008 pointer is returned if it was not possible to determine statically.
11010 Currently, the subroutine can be identified statically if the RV that the
11011 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11012 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11013 suitable if the constant value must be an RV pointing to a CV. Details of
11014 this process may change in future versions of Perl. If the C<rv2cv> op
11015 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11016 the subroutine statically: this flag is used to suppress compile-time
11017 magic on a subroutine call, forcing it to use default runtime behaviour.
11019 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11020 of a GV reference is modified. If a GV was examined and its CV slot was
11021 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11022 If the op is not optimised away, and the CV slot is later populated with
11023 a subroutine having a prototype, that flag eventually triggers the warning
11024 "called too early to check prototype".
11026 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11027 of returning a pointer to the subroutine it returns a pointer to the
11028 GV giving the most appropriate name for the subroutine in this context.
11029 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11030 (C<CvANON>) subroutine that is referenced through a GV it will be the
11031 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11032 A null pointer is returned as usual if there is no statically-determinable
11038 /* shared by toke.c:yylex */
11040 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11042 PADNAME *name = PAD_COMPNAME(off);
11043 CV *compcv = PL_compcv;
11044 while (PadnameOUTER(name)) {
11045 assert(PARENT_PAD_INDEX(name));
11046 compcv = CvOUTSIDE(compcv);
11047 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11048 [off = PARENT_PAD_INDEX(name)];
11050 assert(!PadnameIsOUR(name));
11051 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11052 return PadnamePROTOCV(name);
11054 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11058 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11063 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11064 if (flags & ~RV2CVOPCV_FLAG_MASK)
11065 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11066 if (cvop->op_type != OP_RV2CV)
11068 if (cvop->op_private & OPpENTERSUB_AMPER)
11070 if (!(cvop->op_flags & OPf_KIDS))
11072 rvop = cUNOPx(cvop)->op_first;
11073 switch (rvop->op_type) {
11075 gv = cGVOPx_gv(rvop);
11077 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11078 cv = MUTABLE_CV(SvRV(gv));
11082 if (flags & RV2CVOPCV_RETURN_STUB)
11088 if (flags & RV2CVOPCV_MARK_EARLY)
11089 rvop->op_private |= OPpEARLY_CV;
11094 SV *rv = cSVOPx_sv(rvop);
11097 cv = (CV*)SvRV(rv);
11101 cv = find_lexical_cv(rvop->op_targ);
11106 } NOT_REACHED; /* NOTREACHED */
11108 if (SvTYPE((SV*)cv) != SVt_PVCV)
11110 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11111 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11112 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11121 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11123 Performs the default fixup of the arguments part of an C<entersub>
11124 op tree. This consists of applying list context to each of the
11125 argument ops. This is the standard treatment used on a call marked
11126 with C<&>, or a method call, or a call through a subroutine reference,
11127 or any other call where the callee can't be identified at compile time,
11128 or a call where the callee has no prototype.
11134 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11137 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11138 aop = cUNOPx(entersubop)->op_first;
11139 if (!OpHAS_SIBLING(aop))
11140 aop = cUNOPx(aop)->op_first;
11141 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11143 op_lvalue(aop, OP_ENTERSUB);
11149 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11151 Performs the fixup of the arguments part of an C<entersub> op tree
11152 based on a subroutine prototype. This makes various modifications to
11153 the argument ops, from applying context up to inserting C<refgen> ops,
11154 and checking the number and syntactic types of arguments, as directed by
11155 the prototype. This is the standard treatment used on a subroutine call,
11156 not marked with C<&>, where the callee can be identified at compile time
11157 and has a prototype.
11159 C<protosv> supplies the subroutine prototype to be applied to the call.
11160 It may be a normal defined scalar, of which the string value will be used.
11161 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11162 that has been cast to C<SV*>) which has a prototype. The prototype
11163 supplied, in whichever form, does not need to match the actual callee
11164 referenced by the op tree.
11166 If the argument ops disagree with the prototype, for example by having
11167 an unacceptable number of arguments, a valid op tree is returned anyway.
11168 The error is reflected in the parser state, normally resulting in a single
11169 exception at the top level of parsing which covers all the compilation
11170 errors that occurred. In the error message, the callee is referred to
11171 by the name defined by the C<namegv> parameter.
11177 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11180 const char *proto, *proto_end;
11181 OP *aop, *prev, *cvop, *parent;
11184 I32 contextclass = 0;
11185 const char *e = NULL;
11186 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11187 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11188 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11189 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11190 if (SvTYPE(protosv) == SVt_PVCV)
11191 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11192 else proto = SvPV(protosv, proto_len);
11193 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11194 proto_end = proto + proto_len;
11195 parent = entersubop;
11196 aop = cUNOPx(entersubop)->op_first;
11197 if (!OpHAS_SIBLING(aop)) {
11199 aop = cUNOPx(aop)->op_first;
11202 aop = OpSIBLING(aop);
11203 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11204 while (aop != cvop) {
11207 if (proto >= proto_end)
11209 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11210 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11211 SVfARG(namesv)), SvUTF8(namesv));
11221 /* _ must be at the end */
11222 if (proto[1] && !strchr(";@%", proto[1]))
11238 if ( o3->op_type != OP_UNDEF
11239 && (o3->op_type != OP_SREFGEN
11240 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11242 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11244 bad_type_gv(arg, namegv, o3,
11245 arg == 1 ? "block or sub {}" : "sub {}");
11248 /* '*' allows any scalar type, including bareword */
11251 if (o3->op_type == OP_RV2GV)
11252 goto wrapref; /* autoconvert GLOB -> GLOBref */
11253 else if (o3->op_type == OP_CONST)
11254 o3->op_private &= ~OPpCONST_STRICT;
11260 if (o3->op_type == OP_RV2AV ||
11261 o3->op_type == OP_PADAV ||
11262 o3->op_type == OP_RV2HV ||
11263 o3->op_type == OP_PADHV
11269 case '[': case ']':
11276 switch (*proto++) {
11278 if (contextclass++ == 0) {
11279 e = strchr(proto, ']');
11280 if (!e || e == proto)
11288 if (contextclass) {
11289 const char *p = proto;
11290 const char *const end = proto;
11292 while (*--p != '[')
11293 /* \[$] accepts any scalar lvalue */
11295 && Perl_op_lvalue_flags(aTHX_
11297 OP_READ, /* not entersub */
11300 bad_type_gv(arg, namegv, o3,
11301 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11306 if (o3->op_type == OP_RV2GV)
11309 bad_type_gv(arg, namegv, o3, "symbol");
11312 if (o3->op_type == OP_ENTERSUB
11313 && !(o3->op_flags & OPf_STACKED))
11316 bad_type_gv(arg, namegv, o3, "subroutine");
11319 if (o3->op_type == OP_RV2SV ||
11320 o3->op_type == OP_PADSV ||
11321 o3->op_type == OP_HELEM ||
11322 o3->op_type == OP_AELEM)
11324 if (!contextclass) {
11325 /* \$ accepts any scalar lvalue */
11326 if (Perl_op_lvalue_flags(aTHX_
11328 OP_READ, /* not entersub */
11331 bad_type_gv(arg, namegv, o3, "scalar");
11335 if (o3->op_type == OP_RV2AV ||
11336 o3->op_type == OP_PADAV)
11338 o3->op_flags &=~ OPf_PARENS;
11342 bad_type_gv(arg, namegv, o3, "array");
11345 if (o3->op_type == OP_RV2HV ||
11346 o3->op_type == OP_PADHV)
11348 o3->op_flags &=~ OPf_PARENS;
11352 bad_type_gv(arg, namegv, o3, "hash");
11355 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11357 if (contextclass && e) {
11362 default: goto oops;
11372 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11373 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11378 op_lvalue(aop, OP_ENTERSUB);
11380 aop = OpSIBLING(aop);
11382 if (aop == cvop && *proto == '_') {
11383 /* generate an access to $_ */
11384 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11386 if (!optional && proto_end > proto &&
11387 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11389 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11390 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11391 SVfARG(namesv)), SvUTF8(namesv));
11397 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11399 Performs the fixup of the arguments part of an C<entersub> op tree either
11400 based on a subroutine prototype or using default list-context processing.
11401 This is the standard treatment used on a subroutine call, not marked
11402 with C<&>, where the callee can be identified at compile time.
11404 C<protosv> supplies the subroutine prototype to be applied to the call,
11405 or indicates that there is no prototype. It may be a normal scalar,
11406 in which case if it is defined then the string value will be used
11407 as a prototype, and if it is undefined then there is no prototype.
11408 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11409 that has been cast to C<SV*>), of which the prototype will be used if it
11410 has one. The prototype (or lack thereof) supplied, in whichever form,
11411 does not need to match the actual callee referenced by the op tree.
11413 If the argument ops disagree with the prototype, for example by having
11414 an unacceptable number of arguments, a valid op tree is returned anyway.
11415 The error is reflected in the parser state, normally resulting in a single
11416 exception at the top level of parsing which covers all the compilation
11417 errors that occurred. In the error message, the callee is referred to
11418 by the name defined by the C<namegv> parameter.
11424 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11425 GV *namegv, SV *protosv)
11427 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11428 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11429 return ck_entersub_args_proto(entersubop, namegv, protosv);
11431 return ck_entersub_args_list(entersubop);
11435 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11437 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11438 OP *aop = cUNOPx(entersubop)->op_first;
11440 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11444 if (!OpHAS_SIBLING(aop))
11445 aop = cUNOPx(aop)->op_first;
11446 aop = OpSIBLING(aop);
11447 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11449 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11451 op_free(entersubop);
11452 switch(GvNAME(namegv)[2]) {
11453 case 'F': return newSVOP(OP_CONST, 0,
11454 newSVpv(CopFILE(PL_curcop),0));
11455 case 'L': return newSVOP(
11457 Perl_newSVpvf(aTHX_
11458 "%"IVdf, (IV)CopLINE(PL_curcop)
11461 case 'P': return newSVOP(OP_CONST, 0,
11463 ? newSVhek(HvNAME_HEK(PL_curstash))
11468 NOT_REACHED; /* NOTREACHED */
11471 OP *prev, *cvop, *first, *parent;
11474 parent = entersubop;
11475 if (!OpHAS_SIBLING(aop)) {
11477 aop = cUNOPx(aop)->op_first;
11480 first = prev = aop;
11481 aop = OpSIBLING(aop);
11482 /* find last sibling */
11484 OpHAS_SIBLING(cvop);
11485 prev = cvop, cvop = OpSIBLING(cvop))
11487 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11488 /* Usually, OPf_SPECIAL on an op with no args means that it had
11489 * parens, but these have their own meaning for that flag: */
11490 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11491 && opnum != OP_DELETE && opnum != OP_EXISTS)
11492 flags |= OPf_SPECIAL;
11493 /* excise cvop from end of sibling chain */
11494 op_sibling_splice(parent, prev, 1, NULL);
11496 if (aop == cvop) aop = NULL;
11498 /* detach remaining siblings from the first sibling, then
11499 * dispose of original optree */
11502 op_sibling_splice(parent, first, -1, NULL);
11503 op_free(entersubop);
11505 if (opnum == OP_ENTEREVAL
11506 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11507 flags |= OPpEVAL_BYTES <<8;
11509 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11511 case OA_BASEOP_OR_UNOP:
11512 case OA_FILESTATOP:
11513 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11516 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11519 return opnum == OP_RUNCV
11520 ? newPVOP(OP_RUNCV,0,NULL)
11523 return op_convert_list(opnum,0,aop);
11526 NOT_REACHED; /* NOTREACHED */
11531 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11533 Retrieves the function that will be used to fix up a call to C<cv>.
11534 Specifically, the function is applied to an C<entersub> op tree for a
11535 subroutine call, not marked with C<&>, where the callee can be identified
11536 at compile time as C<cv>.
11538 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11539 argument for it is returned in C<*ckobj_p>. The function is intended
11540 to be called in this manner:
11542 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11544 In this call, C<entersubop> is a pointer to the C<entersub> op,
11545 which may be replaced by the check function, and C<namegv> is a GV
11546 supplying the name that should be used by the check function to refer
11547 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11548 It is permitted to apply the check function in non-standard situations,
11549 such as to a call to a different subroutine or to a method call.
11551 By default, the function is
11552 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11553 and the SV parameter is C<cv> itself. This implements standard
11554 prototype processing. It can be changed, for a particular subroutine,
11555 by L</cv_set_call_checker>.
11561 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11565 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11567 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11568 *ckobj_p = callmg->mg_obj;
11569 if (flagsp) *flagsp = callmg->mg_flags;
11571 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11572 *ckobj_p = (SV*)cv;
11573 if (flagsp) *flagsp = 0;
11578 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11580 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11581 PERL_UNUSED_CONTEXT;
11582 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11586 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11588 Sets the function that will be used to fix up a call to C<cv>.
11589 Specifically, the function is applied to an C<entersub> op tree for a
11590 subroutine call, not marked with C<&>, where the callee can be identified
11591 at compile time as C<cv>.
11593 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11594 for it is supplied in C<ckobj>. The function should be defined like this:
11596 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11598 It is intended to be called in this manner:
11600 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11602 In this call, C<entersubop> is a pointer to the C<entersub> op,
11603 which may be replaced by the check function, and C<namegv> supplies
11604 the name that should be used by the check function to refer
11605 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11606 It is permitted to apply the check function in non-standard situations,
11607 such as to a call to a different subroutine or to a method call.
11609 C<namegv> may not actually be a GV. For efficiency, perl may pass a
11610 CV or other SV instead. Whatever is passed can be used as the first
11611 argument to L</cv_name>. You can force perl to pass a GV by including
11612 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11614 The current setting for a particular CV can be retrieved by
11615 L</cv_get_call_checker>.
11617 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11619 The original form of L</cv_set_call_checker_flags>, which passes it the
11620 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11626 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11628 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11629 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11633 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11634 SV *ckobj, U32 flags)
11636 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11637 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11638 if (SvMAGICAL((SV*)cv))
11639 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11642 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11643 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11645 if (callmg->mg_flags & MGf_REFCOUNTED) {
11646 SvREFCNT_dec(callmg->mg_obj);
11647 callmg->mg_flags &= ~MGf_REFCOUNTED;
11649 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11650 callmg->mg_obj = ckobj;
11651 if (ckobj != (SV*)cv) {
11652 SvREFCNT_inc_simple_void_NN(ckobj);
11653 callmg->mg_flags |= MGf_REFCOUNTED;
11655 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11656 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11661 S_entersub_alloc_targ(pTHX_ OP * const o)
11663 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11664 o->op_private |= OPpENTERSUB_HASTARG;
11668 Perl_ck_subr(pTHX_ OP *o)
11673 SV **const_class = NULL;
11675 PERL_ARGS_ASSERT_CK_SUBR;
11677 aop = cUNOPx(o)->op_first;
11678 if (!OpHAS_SIBLING(aop))
11679 aop = cUNOPx(aop)->op_first;
11680 aop = OpSIBLING(aop);
11681 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11682 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11683 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11685 o->op_private &= ~1;
11686 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11687 if (PERLDB_SUB && PL_curstash != PL_debstash)
11688 o->op_private |= OPpENTERSUB_DB;
11689 switch (cvop->op_type) {
11691 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11695 case OP_METHOD_NAMED:
11696 case OP_METHOD_SUPER:
11697 case OP_METHOD_REDIR:
11698 case OP_METHOD_REDIR_SUPER:
11699 if (aop->op_type == OP_CONST) {
11700 aop->op_private &= ~OPpCONST_STRICT;
11701 const_class = &cSVOPx(aop)->op_sv;
11703 else if (aop->op_type == OP_LIST) {
11704 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11705 if (sib && sib->op_type == OP_CONST) {
11706 sib->op_private &= ~OPpCONST_STRICT;
11707 const_class = &cSVOPx(sib)->op_sv;
11710 /* make class name a shared cow string to speedup method calls */
11711 /* constant string might be replaced with object, f.e. bigint */
11712 if (const_class && SvPOK(*const_class)) {
11714 const char* str = SvPV(*const_class, len);
11716 SV* const shared = newSVpvn_share(
11717 str, SvUTF8(*const_class)
11718 ? -(SSize_t)len : (SSize_t)len,
11721 if (SvREADONLY(*const_class))
11722 SvREADONLY_on(shared);
11723 SvREFCNT_dec(*const_class);
11724 *const_class = shared;
11731 S_entersub_alloc_targ(aTHX_ o);
11732 return ck_entersub_args_list(o);
11734 Perl_call_checker ckfun;
11737 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11738 if (CvISXSUB(cv) || !CvROOT(cv))
11739 S_entersub_alloc_targ(aTHX_ o);
11741 /* The original call checker API guarantees that a GV will be
11742 be provided with the right name. So, if the old API was
11743 used (or the REQUIRE_GV flag was passed), we have to reify
11744 the CV’s GV, unless this is an anonymous sub. This is not
11745 ideal for lexical subs, as its stringification will include
11746 the package. But it is the best we can do. */
11747 if (flags & MGf_REQUIRE_GV) {
11748 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11751 else namegv = MUTABLE_GV(cv);
11752 /* After a syntax error in a lexical sub, the cv that
11753 rv2cv_op_cv returns may be a nameless stub. */
11754 if (!namegv) return ck_entersub_args_list(o);
11757 return ckfun(aTHX_ o, namegv, ckobj);
11762 Perl_ck_svconst(pTHX_ OP *o)
11764 SV * const sv = cSVOPo->op_sv;
11765 PERL_ARGS_ASSERT_CK_SVCONST;
11766 PERL_UNUSED_CONTEXT;
11767 #ifdef PERL_COPY_ON_WRITE
11768 /* Since the read-only flag may be used to protect a string buffer, we
11769 cannot do copy-on-write with existing read-only scalars that are not
11770 already copy-on-write scalars. To allow $_ = "hello" to do COW with
11771 that constant, mark the constant as COWable here, if it is not
11772 already read-only. */
11773 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11776 # ifdef PERL_DEBUG_READONLY_COW
11786 Perl_ck_trunc(pTHX_ OP *o)
11788 PERL_ARGS_ASSERT_CK_TRUNC;
11790 if (o->op_flags & OPf_KIDS) {
11791 SVOP *kid = (SVOP*)cUNOPo->op_first;
11793 if (kid->op_type == OP_NULL)
11794 kid = (SVOP*)OpSIBLING(kid);
11795 if (kid && kid->op_type == OP_CONST &&
11796 (kid->op_private & OPpCONST_BARE) &&
11799 o->op_flags |= OPf_SPECIAL;
11800 kid->op_private &= ~OPpCONST_STRICT;
11807 Perl_ck_substr(pTHX_ OP *o)
11809 PERL_ARGS_ASSERT_CK_SUBSTR;
11812 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11813 OP *kid = cLISTOPo->op_first;
11815 if (kid->op_type == OP_NULL)
11816 kid = OpSIBLING(kid);
11818 kid->op_flags |= OPf_MOD;
11825 Perl_ck_tell(pTHX_ OP *o)
11827 PERL_ARGS_ASSERT_CK_TELL;
11829 if (o->op_flags & OPf_KIDS) {
11830 OP *kid = cLISTOPo->op_first;
11831 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
11832 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11838 Perl_ck_each(pTHX_ OP *o)
11841 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11842 const unsigned orig_type = o->op_type;
11844 PERL_ARGS_ASSERT_CK_EACH;
11847 switch (kid->op_type) {
11853 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
11854 : orig_type == OP_KEYS ? OP_AKEYS
11858 if (kid->op_private == OPpCONST_BARE
11859 || !SvROK(cSVOPx_sv(kid))
11860 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11861 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
11863 /* we let ck_fun handle it */
11866 Perl_croak_nocontext(
11867 "Experimental %s on scalar is now forbidden",
11868 PL_op_desc[orig_type]);
11876 Perl_ck_length(pTHX_ OP *o)
11878 PERL_ARGS_ASSERT_CK_LENGTH;
11882 if (ckWARN(WARN_SYNTAX)) {
11883 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11887 const bool hash = kid->op_type == OP_PADHV
11888 || kid->op_type == OP_RV2HV;
11889 switch (kid->op_type) {
11894 name = S_op_varname(aTHX_ kid);
11900 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11901 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11903 SVfARG(name), hash ? "keys " : "", SVfARG(name)
11906 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11907 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11908 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11910 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11911 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11912 "length() used on @array (did you mean \"scalar(@array)\"?)");
11922 ---------------------------------------------------------
11924 Common vars in list assignment
11926 There now follows some enums and static functions for detecting
11927 common variables in list assignments. Here is a little essay I wrote
11928 for myself when trying to get my head around this. DAPM.
11932 First some random observations:
11934 * If a lexical var is an alias of something else, e.g.
11935 for my $x ($lex, $pkg, $a[0]) {...}
11936 then the act of aliasing will increase the reference count of the SV
11938 * If a package var is an alias of something else, it may still have a
11939 reference count of 1, depending on how the alias was created, e.g.
11940 in *a = *b, $a may have a refcount of 1 since the GP is shared
11941 with a single GvSV pointer to the SV. So If it's an alias of another
11942 package var, then RC may be 1; if it's an alias of another scalar, e.g.
11943 a lexical var or an array element, then it will have RC > 1.
11945 * There are many ways to create a package alias; ultimately, XS code
11946 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
11947 run-time tracing mechanisms are unlikely to be able to catch all cases.
11949 * When the LHS is all my declarations, the same vars can't appear directly
11950 on the RHS, but they can indirectly via closures, aliasing and lvalue
11951 subs. But those techniques all involve an increase in the lexical
11952 scalar's ref count.
11954 * When the LHS is all lexical vars (but not necessarily my declarations),
11955 it is possible for the same lexicals to appear directly on the RHS, and
11956 without an increased ref count, since the stack isn't refcounted.
11957 This case can be detected at compile time by scanning for common lex
11958 vars with PL_generation.
11960 * lvalue subs defeat common var detection, but they do at least
11961 return vars with a temporary ref count increment. Also, you can't
11962 tell at compile time whether a sub call is lvalue.
11967 A: There are a few circumstances where there definitely can't be any
11970 LHS empty: () = (...);
11971 RHS empty: (....) = ();
11972 RHS contains only constants or other 'can't possibly be shared'
11973 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
11974 i.e. they only contain ops not marked as dangerous, whose children
11975 are also not dangerous;
11977 LHS contains a single scalar element: e.g. ($x) = (....); because
11978 after $x has been modified, it won't be used again on the RHS;
11979 RHS contains a single element with no aggregate on LHS: e.g.
11980 ($a,$b,$c) = ($x); again, once $a has been modified, its value
11981 won't be used again.
11983 B: If LHS are all 'my' lexical var declarations (or safe ops, which
11986 my ($a, $b, @c) = ...;
11988 Due to closure and goto tricks, these vars may already have content.
11989 For the same reason, an element on the RHS may be a lexical or package
11990 alias of one of the vars on the left, or share common elements, for
11993 my ($x,$y) = f(); # $x and $y on both sides
11994 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
11999 my @a = @$ra; # elements of @a on both sides
12000 sub f { @a = 1..4; \@a }
12003 First, just consider scalar vars on LHS:
12005 RHS is safe only if (A), or in addition,
12006 * contains only lexical *scalar* vars, where neither side's
12007 lexicals have been flagged as aliases
12009 If RHS is not safe, then it's always legal to check LHS vars for
12010 RC==1, since the only RHS aliases will always be associated
12013 Note that in particular, RHS is not safe if:
12015 * it contains package scalar vars; e.g.:
12018 my ($x, $y) = (2, $x_alias);
12019 sub f { $x = 1; *x_alias = \$x; }
12021 * It contains other general elements, such as flattened or
12022 * spliced or single array or hash elements, e.g.
12025 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12029 use feature 'refaliasing';
12030 \($a[0], $a[1]) = \($y,$x);
12033 It doesn't matter if the array/hash is lexical or package.
12035 * it contains a function call that happens to be an lvalue
12036 sub which returns one or more of the above, e.g.
12047 (so a sub call on the RHS should be treated the same
12048 as having a package var on the RHS).
12050 * any other "dangerous" thing, such an op or built-in that
12051 returns one of the above, e.g. pp_preinc
12054 If RHS is not safe, what we can do however is at compile time flag
12055 that the LHS are all my declarations, and at run time check whether
12056 all the LHS have RC == 1, and if so skip the full scan.
12058 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12060 Here the issue is whether there can be elements of @a on the RHS
12061 which will get prematurely freed when @a is cleared prior to
12062 assignment. This is only a problem if the aliasing mechanism
12063 is one which doesn't increase the refcount - only if RC == 1
12064 will the RHS element be prematurely freed.
12066 Because the array/hash is being INTROed, it or its elements
12067 can't directly appear on the RHS:
12069 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12071 but can indirectly, e.g.:
12075 sub f { @a = 1..3; \@a }
12077 So if the RHS isn't safe as defined by (A), we must always
12078 mortalise and bump the ref count of any remaining RHS elements
12079 when assigning to a non-empty LHS aggregate.
12081 Lexical scalars on the RHS aren't safe if they've been involved in
12084 use feature 'refaliasing';
12087 \(my $lex) = \$pkg;
12088 my @a = ($lex,3); # equivalent to ($a[0],3)
12095 Similarly with lexical arrays and hashes on the RHS:
12109 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12110 my $a; ($a, my $b) = (....);
12112 The difference between (B) and (C) is that it is now physically
12113 possible for the LHS vars to appear on the RHS too, where they
12114 are not reference counted; but in this case, the compile-time
12115 PL_generation sweep will detect such common vars.
12117 So the rules for (C) differ from (B) in that if common vars are
12118 detected, the runtime "test RC==1" optimisation can no longer be used,
12119 and a full mark and sweep is required
12121 D: As (C), but in addition the LHS may contain package vars.
12123 Since package vars can be aliased without a corresponding refcount
12124 increase, all bets are off. It's only safe if (A). E.g.
12126 my ($x, $y) = (1,2);
12128 for $x_alias ($x) {
12129 ($x_alias, $y) = (3, $x); # whoops
12132 Ditto for LHS aggregate package vars.
12134 E: Any other dangerous ops on LHS, e.g.
12135 (f(), $a[0], @$r) = (...);
12137 this is similar to (E) in that all bets are off. In addition, it's
12138 impossible to determine at compile time whether the LHS
12139 contains a scalar or an aggregate, e.g.
12141 sub f : lvalue { @a }
12144 * ---------------------------------------------------------
12148 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12149 * that at least one of the things flagged was seen.
12153 AAS_MY_SCALAR = 0x001, /* my $scalar */
12154 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
12155 AAS_LEX_SCALAR = 0x004, /* $lexical */
12156 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
12157 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12158 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
12159 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
12160 AAS_DANGEROUS = 0x080, /* an op (other than the above)
12161 that's flagged OA_DANGEROUS */
12162 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
12163 not in any of the categories above */
12164 AAS_DEFAV = 0x200, /* contains just a single '@_' on RHS */
12169 /* helper function for S_aassign_scan().
12170 * check a PAD-related op for commonality and/or set its generation number.
12171 * Returns a boolean indicating whether its shared */
12174 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12176 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12177 /* lexical used in aliasing */
12181 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12183 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12190 Helper function for OPpASSIGN_COMMON* detection in rpeep().
12191 It scans the left or right hand subtree of the aassign op, and returns a
12192 set of flags indicating what sorts of things it found there.
12193 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12194 set PL_generation on lexical vars; if the latter, we see if
12195 PL_generation matches.
12196 'top' indicates whether we're recursing or at the top level.
12197 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12198 This fn will increment it by the number seen. It's not intended to
12199 be an accurate count (especially as many ops can push a variable
12200 number of SVs onto the stack); rather it's used as to test whether there
12201 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12205 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12208 bool kid_top = FALSE;
12210 /* first, look for a solitary @_ on the RHS */
12213 && (o->op_flags & OPf_KIDS)
12214 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12216 OP *kid = cUNOPo->op_first;
12217 if ( ( kid->op_type == OP_PUSHMARK
12218 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12219 && ((kid = OpSIBLING(kid)))
12220 && !OpHAS_SIBLING(kid)
12221 && kid->op_type == OP_RV2AV
12222 && !(kid->op_flags & OPf_REF)
12223 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12224 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12225 && ((kid = cUNOPx(kid)->op_first))
12226 && kid->op_type == OP_GV
12227 && cGVOPx_gv(kid) == PL_defgv
12229 flags |= AAS_DEFAV;
12232 switch (o->op_type) {
12235 return AAS_PKG_SCALAR;
12240 if (top && (o->op_flags & OPf_REF))
12241 return (o->op_private & OPpLVAL_INTRO)
12242 ? AAS_MY_AGG : AAS_LEX_AGG;
12243 return AAS_DANGEROUS;
12247 int comm = S_aassign_padcheck(aTHX_ o, rhs)
12248 ? AAS_LEX_SCALAR_COMM : 0;
12250 return (o->op_private & OPpLVAL_INTRO)
12251 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12257 if (cUNOPx(o)->op_first->op_type != OP_GV)
12258 return AAS_DANGEROUS; /* @{expr}, %{expr} */
12260 if (top && (o->op_flags & OPf_REF))
12261 return AAS_PKG_AGG;
12262 return AAS_DANGEROUS;
12266 if (cUNOPx(o)->op_first->op_type != OP_GV) {
12268 return AAS_DANGEROUS; /* ${expr} */
12270 return AAS_PKG_SCALAR; /* $pkg */
12273 if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
12274 /* "@foo = split... " optimises away the aassign and stores its
12275 * destination array in the OP_PUSHRE that precedes it.
12276 * A flattened array is always dangerous.
12279 return AAS_DANGEROUS;
12284 /* undef counts as a scalar on the RHS:
12285 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
12286 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
12290 flags = AAS_SAFE_SCALAR;
12295 /* these are all no-ops; they don't push a potentially common SV
12296 * onto the stack, so they are neither AAS_DANGEROUS nor
12297 * AAS_SAFE_SCALAR */
12300 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12305 /* these do nothing but may have children; but their children
12306 * should also be treated as top-level */
12311 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12313 return AAS_DANGEROUS;
12316 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
12317 && (o->op_private & OPpTARGET_MY))
12320 return S_aassign_padcheck(aTHX_ o, rhs)
12321 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12324 /* if its an unrecognised, non-dangerous op, assume that it
12325 * it the cause of at least one safe scalar */
12327 flags = AAS_SAFE_SCALAR;
12331 if (o->op_flags & OPf_KIDS) {
12333 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12334 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12340 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12341 and modify the optree to make them work inplace */
12344 S_inplace_aassign(pTHX_ OP *o) {
12346 OP *modop, *modop_pushmark;
12348 OP *oleft, *oleft_pushmark;
12350 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12352 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12354 assert(cUNOPo->op_first->op_type == OP_NULL);
12355 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12356 assert(modop_pushmark->op_type == OP_PUSHMARK);
12357 modop = OpSIBLING(modop_pushmark);
12359 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12362 /* no other operation except sort/reverse */
12363 if (OpHAS_SIBLING(modop))
12366 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12367 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12369 if (modop->op_flags & OPf_STACKED) {
12370 /* skip sort subroutine/block */
12371 assert(oright->op_type == OP_NULL);
12372 oright = OpSIBLING(oright);
12375 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12376 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12377 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12378 oleft = OpSIBLING(oleft_pushmark);
12380 /* Check the lhs is an array */
12382 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12383 || OpHAS_SIBLING(oleft)
12384 || (oleft->op_private & OPpLVAL_INTRO)
12388 /* Only one thing on the rhs */
12389 if (OpHAS_SIBLING(oright))
12392 /* check the array is the same on both sides */
12393 if (oleft->op_type == OP_RV2AV) {
12394 if (oright->op_type != OP_RV2AV
12395 || !cUNOPx(oright)->op_first
12396 || cUNOPx(oright)->op_first->op_type != OP_GV
12397 || cUNOPx(oleft )->op_first->op_type != OP_GV
12398 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12399 cGVOPx_gv(cUNOPx(oright)->op_first)
12403 else if (oright->op_type != OP_PADAV
12404 || oright->op_targ != oleft->op_targ
12408 /* This actually is an inplace assignment */
12410 modop->op_private |= OPpSORT_INPLACE;
12412 /* transfer MODishness etc from LHS arg to RHS arg */
12413 oright->op_flags = oleft->op_flags;
12415 /* remove the aassign op and the lhs */
12417 op_null(oleft_pushmark);
12418 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12419 op_null(cUNOPx(oleft)->op_first);
12425 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12426 * that potentially represent a series of one or more aggregate derefs
12427 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12428 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12429 * additional ops left in too).
12431 * The caller will have already verified that the first few ops in the
12432 * chain following 'start' indicate a multideref candidate, and will have
12433 * set 'orig_o' to the point further on in the chain where the first index
12434 * expression (if any) begins. 'orig_action' specifies what type of
12435 * beginning has already been determined by the ops between start..orig_o
12436 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12438 * 'hints' contains any hints flags that need adding (currently just
12439 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12443 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12447 UNOP_AUX_item *arg_buf = NULL;
12448 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12449 int index_skip = -1; /* don't output index arg on this action */
12451 /* similar to regex compiling, do two passes; the first pass
12452 * determines whether the op chain is convertible and calculates the
12453 * buffer size; the second pass populates the buffer and makes any
12454 * changes necessary to ops (such as moving consts to the pad on
12455 * threaded builds).
12457 * NB: for things like Coverity, note that both passes take the same
12458 * path through the logic tree (except for 'if (pass)' bits), since
12459 * both passes are following the same op_next chain; and in
12460 * particular, if it would return early on the second pass, it would
12461 * already have returned early on the first pass.
12463 for (pass = 0; pass < 2; pass++) {
12465 UV action = orig_action;
12466 OP *first_elem_op = NULL; /* first seen aelem/helem */
12467 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12468 int action_count = 0; /* number of actions seen so far */
12469 int action_ix = 0; /* action_count % (actions per IV) */
12470 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12471 bool is_last = FALSE; /* no more derefs to follow */
12472 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12473 UNOP_AUX_item *arg = arg_buf;
12474 UNOP_AUX_item *action_ptr = arg_buf;
12477 action_ptr->uv = 0;
12481 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12482 case MDEREF_HV_gvhv_helem:
12483 next_is_hash = TRUE;
12485 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12486 case MDEREF_AV_gvav_aelem:
12488 #ifdef USE_ITHREADS
12489 arg->pad_offset = cPADOPx(start)->op_padix;
12490 /* stop it being swiped when nulled */
12491 cPADOPx(start)->op_padix = 0;
12493 arg->sv = cSVOPx(start)->op_sv;
12494 cSVOPx(start)->op_sv = NULL;
12500 case MDEREF_HV_padhv_helem:
12501 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12502 next_is_hash = TRUE;
12504 case MDEREF_AV_padav_aelem:
12505 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12507 arg->pad_offset = start->op_targ;
12508 /* we skip setting op_targ = 0 for now, since the intact
12509 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12510 reset_start_targ = TRUE;
12515 case MDEREF_HV_pop_rv2hv_helem:
12516 next_is_hash = TRUE;
12518 case MDEREF_AV_pop_rv2av_aelem:
12522 NOT_REACHED; /* NOTREACHED */
12527 /* look for another (rv2av/hv; get index;
12528 * aelem/helem/exists/delele) sequence */
12533 UV index_type = MDEREF_INDEX_none;
12535 if (action_count) {
12536 /* if this is not the first lookup, consume the rv2av/hv */
12538 /* for N levels of aggregate lookup, we normally expect
12539 * that the first N-1 [ah]elem ops will be flagged as
12540 * /DEREF (so they autovivifiy if necessary), and the last
12541 * lookup op not to be.
12542 * For other things (like @{$h{k1}{k2}}) extra scope or
12543 * leave ops can appear, so abandon the effort in that
12545 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12548 /* rv2av or rv2hv sKR/1 */
12550 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12551 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12552 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12555 /* at this point, we wouldn't expect any of these
12556 * possible private flags:
12557 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12558 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12560 ASSUME(!(o->op_private &
12561 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12563 hints = (o->op_private & OPpHINT_STRICT_REFS);
12565 /* make sure the type of the previous /DEREF matches the
12566 * type of the next lookup */
12567 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12570 action = next_is_hash
12571 ? MDEREF_HV_vivify_rv2hv_helem
12572 : MDEREF_AV_vivify_rv2av_aelem;
12576 /* if this is the second pass, and we're at the depth where
12577 * previously we encountered a non-simple index expression,
12578 * stop processing the index at this point */
12579 if (action_count != index_skip) {
12581 /* look for one or more simple ops that return an array
12582 * index or hash key */
12584 switch (o->op_type) {
12586 /* it may be a lexical var index */
12587 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12588 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12589 ASSUME(!(o->op_private &
12590 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12592 if ( OP_GIMME(o,0) == G_SCALAR
12593 && !(o->op_flags & (OPf_REF|OPf_MOD))
12594 && o->op_private == 0)
12597 arg->pad_offset = o->op_targ;
12599 index_type = MDEREF_INDEX_padsv;
12605 if (next_is_hash) {
12606 /* it's a constant hash index */
12607 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12608 /* "use constant foo => FOO; $h{+foo}" for
12609 * some weird FOO, can leave you with constants
12610 * that aren't simple strings. It's not worth
12611 * the extra hassle for those edge cases */
12616 OP * helem_op = o->op_next;
12618 ASSUME( helem_op->op_type == OP_HELEM
12619 || helem_op->op_type == OP_NULL);
12620 if (helem_op->op_type == OP_HELEM) {
12621 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12622 if ( helem_op->op_private & OPpLVAL_INTRO
12623 || rop->op_type != OP_RV2HV
12627 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12629 #ifdef USE_ITHREADS
12630 /* Relocate sv to the pad for thread safety */
12631 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12632 arg->pad_offset = o->op_targ;
12635 arg->sv = cSVOPx_sv(o);
12640 /* it's a constant array index */
12642 SV *ix_sv = cSVOPo->op_sv;
12647 if ( action_count == 0
12650 && ( action == MDEREF_AV_padav_aelem
12651 || action == MDEREF_AV_gvav_aelem)
12653 maybe_aelemfast = TRUE;
12657 SvREFCNT_dec_NN(cSVOPo->op_sv);
12661 /* we've taken ownership of the SV */
12662 cSVOPo->op_sv = NULL;
12664 index_type = MDEREF_INDEX_const;
12669 /* it may be a package var index */
12671 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12672 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12673 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12674 || o->op_private != 0
12679 if (kid->op_type != OP_RV2SV)
12682 ASSUME(!(kid->op_flags &
12683 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12684 |OPf_SPECIAL|OPf_PARENS)));
12685 ASSUME(!(kid->op_private &
12687 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12688 |OPpDEREF|OPpLVAL_INTRO)));
12689 if( (kid->op_flags &~ OPf_PARENS)
12690 != (OPf_WANT_SCALAR|OPf_KIDS)
12691 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12696 #ifdef USE_ITHREADS
12697 arg->pad_offset = cPADOPx(o)->op_padix;
12698 /* stop it being swiped when nulled */
12699 cPADOPx(o)->op_padix = 0;
12701 arg->sv = cSVOPx(o)->op_sv;
12702 cSVOPo->op_sv = NULL;
12706 index_type = MDEREF_INDEX_gvsv;
12711 } /* action_count != index_skip */
12713 action |= index_type;
12716 /* at this point we have either:
12717 * * detected what looks like a simple index expression,
12718 * and expect the next op to be an [ah]elem, or
12719 * an nulled [ah]elem followed by a delete or exists;
12720 * * found a more complex expression, so something other
12721 * than the above follows.
12724 /* possibly an optimised away [ah]elem (where op_next is
12725 * exists or delete) */
12726 if (o->op_type == OP_NULL)
12729 /* at this point we're looking for an OP_AELEM, OP_HELEM,
12730 * OP_EXISTS or OP_DELETE */
12732 /* if something like arybase (a.k.a $[ ) is in scope,
12733 * abandon optimisation attempt */
12734 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12735 && PL_check[o->op_type] != Perl_ck_null)
12738 if ( o->op_type != OP_AELEM
12739 || (o->op_private &
12740 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12742 maybe_aelemfast = FALSE;
12744 /* look for aelem/helem/exists/delete. If it's not the last elem
12745 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12746 * flags; if it's the last, then it mustn't have
12747 * OPpDEREF_AV/HV, but may have lots of other flags, like
12748 * OPpLVAL_INTRO etc
12751 if ( index_type == MDEREF_INDEX_none
12752 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
12753 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12757 /* we have aelem/helem/exists/delete with valid simple index */
12759 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12760 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
12761 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12764 ASSUME(!(o->op_flags &
12765 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12766 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12768 ok = (o->op_flags &~ OPf_PARENS)
12769 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12770 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12772 else if (o->op_type == OP_EXISTS) {
12773 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12774 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12775 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12776 ok = !(o->op_private & ~OPpARG1_MASK);
12778 else if (o->op_type == OP_DELETE) {
12779 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12780 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12781 ASSUME(!(o->op_private &
12782 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12783 /* don't handle slices or 'local delete'; the latter
12784 * is fairly rare, and has a complex runtime */
12785 ok = !(o->op_private & ~OPpARG1_MASK);
12786 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12787 /* skip handling run-tome error */
12788 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12791 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12792 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12793 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12794 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12795 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12796 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12801 if (!first_elem_op)
12805 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12810 action |= MDEREF_FLAG_last;
12814 /* at this point we have something that started
12815 * promisingly enough (with rv2av or whatever), but failed
12816 * to find a simple index followed by an
12817 * aelem/helem/exists/delete. If this is the first action,
12818 * give up; but if we've already seen at least one
12819 * aelem/helem, then keep them and add a new action with
12820 * MDEREF_INDEX_none, which causes it to do the vivify
12821 * from the end of the previous lookup, and do the deref,
12822 * but stop at that point. So $a[0][expr] will do one
12823 * av_fetch, vivify and deref, then continue executing at
12828 index_skip = action_count;
12829 action |= MDEREF_FLAG_last;
12833 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12836 /* if there's no space for the next action, create a new slot
12837 * for it *before* we start adding args for that action */
12838 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12845 } /* while !is_last */
12853 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12854 if (index_skip == -1) {
12855 mderef->op_flags = o->op_flags
12856 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12857 if (o->op_type == OP_EXISTS)
12858 mderef->op_private = OPpMULTIDEREF_EXISTS;
12859 else if (o->op_type == OP_DELETE)
12860 mderef->op_private = OPpMULTIDEREF_DELETE;
12862 mderef->op_private = o->op_private
12863 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12865 /* accumulate strictness from every level (although I don't think
12866 * they can actually vary) */
12867 mderef->op_private |= hints;
12869 /* integrate the new multideref op into the optree and the
12872 * In general an op like aelem or helem has two child
12873 * sub-trees: the aggregate expression (a_expr) and the
12874 * index expression (i_expr):
12880 * The a_expr returns an AV or HV, while the i-expr returns an
12881 * index. In general a multideref replaces most or all of a
12882 * multi-level tree, e.g.
12898 * With multideref, all the i_exprs will be simple vars or
12899 * constants, except that i_expr1 may be arbitrary in the case
12900 * of MDEREF_INDEX_none.
12902 * The bottom-most a_expr will be either:
12903 * 1) a simple var (so padXv or gv+rv2Xv);
12904 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
12905 * so a simple var with an extra rv2Xv;
12906 * 3) or an arbitrary expression.
12908 * 'start', the first op in the execution chain, will point to
12909 * 1),2): the padXv or gv op;
12910 * 3): the rv2Xv which forms the last op in the a_expr
12911 * execution chain, and the top-most op in the a_expr
12914 * For all cases, the 'start' node is no longer required,
12915 * but we can't free it since one or more external nodes
12916 * may point to it. E.g. consider
12917 * $h{foo} = $a ? $b : $c
12918 * Here, both the op_next and op_other branches of the
12919 * cond_expr point to the gv[*h] of the hash expression, so
12920 * we can't free the 'start' op.
12922 * For expr->[...], we need to save the subtree containing the
12923 * expression; for the other cases, we just need to save the
12925 * So in all cases, we null the start op and keep it around by
12926 * making it the child of the multideref op; for the expr->
12927 * case, the expr will be a subtree of the start node.
12929 * So in the simple 1,2 case the optree above changes to
12935 * ex-gv (or ex-padxv)
12937 * with the op_next chain being
12939 * -> ex-gv -> multideref -> op-following-ex-exists ->
12941 * In the 3 case, we have
12954 * -> rest-of-a_expr subtree ->
12955 * ex-rv2xv -> multideref -> op-following-ex-exists ->
12958 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
12959 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
12960 * multideref attached as the child, e.g.
12966 * ex-rv2av - i_expr1
12974 /* if we free this op, don't free the pad entry */
12975 if (reset_start_targ)
12976 start->op_targ = 0;
12979 /* Cut the bit we need to save out of the tree and attach to
12980 * the multideref op, then free the rest of the tree */
12982 /* find parent of node to be detached (for use by splice) */
12984 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
12985 || orig_action == MDEREF_HV_pop_rv2hv_helem)
12987 /* there is an arbitrary expression preceding us, e.g.
12988 * expr->[..]? so we need to save the 'expr' subtree */
12989 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
12990 p = cUNOPx(p)->op_first;
12991 ASSUME( start->op_type == OP_RV2AV
12992 || start->op_type == OP_RV2HV);
12995 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
12996 * above for exists/delete. */
12997 while ( (p->op_flags & OPf_KIDS)
12998 && cUNOPx(p)->op_first != start
13000 p = cUNOPx(p)->op_first;
13002 ASSUME(cUNOPx(p)->op_first == start);
13004 /* detach from main tree, and re-attach under the multideref */
13005 op_sibling_splice(mderef, NULL, 0,
13006 op_sibling_splice(p, NULL, 1, NULL));
13009 start->op_next = mderef;
13011 mderef->op_next = index_skip == -1 ? o->op_next : o;
13013 /* excise and free the original tree, and replace with
13014 * the multideref op */
13015 p = op_sibling_splice(top_op, NULL, -1, mderef);
13024 Size_t size = arg - arg_buf;
13026 if (maybe_aelemfast && action_count == 1)
13029 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13030 sizeof(UNOP_AUX_item) * (size + 1));
13031 /* for dumping etc: store the length in a hidden first slot;
13032 * we set the op_aux pointer to the second slot */
13033 arg_buf->uv = size;
13036 } /* for (pass = ...) */
13041 /* mechanism for deferring recursion in rpeep() */
13043 #define MAX_DEFERRED 4
13047 if (defer_ix == (MAX_DEFERRED-1)) { \
13048 OP **defer = defer_queue[defer_base]; \
13049 CALL_RPEEP(*defer); \
13050 S_prune_chain_head(defer); \
13051 defer_base = (defer_base + 1) % MAX_DEFERRED; \
13054 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13057 #define IS_AND_OP(o) (o->op_type == OP_AND)
13058 #define IS_OR_OP(o) (o->op_type == OP_OR)
13061 /* A peephole optimizer. We visit the ops in the order they're to execute.
13062 * See the comments at the top of this file for more details about when
13063 * peep() is called */
13066 Perl_rpeep(pTHX_ OP *o)
13070 OP* oldoldop = NULL;
13071 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13072 int defer_base = 0;
13077 if (!o || o->op_opt)
13081 SAVEVPTR(PL_curcop);
13082 for (;; o = o->op_next) {
13083 if (o && o->op_opt)
13086 while (defer_ix >= 0) {
13088 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13089 CALL_RPEEP(*defer);
13090 S_prune_chain_head(defer);
13096 /* By default, this op has now been optimised. A couple of cases below
13097 clear this again. */
13101 /* look for a series of 1 or more aggregate derefs, e.g.
13102 * $a[1]{foo}[$i]{$k}
13103 * and replace with a single OP_MULTIDEREF op.
13104 * Each index must be either a const, or a simple variable,
13106 * First, look for likely combinations of starting ops,
13107 * corresponding to (global and lexical variants of)
13109 * $r->[...] $r->{...}
13110 * (preceding expression)->[...]
13111 * (preceding expression)->{...}
13112 * and if so, call maybe_multideref() to do a full inspection
13113 * of the op chain and if appropriate, replace with an
13121 switch (o2->op_type) {
13123 /* $pkg[..] : gv[*pkg]
13124 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
13126 /* Fail if there are new op flag combinations that we're
13127 * not aware of, rather than:
13128 * * silently failing to optimise, or
13129 * * silently optimising the flag away.
13130 * If this ASSUME starts failing, examine what new flag
13131 * has been added to the op, and decide whether the
13132 * optimisation should still occur with that flag, then
13133 * update the code accordingly. This applies to all the
13134 * other ASSUMEs in the block of code too.
13136 ASSUME(!(o2->op_flags &
13137 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13138 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13142 if (o2->op_type == OP_RV2AV) {
13143 action = MDEREF_AV_gvav_aelem;
13147 if (o2->op_type == OP_RV2HV) {
13148 action = MDEREF_HV_gvhv_helem;
13152 if (o2->op_type != OP_RV2SV)
13155 /* at this point we've seen gv,rv2sv, so the only valid
13156 * construct left is $pkg->[] or $pkg->{} */
13158 ASSUME(!(o2->op_flags & OPf_STACKED));
13159 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13160 != (OPf_WANT_SCALAR|OPf_MOD))
13163 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13164 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13165 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13167 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
13168 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13172 if (o2->op_type == OP_RV2AV) {
13173 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13176 if (o2->op_type == OP_RV2HV) {
13177 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13183 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13185 ASSUME(!(o2->op_flags &
13186 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13187 if ((o2->op_flags &
13188 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13189 != (OPf_WANT_SCALAR|OPf_MOD))
13192 ASSUME(!(o2->op_private &
13193 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13194 /* skip if state or intro, or not a deref */
13195 if ( o2->op_private != OPpDEREF_AV
13196 && o2->op_private != OPpDEREF_HV)
13200 if (o2->op_type == OP_RV2AV) {
13201 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13204 if (o2->op_type == OP_RV2HV) {
13205 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13212 /* $lex[..]: padav[@lex:1,2] sR *
13213 * or $lex{..}: padhv[%lex:1,2] sR */
13214 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13215 OPf_REF|OPf_SPECIAL)));
13216 if ((o2->op_flags &
13217 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13218 != (OPf_WANT_SCALAR|OPf_REF))
13220 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13222 /* OPf_PARENS isn't currently used in this case;
13223 * if that changes, let us know! */
13224 ASSUME(!(o2->op_flags & OPf_PARENS));
13226 /* at this point, we wouldn't expect any of the remaining
13227 * possible private flags:
13228 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13229 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13231 * OPpSLICEWARNING shouldn't affect runtime
13233 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13235 action = o2->op_type == OP_PADAV
13236 ? MDEREF_AV_padav_aelem
13237 : MDEREF_HV_padhv_helem;
13239 S_maybe_multideref(aTHX_ o, o2, action, 0);
13245 action = o2->op_type == OP_RV2AV
13246 ? MDEREF_AV_pop_rv2av_aelem
13247 : MDEREF_HV_pop_rv2hv_helem;
13250 /* (expr)->[...]: rv2av sKR/1;
13251 * (expr)->{...}: rv2hv sKR/1; */
13253 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13255 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13256 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13257 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13260 /* at this point, we wouldn't expect any of these
13261 * possible private flags:
13262 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13263 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13265 ASSUME(!(o2->op_private &
13266 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13268 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13272 S_maybe_multideref(aTHX_ o, o2, action, hints);
13281 switch (o->op_type) {
13283 PL_curcop = ((COP*)o); /* for warnings */
13286 PL_curcop = ((COP*)o); /* for warnings */
13288 /* Optimise a "return ..." at the end of a sub to just be "...".
13289 * This saves 2 ops. Before:
13290 * 1 <;> nextstate(main 1 -e:1) v ->2
13291 * 4 <@> return K ->5
13292 * 2 <0> pushmark s ->3
13293 * - <1> ex-rv2sv sK/1 ->4
13294 * 3 <#> gvsv[*cat] s ->4
13297 * - <@> return K ->-
13298 * - <0> pushmark s ->2
13299 * - <1> ex-rv2sv sK/1 ->-
13300 * 2 <$> gvsv(*cat) s ->3
13303 OP *next = o->op_next;
13304 OP *sibling = OpSIBLING(o);
13305 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13306 && OP_TYPE_IS(sibling, OP_RETURN)
13307 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13308 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13309 ||OP_TYPE_IS(sibling->op_next->op_next,
13311 && cUNOPx(sibling)->op_first == next
13312 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13315 /* Look through the PUSHMARK's siblings for one that
13316 * points to the RETURN */
13317 OP *top = OpSIBLING(next);
13318 while (top && top->op_next) {
13319 if (top->op_next == sibling) {
13320 top->op_next = sibling->op_next;
13321 o->op_next = next->op_next;
13324 top = OpSIBLING(top);
13329 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13331 * This latter form is then suitable for conversion into padrange
13332 * later on. Convert:
13334 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13338 * nextstate1 -> listop -> nextstate3
13340 * pushmark -> padop1 -> padop2
13342 if (o->op_next && (
13343 o->op_next->op_type == OP_PADSV
13344 || o->op_next->op_type == OP_PADAV
13345 || o->op_next->op_type == OP_PADHV
13347 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13348 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13349 && o->op_next->op_next->op_next && (
13350 o->op_next->op_next->op_next->op_type == OP_PADSV
13351 || o->op_next->op_next->op_next->op_type == OP_PADAV
13352 || o->op_next->op_next->op_next->op_type == OP_PADHV
13354 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13355 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13356 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13357 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13359 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13362 ns2 = pad1->op_next;
13363 pad2 = ns2->op_next;
13364 ns3 = pad2->op_next;
13366 /* we assume here that the op_next chain is the same as
13367 * the op_sibling chain */
13368 assert(OpSIBLING(o) == pad1);
13369 assert(OpSIBLING(pad1) == ns2);
13370 assert(OpSIBLING(ns2) == pad2);
13371 assert(OpSIBLING(pad2) == ns3);
13373 /* excise and delete ns2 */
13374 op_sibling_splice(NULL, pad1, 1, NULL);
13377 /* excise pad1 and pad2 */
13378 op_sibling_splice(NULL, o, 2, NULL);
13380 /* create new listop, with children consisting of:
13381 * a new pushmark, pad1, pad2. */
13382 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13383 newop->op_flags |= OPf_PARENS;
13384 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13386 /* insert newop between o and ns3 */
13387 op_sibling_splice(NULL, o, 0, newop);
13389 /*fixup op_next chain */
13390 newpm = cUNOPx(newop)->op_first; /* pushmark */
13391 o ->op_next = newpm;
13392 newpm->op_next = pad1;
13393 pad1 ->op_next = pad2;
13394 pad2 ->op_next = newop; /* listop */
13395 newop->op_next = ns3;
13397 /* Ensure pushmark has this flag if padops do */
13398 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13399 newpm->op_flags |= OPf_MOD;
13405 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13406 to carry two labels. For now, take the easier option, and skip
13407 this optimisation if the first NEXTSTATE has a label. */
13408 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13409 OP *nextop = o->op_next;
13410 while (nextop && nextop->op_type == OP_NULL)
13411 nextop = nextop->op_next;
13413 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13416 oldop->op_next = nextop;
13417 /* Skip (old)oldop assignment since the current oldop's
13418 op_next already points to the next op. */
13425 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13426 if (o->op_next->op_private & OPpTARGET_MY) {
13427 if (o->op_flags & OPf_STACKED) /* chained concats */
13428 break; /* ignore_optimization */
13430 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13431 o->op_targ = o->op_next->op_targ;
13432 o->op_next->op_targ = 0;
13433 o->op_private |= OPpTARGET_MY;
13436 op_null(o->op_next);
13440 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13441 break; /* Scalar stub must produce undef. List stub is noop */
13445 if (o->op_targ == OP_NEXTSTATE
13446 || o->op_targ == OP_DBSTATE)
13448 PL_curcop = ((COP*)o);
13450 /* XXX: We avoid setting op_seq here to prevent later calls
13451 to rpeep() from mistakenly concluding that optimisation
13452 has already occurred. This doesn't fix the real problem,
13453 though (See 20010220.007). AMS 20010719 */
13454 /* op_seq functionality is now replaced by op_opt */
13462 oldop->op_next = o->op_next;
13476 convert repeat into a stub with no kids.
13478 if (o->op_next->op_type == OP_CONST
13479 || ( o->op_next->op_type == OP_PADSV
13480 && !(o->op_next->op_private & OPpLVAL_INTRO))
13481 || ( o->op_next->op_type == OP_GV
13482 && o->op_next->op_next->op_type == OP_RV2SV
13483 && !(o->op_next->op_next->op_private
13484 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13486 const OP *kid = o->op_next->op_next;
13487 if (o->op_next->op_type == OP_GV)
13488 kid = kid->op_next;
13489 /* kid is now the ex-list. */
13490 if (kid->op_type == OP_NULL
13491 && (kid = kid->op_next)->op_type == OP_CONST
13492 /* kid is now the repeat count. */
13493 && kid->op_next->op_type == OP_REPEAT
13494 && kid->op_next->op_private & OPpREPEAT_DOLIST
13495 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13496 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13498 o = kid->op_next; /* repeat */
13500 oldop->op_next = o;
13501 op_free(cBINOPo->op_first);
13502 op_free(cBINOPo->op_last );
13503 o->op_flags &=~ OPf_KIDS;
13504 /* stub is a baseop; repeat is a binop */
13505 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13506 OpTYPE_set(o, OP_STUB);
13512 /* Convert a series of PAD ops for my vars plus support into a
13513 * single padrange op. Basically
13515 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13517 * becomes, depending on circumstances, one of
13519 * padrange ----------------------------------> (list) -> rest
13520 * padrange --------------------------------------------> rest
13522 * where all the pad indexes are sequential and of the same type
13524 * We convert the pushmark into a padrange op, then skip
13525 * any other pad ops, and possibly some trailing ops.
13526 * Note that we don't null() the skipped ops, to make it
13527 * easier for Deparse to undo this optimisation (and none of
13528 * the skipped ops are holding any resourses). It also makes
13529 * it easier for find_uninit_var(), as it can just ignore
13530 * padrange, and examine the original pad ops.
13534 OP *followop = NULL; /* the op that will follow the padrange op */
13537 PADOFFSET base = 0; /* init only to stop compiler whining */
13538 bool gvoid = 0; /* init only to stop compiler whining */
13539 bool defav = 0; /* seen (...) = @_ */
13540 bool reuse = 0; /* reuse an existing padrange op */
13542 /* look for a pushmark -> gv[_] -> rv2av */
13547 if ( p->op_type == OP_GV
13548 && cGVOPx_gv(p) == PL_defgv
13549 && (rv2av = p->op_next)
13550 && rv2av->op_type == OP_RV2AV
13551 && !(rv2av->op_flags & OPf_REF)
13552 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13553 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13555 q = rv2av->op_next;
13556 if (q->op_type == OP_NULL)
13558 if (q->op_type == OP_PUSHMARK) {
13568 /* scan for PAD ops */
13570 for (p = p->op_next; p; p = p->op_next) {
13571 if (p->op_type == OP_NULL)
13574 if (( p->op_type != OP_PADSV
13575 && p->op_type != OP_PADAV
13576 && p->op_type != OP_PADHV
13578 /* any private flag other than INTRO? e.g. STATE */
13579 || (p->op_private & ~OPpLVAL_INTRO)
13583 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13585 if ( p->op_type == OP_PADAV
13587 && p->op_next->op_type == OP_CONST
13588 && p->op_next->op_next
13589 && p->op_next->op_next->op_type == OP_AELEM
13593 /* for 1st padop, note what type it is and the range
13594 * start; for the others, check that it's the same type
13595 * and that the targs are contiguous */
13597 intro = (p->op_private & OPpLVAL_INTRO);
13599 gvoid = OP_GIMME(p,0) == G_VOID;
13602 if ((p->op_private & OPpLVAL_INTRO) != intro)
13604 /* Note that you'd normally expect targs to be
13605 * contiguous in my($a,$b,$c), but that's not the case
13606 * when external modules start doing things, e.g.
13607 i* Function::Parameters */
13608 if (p->op_targ != base + count)
13610 assert(p->op_targ == base + count);
13611 /* Either all the padops or none of the padops should
13612 be in void context. Since we only do the optimisa-
13613 tion for av/hv when the aggregate itself is pushed
13614 on to the stack (one item), there is no need to dis-
13615 tinguish list from scalar context. */
13616 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13620 /* for AV, HV, only when we're not flattening */
13621 if ( p->op_type != OP_PADSV
13623 && !(p->op_flags & OPf_REF)
13627 if (count >= OPpPADRANGE_COUNTMASK)
13630 /* there's a biggest base we can fit into a
13631 * SAVEt_CLEARPADRANGE in pp_padrange */
13632 if (intro && base >
13633 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
13636 /* Success! We've got another valid pad op to optimise away */
13638 followop = p->op_next;
13641 if (count < 1 || (count == 1 && !defav))
13644 /* pp_padrange in specifically compile-time void context
13645 * skips pushing a mark and lexicals; in all other contexts
13646 * (including unknown till runtime) it pushes a mark and the
13647 * lexicals. We must be very careful then, that the ops we
13648 * optimise away would have exactly the same effect as the
13650 * In particular in void context, we can only optimise to
13651 * a padrange if see see the complete sequence
13652 * pushmark, pad*v, ...., list
13653 * which has the net effect of of leaving the markstack as it
13654 * was. Not pushing on to the stack (whereas padsv does touch
13655 * the stack) makes no difference in void context.
13659 if (followop->op_type == OP_LIST
13660 && OP_GIMME(followop,0) == G_VOID
13663 followop = followop->op_next; /* skip OP_LIST */
13665 /* consolidate two successive my(...);'s */
13668 && oldoldop->op_type == OP_PADRANGE
13669 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13670 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13671 && !(oldoldop->op_flags & OPf_SPECIAL)
13674 assert(oldoldop->op_next == oldop);
13675 assert( oldop->op_type == OP_NEXTSTATE
13676 || oldop->op_type == OP_DBSTATE);
13677 assert(oldop->op_next == o);
13680 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13682 /* Do not assume pad offsets for $c and $d are con-
13687 if ( oldoldop->op_targ + old_count == base
13688 && old_count < OPpPADRANGE_COUNTMASK - count) {
13689 base = oldoldop->op_targ;
13690 count += old_count;
13695 /* if there's any immediately following singleton
13696 * my var's; then swallow them and the associated
13698 * my ($a,$b); my $c; my $d;
13700 * my ($a,$b,$c,$d);
13703 while ( ((p = followop->op_next))
13704 && ( p->op_type == OP_PADSV
13705 || p->op_type == OP_PADAV
13706 || p->op_type == OP_PADHV)
13707 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13708 && (p->op_private & OPpLVAL_INTRO) == intro
13709 && !(p->op_private & ~OPpLVAL_INTRO)
13711 && ( p->op_next->op_type == OP_NEXTSTATE
13712 || p->op_next->op_type == OP_DBSTATE)
13713 && count < OPpPADRANGE_COUNTMASK
13714 && base + count == p->op_targ
13717 followop = p->op_next;
13725 assert(oldoldop->op_type == OP_PADRANGE);
13726 oldoldop->op_next = followop;
13727 oldoldop->op_private = (intro | count);
13733 /* Convert the pushmark into a padrange.
13734 * To make Deparse easier, we guarantee that a padrange was
13735 * *always* formerly a pushmark */
13736 assert(o->op_type == OP_PUSHMARK);
13737 o->op_next = followop;
13738 OpTYPE_set(o, OP_PADRANGE);
13740 /* bit 7: INTRO; bit 6..0: count */
13741 o->op_private = (intro | count);
13742 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13743 | gvoid * OPf_WANT_VOID
13744 | (defav ? OPf_SPECIAL : 0));
13752 /* Skip over state($x) in void context. */
13753 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13754 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13756 oldop->op_next = o->op_next;
13757 goto redo_nextstate;
13759 if (o->op_type != OP_PADAV)
13763 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13764 OP* const pop = (o->op_type == OP_PADAV) ?
13765 o->op_next : o->op_next->op_next;
13767 if (pop && pop->op_type == OP_CONST &&
13768 ((PL_op = pop->op_next)) &&
13769 pop->op_next->op_type == OP_AELEM &&
13770 !(pop->op_next->op_private &
13771 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13772 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13775 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13776 no_bareword_allowed(pop);
13777 if (o->op_type == OP_GV)
13778 op_null(o->op_next);
13779 op_null(pop->op_next);
13781 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13782 o->op_next = pop->op_next->op_next;
13783 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13784 o->op_private = (U8)i;
13785 if (o->op_type == OP_GV) {
13788 o->op_type = OP_AELEMFAST;
13791 o->op_type = OP_AELEMFAST_LEX;
13793 if (o->op_type != OP_GV)
13797 /* Remove $foo from the op_next chain in void context. */
13799 && ( o->op_next->op_type == OP_RV2SV
13800 || o->op_next->op_type == OP_RV2AV
13801 || o->op_next->op_type == OP_RV2HV )
13802 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13803 && !(o->op_next->op_private & OPpLVAL_INTRO))
13805 oldop->op_next = o->op_next->op_next;
13806 /* Reprocess the previous op if it is a nextstate, to
13807 allow double-nextstate optimisation. */
13809 if (oldop->op_type == OP_NEXTSTATE) {
13818 else if (o->op_next->op_type == OP_RV2SV) {
13819 if (!(o->op_next->op_private & OPpDEREF)) {
13820 op_null(o->op_next);
13821 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13823 o->op_next = o->op_next->op_next;
13824 OpTYPE_set(o, OP_GVSV);
13827 else if (o->op_next->op_type == OP_READLINE
13828 && o->op_next->op_next->op_type == OP_CONCAT
13829 && (o->op_next->op_next->op_flags & OPf_STACKED))
13831 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13832 OpTYPE_set(o, OP_RCATLINE);
13833 o->op_flags |= OPf_STACKED;
13834 op_null(o->op_next->op_next);
13835 op_null(o->op_next);
13840 #define HV_OR_SCALARHV(op) \
13841 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13843 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13844 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
13845 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
13846 ? cUNOPx(op)->op_first \
13850 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13851 fop->op_private |= OPpTRUEBOOL;
13857 fop = cLOGOP->op_first;
13858 sop = OpSIBLING(fop);
13859 while (cLOGOP->op_other->op_type == OP_NULL)
13860 cLOGOP->op_other = cLOGOP->op_other->op_next;
13861 while (o->op_next && ( o->op_type == o->op_next->op_type
13862 || o->op_next->op_type == OP_NULL))
13863 o->op_next = o->op_next->op_next;
13865 /* if we're an OR and our next is a AND in void context, we'll
13866 follow it's op_other on short circuit, same for reverse.
13867 We can't do this with OP_DOR since if it's true, its return
13868 value is the underlying value which must be evaluated
13872 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13873 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13875 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13877 o->op_next = ((LOGOP*)o->op_next)->op_other;
13879 DEFER(cLOGOP->op_other);
13882 fop = HV_OR_SCALARHV(fop);
13883 if (sop) sop = HV_OR_SCALARHV(sop);
13888 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
13889 while (nop && nop->op_next) {
13890 switch (nop->op_next->op_type) {
13895 lop = nop = nop->op_next;
13898 nop = nop->op_next;
13907 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13908 || o->op_type == OP_AND )
13909 fop->op_private |= OPpTRUEBOOL;
13910 else if (!(lop->op_flags & OPf_WANT))
13911 fop->op_private |= OPpMAYBE_TRUEBOOL;
13913 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13915 sop->op_private |= OPpTRUEBOOL;
13922 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
13923 fop->op_private |= OPpTRUEBOOL;
13924 #undef HV_OR_SCALARHV
13925 /* GERONIMO! */ /* FALLTHROUGH */
13934 while (cLOGOP->op_other->op_type == OP_NULL)
13935 cLOGOP->op_other = cLOGOP->op_other->op_next;
13936 DEFER(cLOGOP->op_other);
13941 while (cLOOP->op_redoop->op_type == OP_NULL)
13942 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
13943 while (cLOOP->op_nextop->op_type == OP_NULL)
13944 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
13945 while (cLOOP->op_lastop->op_type == OP_NULL)
13946 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
13947 /* a while(1) loop doesn't have an op_next that escapes the
13948 * loop, so we have to explicitly follow the op_lastop to
13949 * process the rest of the code */
13950 DEFER(cLOOP->op_lastop);
13954 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
13955 DEFER(cLOGOPo->op_other);
13959 assert(!(cPMOP->op_pmflags & PMf_ONCE));
13960 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
13961 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
13962 cPMOP->op_pmstashstartu.op_pmreplstart
13963 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
13964 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
13970 if (o->op_flags & OPf_SPECIAL) {
13971 /* first arg is a code block */
13972 OP * const nullop = OpSIBLING(cLISTOP->op_first);
13973 OP * kid = cUNOPx(nullop)->op_first;
13975 assert(nullop->op_type == OP_NULL);
13976 assert(kid->op_type == OP_SCOPE
13977 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
13978 /* since OP_SORT doesn't have a handy op_other-style
13979 * field that can point directly to the start of the code
13980 * block, store it in the otherwise-unused op_next field
13981 * of the top-level OP_NULL. This will be quicker at
13982 * run-time, and it will also allow us to remove leading
13983 * OP_NULLs by just messing with op_nexts without
13984 * altering the basic op_first/op_sibling layout. */
13985 kid = kLISTOP->op_first;
13987 (kid->op_type == OP_NULL
13988 && ( kid->op_targ == OP_NEXTSTATE
13989 || kid->op_targ == OP_DBSTATE ))
13990 || kid->op_type == OP_STUB
13991 || kid->op_type == OP_ENTER);
13992 nullop->op_next = kLISTOP->op_next;
13993 DEFER(nullop->op_next);
13996 /* check that RHS of sort is a single plain array */
13997 oright = cUNOPo->op_first;
13998 if (!oright || oright->op_type != OP_PUSHMARK)
14001 if (o->op_private & OPpSORT_INPLACE)
14004 /* reverse sort ... can be optimised. */
14005 if (!OpHAS_SIBLING(cUNOPo)) {
14006 /* Nothing follows us on the list. */
14007 OP * const reverse = o->op_next;
14009 if (reverse->op_type == OP_REVERSE &&
14010 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14011 OP * const pushmark = cUNOPx(reverse)->op_first;
14012 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14013 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14014 /* reverse -> pushmark -> sort */
14015 o->op_private |= OPpSORT_REVERSE;
14017 pushmark->op_next = oright->op_next;
14027 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14029 LISTOP *enter, *exlist;
14031 if (o->op_private & OPpSORT_INPLACE)
14034 enter = (LISTOP *) o->op_next;
14037 if (enter->op_type == OP_NULL) {
14038 enter = (LISTOP *) enter->op_next;
14042 /* for $a (...) will have OP_GV then OP_RV2GV here.
14043 for (...) just has an OP_GV. */
14044 if (enter->op_type == OP_GV) {
14045 gvop = (OP *) enter;
14046 enter = (LISTOP *) enter->op_next;
14049 if (enter->op_type == OP_RV2GV) {
14050 enter = (LISTOP *) enter->op_next;
14056 if (enter->op_type != OP_ENTERITER)
14059 iter = enter->op_next;
14060 if (!iter || iter->op_type != OP_ITER)
14063 expushmark = enter->op_first;
14064 if (!expushmark || expushmark->op_type != OP_NULL
14065 || expushmark->op_targ != OP_PUSHMARK)
14068 exlist = (LISTOP *) OpSIBLING(expushmark);
14069 if (!exlist || exlist->op_type != OP_NULL
14070 || exlist->op_targ != OP_LIST)
14073 if (exlist->op_last != o) {
14074 /* Mmm. Was expecting to point back to this op. */
14077 theirmark = exlist->op_first;
14078 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14081 if (OpSIBLING(theirmark) != o) {
14082 /* There's something between the mark and the reverse, eg
14083 for (1, reverse (...))
14088 ourmark = ((LISTOP *)o)->op_first;
14089 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14092 ourlast = ((LISTOP *)o)->op_last;
14093 if (!ourlast || ourlast->op_next != o)
14096 rv2av = OpSIBLING(ourmark);
14097 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14098 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14099 /* We're just reversing a single array. */
14100 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14101 enter->op_flags |= OPf_STACKED;
14104 /* We don't have control over who points to theirmark, so sacrifice
14106 theirmark->op_next = ourmark->op_next;
14107 theirmark->op_flags = ourmark->op_flags;
14108 ourlast->op_next = gvop ? gvop : (OP *) enter;
14111 enter->op_private |= OPpITER_REVERSED;
14112 iter->op_private |= OPpITER_REVERSED;
14119 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14120 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14125 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14126 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14129 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14131 sv = newRV((SV *)PL_compcv);
14135 OpTYPE_set(o, OP_CONST);
14136 o->op_flags |= OPf_SPECIAL;
14137 cSVOPo->op_sv = sv;
14142 if (OP_GIMME(o,0) == G_VOID
14143 || ( o->op_next->op_type == OP_LINESEQ
14144 && ( o->op_next->op_next->op_type == OP_LEAVESUB
14145 || ( o->op_next->op_next->op_type == OP_RETURN
14146 && !CvLVALUE(PL_compcv)))))
14148 OP *right = cBINOP->op_first;
14167 OP *left = OpSIBLING(right);
14168 if (left->op_type == OP_SUBSTR
14169 && (left->op_private & 7) < 4) {
14171 /* cut out right */
14172 op_sibling_splice(o, NULL, 1, NULL);
14173 /* and insert it as second child of OP_SUBSTR */
14174 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14176 left->op_private |= OPpSUBSTR_REPL_FIRST;
14178 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14185 int l, r, lr, lscalars, rscalars;
14187 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14188 Note that we do this now rather than in newASSIGNOP(),
14189 since only by now are aliased lexicals flagged as such
14191 See the essay "Common vars in list assignment" above for
14192 the full details of the rationale behind all the conditions
14195 PL_generation sorcery:
14196 To detect whether there are common vars, the global var
14197 PL_generation is incremented for each assign op we scan.
14198 Then we run through all the lexical variables on the LHS,
14199 of the assignment, setting a spare slot in each of them to
14200 PL_generation. Then we scan the RHS, and if any lexicals
14201 already have that value, we know we've got commonality.
14202 Also, if the generation number is already set to
14203 PERL_INT_MAX, then the variable is involved in aliasing, so
14204 we also have potential commonality in that case.
14210 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
14213 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14217 /* After looking for things which are *always* safe, this main
14218 * if/else chain selects primarily based on the type of the
14219 * LHS, gradually working its way down from the more dangerous
14220 * to the more restrictive and thus safer cases */
14222 if ( !l /* () = ....; */
14223 || !r /* .... = (); */
14224 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14225 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14226 || (lscalars < 2) /* ($x, undef) = ... */
14228 NOOP; /* always safe */
14230 else if (l & AAS_DANGEROUS) {
14231 /* always dangerous */
14232 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14233 o->op_private |= OPpASSIGN_COMMON_AGG;
14235 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14236 /* package vars are always dangerous - too many
14237 * aliasing possibilities */
14238 if (l & AAS_PKG_SCALAR)
14239 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14240 if (l & AAS_PKG_AGG)
14241 o->op_private |= OPpASSIGN_COMMON_AGG;
14243 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14244 |AAS_LEX_SCALAR|AAS_LEX_AGG))
14246 /* LHS contains only lexicals and safe ops */
14248 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14249 o->op_private |= OPpASSIGN_COMMON_AGG;
14251 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14252 if (lr & AAS_LEX_SCALAR_COMM)
14253 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14254 else if ( !(l & AAS_LEX_SCALAR)
14255 && (r & AAS_DEFAV))
14259 * as scalar-safe for performance reasons.
14260 * (it will still have been marked _AGG if necessary */
14263 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14264 o->op_private |= OPpASSIGN_COMMON_RC1;
14269 * may have to handle aggregate on LHS, but we can't
14270 * have common scalars. */
14273 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14279 Perl_cpeep_t cpeep =
14280 XopENTRYCUSTOM(o, xop_peep);
14282 cpeep(aTHX_ o, oldop);
14287 /* did we just null the current op? If so, re-process it to handle
14288 * eliding "empty" ops from the chain */
14289 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14302 Perl_peep(pTHX_ OP *o)
14308 =head1 Custom Operators
14310 =for apidoc Ao||custom_op_xop
14311 Return the XOP structure for a given custom op. This macro should be
14312 considered internal to C<OP_NAME> and the other access macros: use them instead.
14313 This macro does call a function. Prior
14314 to 5.19.6, this was implemented as a
14321 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14327 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14329 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14330 assert(o->op_type == OP_CUSTOM);
14332 /* This is wrong. It assumes a function pointer can be cast to IV,
14333 * which isn't guaranteed, but this is what the old custom OP code
14334 * did. In principle it should be safer to Copy the bytes of the
14335 * pointer into a PV: since the new interface is hidden behind
14336 * functions, this can be changed later if necessary. */
14337 /* Change custom_op_xop if this ever happens */
14338 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14341 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14343 /* assume noone will have just registered a desc */
14344 if (!he && PL_custom_op_names &&
14345 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14350 /* XXX does all this need to be shared mem? */
14351 Newxz(xop, 1, XOP);
14352 pv = SvPV(HeVAL(he), l);
14353 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14354 if (PL_custom_op_descs &&
14355 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14357 pv = SvPV(HeVAL(he), l);
14358 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14360 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14364 xop = (XOP *)&xop_null;
14366 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14370 if(field == XOPe_xop_ptr) {
14373 const U32 flags = XopFLAGS(xop);
14374 if(flags & field) {
14376 case XOPe_xop_name:
14377 any.xop_name = xop->xop_name;
14379 case XOPe_xop_desc:
14380 any.xop_desc = xop->xop_desc;
14382 case XOPe_xop_class:
14383 any.xop_class = xop->xop_class;
14385 case XOPe_xop_peep:
14386 any.xop_peep = xop->xop_peep;
14389 NOT_REACHED; /* NOTREACHED */
14394 case XOPe_xop_name:
14395 any.xop_name = XOPd_xop_name;
14397 case XOPe_xop_desc:
14398 any.xop_desc = XOPd_xop_desc;
14400 case XOPe_xop_class:
14401 any.xop_class = XOPd_xop_class;
14403 case XOPe_xop_peep:
14404 any.xop_peep = XOPd_xop_peep;
14407 NOT_REACHED; /* NOTREACHED */
14412 /* Some gcc releases emit a warning for this function:
14413 * op.c: In function 'Perl_custom_op_get_field':
14414 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14415 * Whether this is true, is currently unknown. */
14421 =for apidoc Ao||custom_op_register
14422 Register a custom op. See L<perlguts/"Custom Operators">.
14428 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14432 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14434 /* see the comment in custom_op_xop */
14435 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14437 if (!PL_custom_ops)
14438 PL_custom_ops = newHV();
14440 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14441 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14446 =for apidoc core_prototype
14448 This function assigns the prototype of the named core function to C<sv>, or
14449 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
14450 C<NULL> if the core function has no prototype. C<code> is a code as returned
14451 by C<keyword()>. It must not be equal to 0.
14457 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14460 int i = 0, n = 0, seen_question = 0, defgv = 0;
14462 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14463 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14464 bool nullret = FALSE;
14466 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14470 if (!sv) sv = sv_newmortal();
14472 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14474 switch (code < 0 ? -code : code) {
14475 case KEY_and : case KEY_chop: case KEY_chomp:
14476 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14477 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14478 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14479 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14480 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14481 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14482 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14483 case KEY_x : case KEY_xor :
14484 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14485 case KEY_glob: retsetpvs("_;", OP_GLOB);
14486 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
14487 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
14488 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
14489 case KEY_push: retsetpvs("\\@@", OP_PUSH);
14490 case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
14491 case KEY_pop: retsetpvs(";\\@", OP_POP);
14492 case KEY_shift: retsetpvs(";\\@", OP_SHIFT);
14493 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14495 retsetpvs("\\@;$$@", OP_SPLICE);
14496 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14498 case KEY_evalbytes:
14499 name = "entereval"; break;
14507 while (i < MAXO) { /* The slow way. */
14508 if (strEQ(name, PL_op_name[i])
14509 || strEQ(name, PL_op_desc[i]))
14511 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14518 defgv = PL_opargs[i] & OA_DEFGV;
14519 oa = PL_opargs[i] >> OASHIFT;
14521 if (oa & OA_OPTIONAL && !seen_question && (
14522 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14527 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14528 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14529 /* But globs are already references (kinda) */
14530 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14534 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14535 && !scalar_mod_type(NULL, i)) {
14540 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14544 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14545 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14546 str[n-1] = '_'; defgv = 0;
14550 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14552 sv_setpvn(sv, str, n - 1);
14553 if (opnum) *opnum = i;
14558 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14561 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14564 PERL_ARGS_ASSERT_CORESUB_OP;
14568 return op_append_elem(OP_LINESEQ,
14571 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14575 case OP_SELECT: /* which represents OP_SSELECT as well */
14580 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14581 newSVOP(OP_CONST, 0, newSVuv(1))
14583 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14585 coresub_op(coreargssv, 0, OP_SELECT)
14589 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14591 return op_append_elem(
14594 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14595 ? OPpOFFBYONE << 8 : 0)
14597 case OA_BASEOP_OR_UNOP:
14598 if (opnum == OP_ENTEREVAL) {
14599 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14600 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14602 else o = newUNOP(opnum,0,argop);
14603 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14606 if (is_handle_constructor(o, 1))
14607 argop->op_private |= OPpCOREARGS_DEREF1;
14608 if (scalar_mod_type(NULL, opnum))
14609 argop->op_private |= OPpCOREARGS_SCALARMOD;
14613 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14614 if (is_handle_constructor(o, 2))
14615 argop->op_private |= OPpCOREARGS_DEREF2;
14616 if (opnum == OP_SUBSTR) {
14617 o->op_private |= OPpMAYBE_LVSUB;
14626 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14627 SV * const *new_const_svp)
14629 const char *hvname;
14630 bool is_const = !!CvCONST(old_cv);
14631 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14633 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14635 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14637 /* They are 2 constant subroutines generated from
14638 the same constant. This probably means that
14639 they are really the "same" proxy subroutine
14640 instantiated in 2 places. Most likely this is
14641 when a constant is exported twice. Don't warn.
14644 (ckWARN(WARN_REDEFINE)
14646 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14647 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14648 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14649 strEQ(hvname, "autouse"))
14653 && ckWARN_d(WARN_REDEFINE)
14654 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14657 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14659 ? "Constant subroutine %"SVf" redefined"
14660 : "Subroutine %"SVf" redefined",
14665 =head1 Hook manipulation
14667 These functions provide convenient and thread-safe means of manipulating
14674 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14676 Puts a C function into the chain of check functions for a specified op
14677 type. This is the preferred way to manipulate the L</PL_check> array.
14678 C<opcode> specifies which type of op is to be affected. C<new_checker>
14679 is a pointer to the C function that is to be added to that opcode's
14680 check chain, and C<old_checker_p> points to the storage location where a
14681 pointer to the next function in the chain will be stored. The value of
14682 C<new_pointer> is written into the L</PL_check> array, while the value
14683 previously stored there is written to C<*old_checker_p>.
14685 The function should be defined like this:
14687 static OP *new_checker(pTHX_ OP *op) { ... }
14689 It is intended to be called in this manner:
14691 new_checker(aTHX_ op)
14693 C<old_checker_p> should be defined like this:
14695 static Perl_check_t old_checker_p;
14697 L</PL_check> is global to an entire process, and a module wishing to
14698 hook op checking may find itself invoked more than once per process,
14699 typically in different threads. To handle that situation, this function
14700 is idempotent. The location C<*old_checker_p> must initially (once
14701 per process) contain a null pointer. A C variable of static duration
14702 (declared at file scope, typically also marked C<static> to give
14703 it internal linkage) will be implicitly initialised appropriately,
14704 if it does not have an explicit initialiser. This function will only
14705 actually modify the check chain if it finds C<*old_checker_p> to be null.
14706 This function is also thread safe on the small scale. It uses appropriate
14707 locking to avoid race conditions in accessing L</PL_check>.
14709 When this function is called, the function referenced by C<new_checker>
14710 must be ready to be called, except for C<*old_checker_p> being unfilled.
14711 In a threading situation, C<new_checker> may be called immediately,
14712 even before this function has returned. C<*old_checker_p> will always
14713 be appropriately set before C<new_checker> is called. If C<new_checker>
14714 decides not to do anything special with an op that it is given (which
14715 is the usual case for most uses of op check hooking), it must chain the
14716 check function referenced by C<*old_checker_p>.
14718 If you want to influence compilation of calls to a specific subroutine,
14719 then use L</cv_set_call_checker> rather than hooking checking of all
14726 Perl_wrap_op_checker(pTHX_ Optype opcode,
14727 Perl_check_t new_checker, Perl_check_t *old_checker_p)
14731 PERL_UNUSED_CONTEXT;
14732 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14733 if (*old_checker_p) return;
14734 OP_CHECK_MUTEX_LOCK;
14735 if (!*old_checker_p) {
14736 *old_checker_p = PL_check[opcode];
14737 PL_check[opcode] = new_checker;
14739 OP_CHECK_MUTEX_UNLOCK;
14744 /* Efficient sub that returns a constant scalar value. */
14746 const_sv_xsub(pTHX_ CV* cv)
14749 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14750 PERL_UNUSED_ARG(items);
14760 const_av_xsub(pTHX_ CV* cv)
14763 AV * const av = MUTABLE_AV(XSANY.any_ptr);
14771 if (SvRMAGICAL(av))
14772 Perl_croak(aTHX_ "Magical list constants are not supported");
14773 if (GIMME_V != G_ARRAY) {
14775 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14778 EXTEND(SP, AvFILLp(av)+1);
14779 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14780 XSRETURN(AvFILLp(av)+1);
14784 * ex: set ts=8 sts=4 sw=4 et: