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 * Don't bother testing if:
717 * * the op_ppaddr doesn't match the op; someone may have
718 * overridden the op and be doing strange things with it;
719 * * we've errored, as op flags are often left in an
720 * inconsistent state then. Note that an error when
721 * compiling the main program leaves PL_parser NULL, so
722 * we can't spot faults in the main code, only
723 * evaled/required code */
725 if ( o->op_ppaddr == PL_ppaddr[o->op_type]
727 && !PL_parser->error_count)
729 assert(!(o->op_private & ~PL_op_private_valid[type]));
733 if (o->op_private & OPpREFCOUNTED) {
744 refcnt = OpREFCNT_dec(o);
747 /* Need to find and remove any pattern match ops from the list
748 we maintain for reset(). */
749 find_and_forget_pmops(o);
759 /* Call the op_free hook if it has been set. Do it now so that it's called
760 * at the right time for refcounted ops, but still before all of the kids
764 if (o->op_flags & OPf_KIDS) {
766 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
767 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
768 if (!kid || kid->op_type == OP_FREED)
769 /* During the forced freeing of ops after
770 compilation failure, kidops may be freed before
773 if (!(kid->op_flags & OPf_KIDS))
774 /* If it has no kids, just free it now */
781 type = (OPCODE)o->op_targ;
784 Slab_to_rw(OpSLAB(o));
786 /* COP* is not cleared by op_clear() so that we may track line
787 * numbers etc even after null() */
788 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
794 #ifdef DEBUG_LEAKING_SCALARS
798 } while ( (o = POP_DEFERRED_OP()) );
800 Safefree(defer_stack);
803 /* S_op_clear_gv(): free a GV attached to an OP */
806 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
808 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
812 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
813 || o->op_type == OP_MULTIDEREF)
816 ? ((GV*)PAD_SVl(*ixp)) : NULL;
818 ? (GV*)(*svp) : NULL;
820 /* It's possible during global destruction that the GV is freed
821 before the optree. Whilst the SvREFCNT_inc is happy to bump from
822 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
823 will trigger an assertion failure, because the entry to sv_clear
824 checks that the scalar is not already freed. A check of for
825 !SvIS_FREED(gv) turns out to be invalid, because during global
826 destruction the reference count can be forced down to zero
827 (with SVf_BREAK set). In which case raising to 1 and then
828 dropping to 0 triggers cleanup before it should happen. I
829 *think* that this might actually be a general, systematic,
830 weakness of the whole idea of SVf_BREAK, in that code *is*
831 allowed to raise and lower references during global destruction,
832 so any *valid* code that happens to do this during global
833 destruction might well trigger premature cleanup. */
834 bool still_valid = gv && SvREFCNT(gv);
837 SvREFCNT_inc_simple_void(gv);
840 pad_swipe(*ixp, TRUE);
848 int try_downgrade = SvREFCNT(gv) == 2;
851 gv_try_downgrade(gv);
857 Perl_op_clear(pTHX_ OP *o)
862 PERL_ARGS_ASSERT_OP_CLEAR;
864 switch (o->op_type) {
865 case OP_NULL: /* Was holding old type, if any. */
868 case OP_ENTEREVAL: /* Was holding hints. */
872 if (!(o->op_flags & OPf_REF)
873 || (PL_check[o->op_type] != Perl_ck_ftst))
880 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
882 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
885 case OP_METHOD_REDIR:
886 case OP_METHOD_REDIR_SUPER:
888 if (cMETHOPx(o)->op_rclass_targ) {
889 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
890 cMETHOPx(o)->op_rclass_targ = 0;
893 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
894 cMETHOPx(o)->op_rclass_sv = NULL;
896 case OP_METHOD_NAMED:
897 case OP_METHOD_SUPER:
898 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
899 cMETHOPx(o)->op_u.op_meth_sv = NULL;
902 pad_swipe(o->op_targ, 1);
909 SvREFCNT_dec(cSVOPo->op_sv);
910 cSVOPo->op_sv = NULL;
913 Even if op_clear does a pad_free for the target of the op,
914 pad_free doesn't actually remove the sv that exists in the pad;
915 instead it lives on. This results in that it could be reused as
916 a target later on when the pad was reallocated.
919 pad_swipe(o->op_targ,1);
929 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
934 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
935 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
937 if (cPADOPo->op_padix > 0) {
938 pad_swipe(cPADOPo->op_padix, TRUE);
939 cPADOPo->op_padix = 0;
942 SvREFCNT_dec(cSVOPo->op_sv);
943 cSVOPo->op_sv = NULL;
947 PerlMemShared_free(cPVOPo->op_pv);
948 cPVOPo->op_pv = NULL;
952 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
956 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
957 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
960 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
966 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
967 op_free(cPMOPo->op_code_list);
968 cPMOPo->op_code_list = NULL;
970 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
971 /* we use the same protection as the "SAFE" version of the PM_ macros
972 * here since sv_clean_all might release some PMOPs
973 * after PL_regex_padav has been cleared
974 * and the clearing of PL_regex_padav needs to
975 * happen before sv_clean_all
978 if(PL_regex_pad) { /* We could be in destruction */
979 const IV offset = (cPMOPo)->op_pmoffset;
980 ReREFCNT_dec(PM_GETRE(cPMOPo));
981 PL_regex_pad[offset] = &PL_sv_undef;
982 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
986 ReREFCNT_dec(PM_GETRE(cPMOPo));
987 PM_SETRE(cPMOPo, NULL);
994 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
995 UV actions = items->uv;
997 bool is_hash = FALSE;
1000 switch (actions & MDEREF_ACTION_MASK) {
1003 actions = (++items)->uv;
1006 case MDEREF_HV_padhv_helem:
1008 case MDEREF_AV_padav_aelem:
1009 pad_free((++items)->pad_offset);
1012 case MDEREF_HV_gvhv_helem:
1014 case MDEREF_AV_gvav_aelem:
1016 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1018 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1022 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1024 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1026 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1028 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1030 goto do_vivify_rv2xv_elem;
1032 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1034 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1035 pad_free((++items)->pad_offset);
1036 goto do_vivify_rv2xv_elem;
1038 case MDEREF_HV_pop_rv2hv_helem:
1039 case MDEREF_HV_vivify_rv2hv_helem:
1041 do_vivify_rv2xv_elem:
1042 case MDEREF_AV_pop_rv2av_aelem:
1043 case MDEREF_AV_vivify_rv2av_aelem:
1045 switch (actions & MDEREF_INDEX_MASK) {
1046 case MDEREF_INDEX_none:
1049 case MDEREF_INDEX_const:
1053 pad_swipe((++items)->pad_offset, 1);
1055 SvREFCNT_dec((++items)->sv);
1061 case MDEREF_INDEX_padsv:
1062 pad_free((++items)->pad_offset);
1064 case MDEREF_INDEX_gvsv:
1066 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1068 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1073 if (actions & MDEREF_FLAG_last)
1086 actions >>= MDEREF_SHIFT;
1089 /* start of malloc is at op_aux[-1], where the length is
1091 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1096 if (o->op_targ > 0) {
1097 pad_free(o->op_targ);
1103 S_cop_free(pTHX_ COP* cop)
1105 PERL_ARGS_ASSERT_COP_FREE;
1108 if (! specialWARN(cop->cop_warnings))
1109 PerlMemShared_free(cop->cop_warnings);
1110 cophh_free(CopHINTHASH_get(cop));
1111 if (PL_curcop == cop)
1116 S_forget_pmop(pTHX_ PMOP *const o
1119 HV * const pmstash = PmopSTASH(o);
1121 PERL_ARGS_ASSERT_FORGET_PMOP;
1123 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1124 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1126 PMOP **const array = (PMOP**) mg->mg_ptr;
1127 U32 count = mg->mg_len / sizeof(PMOP**);
1131 if (array[i] == o) {
1132 /* Found it. Move the entry at the end to overwrite it. */
1133 array[i] = array[--count];
1134 mg->mg_len = count * sizeof(PMOP**);
1135 /* Could realloc smaller at this point always, but probably
1136 not worth it. Probably worth free()ing if we're the
1139 Safefree(mg->mg_ptr);
1152 S_find_and_forget_pmops(pTHX_ OP *o)
1154 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1156 if (o->op_flags & OPf_KIDS) {
1157 OP *kid = cUNOPo->op_first;
1159 switch (kid->op_type) {
1164 forget_pmop((PMOP*)kid);
1166 find_and_forget_pmops(kid);
1167 kid = OpSIBLING(kid);
1173 =for apidoc Am|void|op_null|OP *o
1175 Neutralizes an op when it is no longer needed, but is still linked to from
1182 Perl_op_null(pTHX_ OP *o)
1186 PERL_ARGS_ASSERT_OP_NULL;
1188 if (o->op_type == OP_NULL)
1191 o->op_targ = o->op_type;
1192 OpTYPE_set(o, OP_NULL);
1196 Perl_op_refcnt_lock(pTHX)
1197 PERL_TSA_ACQUIRE(PL_op_mutex)
1202 PERL_UNUSED_CONTEXT;
1207 Perl_op_refcnt_unlock(pTHX)
1208 PERL_TSA_RELEASE(PL_op_mutex)
1213 PERL_UNUSED_CONTEXT;
1219 =for apidoc op_sibling_splice
1221 A general function for editing the structure of an existing chain of
1222 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1223 you to delete zero or more sequential nodes, replacing them with zero or
1224 more different nodes. Performs the necessary op_first/op_last
1225 housekeeping on the parent node and op_sibling manipulation on the
1226 children. The last deleted node will be marked as as the last node by
1227 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1229 Note that op_next is not manipulated, and nodes are not freed; that is the
1230 responsibility of the caller. It also won't create a new list op for an
1231 empty list etc; use higher-level functions like op_append_elem() for that.
1233 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1234 the splicing doesn't affect the first or last op in the chain.
1236 C<start> is the node preceding the first node to be spliced. Node(s)
1237 following it will be deleted, and ops will be inserted after it. If it is
1238 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1241 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1242 If -1 or greater than or equal to the number of remaining kids, all
1243 remaining kids are deleted.
1245 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1246 If C<NULL>, no nodes are inserted.
1248 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1253 action before after returns
1254 ------ ----- ----- -------
1257 splice(P, A, 2, X-Y-Z) | | B-C
1261 splice(P, NULL, 1, X-Y) | | A
1265 splice(P, NULL, 3, NULL) | | A-B-C
1269 splice(P, B, 0, X-Y) | | NULL
1273 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1274 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1280 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1284 OP *last_del = NULL;
1285 OP *last_ins = NULL;
1288 first = OpSIBLING(start);
1292 first = cLISTOPx(parent)->op_first;
1294 assert(del_count >= -1);
1296 if (del_count && first) {
1298 while (--del_count && OpHAS_SIBLING(last_del))
1299 last_del = OpSIBLING(last_del);
1300 rest = OpSIBLING(last_del);
1301 OpLASTSIB_set(last_del, NULL);
1308 while (OpHAS_SIBLING(last_ins))
1309 last_ins = OpSIBLING(last_ins);
1310 OpMAYBESIB_set(last_ins, rest, NULL);
1316 OpMAYBESIB_set(start, insert, NULL);
1321 cLISTOPx(parent)->op_first = insert;
1323 parent->op_flags |= OPf_KIDS;
1325 parent->op_flags &= ~OPf_KIDS;
1329 /* update op_last etc */
1336 /* ought to use OP_CLASS(parent) here, but that can't handle
1337 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1339 type = parent->op_type;
1340 if (type == OP_CUSTOM) {
1342 type = XopENTRYCUSTOM(parent, xop_class);
1345 if (type == OP_NULL)
1346 type = parent->op_targ;
1347 type = PL_opargs[type] & OA_CLASS_MASK;
1350 lastop = last_ins ? last_ins : start ? start : NULL;
1351 if ( type == OA_BINOP
1352 || type == OA_LISTOP
1356 cLISTOPx(parent)->op_last = lastop;
1359 OpLASTSIB_set(lastop, parent);
1361 return last_del ? first : NULL;
1364 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1368 #ifdef PERL_OP_PARENT
1371 =for apidoc op_parent
1373 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1374 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1380 Perl_op_parent(OP *o)
1382 PERL_ARGS_ASSERT_OP_PARENT;
1383 while (OpHAS_SIBLING(o))
1385 return o->op_sibparent;
1391 /* replace the sibling following start with a new UNOP, which becomes
1392 * the parent of the original sibling; e.g.
1394 * op_sibling_newUNOP(P, A, unop-args...)
1402 * where U is the new UNOP.
1404 * parent and start args are the same as for op_sibling_splice();
1405 * type and flags args are as newUNOP().
1407 * Returns the new UNOP.
1411 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1415 kid = op_sibling_splice(parent, start, 1, NULL);
1416 newop = newUNOP(type, flags, kid);
1417 op_sibling_splice(parent, start, 0, newop);
1422 /* lowest-level newLOGOP-style function - just allocates and populates
1423 * the struct. Higher-level stuff should be done by S_new_logop() /
1424 * newLOGOP(). This function exists mainly to avoid op_first assignment
1425 * being spread throughout this file.
1429 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1434 NewOp(1101, logop, 1, LOGOP);
1435 OpTYPE_set(logop, type);
1436 logop->op_first = first;
1437 logop->op_other = other;
1438 logop->op_flags = OPf_KIDS;
1439 while (kid && OpHAS_SIBLING(kid))
1440 kid = OpSIBLING(kid);
1442 OpLASTSIB_set(kid, (OP*)logop);
1447 /* Contextualizers */
1450 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1452 Applies a syntactic context to an op tree representing an expression.
1453 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1454 or C<G_VOID> to specify the context to apply. The modified op tree
1461 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1463 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1465 case G_SCALAR: return scalar(o);
1466 case G_ARRAY: return list(o);
1467 case G_VOID: return scalarvoid(o);
1469 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1476 =for apidoc Am|OP*|op_linklist|OP *o
1477 This function is the implementation of the L</LINKLIST> macro. It should
1478 not be called directly.
1484 Perl_op_linklist(pTHX_ OP *o)
1488 PERL_ARGS_ASSERT_OP_LINKLIST;
1493 /* establish postfix order */
1494 first = cUNOPo->op_first;
1497 o->op_next = LINKLIST(first);
1500 OP *sibl = OpSIBLING(kid);
1502 kid->op_next = LINKLIST(sibl);
1517 S_scalarkids(pTHX_ OP *o)
1519 if (o && o->op_flags & OPf_KIDS) {
1521 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1528 S_scalarboolean(pTHX_ OP *o)
1530 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1532 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1533 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1534 if (ckWARN(WARN_SYNTAX)) {
1535 const line_t oldline = CopLINE(PL_curcop);
1537 if (PL_parser && PL_parser->copline != NOLINE) {
1538 /* This ensures that warnings are reported at the first line
1539 of the conditional, not the last. */
1540 CopLINE_set(PL_curcop, PL_parser->copline);
1542 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1543 CopLINE_set(PL_curcop, oldline);
1550 S_op_varname(pTHX_ const OP *o)
1553 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1554 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1556 const char funny = o->op_type == OP_PADAV
1557 || o->op_type == OP_RV2AV ? '@' : '%';
1558 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1560 if (cUNOPo->op_first->op_type != OP_GV
1561 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1563 return varname(gv, funny, 0, NULL, 0, 1);
1566 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1571 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1572 { /* or not so pretty :-) */
1573 if (o->op_type == OP_CONST) {
1575 if (SvPOK(*retsv)) {
1577 *retsv = sv_newmortal();
1578 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1579 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1581 else if (!SvOK(*retsv))
1584 else *retpv = "...";
1588 S_scalar_slice_warning(pTHX_ const OP *o)
1592 o->op_type == OP_HSLICE ? '{' : '[';
1594 o->op_type == OP_HSLICE ? '}' : ']';
1596 SV *keysv = NULL; /* just to silence compiler warnings */
1597 const char *key = NULL;
1599 if (!(o->op_private & OPpSLICEWARNING))
1601 if (PL_parser && PL_parser->error_count)
1602 /* This warning can be nonsensical when there is a syntax error. */
1605 kid = cLISTOPo->op_first;
1606 kid = OpSIBLING(kid); /* get past pushmark */
1607 /* weed out false positives: any ops that can return lists */
1608 switch (kid->op_type) {
1634 /* Don't warn if we have a nulled list either. */
1635 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1638 assert(OpSIBLING(kid));
1639 name = S_op_varname(aTHX_ OpSIBLING(kid));
1640 if (!name) /* XS module fiddling with the op tree */
1642 S_op_pretty(aTHX_ kid, &keysv, &key);
1643 assert(SvPOK(name));
1644 sv_chop(name,SvPVX(name)+1);
1646 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1647 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1648 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1650 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1651 lbrack, key, rbrack);
1653 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1654 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1655 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1657 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1658 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1662 Perl_scalar(pTHX_ OP *o)
1666 /* assumes no premature commitment */
1667 if (!o || (PL_parser && PL_parser->error_count)
1668 || (o->op_flags & OPf_WANT)
1669 || o->op_type == OP_RETURN)
1674 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1676 switch (o->op_type) {
1678 scalar(cBINOPo->op_first);
1679 if (o->op_private & OPpREPEAT_DOLIST) {
1680 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1681 assert(kid->op_type == OP_PUSHMARK);
1682 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1683 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1684 o->op_private &=~ OPpREPEAT_DOLIST;
1691 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1701 if (o->op_flags & OPf_KIDS) {
1702 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1708 kid = cLISTOPo->op_first;
1710 kid = OpSIBLING(kid);
1713 OP *sib = OpSIBLING(kid);
1714 if (sib && kid->op_type != OP_LEAVEWHEN
1715 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1716 || ( sib->op_targ != OP_NEXTSTATE
1717 && sib->op_targ != OP_DBSTATE )))
1723 PL_curcop = &PL_compiling;
1728 kid = cLISTOPo->op_first;
1731 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1736 /* Warn about scalar context */
1737 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1738 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1741 const char *key = NULL;
1743 /* This warning can be nonsensical when there is a syntax error. */
1744 if (PL_parser && PL_parser->error_count)
1747 if (!ckWARN(WARN_SYNTAX)) break;
1749 kid = cLISTOPo->op_first;
1750 kid = OpSIBLING(kid); /* get past pushmark */
1751 assert(OpSIBLING(kid));
1752 name = S_op_varname(aTHX_ OpSIBLING(kid));
1753 if (!name) /* XS module fiddling with the op tree */
1755 S_op_pretty(aTHX_ kid, &keysv, &key);
1756 assert(SvPOK(name));
1757 sv_chop(name,SvPVX(name)+1);
1759 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1760 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1761 "%%%"SVf"%c%s%c in scalar context better written "
1763 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1764 lbrack, key, rbrack);
1766 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1767 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1768 "%%%"SVf"%c%"SVf"%c in scalar context better "
1769 "written as $%"SVf"%c%"SVf"%c",
1770 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1771 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1778 Perl_scalarvoid(pTHX_ OP *arg)
1784 SSize_t defer_stack_alloc = 0;
1785 SSize_t defer_ix = -1;
1786 OP **defer_stack = NULL;
1789 PERL_ARGS_ASSERT_SCALARVOID;
1792 SV *useless_sv = NULL;
1793 const char* useless = NULL;
1795 if (o->op_type == OP_NEXTSTATE
1796 || o->op_type == OP_DBSTATE
1797 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1798 || o->op_targ == OP_DBSTATE)))
1799 PL_curcop = (COP*)o; /* for warning below */
1801 /* assumes no premature commitment */
1802 want = o->op_flags & OPf_WANT;
1803 if ((want && want != OPf_WANT_SCALAR)
1804 || (PL_parser && PL_parser->error_count)
1805 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1810 if ((o->op_private & OPpTARGET_MY)
1811 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1813 /* newASSIGNOP has already applied scalar context, which we
1814 leave, as if this op is inside SASSIGN. */
1818 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1820 switch (o->op_type) {
1822 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1826 if (o->op_flags & OPf_STACKED)
1828 if (o->op_type == OP_REPEAT)
1829 scalar(cBINOPo->op_first);
1832 if (o->op_private == 4)
1867 case OP_GETSOCKNAME:
1868 case OP_GETPEERNAME:
1873 case OP_GETPRIORITY:
1898 useless = OP_DESC(o);
1908 case OP_AELEMFAST_LEX:
1912 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1913 /* Otherwise it's "Useless use of grep iterator" */
1914 useless = OP_DESC(o);
1918 kid = cLISTOPo->op_first;
1919 if (kid && kid->op_type == OP_PUSHRE
1921 && !(o->op_flags & OPf_STACKED)
1923 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1925 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1928 useless = OP_DESC(o);
1932 kid = cUNOPo->op_first;
1933 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1934 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1937 useless = "negative pattern binding (!~)";
1941 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1942 useless = "non-destructive substitution (s///r)";
1946 useless = "non-destructive transliteration (tr///r)";
1953 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1954 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1955 useless = "a variable";
1960 if (cSVOPo->op_private & OPpCONST_STRICT)
1961 no_bareword_allowed(o);
1963 if (ckWARN(WARN_VOID)) {
1965 /* don't warn on optimised away booleans, eg
1966 * use constant Foo, 5; Foo || print; */
1967 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1969 /* the constants 0 and 1 are permitted as they are
1970 conventionally used as dummies in constructs like
1971 1 while some_condition_with_side_effects; */
1972 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1974 else if (SvPOK(sv)) {
1975 SV * const dsv = newSVpvs("");
1977 = Perl_newSVpvf(aTHX_
1979 pv_pretty(dsv, SvPVX_const(sv),
1980 SvCUR(sv), 32, NULL, NULL,
1982 | PERL_PV_ESCAPE_NOCLEAR
1983 | PERL_PV_ESCAPE_UNI_DETECT));
1984 SvREFCNT_dec_NN(dsv);
1986 else if (SvOK(sv)) {
1987 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1990 useless = "a constant (undef)";
1993 op_null(o); /* don't execute or even remember it */
1997 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2001 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2005 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2009 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2014 UNOP *refgen, *rv2cv;
2017 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2020 rv2gv = ((BINOP *)o)->op_last;
2021 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2024 refgen = (UNOP *)((BINOP *)o)->op_first;
2026 if (!refgen || (refgen->op_type != OP_REFGEN
2027 && refgen->op_type != OP_SREFGEN))
2030 exlist = (LISTOP *)refgen->op_first;
2031 if (!exlist || exlist->op_type != OP_NULL
2032 || exlist->op_targ != OP_LIST)
2035 if (exlist->op_first->op_type != OP_PUSHMARK
2036 && exlist->op_first != exlist->op_last)
2039 rv2cv = (UNOP*)exlist->op_last;
2041 if (rv2cv->op_type != OP_RV2CV)
2044 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2045 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2046 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2048 o->op_private |= OPpASSIGN_CV_TO_GV;
2049 rv2gv->op_private |= OPpDONT_INIT_GV;
2050 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2062 kid = cLOGOPo->op_first;
2063 if (kid->op_type == OP_NOT
2064 && (kid->op_flags & OPf_KIDS)) {
2065 if (o->op_type == OP_AND) {
2066 OpTYPE_set(o, OP_OR);
2068 OpTYPE_set(o, OP_AND);
2078 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2079 if (!(kid->op_flags & OPf_KIDS))
2086 if (o->op_flags & OPf_STACKED)
2093 if (!(o->op_flags & OPf_KIDS))
2104 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2105 if (!(kid->op_flags & OPf_KIDS))
2111 /* If the first kid after pushmark is something that the padrange
2112 optimisation would reject, then null the list and the pushmark.
2114 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2115 && ( !(kid = OpSIBLING(kid))
2116 || ( kid->op_type != OP_PADSV
2117 && kid->op_type != OP_PADAV
2118 && kid->op_type != OP_PADHV)
2119 || kid->op_private & ~OPpLVAL_INTRO
2120 || !(kid = OpSIBLING(kid))
2121 || ( kid->op_type != OP_PADSV
2122 && kid->op_type != OP_PADAV
2123 && kid->op_type != OP_PADHV)
2124 || kid->op_private & ~OPpLVAL_INTRO)
2126 op_null(cUNOPo->op_first); /* NULL the pushmark */
2127 op_null(o); /* NULL the list */
2139 /* mortalise it, in case warnings are fatal. */
2140 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2141 "Useless use of %"SVf" in void context",
2142 SVfARG(sv_2mortal(useless_sv)));
2145 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2146 "Useless use of %s in void context",
2149 } while ( (o = POP_DEFERRED_OP()) );
2151 Safefree(defer_stack);
2157 S_listkids(pTHX_ OP *o)
2159 if (o && o->op_flags & OPf_KIDS) {
2161 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2168 Perl_list(pTHX_ OP *o)
2172 /* assumes no premature commitment */
2173 if (!o || (o->op_flags & OPf_WANT)
2174 || (PL_parser && PL_parser->error_count)
2175 || o->op_type == OP_RETURN)
2180 if ((o->op_private & OPpTARGET_MY)
2181 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2183 return o; /* As if inside SASSIGN */
2186 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2188 switch (o->op_type) {
2190 list(cBINOPo->op_first);
2193 if (o->op_private & OPpREPEAT_DOLIST
2194 && !(o->op_flags & OPf_STACKED))
2196 list(cBINOPo->op_first);
2197 kid = cBINOPo->op_last;
2198 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2199 && SvIVX(kSVOP_sv) == 1)
2201 op_null(o); /* repeat */
2202 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2204 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2211 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2219 if (!(o->op_flags & OPf_KIDS))
2221 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2222 list(cBINOPo->op_first);
2223 return gen_constant_list(o);
2229 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2230 op_null(cUNOPo->op_first); /* NULL the pushmark */
2231 op_null(o); /* NULL the list */
2236 kid = cLISTOPo->op_first;
2238 kid = OpSIBLING(kid);
2241 OP *sib = OpSIBLING(kid);
2242 if (sib && kid->op_type != OP_LEAVEWHEN)
2248 PL_curcop = &PL_compiling;
2252 kid = cLISTOPo->op_first;
2259 S_scalarseq(pTHX_ OP *o)
2262 const OPCODE type = o->op_type;
2264 if (type == OP_LINESEQ || type == OP_SCOPE ||
2265 type == OP_LEAVE || type == OP_LEAVETRY)
2268 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2269 if ((sib = OpSIBLING(kid))
2270 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2271 || ( sib->op_targ != OP_NEXTSTATE
2272 && sib->op_targ != OP_DBSTATE )))
2277 PL_curcop = &PL_compiling;
2279 o->op_flags &= ~OPf_PARENS;
2280 if (PL_hints & HINT_BLOCK_SCOPE)
2281 o->op_flags |= OPf_PARENS;
2284 o = newOP(OP_STUB, 0);
2289 S_modkids(pTHX_ OP *o, I32 type)
2291 if (o && o->op_flags & OPf_KIDS) {
2293 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2294 op_lvalue(kid, type);
2300 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2301 * const fields. Also, convert CONST keys to HEK-in-SVs.
2302 * rop is the op that retrieves the hash;
2303 * key_op is the first key
2307 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2313 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2315 if (rop->op_first->op_type == OP_PADSV)
2316 /* @$hash{qw(keys here)} */
2317 rop = (UNOP*)rop->op_first;
2319 /* @{$hash}{qw(keys here)} */
2320 if (rop->op_first->op_type == OP_SCOPE
2321 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2323 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2330 lexname = NULL; /* just to silence compiler warnings */
2331 fields = NULL; /* just to silence compiler warnings */
2335 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2336 SvPAD_TYPED(lexname))
2337 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2338 && isGV(*fields) && GvHV(*fields);
2340 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2342 if (key_op->op_type != OP_CONST)
2344 svp = cSVOPx_svp(key_op);
2346 /* Make the CONST have a shared SV */
2347 if ( !SvIsCOW_shared_hash(sv = *svp)
2348 && SvTYPE(sv) < SVt_PVMG
2353 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2354 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2355 SvREFCNT_dec_NN(sv);
2360 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2362 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2363 "in variable %"PNf" of type %"HEKf,
2364 SVfARG(*svp), PNfARG(lexname),
2365 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2372 =for apidoc finalize_optree
2374 This function finalizes the optree. Should be called directly after
2375 the complete optree is built. It does some additional
2376 checking which can't be done in the normal C<ck_>xxx functions and makes
2377 the tree thread-safe.
2382 Perl_finalize_optree(pTHX_ OP* o)
2384 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2387 SAVEVPTR(PL_curcop);
2395 /* Relocate sv to the pad for thread safety.
2396 * Despite being a "constant", the SV is written to,
2397 * for reference counts, sv_upgrade() etc. */
2398 PERL_STATIC_INLINE void
2399 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2402 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2404 ix = pad_alloc(OP_CONST, SVf_READONLY);
2405 SvREFCNT_dec(PAD_SVl(ix));
2406 PAD_SETSV(ix, *svp);
2407 /* XXX I don't know how this isn't readonly already. */
2408 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2416 S_finalize_op(pTHX_ OP* o)
2418 PERL_ARGS_ASSERT_FINALIZE_OP;
2421 switch (o->op_type) {
2424 PL_curcop = ((COP*)o); /* for warnings */
2427 if (OpHAS_SIBLING(o)) {
2428 OP *sib = OpSIBLING(o);
2429 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2430 && ckWARN(WARN_EXEC)
2431 && OpHAS_SIBLING(sib))
2433 const OPCODE type = OpSIBLING(sib)->op_type;
2434 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2435 const line_t oldline = CopLINE(PL_curcop);
2436 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2437 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2438 "Statement unlikely to be reached");
2439 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2440 "\t(Maybe you meant system() when you said exec()?)\n");
2441 CopLINE_set(PL_curcop, oldline);
2448 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2449 GV * const gv = cGVOPo_gv;
2450 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2451 /* XXX could check prototype here instead of just carping */
2452 SV * const sv = sv_newmortal();
2453 gv_efullname3(sv, gv, NULL);
2454 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2455 "%"SVf"() called too early to check prototype",
2462 if (cSVOPo->op_private & OPpCONST_STRICT)
2463 no_bareword_allowed(o);
2467 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2472 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2473 case OP_METHOD_NAMED:
2474 case OP_METHOD_SUPER:
2475 case OP_METHOD_REDIR:
2476 case OP_METHOD_REDIR_SUPER:
2477 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2486 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2489 rop = (UNOP*)((BINOP*)o)->op_first;
2494 S_scalar_slice_warning(aTHX_ o);
2498 kid = OpSIBLING(cLISTOPo->op_first);
2499 if (/* I bet there's always a pushmark... */
2500 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2501 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2506 key_op = (SVOP*)(kid->op_type == OP_CONST
2508 : OpSIBLING(kLISTOP->op_first));
2510 rop = (UNOP*)((LISTOP*)o)->op_last;
2513 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2515 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2519 S_scalar_slice_warning(aTHX_ o);
2523 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2524 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2531 if (o->op_flags & OPf_KIDS) {
2535 /* check that op_last points to the last sibling, and that
2536 * the last op_sibling/op_sibparent field points back to the
2537 * parent, and that the only ops with KIDS are those which are
2538 * entitled to them */
2539 U32 type = o->op_type;
2543 if (type == OP_NULL) {
2545 /* ck_glob creates a null UNOP with ex-type GLOB
2546 * (which is a list op. So pretend it wasn't a listop */
2547 if (type == OP_GLOB)
2550 family = PL_opargs[type] & OA_CLASS_MASK;
2552 has_last = ( family == OA_BINOP
2553 || family == OA_LISTOP
2554 || family == OA_PMOP
2555 || family == OA_LOOP
2557 assert( has_last /* has op_first and op_last, or ...
2558 ... has (or may have) op_first: */
2559 || family == OA_UNOP
2560 || family == OA_UNOP_AUX
2561 || family == OA_LOGOP
2562 || family == OA_BASEOP_OR_UNOP
2563 || family == OA_FILESTATOP
2564 || family == OA_LOOPEXOP
2565 || family == OA_METHOP
2566 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2567 || type == OP_SASSIGN
2568 || type == OP_CUSTOM
2569 || type == OP_NULL /* new_logop does this */
2572 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2573 # ifdef PERL_OP_PARENT
2574 if (!OpHAS_SIBLING(kid)) {
2576 assert(kid == cLISTOPo->op_last);
2577 assert(kid->op_sibparent == o);
2580 if (has_last && !OpHAS_SIBLING(kid))
2581 assert(kid == cLISTOPo->op_last);
2586 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2592 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2594 Propagate lvalue ("modifiable") context to an op and its children.
2595 C<type> represents the context type, roughly based on the type of op that
2596 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2597 because it has no op type of its own (it is signalled by a flag on
2600 This function detects things that can't be modified, such as C<$x+1>, and
2601 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2602 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2604 It also flags things that need to behave specially in an lvalue context,
2605 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2611 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2614 PadnameLVALUE_on(pn);
2615 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2618 assert(CvPADLIST(cv));
2620 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2621 assert(PadnameLEN(pn));
2622 PadnameLVALUE_on(pn);
2627 S_vivifies(const OPCODE type)
2630 case OP_RV2AV: case OP_ASLICE:
2631 case OP_RV2HV: case OP_KVASLICE:
2632 case OP_RV2SV: case OP_HSLICE:
2633 case OP_AELEMFAST: case OP_KVHSLICE:
2642 S_lvref(pTHX_ OP *o, I32 type)
2646 switch (o->op_type) {
2648 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2649 kid = OpSIBLING(kid))
2650 S_lvref(aTHX_ kid, type);
2655 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2656 o->op_flags |= OPf_STACKED;
2657 if (o->op_flags & OPf_PARENS) {
2658 if (o->op_private & OPpLVAL_INTRO) {
2659 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2660 "localized parenthesized array in list assignment"));
2664 OpTYPE_set(o, OP_LVAVREF);
2665 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2666 o->op_flags |= OPf_MOD|OPf_REF;
2669 o->op_private |= OPpLVREF_AV;
2672 kid = cUNOPo->op_first;
2673 if (kid->op_type == OP_NULL)
2674 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2676 o->op_private = OPpLVREF_CV;
2677 if (kid->op_type == OP_GV)
2678 o->op_flags |= OPf_STACKED;
2679 else if (kid->op_type == OP_PADCV) {
2680 o->op_targ = kid->op_targ;
2682 op_free(cUNOPo->op_first);
2683 cUNOPo->op_first = NULL;
2684 o->op_flags &=~ OPf_KIDS;
2689 if (o->op_flags & OPf_PARENS) {
2691 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2692 "parenthesized hash in list assignment"));
2695 o->op_private |= OPpLVREF_HV;
2699 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2700 o->op_flags |= OPf_STACKED;
2703 if (o->op_flags & OPf_PARENS) goto parenhash;
2704 o->op_private |= OPpLVREF_HV;
2707 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2710 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2711 if (o->op_flags & OPf_PARENS) goto slurpy;
2712 o->op_private |= OPpLVREF_AV;
2716 o->op_private |= OPpLVREF_ELEM;
2717 o->op_flags |= OPf_STACKED;
2721 OpTYPE_set(o, OP_LVREFSLICE);
2722 o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2725 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2727 else if (!(o->op_flags & OPf_KIDS))
2729 if (o->op_targ != OP_LIST) {
2730 S_lvref(aTHX_ cBINOPo->op_first, type);
2735 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2736 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2737 S_lvref(aTHX_ kid, type);
2741 if (o->op_flags & OPf_PARENS)
2746 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2747 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2748 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2753 OpTYPE_set(o, OP_LVREF);
2755 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2756 if (type == OP_ENTERLOOP)
2757 o->op_private |= OPpLVREF_ITER;
2761 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2765 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2768 if (!o || (PL_parser && PL_parser->error_count))
2771 if ((o->op_private & OPpTARGET_MY)
2772 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2777 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2779 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2781 switch (o->op_type) {
2786 if ((o->op_flags & OPf_PARENS))
2790 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2791 !(o->op_flags & OPf_STACKED)) {
2792 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
2793 assert(cUNOPo->op_first->op_type == OP_NULL);
2794 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2797 else { /* lvalue subroutine call */
2798 o->op_private |= OPpLVAL_INTRO;
2799 PL_modcount = RETURN_UNLIMITED_NUMBER;
2800 if (type == OP_GREPSTART || type == OP_ENTERSUB
2801 || type == OP_REFGEN || type == OP_LEAVESUBLV) {
2802 /* Potential lvalue context: */
2803 o->op_private |= OPpENTERSUB_INARGS;
2806 else { /* Compile-time error message: */
2807 OP *kid = cUNOPo->op_first;
2812 if (kid->op_type != OP_PUSHMARK) {
2813 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2815 "panic: unexpected lvalue entersub "
2816 "args: type/targ %ld:%"UVuf,
2817 (long)kid->op_type, (UV)kid->op_targ);
2818 kid = kLISTOP->op_first;
2820 while (OpHAS_SIBLING(kid))
2821 kid = OpSIBLING(kid);
2822 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2823 break; /* Postpone until runtime */
2826 kid = kUNOP->op_first;
2827 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2828 kid = kUNOP->op_first;
2829 if (kid->op_type == OP_NULL)
2831 "Unexpected constant lvalue entersub "
2832 "entry via type/targ %ld:%"UVuf,
2833 (long)kid->op_type, (UV)kid->op_targ);
2834 if (kid->op_type != OP_GV) {
2841 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2842 ? MUTABLE_CV(SvRV(gv))
2848 if (flags & OP_LVALUE_NO_CROAK)
2851 namesv = cv_name(cv, NULL, 0);
2852 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2853 "subroutine call of &%"SVf" in %s",
2854 SVfARG(namesv), PL_op_desc[type]),
2862 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2863 /* grep, foreach, subcalls, refgen */
2864 if (type == OP_GREPSTART || type == OP_ENTERSUB
2865 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2867 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2868 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2871 type ? PL_op_desc[type] : "local"));
2884 case OP_RIGHT_SHIFT:
2893 if (!(o->op_flags & OPf_STACKED))
2899 if (o->op_flags & OPf_STACKED) {
2903 if (!(o->op_private & OPpREPEAT_DOLIST))
2906 const I32 mods = PL_modcount;
2907 modkids(cBINOPo->op_first, type);
2908 if (type != OP_AASSIGN)
2910 kid = cBINOPo->op_last;
2911 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2912 const IV iv = SvIV(kSVOP_sv);
2913 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2915 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2918 PL_modcount = RETURN_UNLIMITED_NUMBER;
2924 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2925 op_lvalue(kid, type);
2930 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2931 PL_modcount = RETURN_UNLIMITED_NUMBER;
2932 return o; /* Treat \(@foo) like ordinary list. */
2936 if (scalar_mod_type(o, type))
2938 ref(cUNOPo->op_first, o->op_type);
2945 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2946 if (type == OP_LEAVESUBLV && (
2947 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2948 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2950 o->op_private |= OPpMAYBE_LVSUB;
2954 PL_modcount = RETURN_UNLIMITED_NUMBER;
2958 if (type == OP_LEAVESUBLV)
2959 o->op_private |= OPpMAYBE_LVSUB;
2962 PL_hints |= HINT_BLOCK_SCOPE;
2963 if (type == OP_LEAVESUBLV)
2964 o->op_private |= OPpMAYBE_LVSUB;
2968 ref(cUNOPo->op_first, o->op_type);
2972 PL_hints |= HINT_BLOCK_SCOPE;
2982 case OP_AELEMFAST_LEX:
2989 PL_modcount = RETURN_UNLIMITED_NUMBER;
2990 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2991 return o; /* Treat \(@foo) like ordinary list. */
2992 if (scalar_mod_type(o, type))
2994 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2995 && type == OP_LEAVESUBLV)
2996 o->op_private |= OPpMAYBE_LVSUB;
3000 if (!type) /* local() */
3001 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3002 PNfARG(PAD_COMPNAME(o->op_targ)));
3003 if (!(o->op_private & OPpLVAL_INTRO)
3004 || ( type != OP_SASSIGN && type != OP_AASSIGN
3005 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3006 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3014 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
3018 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3024 if (type == OP_LEAVESUBLV)
3025 o->op_private |= OPpMAYBE_LVSUB;
3026 if (o->op_flags & OPf_KIDS)
3027 op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3032 ref(cBINOPo->op_first, o->op_type);
3033 if (type == OP_ENTERSUB &&
3034 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3035 o->op_private |= OPpLVAL_DEFER;
3036 if (type == OP_LEAVESUBLV)
3037 o->op_private |= OPpMAYBE_LVSUB;
3044 o->op_private |= OPpLVALUE;
3050 if (o->op_flags & OPf_KIDS)
3051 op_lvalue(cLISTOPo->op_last, type);
3056 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3058 else if (!(o->op_flags & OPf_KIDS))
3060 if (o->op_targ != OP_LIST) {
3061 op_lvalue(cBINOPo->op_first, type);
3067 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3068 /* elements might be in void context because the list is
3069 in scalar context or because they are attribute sub calls */
3070 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3071 op_lvalue(kid, type);
3079 if (type == OP_LEAVESUBLV
3080 || !S_vivifies(cLOGOPo->op_first->op_type))
3081 op_lvalue(cLOGOPo->op_first, type);
3082 if (type == OP_LEAVESUBLV
3083 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3084 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3088 if (type != OP_AASSIGN && type != OP_SASSIGN
3089 && type != OP_ENTERLOOP)
3091 /* Don’t bother applying lvalue context to the ex-list. */
3092 kid = cUNOPx(cUNOPo->op_first)->op_first;
3093 assert (!OpHAS_SIBLING(kid));
3096 if (type != OP_AASSIGN) goto nomod;
3097 kid = cUNOPo->op_first;
3100 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3101 S_lvref(aTHX_ kid, type);
3102 if (!PL_parser || PL_parser->error_count == ec) {
3103 if (!FEATURE_REFALIASING_IS_ENABLED)
3105 "Experimental aliasing via reference not enabled");
3106 Perl_ck_warner_d(aTHX_
3107 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3108 "Aliasing via reference is experimental");
3111 if (o->op_type == OP_REFGEN)
3112 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3117 kid = cLISTOPo->op_first;
3118 if (kid && kid->op_type == OP_PUSHRE &&
3120 || o->op_flags & OPf_STACKED
3122 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3124 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3127 /* This is actually @array = split. */
3128 PL_modcount = RETURN_UNLIMITED_NUMBER;
3134 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3138 /* [20011101.069] File test operators interpret OPf_REF to mean that
3139 their argument is a filehandle; thus \stat(".") should not set
3141 if (type == OP_REFGEN &&
3142 PL_check[o->op_type] == Perl_ck_ftst)
3145 if (type != OP_LEAVESUBLV)
3146 o->op_flags |= OPf_MOD;
3148 if (type == OP_AASSIGN || type == OP_SASSIGN)
3149 o->op_flags |= OPf_SPECIAL|OPf_REF;
3150 else if (!type) { /* local() */
3153 o->op_private |= OPpLVAL_INTRO;
3154 o->op_flags &= ~OPf_SPECIAL;
3155 PL_hints |= HINT_BLOCK_SCOPE;
3160 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3161 "Useless localization of %s", OP_DESC(o));
3164 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3165 && type != OP_LEAVESUBLV)
3166 o->op_flags |= OPf_REF;
3171 S_scalar_mod_type(const OP *o, I32 type)
3176 if (o && o->op_type == OP_RV2GV)
3200 case OP_RIGHT_SHIFT:
3221 S_is_handle_constructor(const OP *o, I32 numargs)
3223 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3225 switch (o->op_type) {
3233 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3246 S_refkids(pTHX_ OP *o, I32 type)
3248 if (o && o->op_flags & OPf_KIDS) {
3250 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3257 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3262 PERL_ARGS_ASSERT_DOREF;
3264 if (PL_parser && PL_parser->error_count)
3267 switch (o->op_type) {
3269 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3270 !(o->op_flags & OPf_STACKED)) {
3271 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3272 assert(cUNOPo->op_first->op_type == OP_NULL);
3273 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3274 o->op_flags |= OPf_SPECIAL;
3276 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3277 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3278 : type == OP_RV2HV ? OPpDEREF_HV
3280 o->op_flags |= OPf_MOD;
3286 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3287 doref(kid, type, set_op_ref);
3290 if (type == OP_DEFINED)
3291 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3292 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3295 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3296 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3297 : type == OP_RV2HV ? OPpDEREF_HV
3299 o->op_flags |= OPf_MOD;
3306 o->op_flags |= OPf_REF;
3309 if (type == OP_DEFINED)
3310 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3311 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3317 o->op_flags |= OPf_REF;
3322 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3324 doref(cBINOPo->op_first, type, set_op_ref);
3328 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3329 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3330 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3331 : type == OP_RV2HV ? OPpDEREF_HV
3333 o->op_flags |= OPf_MOD;
3343 if (!(o->op_flags & OPf_KIDS))
3345 doref(cLISTOPo->op_last, type, set_op_ref);
3355 S_dup_attrlist(pTHX_ OP *o)
3359 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3361 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3362 * where the first kid is OP_PUSHMARK and the remaining ones
3363 * are OP_CONST. We need to push the OP_CONST values.
3365 if (o->op_type == OP_CONST)
3366 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3368 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3370 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3371 if (o->op_type == OP_CONST)
3372 rop = op_append_elem(OP_LIST, rop,
3373 newSVOP(OP_CONST, o->op_flags,
3374 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3381 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3383 PERL_ARGS_ASSERT_APPLY_ATTRS;
3385 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3387 /* fake up C<use attributes $pkg,$rv,@attrs> */
3389 #define ATTRSMODULE "attributes"
3390 #define ATTRSMODULE_PM "attributes.pm"
3393 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3394 newSVpvs(ATTRSMODULE),
3396 op_prepend_elem(OP_LIST,
3397 newSVOP(OP_CONST, 0, stashsv),
3398 op_prepend_elem(OP_LIST,
3399 newSVOP(OP_CONST, 0,
3401 dup_attrlist(attrs))));
3406 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3408 OP *pack, *imop, *arg;
3409 SV *meth, *stashsv, **svp;
3411 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3416 assert(target->op_type == OP_PADSV ||
3417 target->op_type == OP_PADHV ||
3418 target->op_type == OP_PADAV);
3420 /* Ensure that attributes.pm is loaded. */
3421 /* Don't force the C<use> if we don't need it. */
3422 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3423 if (svp && *svp != &PL_sv_undef)
3424 NOOP; /* already in %INC */
3426 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3427 newSVpvs(ATTRSMODULE), NULL);
3429 /* Need package name for method call. */
3430 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3432 /* Build up the real arg-list. */
3433 stashsv = newSVhek(HvNAME_HEK(stash));
3435 arg = newOP(OP_PADSV, 0);
3436 arg->op_targ = target->op_targ;
3437 arg = op_prepend_elem(OP_LIST,
3438 newSVOP(OP_CONST, 0, stashsv),
3439 op_prepend_elem(OP_LIST,
3440 newUNOP(OP_REFGEN, 0,
3442 dup_attrlist(attrs)));
3444 /* Fake up a method call to import */
3445 meth = newSVpvs_share("import");
3446 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3447 op_append_elem(OP_LIST,
3448 op_prepend_elem(OP_LIST, pack, arg),
3449 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3451 /* Combine the ops. */
3452 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3456 =notfor apidoc apply_attrs_string
3458 Attempts to apply a list of attributes specified by the C<attrstr> and
3459 C<len> arguments to the subroutine identified by the C<cv> argument which
3460 is expected to be associated with the package identified by the C<stashpv>
3461 argument (see L<attributes>). It gets this wrong, though, in that it
3462 does not correctly identify the boundaries of the individual attribute
3463 specifications within C<attrstr>. This is not really intended for the
3464 public API, but has to be listed here for systems such as AIX which
3465 need an explicit export list for symbols. (It's called from XS code
3466 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3467 to respect attribute syntax properly would be welcome.
3473 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3474 const char *attrstr, STRLEN len)
3478 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3481 len = strlen(attrstr);
3485 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3487 const char * const sstr = attrstr;
3488 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3489 attrs = op_append_elem(OP_LIST, attrs,
3490 newSVOP(OP_CONST, 0,
3491 newSVpvn(sstr, attrstr-sstr)));
3495 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3496 newSVpvs(ATTRSMODULE),
3497 NULL, op_prepend_elem(OP_LIST,
3498 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3499 op_prepend_elem(OP_LIST,
3500 newSVOP(OP_CONST, 0,
3501 newRV(MUTABLE_SV(cv))),
3506 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3508 OP *new_proto = NULL;
3513 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3519 if (o->op_type == OP_CONST) {
3520 pv = SvPV(cSVOPo_sv, pvlen);
3521 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3522 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3523 SV ** const tmpo = cSVOPx_svp(o);
3524 SvREFCNT_dec(cSVOPo_sv);
3529 } else if (o->op_type == OP_LIST) {
3531 assert(o->op_flags & OPf_KIDS);
3532 lasto = cLISTOPo->op_first;
3533 assert(lasto->op_type == OP_PUSHMARK);
3534 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3535 if (o->op_type == OP_CONST) {
3536 pv = SvPV(cSVOPo_sv, pvlen);
3537 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3538 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3539 SV ** const tmpo = cSVOPx_svp(o);
3540 SvREFCNT_dec(cSVOPo_sv);
3542 if (new_proto && ckWARN(WARN_MISC)) {
3544 const char * newp = SvPV(cSVOPo_sv, new_len);
3545 Perl_warner(aTHX_ packWARN(WARN_MISC),
3546 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3547 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3553 /* excise new_proto from the list */
3554 op_sibling_splice(*attrs, lasto, 1, NULL);
3561 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3562 would get pulled in with no real need */
3563 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3572 svname = sv_newmortal();
3573 gv_efullname3(svname, name, NULL);
3575 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3576 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3578 svname = (SV *)name;
3579 if (ckWARN(WARN_ILLEGALPROTO))
3580 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3581 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3582 STRLEN old_len, new_len;
3583 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3584 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3586 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3587 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3589 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3590 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3600 S_cant_declare(pTHX_ OP *o)
3602 if (o->op_type == OP_NULL
3603 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3604 o = cUNOPo->op_first;
3605 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3606 o->op_type == OP_NULL
3607 && o->op_flags & OPf_SPECIAL
3610 PL_parser->in_my == KEY_our ? "our" :
3611 PL_parser->in_my == KEY_state ? "state" :
3616 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3619 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3621 PERL_ARGS_ASSERT_MY_KID;
3623 if (!o || (PL_parser && PL_parser->error_count))
3628 if (type == OP_LIST) {
3630 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3631 my_kid(kid, attrs, imopsp);
3633 } else if (type == OP_UNDEF || type == OP_STUB) {
3635 } else if (type == OP_RV2SV || /* "our" declaration */
3637 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3638 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3639 S_cant_declare(aTHX_ o);
3641 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3643 PL_parser->in_my = FALSE;
3644 PL_parser->in_my_stash = NULL;
3645 apply_attrs(GvSTASH(gv),
3646 (type == OP_RV2SV ? GvSV(gv) :
3647 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3648 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3651 o->op_private |= OPpOUR_INTRO;
3654 else if (type != OP_PADSV &&
3657 type != OP_PUSHMARK)
3659 S_cant_declare(aTHX_ o);
3662 else if (attrs && type != OP_PUSHMARK) {
3666 PL_parser->in_my = FALSE;
3667 PL_parser->in_my_stash = NULL;
3669 /* check for C<my Dog $spot> when deciding package */
3670 stash = PAD_COMPNAME_TYPE(o->op_targ);
3672 stash = PL_curstash;
3673 apply_attrs_my(stash, o, attrs, imopsp);
3675 o->op_flags |= OPf_MOD;
3676 o->op_private |= OPpLVAL_INTRO;
3678 o->op_private |= OPpPAD_STATE;
3683 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3686 int maybe_scalar = 0;
3688 PERL_ARGS_ASSERT_MY_ATTRS;
3690 /* [perl #17376]: this appears to be premature, and results in code such as
3691 C< our(%x); > executing in list mode rather than void mode */
3693 if (o->op_flags & OPf_PARENS)
3703 o = my_kid(o, attrs, &rops);
3705 if (maybe_scalar && o->op_type == OP_PADSV) {
3706 o = scalar(op_append_list(OP_LIST, rops, o));
3707 o->op_private |= OPpLVAL_INTRO;
3710 /* The listop in rops might have a pushmark at the beginning,
3711 which will mess up list assignment. */
3712 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3713 if (rops->op_type == OP_LIST &&
3714 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3716 OP * const pushmark = lrops->op_first;
3717 /* excise pushmark */
3718 op_sibling_splice(rops, NULL, 1, NULL);
3721 o = op_append_list(OP_LIST, o, rops);
3724 PL_parser->in_my = FALSE;
3725 PL_parser->in_my_stash = NULL;
3730 Perl_sawparens(pTHX_ OP *o)
3732 PERL_UNUSED_CONTEXT;
3734 o->op_flags |= OPf_PARENS;
3739 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3743 const OPCODE ltype = left->op_type;
3744 const OPCODE rtype = right->op_type;
3746 PERL_ARGS_ASSERT_BIND_MATCH;
3748 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3749 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3751 const char * const desc
3753 rtype == OP_SUBST || rtype == OP_TRANS
3754 || rtype == OP_TRANSR
3756 ? (int)rtype : OP_MATCH];
3757 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3759 S_op_varname(aTHX_ left);
3761 Perl_warner(aTHX_ packWARN(WARN_MISC),
3762 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3763 desc, SVfARG(name), SVfARG(name));
3765 const char * const sample = (isary
3766 ? "@array" : "%hash");
3767 Perl_warner(aTHX_ packWARN(WARN_MISC),
3768 "Applying %s to %s will act on scalar(%s)",
3769 desc, sample, sample);
3773 if (rtype == OP_CONST &&
3774 cSVOPx(right)->op_private & OPpCONST_BARE &&
3775 cSVOPx(right)->op_private & OPpCONST_STRICT)
3777 no_bareword_allowed(right);
3780 /* !~ doesn't make sense with /r, so error on it for now */
3781 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3783 /* diag_listed_as: Using !~ with %s doesn't make sense */
3784 yyerror("Using !~ with s///r doesn't make sense");
3785 if (rtype == OP_TRANSR && type == OP_NOT)
3786 /* diag_listed_as: Using !~ with %s doesn't make sense */
3787 yyerror("Using !~ with tr///r doesn't make sense");
3789 ismatchop = (rtype == OP_MATCH ||
3790 rtype == OP_SUBST ||
3791 rtype == OP_TRANS || rtype == OP_TRANSR)
3792 && !(right->op_flags & OPf_SPECIAL);
3793 if (ismatchop && right->op_private & OPpTARGET_MY) {
3795 right->op_private &= ~OPpTARGET_MY;
3797 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3798 if (left->op_type == OP_PADSV
3799 && !(left->op_private & OPpLVAL_INTRO))
3801 right->op_targ = left->op_targ;
3806 right->op_flags |= OPf_STACKED;
3807 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3808 ! (rtype == OP_TRANS &&
3809 right->op_private & OPpTRANS_IDENTICAL) &&
3810 ! (rtype == OP_SUBST &&
3811 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3812 left = op_lvalue(left, rtype);
3813 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3814 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3816 o = op_prepend_elem(rtype, scalar(left), right);
3819 return newUNOP(OP_NOT, 0, scalar(o));
3823 return bind_match(type, left,
3824 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3828 Perl_invert(pTHX_ OP *o)
3832 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3836 =for apidoc Amx|OP *|op_scope|OP *o
3838 Wraps up an op tree with some additional ops so that at runtime a dynamic
3839 scope will be created. The original ops run in the new dynamic scope,
3840 and then, provided that they exit normally, the scope will be unwound.
3841 The additional ops used to create and unwind the dynamic scope will
3842 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3843 instead if the ops are simple enough to not need the full dynamic scope
3850 Perl_op_scope(pTHX_ OP *o)
3854 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3855 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3856 OpTYPE_set(o, OP_LEAVE);
3858 else if (o->op_type == OP_LINESEQ) {
3860 OpTYPE_set(o, OP_SCOPE);
3861 kid = ((LISTOP*)o)->op_first;
3862 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3865 /* The following deals with things like 'do {1 for 1}' */
3866 kid = OpSIBLING(kid);
3868 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3873 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3879 Perl_op_unscope(pTHX_ OP *o)
3881 if (o && o->op_type == OP_LINESEQ) {
3882 OP *kid = cLISTOPo->op_first;
3883 for(; kid; kid = OpSIBLING(kid))
3884 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3891 =for apidoc Am|int|block_start|int full
3893 Handles compile-time scope entry.
3894 Arranges for hints to be restored on block
3895 exit and also handles pad sequence numbers to make lexical variables scope
3896 right. Returns a savestack index for use with C<block_end>.
3902 Perl_block_start(pTHX_ int full)
3904 const int retval = PL_savestack_ix;
3906 PL_compiling.cop_seq = PL_cop_seqmax;
3908 pad_block_start(full);
3910 PL_hints &= ~HINT_BLOCK_SCOPE;
3911 SAVECOMPILEWARNINGS();
3912 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3913 SAVEI32(PL_compiling.cop_seq);
3914 PL_compiling.cop_seq = 0;
3916 CALL_BLOCK_HOOKS(bhk_start, full);
3922 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3924 Handles compile-time scope exit. C<floor>
3925 is the savestack index returned by
3926 C<block_start>, and C<seq> is the body of the block. Returns the block,
3933 Perl_block_end(pTHX_ I32 floor, OP *seq)
3935 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3936 OP* retval = scalarseq(seq);
3939 /* XXX Is the null PL_parser check necessary here? */
3940 assert(PL_parser); /* Let’s find out under debugging builds. */
3941 if (PL_parser && PL_parser->parsed_sub) {
3942 o = newSTATEOP(0, NULL, NULL);
3944 retval = op_append_elem(OP_LINESEQ, retval, o);
3947 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3951 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3955 /* pad_leavemy has created a sequence of introcv ops for all my
3956 subs declared in the block. We have to replicate that list with
3957 clonecv ops, to deal with this situation:
3962 sub s1 { state sub foo { \&s2 } }
3965 Originally, I was going to have introcv clone the CV and turn
3966 off the stale flag. Since &s1 is declared before &s2, the
3967 introcv op for &s1 is executed (on sub entry) before the one for
3968 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3969 cloned, since it is a state sub) closes over &s2 and expects
3970 to see it in its outer CV’s pad. If the introcv op clones &s1,
3971 then &s2 is still marked stale. Since &s1 is not active, and
3972 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3973 ble will not stay shared’ warning. Because it is the same stub
3974 that will be used when the introcv op for &s2 is executed, clos-
3975 ing over it is safe. Hence, we have to turn off the stale flag
3976 on all lexical subs in the block before we clone any of them.
3977 Hence, having introcv clone the sub cannot work. So we create a
3978 list of ops like this:
4002 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4003 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4004 for (;; kid = OpSIBLING(kid)) {
4005 OP *newkid = newOP(OP_CLONECV, 0);
4006 newkid->op_targ = kid->op_targ;
4007 o = op_append_elem(OP_LINESEQ, o, newkid);
4008 if (kid == last) break;
4010 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4013 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4019 =head1 Compile-time scope hooks
4021 =for apidoc Aox||blockhook_register
4023 Register a set of hooks to be called when the Perl lexical scope changes
4024 at compile time. See L<perlguts/"Compile-time scope hooks">.
4030 Perl_blockhook_register(pTHX_ BHK *hk)
4032 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4034 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4038 Perl_newPROG(pTHX_ OP *o)
4040 PERL_ARGS_ASSERT_NEWPROG;
4047 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4048 ((PL_in_eval & EVAL_KEEPERR)
4049 ? OPf_SPECIAL : 0), o);
4051 cx = &cxstack[cxstack_ix];
4052 assert(CxTYPE(cx) == CXt_EVAL);
4054 if ((cx->blk_gimme & G_WANT) == G_VOID)
4055 scalarvoid(PL_eval_root);
4056 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4059 scalar(PL_eval_root);
4061 PL_eval_start = op_linklist(PL_eval_root);
4062 PL_eval_root->op_private |= OPpREFCOUNTED;
4063 OpREFCNT_set(PL_eval_root, 1);
4064 PL_eval_root->op_next = 0;
4065 i = PL_savestack_ix;
4068 CALL_PEEP(PL_eval_start);
4069 finalize_optree(PL_eval_root);
4070 S_prune_chain_head(&PL_eval_start);
4072 PL_savestack_ix = i;
4075 if (o->op_type == OP_STUB) {
4076 /* This block is entered if nothing is compiled for the main
4077 program. This will be the case for an genuinely empty main
4078 program, or one which only has BEGIN blocks etc, so already
4081 Historically (5.000) the guard above was !o. However, commit
4082 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4083 c71fccf11fde0068, changed perly.y so that newPROG() is now
4084 called with the output of block_end(), which returns a new
4085 OP_STUB for the case of an empty optree. ByteLoader (and
4086 maybe other things) also take this path, because they set up
4087 PL_main_start and PL_main_root directly, without generating an
4090 If the parsing the main program aborts (due to parse errors,
4091 or due to BEGIN or similar calling exit), then newPROG()
4092 isn't even called, and hence this code path and its cleanups
4093 are skipped. This shouldn't make a make a difference:
4094 * a non-zero return from perl_parse is a failure, and
4095 perl_destruct() should be called immediately.
4096 * however, if exit(0) is called during the parse, then
4097 perl_parse() returns 0, and perl_run() is called. As
4098 PL_main_start will be NULL, perl_run() will return
4099 promptly, and the exit code will remain 0.
4102 PL_comppad_name = 0;
4104 S_op_destroy(aTHX_ o);
4107 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4108 PL_curcop = &PL_compiling;
4109 PL_main_start = LINKLIST(PL_main_root);
4110 PL_main_root->op_private |= OPpREFCOUNTED;
4111 OpREFCNT_set(PL_main_root, 1);
4112 PL_main_root->op_next = 0;
4113 CALL_PEEP(PL_main_start);
4114 finalize_optree(PL_main_root);
4115 S_prune_chain_head(&PL_main_start);
4116 cv_forget_slab(PL_compcv);
4119 /* Register with debugger */
4121 CV * const cv = get_cvs("DB::postponed", 0);
4125 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4127 call_sv(MUTABLE_SV(cv), G_DISCARD);
4134 Perl_localize(pTHX_ OP *o, I32 lex)
4136 PERL_ARGS_ASSERT_LOCALIZE;
4138 if (o->op_flags & OPf_PARENS)
4139 /* [perl #17376]: this appears to be premature, and results in code such as
4140 C< our(%x); > executing in list mode rather than void mode */
4147 if ( PL_parser->bufptr > PL_parser->oldbufptr
4148 && PL_parser->bufptr[-1] == ','
4149 && ckWARN(WARN_PARENTHESIS))
4151 char *s = PL_parser->bufptr;
4154 /* some heuristics to detect a potential error */
4155 while (*s && (strchr(", \t\n", *s)))
4159 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4161 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4164 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4166 while (*s && (strchr(", \t\n", *s)))
4172 if (sigil && (*s == ';' || *s == '=')) {
4173 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4174 "Parentheses missing around \"%s\" list",
4176 ? (PL_parser->in_my == KEY_our
4178 : PL_parser->in_my == KEY_state
4188 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4189 PL_parser->in_my = FALSE;
4190 PL_parser->in_my_stash = NULL;
4195 Perl_jmaybe(pTHX_ OP *o)
4197 PERL_ARGS_ASSERT_JMAYBE;
4199 if (o->op_type == OP_LIST) {
4201 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4202 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4207 PERL_STATIC_INLINE OP *
4208 S_op_std_init(pTHX_ OP *o)
4210 I32 type = o->op_type;
4212 PERL_ARGS_ASSERT_OP_STD_INIT;
4214 if (PL_opargs[type] & OA_RETSCALAR)
4216 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4217 o->op_targ = pad_alloc(type, SVs_PADTMP);
4222 PERL_STATIC_INLINE OP *
4223 S_op_integerize(pTHX_ OP *o)
4225 I32 type = o->op_type;
4227 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4229 /* integerize op. */
4230 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4233 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4236 if (type == OP_NEGATE)
4237 /* XXX might want a ck_negate() for this */
4238 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4244 S_fold_constants(pTHX_ OP *o)
4249 VOL I32 type = o->op_type;
4255 SV * const oldwarnhook = PL_warnhook;
4256 SV * const olddiehook = PL_diehook;
4258 U8 oldwarn = PL_dowarn;
4261 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4263 if (!(PL_opargs[type] & OA_FOLDCONST))
4272 #ifdef USE_LOCALE_CTYPE
4273 if (IN_LC_COMPILETIME(LC_CTYPE))
4282 #ifdef USE_LOCALE_COLLATE
4283 if (IN_LC_COMPILETIME(LC_COLLATE))
4288 /* XXX what about the numeric ops? */
4289 #ifdef USE_LOCALE_NUMERIC
4290 if (IN_LC_COMPILETIME(LC_NUMERIC))
4295 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4296 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4299 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4300 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4302 const char *s = SvPVX_const(sv);
4303 while (s < SvEND(sv)) {
4304 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4311 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4314 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4315 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4319 if (PL_parser && PL_parser->error_count)
4320 goto nope; /* Don't try to run w/ errors */
4322 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4323 const OPCODE type = curop->op_type;
4324 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4326 type != OP_SCALAR &&
4328 type != OP_PUSHMARK)
4334 curop = LINKLIST(o);
4335 old_next = o->op_next;
4339 oldscope = PL_scopestack_ix;
4340 create_eval_scope(G_FAKINGEVAL);
4342 /* Verify that we don't need to save it: */
4343 assert(PL_curcop == &PL_compiling);
4344 StructCopy(&PL_compiling, ¬_compiling, COP);
4345 PL_curcop = ¬_compiling;
4346 /* The above ensures that we run with all the correct hints of the
4347 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4348 assert(IN_PERL_RUNTIME);
4349 PL_warnhook = PERL_WARNHOOK_FATAL;
4353 /* Effective $^W=1. */
4354 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4355 PL_dowarn |= G_WARN_ON;
4360 sv = *(PL_stack_sp--);
4361 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4362 pad_swipe(o->op_targ, FALSE);
4364 else if (SvTEMP(sv)) { /* grab mortal temp? */
4365 SvREFCNT_inc_simple_void(sv);
4368 else { assert(SvIMMORTAL(sv)); }
4371 /* Something tried to die. Abandon constant folding. */
4372 /* Pretend the error never happened. */
4374 o->op_next = old_next;
4378 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4379 PL_warnhook = oldwarnhook;
4380 PL_diehook = olddiehook;
4381 /* XXX note that this croak may fail as we've already blown away
4382 * the stack - eg any nested evals */
4383 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4386 PL_dowarn = oldwarn;
4387 PL_warnhook = oldwarnhook;
4388 PL_diehook = olddiehook;
4389 PL_curcop = &PL_compiling;
4391 if (PL_scopestack_ix > oldscope)
4392 delete_eval_scope();
4397 /* OP_STRINGIFY and constant folding are used to implement qq.
4398 Here the constant folding is an implementation detail that we
4399 want to hide. If the stringify op is itself already marked
4400 folded, however, then it is actually a folded join. */
4401 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4406 else if (!SvIMMORTAL(sv)) {
4410 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4411 if (!is_stringify) newop->op_folded = 1;
4419 S_gen_constant_list(pTHX_ OP *o)
4423 const SSize_t oldtmps_floor = PL_tmps_floor;
4428 if (PL_parser && PL_parser->error_count)
4429 return o; /* Don't attempt to run with errors */
4431 curop = LINKLIST(o);
4434 S_prune_chain_head(&curop);
4436 Perl_pp_pushmark(aTHX);
4439 assert (!(curop->op_flags & OPf_SPECIAL));
4440 assert(curop->op_type == OP_RANGE);
4441 Perl_pp_anonlist(aTHX);
4442 PL_tmps_floor = oldtmps_floor;
4444 OpTYPE_set(o, OP_RV2AV);
4445 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4446 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4447 o->op_opt = 0; /* needs to be revisited in rpeep() */
4448 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4450 /* replace subtree with an OP_CONST */
4451 curop = ((UNOP*)o)->op_first;
4452 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4455 if (AvFILLp(av) != -1)
4456 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4459 SvREADONLY_on(*svp);
4466 =head1 Optree Manipulation Functions
4469 /* List constructors */
4472 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4474 Append an item to the list of ops contained directly within a list-type
4475 op, returning the lengthened list. C<first> is the list-type op,
4476 and C<last> is the op to append to the list. C<optype> specifies the
4477 intended opcode for the list. If C<first> is not already a list of the
4478 right type, it will be upgraded into one. If either C<first> or C<last>
4479 is null, the other is returned unchanged.
4485 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4493 if (first->op_type != (unsigned)type
4494 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4496 return newLISTOP(type, 0, first, last);
4499 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4500 first->op_flags |= OPf_KIDS;
4505 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4507 Concatenate the lists of ops contained directly within two list-type ops,
4508 returning the combined list. C<first> and C<last> are the list-type ops
4509 to concatenate. C<optype> specifies the intended opcode for the list.
4510 If either C<first> or C<last> is not already a list of the right type,
4511 it will be upgraded into one. If either C<first> or C<last> is null,
4512 the other is returned unchanged.
4518 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4526 if (first->op_type != (unsigned)type)
4527 return op_prepend_elem(type, first, last);
4529 if (last->op_type != (unsigned)type)
4530 return op_append_elem(type, first, last);
4532 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4533 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4534 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4535 first->op_flags |= (last->op_flags & OPf_KIDS);
4537 S_op_destroy(aTHX_ last);
4543 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4545 Prepend an item to the list of ops contained directly within a list-type
4546 op, returning the lengthened list. C<first> is the op to prepend to the
4547 list, and C<last> is the list-type op. C<optype> specifies the intended
4548 opcode for the list. If C<last> is not already a list of the right type,
4549 it will be upgraded into one. If either C<first> or C<last> is null,
4550 the other is returned unchanged.
4556 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4564 if (last->op_type == (unsigned)type) {
4565 if (type == OP_LIST) { /* already a PUSHMARK there */
4566 /* insert 'first' after pushmark */
4567 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4568 if (!(first->op_flags & OPf_PARENS))
4569 last->op_flags &= ~OPf_PARENS;
4572 op_sibling_splice(last, NULL, 0, first);
4573 last->op_flags |= OPf_KIDS;
4577 return newLISTOP(type, 0, first, last);
4581 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4583 Converts C<o> into a list op if it is not one already, and then converts it
4584 into the specified C<type>, calling its check function, allocating a target if
4585 it needs one, and folding constants.
4587 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4588 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4589 C<op_convert_list> to make it the right type.
4595 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4598 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4599 if (!o || o->op_type != OP_LIST)
4600 o = force_list(o, 0);
4603 o->op_flags &= ~OPf_WANT;
4604 o->op_private &= ~OPpLVAL_INTRO;
4607 if (!(PL_opargs[type] & OA_MARK))
4608 op_null(cLISTOPo->op_first);
4610 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4611 if (kid2 && kid2->op_type == OP_COREARGS) {
4612 op_null(cLISTOPo->op_first);
4613 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4617 OpTYPE_set(o, type);
4618 o->op_flags |= flags;
4619 if (flags & OPf_FOLDED)
4622 o = CHECKOP(type, o);
4623 if (o->op_type != (unsigned)type)
4626 return fold_constants(op_integerize(op_std_init(o)));
4633 =head1 Optree construction
4635 =for apidoc Am|OP *|newNULLLIST
4637 Constructs, checks, and returns a new C<stub> op, which represents an
4638 empty list expression.
4644 Perl_newNULLLIST(pTHX)
4646 return newOP(OP_STUB, 0);
4649 /* promote o and any siblings to be a list if its not already; i.e.
4657 * pushmark - o - A - B
4659 * If nullit it true, the list op is nulled.
4663 S_force_list(pTHX_ OP *o, bool nullit)
4665 if (!o || o->op_type != OP_LIST) {
4668 /* manually detach any siblings then add them back later */
4669 rest = OpSIBLING(o);
4670 OpLASTSIB_set(o, NULL);
4672 o = newLISTOP(OP_LIST, 0, o, NULL);
4674 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4682 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4684 Constructs, checks, and returns an op of any list type. C<type> is
4685 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4686 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
4687 supply up to two ops to be direct children of the list op; they are
4688 consumed by this function and become part of the constructed op tree.
4690 For most list operators, the check function expects all the kid ops to be
4691 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4692 appropriate. What you want to do in that case is create an op of type
4693 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4694 See L</op_convert_list> for more information.
4701 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4706 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4707 || type == OP_CUSTOM);
4709 NewOp(1101, listop, 1, LISTOP);
4711 OpTYPE_set(listop, type);
4714 listop->op_flags = (U8)flags;
4718 else if (!first && last)
4721 OpMORESIB_set(first, last);
4722 listop->op_first = first;
4723 listop->op_last = last;
4724 if (type == OP_LIST) {
4725 OP* const pushop = newOP(OP_PUSHMARK, 0);
4726 OpMORESIB_set(pushop, first);
4727 listop->op_first = pushop;
4728 listop->op_flags |= OPf_KIDS;
4730 listop->op_last = pushop;
4732 if (listop->op_last)
4733 OpLASTSIB_set(listop->op_last, (OP*)listop);
4735 return CHECKOP(type, listop);
4739 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4741 Constructs, checks, and returns an op of any base type (any type that
4742 has no extra fields). C<type> is the opcode. C<flags> gives the
4743 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4750 Perl_newOP(pTHX_ I32 type, I32 flags)
4755 if (type == -OP_ENTEREVAL) {
4756 type = OP_ENTEREVAL;
4757 flags |= OPpEVAL_BYTES<<8;
4760 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4761 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4762 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4763 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4765 NewOp(1101, o, 1, OP);
4766 OpTYPE_set(o, type);
4767 o->op_flags = (U8)flags;
4770 o->op_private = (U8)(0 | (flags >> 8));
4771 if (PL_opargs[type] & OA_RETSCALAR)
4773 if (PL_opargs[type] & OA_TARGET)
4774 o->op_targ = pad_alloc(type, SVs_PADTMP);
4775 return CHECKOP(type, o);
4779 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4781 Constructs, checks, and returns an op of any unary type. C<type> is
4782 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4783 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4784 bits, the eight bits of C<op_private>, except that the bit with value 1
4785 is automatically set. C<first> supplies an optional op to be the direct
4786 child of the unary op; it is consumed by this function and become part
4787 of the constructed op tree.
4793 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4798 if (type == -OP_ENTEREVAL) {
4799 type = OP_ENTEREVAL;
4800 flags |= OPpEVAL_BYTES<<8;
4803 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4804 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4805 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4806 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4807 || type == OP_SASSIGN
4808 || type == OP_ENTERTRY
4809 || type == OP_CUSTOM
4810 || type == OP_NULL );
4813 first = newOP(OP_STUB, 0);
4814 if (PL_opargs[type] & OA_MARK)
4815 first = force_list(first, 1);
4817 NewOp(1101, unop, 1, UNOP);
4818 OpTYPE_set(unop, type);
4819 unop->op_first = first;
4820 unop->op_flags = (U8)(flags | OPf_KIDS);
4821 unop->op_private = (U8)(1 | (flags >> 8));
4823 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4824 OpLASTSIB_set(first, (OP*)unop);
4826 unop = (UNOP*) CHECKOP(type, unop);
4830 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4834 =for apidoc newUNOP_AUX
4836 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4837 initialised to C<aux>
4843 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4848 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4849 || type == OP_CUSTOM);
4851 NewOp(1101, unop, 1, UNOP_AUX);
4852 unop->op_type = (OPCODE)type;
4853 unop->op_ppaddr = PL_ppaddr[type];
4854 unop->op_first = first;
4855 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4856 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4859 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4860 OpLASTSIB_set(first, (OP*)unop);
4862 unop = (UNOP_AUX*) CHECKOP(type, unop);
4864 return op_std_init((OP *) unop);
4868 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4870 Constructs, checks, and returns an op of method type with a method name
4871 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
4872 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4873 and, shifted up eight bits, the eight bits of C<op_private>, except that
4874 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
4875 op which evaluates method name; it is consumed by this function and
4876 become part of the constructed op tree.
4877 Supported optypes: C<OP_METHOD>.
4883 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4887 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4888 || type == OP_CUSTOM);
4890 NewOp(1101, methop, 1, METHOP);
4892 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4893 methop->op_flags = (U8)(flags | OPf_KIDS);
4894 methop->op_u.op_first = dynamic_meth;
4895 methop->op_private = (U8)(1 | (flags >> 8));
4897 if (!OpHAS_SIBLING(dynamic_meth))
4898 OpLASTSIB_set(dynamic_meth, (OP*)methop);
4902 methop->op_flags = (U8)(flags & ~OPf_KIDS);
4903 methop->op_u.op_meth_sv = const_meth;
4904 methop->op_private = (U8)(0 | (flags >> 8));
4905 methop->op_next = (OP*)methop;
4909 methop->op_rclass_targ = 0;
4911 methop->op_rclass_sv = NULL;
4914 OpTYPE_set(methop, type);
4915 return CHECKOP(type, methop);
4919 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4920 PERL_ARGS_ASSERT_NEWMETHOP;
4921 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4925 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4927 Constructs, checks, and returns an op of method type with a constant
4928 method name. C<type> is the opcode. C<flags> gives the eight bits of
4929 C<op_flags>, and, shifted up eight bits, the eight bits of
4930 C<op_private>. C<const_meth> supplies a constant method name;
4931 it must be a shared COW string.
4932 Supported optypes: C<OP_METHOD_NAMED>.
4938 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4939 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4940 return newMETHOP_internal(type, flags, NULL, const_meth);
4944 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4946 Constructs, checks, and returns an op of any binary type. C<type>
4947 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
4948 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4949 the eight bits of C<op_private>, except that the bit with value 1 or
4950 2 is automatically set as required. C<first> and C<last> supply up to
4951 two ops to be the direct children of the binary op; they are consumed
4952 by this function and become part of the constructed op tree.
4958 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4963 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4964 || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
4966 NewOp(1101, binop, 1, BINOP);
4969 first = newOP(OP_NULL, 0);
4971 OpTYPE_set(binop, type);
4972 binop->op_first = first;
4973 binop->op_flags = (U8)(flags | OPf_KIDS);
4976 binop->op_private = (U8)(1 | (flags >> 8));
4979 binop->op_private = (U8)(2 | (flags >> 8));
4980 OpMORESIB_set(first, last);
4983 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
4984 OpLASTSIB_set(last, (OP*)binop);
4986 binop->op_last = OpSIBLING(binop->op_first);
4988 OpLASTSIB_set(binop->op_last, (OP*)binop);
4990 binop = (BINOP*)CHECKOP(type, binop);
4991 if (binop->op_next || binop->op_type != (OPCODE)type)
4994 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4997 static int uvcompare(const void *a, const void *b)
4998 __attribute__nonnull__(1)
4999 __attribute__nonnull__(2)
5000 __attribute__pure__;
5001 static int uvcompare(const void *a, const void *b)
5003 if (*((const UV *)a) < (*(const UV *)b))
5005 if (*((const UV *)a) > (*(const UV *)b))
5007 if (*((const UV *)a+1) < (*(const UV *)b+1))
5009 if (*((const UV *)a+1) > (*(const UV *)b+1))
5015 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5017 SV * const tstr = ((SVOP*)expr)->op_sv;
5019 ((SVOP*)repl)->op_sv;
5022 const U8 *t = (U8*)SvPV_const(tstr, tlen);
5023 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5029 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5030 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5031 I32 del = o->op_private & OPpTRANS_DELETE;
5034 PERL_ARGS_ASSERT_PMTRANS;
5036 PL_hints |= HINT_BLOCK_SCOPE;
5039 o->op_private |= OPpTRANS_FROM_UTF;
5042 o->op_private |= OPpTRANS_TO_UTF;
5044 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5045 SV* const listsv = newSVpvs("# comment\n");
5047 const U8* tend = t + tlen;
5048 const U8* rend = r + rlen;
5064 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5065 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5068 const U32 flags = UTF8_ALLOW_DEFAULT;
5072 t = tsave = bytes_to_utf8(t, &len);
5075 if (!to_utf && rlen) {
5077 r = rsave = bytes_to_utf8(r, &len);
5081 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5082 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5086 U8 tmpbuf[UTF8_MAXBYTES+1];
5089 Newx(cp, 2*tlen, UV);
5091 transv = newSVpvs("");
5093 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5095 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5097 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5101 cp[2*i+1] = cp[2*i];
5105 qsort(cp, i, 2*sizeof(UV), uvcompare);
5106 for (j = 0; j < i; j++) {
5108 diff = val - nextmin;
5110 t = uvchr_to_utf8(tmpbuf,nextmin);
5111 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5113 U8 range_mark = ILLEGAL_UTF8_BYTE;
5114 t = uvchr_to_utf8(tmpbuf, val - 1);
5115 sv_catpvn(transv, (char *)&range_mark, 1);
5116 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5123 t = uvchr_to_utf8(tmpbuf,nextmin);
5124 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5126 U8 range_mark = ILLEGAL_UTF8_BYTE;
5127 sv_catpvn(transv, (char *)&range_mark, 1);
5129 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5130 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5131 t = (const U8*)SvPVX_const(transv);
5132 tlen = SvCUR(transv);
5136 else if (!rlen && !del) {
5137 r = t; rlen = tlen; rend = tend;
5140 if ((!rlen && !del) || t == r ||
5141 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5143 o->op_private |= OPpTRANS_IDENTICAL;
5147 while (t < tend || tfirst <= tlast) {
5148 /* see if we need more "t" chars */
5149 if (tfirst > tlast) {
5150 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5152 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5154 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5161 /* now see if we need more "r" chars */
5162 if (rfirst > rlast) {
5164 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5166 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5168 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5177 rfirst = rlast = 0xffffffff;
5181 /* now see which range will peter out first, if either. */
5182 tdiff = tlast - tfirst;
5183 rdiff = rlast - rfirst;
5184 tcount += tdiff + 1;
5185 rcount += rdiff + 1;
5192 if (rfirst == 0xffffffff) {
5193 diff = tdiff; /* oops, pretend rdiff is infinite */
5195 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5196 (long)tfirst, (long)tlast);
5198 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5202 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5203 (long)tfirst, (long)(tfirst + diff),
5206 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5207 (long)tfirst, (long)rfirst);
5209 if (rfirst + diff > max)
5210 max = rfirst + diff;
5212 grows = (tfirst < rfirst &&
5213 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5225 else if (max > 0xff)
5230 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5232 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5233 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5234 PAD_SETSV(cPADOPo->op_padix, swash);
5236 SvREADONLY_on(swash);
5238 cSVOPo->op_sv = swash;
5240 SvREFCNT_dec(listsv);
5241 SvREFCNT_dec(transv);
5243 if (!del && havefinal && rlen)
5244 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5245 newSVuv((UV)final), 0);
5254 else if (rlast == 0xffffffff)
5260 tbl = (short*)PerlMemShared_calloc(
5261 (o->op_private & OPpTRANS_COMPLEMENT) &&
5262 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5264 cPVOPo->op_pv = (char*)tbl;
5266 for (i = 0; i < (I32)tlen; i++)
5268 for (i = 0, j = 0; i < 256; i++) {
5270 if (j >= (I32)rlen) {
5279 if (i < 128 && r[j] >= 128)
5289 o->op_private |= OPpTRANS_IDENTICAL;
5291 else if (j >= (I32)rlen)
5296 PerlMemShared_realloc(tbl,
5297 (0x101+rlen-j) * sizeof(short));
5298 cPVOPo->op_pv = (char*)tbl;
5300 tbl[0x100] = (short)(rlen - j);
5301 for (i=0; i < (I32)rlen - j; i++)
5302 tbl[0x101+i] = r[j+i];
5306 if (!rlen && !del) {
5309 o->op_private |= OPpTRANS_IDENTICAL;
5311 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5312 o->op_private |= OPpTRANS_IDENTICAL;
5314 for (i = 0; i < 256; i++)
5316 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5317 if (j >= (I32)rlen) {
5319 if (tbl[t[i]] == -1)
5325 if (tbl[t[i]] == -1) {
5326 if (t[i] < 128 && r[j] >= 128)
5334 if(del && rlen == tlen) {
5335 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5336 } else if(rlen > tlen && !complement) {
5337 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5341 o->op_private |= OPpTRANS_GROWS;
5349 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5351 Constructs, checks, and returns an op of any pattern matching type.
5352 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
5353 and, shifted up eight bits, the eight bits of C<op_private>.
5359 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5364 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5365 || type == OP_CUSTOM);
5367 NewOp(1101, pmop, 1, PMOP);
5368 OpTYPE_set(pmop, type);
5369 pmop->op_flags = (U8)flags;
5370 pmop->op_private = (U8)(0 | (flags >> 8));
5371 if (PL_opargs[type] & OA_RETSCALAR)
5374 if (PL_hints & HINT_RE_TAINT)
5375 pmop->op_pmflags |= PMf_RETAINT;
5376 #ifdef USE_LOCALE_CTYPE
5377 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5378 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5383 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5385 if (PL_hints & HINT_RE_FLAGS) {
5386 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5387 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5389 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5390 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5391 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5393 if (reflags && SvOK(reflags)) {
5394 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5400 assert(SvPOK(PL_regex_pad[0]));
5401 if (SvCUR(PL_regex_pad[0])) {
5402 /* Pop off the "packed" IV from the end. */
5403 SV *const repointer_list = PL_regex_pad[0];
5404 const char *p = SvEND(repointer_list) - sizeof(IV);
5405 const IV offset = *((IV*)p);
5407 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5409 SvEND_set(repointer_list, p);
5411 pmop->op_pmoffset = offset;
5412 /* This slot should be free, so assert this: */
5413 assert(PL_regex_pad[offset] == &PL_sv_undef);
5415 SV * const repointer = &PL_sv_undef;
5416 av_push(PL_regex_padav, repointer);
5417 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5418 PL_regex_pad = AvARRAY(PL_regex_padav);
5422 return CHECKOP(type, pmop);
5430 /* Any pad names in scope are potentially lvalues. */
5431 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5432 PADNAME *pn = PAD_COMPNAME_SV(i);
5433 if (!pn || !PadnameLEN(pn))
5435 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5436 S_mark_padname_lvalue(aTHX_ pn);
5440 /* Given some sort of match op o, and an expression expr containing a
5441 * pattern, either compile expr into a regex and attach it to o (if it's
5442 * constant), or convert expr into a runtime regcomp op sequence (if it's
5445 * isreg indicates that the pattern is part of a regex construct, eg
5446 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5447 * split "pattern", which aren't. In the former case, expr will be a list
5448 * if the pattern contains more than one term (eg /a$b/).
5450 * When the pattern has been compiled within a new anon CV (for
5451 * qr/(?{...})/ ), then floor indicates the savestack level just before
5452 * the new sub was created
5456 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5460 I32 repl_has_vars = 0;
5461 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5462 bool is_compiletime;
5465 PERL_ARGS_ASSERT_PMRUNTIME;
5468 return pmtrans(o, expr, repl);
5471 /* find whether we have any runtime or code elements;
5472 * at the same time, temporarily set the op_next of each DO block;
5473 * then when we LINKLIST, this will cause the DO blocks to be excluded
5474 * from the op_next chain (and from having LINKLIST recursively
5475 * applied to them). We fix up the DOs specially later */
5479 if (expr->op_type == OP_LIST) {
5481 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5482 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5484 assert(!o->op_next);
5485 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5486 assert(PL_parser && PL_parser->error_count);
5487 /* This can happen with qr/ (?{(^{})/. Just fake up
5488 the op we were expecting to see, to avoid crashing
5490 op_sibling_splice(expr, o, 0,
5491 newSVOP(OP_CONST, 0, &PL_sv_no));
5493 o->op_next = OpSIBLING(o);
5495 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5499 else if (expr->op_type != OP_CONST)
5504 /* fix up DO blocks; treat each one as a separate little sub;
5505 * also, mark any arrays as LIST/REF */
5507 if (expr->op_type == OP_LIST) {
5509 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5511 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5512 assert( !(o->op_flags & OPf_WANT));
5513 /* push the array rather than its contents. The regex
5514 * engine will retrieve and join the elements later */
5515 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5519 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5521 o->op_next = NULL; /* undo temporary hack from above */
5524 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5525 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5527 assert(leaveop->op_first->op_type == OP_ENTER);
5528 assert(OpHAS_SIBLING(leaveop->op_first));
5529 o->op_next = OpSIBLING(leaveop->op_first);
5531 assert(leaveop->op_flags & OPf_KIDS);
5532 assert(leaveop->op_last->op_next == (OP*)leaveop);
5533 leaveop->op_next = NULL; /* stop on last op */
5534 op_null((OP*)leaveop);
5538 OP *scope = cLISTOPo->op_first;
5539 assert(scope->op_type == OP_SCOPE);
5540 assert(scope->op_flags & OPf_KIDS);
5541 scope->op_next = NULL; /* stop on last op */
5544 /* have to peep the DOs individually as we've removed it from
5545 * the op_next chain */
5547 S_prune_chain_head(&(o->op_next));
5549 /* runtime finalizes as part of finalizing whole tree */
5553 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5554 assert( !(expr->op_flags & OPf_WANT));
5555 /* push the array rather than its contents. The regex
5556 * engine will retrieve and join the elements later */
5557 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5560 PL_hints |= HINT_BLOCK_SCOPE;
5562 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5564 if (is_compiletime) {
5565 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5566 regexp_engine const *eng = current_re_engine();
5568 if (o->op_flags & OPf_SPECIAL)
5569 rx_flags |= RXf_SPLIT;
5571 if (!has_code || !eng->op_comp) {
5572 /* compile-time simple constant pattern */
5574 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5575 /* whoops! we guessed that a qr// had a code block, but we
5576 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5577 * that isn't required now. Note that we have to be pretty
5578 * confident that nothing used that CV's pad while the
5579 * regex was parsed, except maybe op targets for \Q etc.
5580 * If there were any op targets, though, they should have
5581 * been stolen by constant folding.
5585 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5586 while (++i <= AvFILLp(PL_comppad)) {
5587 assert(!PL_curpad[i]);
5590 /* But we know that one op is using this CV's slab. */
5591 cv_forget_slab(PL_compcv);
5593 pm->op_pmflags &= ~PMf_HAS_CV;
5598 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5599 rx_flags, pm->op_pmflags)
5600 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5601 rx_flags, pm->op_pmflags)
5606 /* compile-time pattern that includes literal code blocks */
5607 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5610 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5613 if (pm->op_pmflags & PMf_HAS_CV) {
5615 /* this QR op (and the anon sub we embed it in) is never
5616 * actually executed. It's just a placeholder where we can
5617 * squirrel away expr in op_code_list without the peephole
5618 * optimiser etc processing it for a second time */
5619 OP *qr = newPMOP(OP_QR, 0);
5620 ((PMOP*)qr)->op_code_list = expr;
5622 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5623 SvREFCNT_inc_simple_void(PL_compcv);
5624 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5625 ReANY(re)->qr_anoncv = cv;
5627 /* attach the anon CV to the pad so that
5628 * pad_fixup_inner_anons() can find it */
5629 (void)pad_add_anon(cv, o->op_type);
5630 SvREFCNT_inc_simple_void(cv);
5633 pm->op_code_list = expr;
5638 /* runtime pattern: build chain of regcomp etc ops */
5640 PADOFFSET cv_targ = 0;
5642 reglist = isreg && expr->op_type == OP_LIST;
5647 pm->op_code_list = expr;
5648 /* don't free op_code_list; its ops are embedded elsewhere too */
5649 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5652 if (o->op_flags & OPf_SPECIAL)
5653 pm->op_pmflags |= PMf_SPLIT;
5655 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5656 * to allow its op_next to be pointed past the regcomp and
5657 * preceding stacking ops;
5658 * OP_REGCRESET is there to reset taint before executing the
5660 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5661 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5663 if (pm->op_pmflags & PMf_HAS_CV) {
5664 /* we have a runtime qr with literal code. This means
5665 * that the qr// has been wrapped in a new CV, which
5666 * means that runtime consts, vars etc will have been compiled
5667 * against a new pad. So... we need to execute those ops
5668 * within the environment of the new CV. So wrap them in a call
5669 * to a new anon sub. i.e. for
5673 * we build an anon sub that looks like
5675 * sub { "a", $b, '(?{...})' }
5677 * and call it, passing the returned list to regcomp.
5678 * Or to put it another way, the list of ops that get executed
5682 * ------ -------------------
5683 * pushmark (for regcomp)
5684 * pushmark (for entersub)
5688 * regcreset regcreset
5690 * const("a") const("a")
5692 * const("(?{...})") const("(?{...})")
5697 SvREFCNT_inc_simple_void(PL_compcv);
5698 CvLVALUE_on(PL_compcv);
5699 /* these lines are just an unrolled newANONATTRSUB */
5700 expr = newSVOP(OP_ANONCODE, 0,
5701 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5702 cv_targ = expr->op_targ;
5703 expr = newUNOP(OP_REFGEN, 0, expr);
5705 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5708 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5709 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5710 | (reglist ? OPf_STACKED : 0);
5711 rcop->op_targ = cv_targ;
5713 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5714 if (PL_hints & HINT_RE_EVAL)
5715 S_set_haseval(aTHX);
5717 /* establish postfix order */
5718 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5720 rcop->op_next = expr;
5721 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5724 rcop->op_next = LINKLIST(expr);
5725 expr->op_next = (OP*)rcop;
5728 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5734 /* If we are looking at s//.../e with a single statement, get past
5735 the implicit do{}. */
5736 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5737 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5738 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5741 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5742 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5743 && !OpHAS_SIBLING(sib))
5746 if (curop->op_type == OP_CONST)
5748 else if (( (curop->op_type == OP_RV2SV ||
5749 curop->op_type == OP_RV2AV ||
5750 curop->op_type == OP_RV2HV ||
5751 curop->op_type == OP_RV2GV)
5752 && cUNOPx(curop)->op_first
5753 && cUNOPx(curop)->op_first->op_type == OP_GV )
5754 || curop->op_type == OP_PADSV
5755 || curop->op_type == OP_PADAV
5756 || curop->op_type == OP_PADHV
5757 || curop->op_type == OP_PADANY) {
5765 || !RX_PRELEN(PM_GETRE(pm))
5766 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5768 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5769 op_prepend_elem(o->op_type, scalar(repl), o);
5772 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5773 rcop->op_private = 1;
5775 /* establish postfix order */
5776 rcop->op_next = LINKLIST(repl);
5777 repl->op_next = (OP*)rcop;
5779 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5780 assert(!(pm->op_pmflags & PMf_ONCE));
5781 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5790 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5792 Constructs, checks, and returns an op of any type that involves an
5793 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
5794 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
5795 takes ownership of one reference to it.
5801 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5806 PERL_ARGS_ASSERT_NEWSVOP;
5808 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5809 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5810 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5811 || type == OP_CUSTOM);
5813 NewOp(1101, svop, 1, SVOP);
5814 OpTYPE_set(svop, type);
5816 svop->op_next = (OP*)svop;
5817 svop->op_flags = (U8)flags;
5818 svop->op_private = (U8)(0 | (flags >> 8));
5819 if (PL_opargs[type] & OA_RETSCALAR)
5821 if (PL_opargs[type] & OA_TARGET)
5822 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5823 return CHECKOP(type, svop);
5827 =for apidoc Am|OP *|newDEFSVOP|
5829 Constructs and returns an op to access C<$_>.
5835 Perl_newDEFSVOP(pTHX)
5837 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5843 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5845 Constructs, checks, and returns an op of any type that involves a
5846 reference to a pad element. C<type> is the opcode. C<flags> gives the
5847 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5848 is populated with C<sv>; this function takes ownership of one reference
5851 This function only exists if Perl has been compiled to use ithreads.
5857 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5862 PERL_ARGS_ASSERT_NEWPADOP;
5864 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5865 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5866 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5867 || type == OP_CUSTOM);
5869 NewOp(1101, padop, 1, PADOP);
5870 OpTYPE_set(padop, type);
5872 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5873 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5874 PAD_SETSV(padop->op_padix, sv);
5876 padop->op_next = (OP*)padop;
5877 padop->op_flags = (U8)flags;
5878 if (PL_opargs[type] & OA_RETSCALAR)
5880 if (PL_opargs[type] & OA_TARGET)
5881 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5882 return CHECKOP(type, padop);
5885 #endif /* USE_ITHREADS */
5888 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5890 Constructs, checks, and returns an op of any type that involves an
5891 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
5892 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
5893 reference; calling this function does not transfer ownership of any
5900 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5902 PERL_ARGS_ASSERT_NEWGVOP;
5905 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5907 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5912 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5914 Constructs, checks, and returns an op of any type that involves an
5915 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
5916 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
5917 must have been allocated using C<PerlMemShared_malloc>; the memory will
5918 be freed when the op is destroyed.
5924 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5927 const bool utf8 = cBOOL(flags & SVf_UTF8);
5932 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5933 || type == OP_RUNCV || type == OP_CUSTOM
5934 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5936 NewOp(1101, pvop, 1, PVOP);
5937 OpTYPE_set(pvop, type);
5939 pvop->op_next = (OP*)pvop;
5940 pvop->op_flags = (U8)flags;
5941 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5942 if (PL_opargs[type] & OA_RETSCALAR)
5944 if (PL_opargs[type] & OA_TARGET)
5945 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5946 return CHECKOP(type, pvop);
5950 Perl_package(pTHX_ OP *o)
5952 SV *const sv = cSVOPo->op_sv;
5954 PERL_ARGS_ASSERT_PACKAGE;
5956 SAVEGENERICSV(PL_curstash);
5957 save_item(PL_curstname);
5959 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5961 sv_setsv(PL_curstname, sv);
5963 PL_hints |= HINT_BLOCK_SCOPE;
5964 PL_parser->copline = NOLINE;
5970 Perl_package_version( pTHX_ OP *v )
5972 U32 savehints = PL_hints;
5973 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5974 PL_hints &= ~HINT_STRICT_VARS;
5975 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5976 PL_hints = savehints;
5981 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5986 SV *use_version = NULL;
5988 PERL_ARGS_ASSERT_UTILIZE;
5990 if (idop->op_type != OP_CONST)
5991 Perl_croak(aTHX_ "Module name must be constant");
5996 SV * const vesv = ((SVOP*)version)->op_sv;
5998 if (!arg && !SvNIOKp(vesv)) {
6005 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6006 Perl_croak(aTHX_ "Version number must be a constant number");
6008 /* Make copy of idop so we don't free it twice */
6009 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6011 /* Fake up a method call to VERSION */
6012 meth = newSVpvs_share("VERSION");
6013 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6014 op_append_elem(OP_LIST,
6015 op_prepend_elem(OP_LIST, pack, version),
6016 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6020 /* Fake up an import/unimport */
6021 if (arg && arg->op_type == OP_STUB) {
6022 imop = arg; /* no import on explicit () */
6024 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6025 imop = NULL; /* use 5.0; */
6027 use_version = ((SVOP*)idop)->op_sv;
6029 idop->op_private |= OPpCONST_NOVER;
6034 /* Make copy of idop so we don't free it twice */
6035 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6037 /* Fake up a method call to import/unimport */
6039 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6040 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6041 op_append_elem(OP_LIST,
6042 op_prepend_elem(OP_LIST, pack, arg),
6043 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6047 /* Fake up the BEGIN {}, which does its thing immediately. */
6049 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6052 op_append_elem(OP_LINESEQ,
6053 op_append_elem(OP_LINESEQ,
6054 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6055 newSTATEOP(0, NULL, veop)),
6056 newSTATEOP(0, NULL, imop) ));
6060 * feature bundle that corresponds to the required version. */
6061 use_version = sv_2mortal(new_version(use_version));
6062 S_enable_feature_bundle(aTHX_ use_version);
6064 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6065 if (vcmp(use_version,
6066 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6067 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6068 PL_hints |= HINT_STRICT_REFS;
6069 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6070 PL_hints |= HINT_STRICT_SUBS;
6071 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6072 PL_hints |= HINT_STRICT_VARS;
6074 /* otherwise they are off */
6076 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6077 PL_hints &= ~HINT_STRICT_REFS;
6078 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6079 PL_hints &= ~HINT_STRICT_SUBS;
6080 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6081 PL_hints &= ~HINT_STRICT_VARS;
6085 /* The "did you use incorrect case?" warning used to be here.
6086 * The problem is that on case-insensitive filesystems one
6087 * might get false positives for "use" (and "require"):
6088 * "use Strict" or "require CARP" will work. This causes
6089 * portability problems for the script: in case-strict
6090 * filesystems the script will stop working.
6092 * The "incorrect case" warning checked whether "use Foo"
6093 * imported "Foo" to your namespace, but that is wrong, too:
6094 * there is no requirement nor promise in the language that
6095 * a Foo.pm should or would contain anything in package "Foo".
6097 * There is very little Configure-wise that can be done, either:
6098 * the case-sensitivity of the build filesystem of Perl does not
6099 * help in guessing the case-sensitivity of the runtime environment.
6102 PL_hints |= HINT_BLOCK_SCOPE;
6103 PL_parser->copline = NOLINE;
6104 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6108 =head1 Embedding Functions
6110 =for apidoc load_module
6112 Loads the module whose name is pointed to by the string part of name.
6113 Note that the actual module name, not its filename, should be given.
6114 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
6115 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6116 (or 0 for no flags). ver, if specified
6117 and not NULL, provides version semantics
6118 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
6119 arguments can be used to specify arguments to the module's C<import()>
6120 method, similar to C<use Foo::Bar VERSION LIST>. They must be
6121 terminated with a final C<NULL> pointer. Note that this list can only
6122 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6123 Otherwise at least a single C<NULL> pointer to designate the default
6124 import list is required.
6126 The reference count for each specified C<SV*> parameter is decremented.
6131 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6135 PERL_ARGS_ASSERT_LOAD_MODULE;
6137 va_start(args, ver);
6138 vload_module(flags, name, ver, &args);
6142 #ifdef PERL_IMPLICIT_CONTEXT
6144 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6148 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6149 va_start(args, ver);
6150 vload_module(flags, name, ver, &args);
6156 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6159 OP * const modname = newSVOP(OP_CONST, 0, name);
6161 PERL_ARGS_ASSERT_VLOAD_MODULE;
6163 modname->op_private |= OPpCONST_BARE;
6165 veop = newSVOP(OP_CONST, 0, ver);
6169 if (flags & PERL_LOADMOD_NOIMPORT) {
6170 imop = sawparens(newNULLLIST());
6172 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6173 imop = va_arg(*args, OP*);
6178 sv = va_arg(*args, SV*);
6180 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6181 sv = va_arg(*args, SV*);
6185 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6186 * that it has a PL_parser to play with while doing that, and also
6187 * that it doesn't mess with any existing parser, by creating a tmp
6188 * new parser with lex_start(). This won't actually be used for much,
6189 * since pp_require() will create another parser for the real work.
6190 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6193 SAVEVPTR(PL_curcop);
6194 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6195 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6196 veop, modname, imop);
6200 PERL_STATIC_INLINE OP *
6201 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6203 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6204 newLISTOP(OP_LIST, 0, arg,
6205 newUNOP(OP_RV2CV, 0,
6206 newGVOP(OP_GV, 0, gv))));
6210 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6215 PERL_ARGS_ASSERT_DOFILE;
6217 if (!force_builtin && (gv = gv_override("do", 2))) {
6218 doop = S_new_entersubop(aTHX_ gv, term);
6221 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6227 =head1 Optree construction
6229 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6231 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
6232 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6233 be set automatically, and, shifted up eight bits, the eight bits of
6234 C<op_private>, except that the bit with value 1 or 2 is automatically
6235 set as required. C<listval> and C<subscript> supply the parameters of
6236 the slice; they are consumed by this function and become part of the
6237 constructed op tree.
6243 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6245 return newBINOP(OP_LSLICE, flags,
6246 list(force_list(subscript, 1)),
6247 list(force_list(listval, 1)) );
6250 #define ASSIGN_LIST 1
6251 #define ASSIGN_REF 2
6254 S_assignment_type(pTHX_ const OP *o)
6263 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6264 o = cUNOPo->op_first;
6266 flags = o->op_flags;
6268 if (type == OP_COND_EXPR) {
6269 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6270 const I32 t = assignment_type(sib);
6271 const I32 f = assignment_type(OpSIBLING(sib));
6273 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6275 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6276 yyerror("Assignment to both a list and a scalar");
6280 if (type == OP_SREFGEN)
6282 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6283 type = kid->op_type;
6284 flags |= kid->op_flags;
6285 if (!(flags & OPf_PARENS)
6286 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6287 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6293 if (type == OP_LIST &&
6294 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6295 o->op_private & OPpLVAL_INTRO)
6298 if (type == OP_LIST || flags & OPf_PARENS ||
6299 type == OP_RV2AV || type == OP_RV2HV ||
6300 type == OP_ASLICE || type == OP_HSLICE ||
6301 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6304 if (type == OP_PADAV || type == OP_PADHV)
6307 if (type == OP_RV2SV)
6315 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6317 Constructs, checks, and returns an assignment op. C<left> and C<right>
6318 supply the parameters of the assignment; they are consumed by this
6319 function and become part of the constructed op tree.
6321 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6322 a suitable conditional optree is constructed. If C<optype> is the opcode
6323 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6324 performs the binary operation and assigns the result to the left argument.
6325 Either way, if C<optype> is non-zero then C<flags> has no effect.
6327 If C<optype> is zero, then a plain scalar or list assignment is
6328 constructed. Which type of assignment it is is automatically determined.
6329 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6330 will be set automatically, and, shifted up eight bits, the eight bits
6331 of C<op_private>, except that the bit with value 1 or 2 is automatically
6338 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6344 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6345 return newLOGOP(optype, 0,
6346 op_lvalue(scalar(left), optype),
6347 newUNOP(OP_SASSIGN, 0, scalar(right)));
6350 return newBINOP(optype, OPf_STACKED,
6351 op_lvalue(scalar(left), optype), scalar(right));
6355 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6356 static const char no_list_state[] = "Initialization of state variables"
6357 " in list context currently forbidden";
6360 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6361 left->op_private &= ~ OPpSLICEWARNING;
6364 left = op_lvalue(left, OP_AASSIGN);
6365 curop = list(force_list(left, 1));
6366 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6367 o->op_private = (U8)(0 | (flags >> 8));
6369 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6371 OP* lop = ((LISTOP*)left)->op_first;
6373 if ((lop->op_type == OP_PADSV ||
6374 lop->op_type == OP_PADAV ||
6375 lop->op_type == OP_PADHV ||
6376 lop->op_type == OP_PADANY)
6377 && (lop->op_private & OPpPAD_STATE)
6379 yyerror(no_list_state);
6380 lop = OpSIBLING(lop);
6383 else if ( (left->op_private & OPpLVAL_INTRO)
6384 && (left->op_private & OPpPAD_STATE)
6385 && ( left->op_type == OP_PADSV
6386 || left->op_type == OP_PADAV
6387 || left->op_type == OP_PADHV
6388 || left->op_type == OP_PADANY)
6390 /* All single variable list context state assignments, hence
6400 yyerror(no_list_state);
6403 if (right && right->op_type == OP_SPLIT
6404 && !(right->op_flags & OPf_STACKED)) {
6405 OP* tmpop = ((LISTOP*)right)->op_first;
6406 PMOP * const pm = (PMOP*)tmpop;
6407 assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6410 !pm->op_pmreplrootu.op_pmtargetoff
6412 !pm->op_pmreplrootu.op_pmtargetgv
6416 if (!(left->op_private & OPpLVAL_INTRO) &&
6417 ( (left->op_type == OP_RV2AV &&
6418 (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6419 || left->op_type == OP_PADAV )
6421 if (tmpop != (OP *)pm) {
6423 pm->op_pmreplrootu.op_pmtargetoff
6424 = cPADOPx(tmpop)->op_padix;
6425 cPADOPx(tmpop)->op_padix = 0; /* steal it */
6427 pm->op_pmreplrootu.op_pmtargetgv
6428 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6429 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
6431 right->op_private |=
6432 left->op_private & OPpOUR_INTRO;
6435 pm->op_targ = left->op_targ;
6436 left->op_targ = 0; /* filch it */
6439 tmpop = cUNOPo->op_first; /* to list (nulled) */
6440 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6441 /* detach rest of siblings from o subtree,
6442 * and free subtree */
6443 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6444 op_free(o); /* blow off assign */
6445 right->op_flags &= ~OPf_WANT;
6446 /* "I don't know and I don't care." */
6449 else if (left->op_type == OP_RV2AV
6450 || left->op_type == OP_PADAV)
6452 /* Detach the array. */
6456 op_sibling_splice(cBINOPo->op_last,
6457 cUNOPx(cBINOPo->op_last)
6458 ->op_first, 1, NULL);
6459 assert(ary == left);
6460 /* Attach it to the split. */
6461 op_sibling_splice(right, cLISTOPx(right)->op_last,
6463 right->op_flags |= OPf_STACKED;
6464 /* Detach split and expunge aassign as above. */
6467 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6468 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6471 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6472 SV * const sv = *svp;
6473 if (SvIOK(sv) && SvIVX(sv) == 0)
6475 if (right->op_private & OPpSPLIT_IMPLIM) {
6476 /* our own SV, created in ck_split */
6478 sv_setiv(sv, PL_modcount+1);
6481 /* SV may belong to someone else */
6483 *svp = newSViv(PL_modcount+1);
6491 if (assign_type == ASSIGN_REF)
6492 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6494 right = newOP(OP_UNDEF, 0);
6495 if (right->op_type == OP_READLINE) {
6496 right->op_flags |= OPf_STACKED;
6497 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6501 o = newBINOP(OP_SASSIGN, flags,
6502 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6508 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6510 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6511 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6512 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6513 If C<label> is non-null, it supplies the name of a label to attach to
6514 the state op; this function takes ownership of the memory pointed at by
6515 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
6518 If C<o> is null, the state op is returned. Otherwise the state op is
6519 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
6520 is consumed by this function and becomes part of the returned op tree.
6526 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6529 const U32 seq = intro_my();
6530 const U32 utf8 = flags & SVf_UTF8;
6533 PL_parser->parsed_sub = 0;
6537 NewOp(1101, cop, 1, COP);
6538 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6539 OpTYPE_set(cop, OP_DBSTATE);
6542 OpTYPE_set(cop, OP_NEXTSTATE);
6544 cop->op_flags = (U8)flags;
6545 CopHINTS_set(cop, PL_hints);
6547 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6549 cop->op_next = (OP*)cop;
6552 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6553 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6555 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6557 PL_hints |= HINT_BLOCK_SCOPE;
6558 /* It seems that we need to defer freeing this pointer, as other parts
6559 of the grammar end up wanting to copy it after this op has been
6564 if (PL_parser->preambling != NOLINE) {
6565 CopLINE_set(cop, PL_parser->preambling);
6566 PL_parser->copline = NOLINE;
6568 else if (PL_parser->copline == NOLINE)
6569 CopLINE_set(cop, CopLINE(PL_curcop));
6571 CopLINE_set(cop, PL_parser->copline);
6572 PL_parser->copline = NOLINE;
6575 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6577 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6579 CopSTASH_set(cop, PL_curstash);
6581 if (cop->op_type == OP_DBSTATE) {
6582 /* this line can have a breakpoint - store the cop in IV */
6583 AV *av = CopFILEAVx(PL_curcop);
6585 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6586 if (svp && *svp != &PL_sv_undef ) {
6587 (void)SvIOK_on(*svp);
6588 SvIV_set(*svp, PTR2IV(cop));
6593 if (flags & OPf_SPECIAL)
6595 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6599 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6601 Constructs, checks, and returns a logical (flow control) op. C<type>
6602 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6603 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6604 the eight bits of C<op_private>, except that the bit with value 1 is
6605 automatically set. C<first> supplies the expression controlling the
6606 flow, and C<other> supplies the side (alternate) chain of ops; they are
6607 consumed by this function and become part of the constructed op tree.
6613 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6615 PERL_ARGS_ASSERT_NEWLOGOP;
6617 return new_logop(type, flags, &first, &other);
6621 S_search_const(pTHX_ OP *o)
6623 PERL_ARGS_ASSERT_SEARCH_CONST;
6625 switch (o->op_type) {
6629 if (o->op_flags & OPf_KIDS)
6630 return search_const(cUNOPo->op_first);
6637 if (!(o->op_flags & OPf_KIDS))
6639 kid = cLISTOPo->op_first;
6641 switch (kid->op_type) {
6645 kid = OpSIBLING(kid);
6648 if (kid != cLISTOPo->op_last)
6654 kid = cLISTOPo->op_last;
6656 return search_const(kid);
6664 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6672 int prepend_not = 0;
6674 PERL_ARGS_ASSERT_NEW_LOGOP;
6679 /* [perl #59802]: Warn about things like "return $a or $b", which
6680 is parsed as "(return $a) or $b" rather than "return ($a or
6681 $b)". NB: This also applies to xor, which is why we do it
6684 switch (first->op_type) {
6688 /* XXX: Perhaps we should emit a stronger warning for these.
6689 Even with the high-precedence operator they don't seem to do
6692 But until we do, fall through here.
6698 /* XXX: Currently we allow people to "shoot themselves in the
6699 foot" by explicitly writing "(return $a) or $b".
6701 Warn unless we are looking at the result from folding or if
6702 the programmer explicitly grouped the operators like this.
6703 The former can occur with e.g.
6705 use constant FEATURE => ( $] >= ... );
6706 sub { not FEATURE and return or do_stuff(); }
6708 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6709 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6710 "Possible precedence issue with control flow operator");
6711 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6717 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6718 return newBINOP(type, flags, scalar(first), scalar(other));
6720 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6721 || type == OP_CUSTOM);
6723 scalarboolean(first);
6724 /* optimize AND and OR ops that have NOTs as children */
6725 if (first->op_type == OP_NOT
6726 && (first->op_flags & OPf_KIDS)
6727 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6728 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6730 if (type == OP_AND || type == OP_OR) {
6736 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6738 prepend_not = 1; /* prepend a NOT op later */
6742 /* search for a constant op that could let us fold the test */
6743 if ((cstop = search_const(first))) {
6744 if (cstop->op_private & OPpCONST_STRICT)
6745 no_bareword_allowed(cstop);
6746 else if ((cstop->op_private & OPpCONST_BARE))
6747 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6748 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6749 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6750 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6752 if (other->op_type == OP_CONST)
6753 other->op_private |= OPpCONST_SHORTCIRCUIT;
6755 if (other->op_type == OP_LEAVE)
6756 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6757 else if (other->op_type == OP_MATCH
6758 || other->op_type == OP_SUBST
6759 || other->op_type == OP_TRANSR
6760 || other->op_type == OP_TRANS)
6761 /* Mark the op as being unbindable with =~ */
6762 other->op_flags |= OPf_SPECIAL;
6764 other->op_folded = 1;
6768 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6769 const OP *o2 = other;
6770 if ( ! (o2->op_type == OP_LIST
6771 && (( o2 = cUNOPx(o2)->op_first))
6772 && o2->op_type == OP_PUSHMARK
6773 && (( o2 = OpSIBLING(o2))) )
6776 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6777 || o2->op_type == OP_PADHV)
6778 && o2->op_private & OPpLVAL_INTRO
6779 && !(o2->op_private & OPpPAD_STATE))
6781 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6782 "Deprecated use of my() in false conditional");
6786 if (cstop->op_type == OP_CONST)
6787 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6792 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6793 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6795 const OP * const k1 = ((UNOP*)first)->op_first;
6796 const OP * const k2 = OpSIBLING(k1);
6798 switch (first->op_type)
6801 if (k2 && k2->op_type == OP_READLINE
6802 && (k2->op_flags & OPf_STACKED)
6803 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6805 warnop = k2->op_type;
6810 if (k1->op_type == OP_READDIR
6811 || k1->op_type == OP_GLOB
6812 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6813 || k1->op_type == OP_EACH
6814 || k1->op_type == OP_AEACH)
6816 warnop = ((k1->op_type == OP_NULL)
6817 ? (OPCODE)k1->op_targ : k1->op_type);
6822 const line_t oldline = CopLINE(PL_curcop);
6823 /* This ensures that warnings are reported at the first line
6824 of the construction, not the last. */
6825 CopLINE_set(PL_curcop, PL_parser->copline);
6826 Perl_warner(aTHX_ packWARN(WARN_MISC),
6827 "Value of %s%s can be \"0\"; test with defined()",
6829 ((warnop == OP_READLINE || warnop == OP_GLOB)
6830 ? " construct" : "() operator"));
6831 CopLINE_set(PL_curcop, oldline);
6838 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6839 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6841 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6842 logop->op_flags |= (U8)flags;
6843 logop->op_private = (U8)(1 | (flags >> 8));
6845 /* establish postfix order */
6846 logop->op_next = LINKLIST(first);
6847 first->op_next = (OP*)logop;
6848 assert(!OpHAS_SIBLING(first));
6849 op_sibling_splice((OP*)logop, first, 0, other);
6851 CHECKOP(type,logop);
6853 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
6854 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
6862 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6864 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6865 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6866 will be set automatically, and, shifted up eight bits, the eight bits of
6867 C<op_private>, except that the bit with value 1 is automatically set.
6868 C<first> supplies the expression selecting between the two branches,
6869 and C<trueop> and C<falseop> supply the branches; they are consumed by
6870 this function and become part of the constructed op tree.
6876 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6884 PERL_ARGS_ASSERT_NEWCONDOP;
6887 return newLOGOP(OP_AND, 0, first, trueop);
6889 return newLOGOP(OP_OR, 0, first, falseop);
6891 scalarboolean(first);
6892 if ((cstop = search_const(first))) {
6893 /* Left or right arm of the conditional? */
6894 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6895 OP *live = left ? trueop : falseop;
6896 OP *const dead = left ? falseop : trueop;
6897 if (cstop->op_private & OPpCONST_BARE &&
6898 cstop->op_private & OPpCONST_STRICT) {
6899 no_bareword_allowed(cstop);
6903 if (live->op_type == OP_LEAVE)
6904 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6905 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6906 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6907 /* Mark the op as being unbindable with =~ */
6908 live->op_flags |= OPf_SPECIAL;
6909 live->op_folded = 1;
6912 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6913 logop->op_flags |= (U8)flags;
6914 logop->op_private = (U8)(1 | (flags >> 8));
6915 logop->op_next = LINKLIST(falseop);
6917 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6920 /* establish postfix order */
6921 start = LINKLIST(first);
6922 first->op_next = (OP*)logop;
6924 /* make first, trueop, falseop siblings */
6925 op_sibling_splice((OP*)logop, first, 0, trueop);
6926 op_sibling_splice((OP*)logop, trueop, 0, falseop);
6928 o = newUNOP(OP_NULL, 0, (OP*)logop);
6930 trueop->op_next = falseop->op_next = o;
6937 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6939 Constructs and returns a C<range> op, with subordinate C<flip> and
6940 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
6941 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6942 for both the C<flip> and C<range> ops, except that the bit with value
6943 1 is automatically set. C<left> and C<right> supply the expressions
6944 controlling the endpoints of the range; they are consumed by this function
6945 and become part of the constructed op tree.
6951 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6959 PERL_ARGS_ASSERT_NEWRANGE;
6961 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6962 range->op_flags = OPf_KIDS;
6963 leftstart = LINKLIST(left);
6964 range->op_private = (U8)(1 | (flags >> 8));
6966 /* make left and right siblings */
6967 op_sibling_splice((OP*)range, left, 0, right);
6969 range->op_next = (OP*)range;
6970 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6971 flop = newUNOP(OP_FLOP, 0, flip);
6972 o = newUNOP(OP_NULL, 0, flop);
6974 range->op_next = leftstart;
6976 left->op_next = flip;
6977 right->op_next = flop;
6980 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
6981 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6983 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
6984 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6985 SvPADTMP_on(PAD_SV(flip->op_targ));
6987 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6988 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6990 /* check barewords before they might be optimized aways */
6991 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6992 no_bareword_allowed(left);
6993 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6994 no_bareword_allowed(right);
6997 if (!flip->op_private || !flop->op_private)
6998 LINKLIST(o); /* blow off optimizer unless constant */
7004 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7006 Constructs, checks, and returns an op tree expressing a loop. This is
7007 only a loop in the control flow through the op tree; it does not have
7008 the heavyweight loop structure that allows exiting the loop by C<last>
7009 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
7010 top-level op, except that some bits will be set automatically as required.
7011 C<expr> supplies the expression controlling loop iteration, and C<block>
7012 supplies the body of the loop; they are consumed by this function and
7013 become part of the constructed op tree. C<debuggable> is currently
7014 unused and should always be 1.
7020 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7024 const bool once = block && block->op_flags & OPf_SPECIAL &&
7025 block->op_type == OP_NULL;
7027 PERL_UNUSED_ARG(debuggable);
7031 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7032 || ( expr->op_type == OP_NOT
7033 && cUNOPx(expr)->op_first->op_type == OP_CONST
7034 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7037 /* Return the block now, so that S_new_logop does not try to
7039 return block; /* do {} while 0 does once */
7040 if (expr->op_type == OP_READLINE
7041 || expr->op_type == OP_READDIR
7042 || expr->op_type == OP_GLOB
7043 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7044 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7045 expr = newUNOP(OP_DEFINED, 0,
7046 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7047 } else if (expr->op_flags & OPf_KIDS) {
7048 const OP * const k1 = ((UNOP*)expr)->op_first;
7049 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7050 switch (expr->op_type) {
7052 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7053 && (k2->op_flags & OPf_STACKED)
7054 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7055 expr = newUNOP(OP_DEFINED, 0, expr);
7059 if (k1 && (k1->op_type == OP_READDIR
7060 || k1->op_type == OP_GLOB
7061 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7062 || k1->op_type == OP_EACH
7063 || k1->op_type == OP_AEACH))
7064 expr = newUNOP(OP_DEFINED, 0, expr);
7070 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7071 * op, in listop. This is wrong. [perl #27024] */
7073 block = newOP(OP_NULL, 0);
7074 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7075 o = new_logop(OP_AND, 0, &expr, &listop);
7082 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7084 if (once && o != listop)
7086 assert(cUNOPo->op_first->op_type == OP_AND
7087 || cUNOPo->op_first->op_type == OP_OR);
7088 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7092 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7094 o->op_flags |= flags;
7096 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7101 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7103 Constructs, checks, and returns an op tree expressing a C<while> loop.
7104 This is a heavyweight loop, with structure that allows exiting the loop
7105 by C<last> and suchlike.
7107 C<loop> is an optional preconstructed C<enterloop> op to use in the
7108 loop; if it is null then a suitable op will be constructed automatically.
7109 C<expr> supplies the loop's controlling expression. C<block> supplies the
7110 main body of the loop, and C<cont> optionally supplies a C<continue> block
7111 that operates as a second half of the body. All of these optree inputs
7112 are consumed by this function and become part of the constructed op tree.
7114 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7115 op and, shifted up eight bits, the eight bits of C<op_private> for
7116 the C<leaveloop> op, except that (in both cases) some bits will be set
7117 automatically. C<debuggable> is currently unused and should always be 1.
7118 C<has_my> can be supplied as true to force the
7119 loop body to be enclosed in its own scope.
7125 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7126 OP *expr, OP *block, OP *cont, I32 has_my)
7135 PERL_UNUSED_ARG(debuggable);
7138 if (expr->op_type == OP_READLINE
7139 || expr->op_type == OP_READDIR
7140 || expr->op_type == OP_GLOB
7141 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7142 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7143 expr = newUNOP(OP_DEFINED, 0,
7144 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7145 } else if (expr->op_flags & OPf_KIDS) {
7146 const OP * const k1 = ((UNOP*)expr)->op_first;
7147 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7148 switch (expr->op_type) {
7150 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7151 && (k2->op_flags & OPf_STACKED)
7152 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7153 expr = newUNOP(OP_DEFINED, 0, expr);
7157 if (k1 && (k1->op_type == OP_READDIR
7158 || k1->op_type == OP_GLOB
7159 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7160 || k1->op_type == OP_EACH
7161 || k1->op_type == OP_AEACH))
7162 expr = newUNOP(OP_DEFINED, 0, expr);
7169 block = newOP(OP_NULL, 0);
7170 else if (cont || has_my) {
7171 block = op_scope(block);
7175 next = LINKLIST(cont);
7178 OP * const unstack = newOP(OP_UNSTACK, 0);
7181 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7185 listop = op_append_list(OP_LINESEQ, block, cont);
7187 redo = LINKLIST(listop);
7191 o = new_logop(OP_AND, 0, &expr, &listop);
7192 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7194 return expr; /* listop already freed by new_logop */
7197 ((LISTOP*)listop)->op_last->op_next =
7198 (o == listop ? redo : LINKLIST(o));
7204 NewOp(1101,loop,1,LOOP);
7205 OpTYPE_set(loop, OP_ENTERLOOP);
7206 loop->op_private = 0;
7207 loop->op_next = (OP*)loop;
7210 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7212 loop->op_redoop = redo;
7213 loop->op_lastop = o;
7214 o->op_private |= loopflags;
7217 loop->op_nextop = next;
7219 loop->op_nextop = o;
7221 o->op_flags |= flags;
7222 o->op_private |= (flags >> 8);
7227 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7229 Constructs, checks, and returns an op tree expressing a C<foreach>
7230 loop (iteration through a list of values). This is a heavyweight loop,
7231 with structure that allows exiting the loop by C<last> and suchlike.
7233 C<sv> optionally supplies the variable that will be aliased to each
7234 item in turn; if null, it defaults to C<$_>.
7235 C<expr> supplies the list of values to iterate over. C<block> supplies
7236 the main body of the loop, and C<cont> optionally supplies a C<continue>
7237 block that operates as a second half of the body. All of these optree
7238 inputs are consumed by this function and become part of the constructed
7241 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7242 op and, shifted up eight bits, the eight bits of C<op_private> for
7243 the C<leaveloop> op, except that (in both cases) some bits will be set
7250 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7255 PADOFFSET padoff = 0;
7259 PERL_ARGS_ASSERT_NEWFOROP;
7262 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7263 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7264 OpTYPE_set(sv, OP_RV2GV);
7266 /* The op_type check is needed to prevent a possible segfault
7267 * if the loop variable is undeclared and 'strict vars' is in
7268 * effect. This is illegal but is nonetheless parsed, so we
7269 * may reach this point with an OP_CONST where we're expecting
7272 if (cUNOPx(sv)->op_first->op_type == OP_GV
7273 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7274 iterpflags |= OPpITER_DEF;
7276 else if (sv->op_type == OP_PADSV) { /* private variable */
7277 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7278 padoff = sv->op_targ;
7282 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7284 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7287 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7289 PADNAME * const pn = PAD_COMPNAME(padoff);
7290 const char * const name = PadnamePV(pn);
7292 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7293 iterpflags |= OPpITER_DEF;
7297 sv = newGVOP(OP_GV, 0, PL_defgv);
7298 iterpflags |= OPpITER_DEF;
7301 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7302 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7303 iterflags |= OPf_STACKED;
7305 else if (expr->op_type == OP_NULL &&
7306 (expr->op_flags & OPf_KIDS) &&
7307 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7309 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7310 * set the STACKED flag to indicate that these values are to be
7311 * treated as min/max values by 'pp_enteriter'.
7313 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7314 LOGOP* const range = (LOGOP*) flip->op_first;
7315 OP* const left = range->op_first;
7316 OP* const right = OpSIBLING(left);
7319 range->op_flags &= ~OPf_KIDS;
7320 /* detach range's children */
7321 op_sibling_splice((OP*)range, NULL, -1, NULL);
7323 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7324 listop->op_first->op_next = range->op_next;
7325 left->op_next = range->op_other;
7326 right->op_next = (OP*)listop;
7327 listop->op_next = listop->op_first;
7330 expr = (OP*)(listop);
7332 iterflags |= OPf_STACKED;
7335 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7338 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7339 op_append_elem(OP_LIST, list(expr),
7341 assert(!loop->op_next);
7342 /* for my $x () sets OPpLVAL_INTRO;
7343 * for our $x () sets OPpOUR_INTRO */
7344 loop->op_private = (U8)iterpflags;
7345 if (loop->op_slabbed
7346 && DIFF(loop, OpSLOT(loop)->opslot_next)
7347 < SIZE_TO_PSIZE(sizeof(LOOP)))
7350 NewOp(1234,tmp,1,LOOP);
7351 Copy(loop,tmp,1,LISTOP);
7352 #ifdef PERL_OP_PARENT
7353 assert(loop->op_last->op_sibparent == (OP*)loop);
7354 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7356 S_op_destroy(aTHX_ (OP*)loop);
7359 else if (!loop->op_slabbed)
7361 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7362 #ifdef PERL_OP_PARENT
7363 OpLASTSIB_set(loop->op_last, (OP*)loop);
7366 loop->op_targ = padoff;
7367 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7372 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7374 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7375 or C<last>). C<type> is the opcode. C<label> supplies the parameter
7376 determining the target of the op; it is consumed by this function and
7377 becomes part of the constructed op tree.
7383 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7387 PERL_ARGS_ASSERT_NEWLOOPEX;
7389 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7390 || type == OP_CUSTOM);
7392 if (type != OP_GOTO) {
7393 /* "last()" means "last" */
7394 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7395 o = newOP(type, OPf_SPECIAL);
7399 /* Check whether it's going to be a goto &function */
7400 if (label->op_type == OP_ENTERSUB
7401 && !(label->op_flags & OPf_STACKED))
7402 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7405 /* Check for a constant argument */
7406 if (label->op_type == OP_CONST) {
7407 SV * const sv = ((SVOP *)label)->op_sv;
7409 const char *s = SvPV_const(sv,l);
7410 if (l == strlen(s)) {
7412 SvUTF8(((SVOP*)label)->op_sv),
7414 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7418 /* If we have already created an op, we do not need the label. */
7421 else o = newUNOP(type, OPf_STACKED, label);
7423 PL_hints |= HINT_BLOCK_SCOPE;
7427 /* if the condition is a literal array or hash
7428 (or @{ ... } etc), make a reference to it.
7431 S_ref_array_or_hash(pTHX_ OP *cond)
7434 && (cond->op_type == OP_RV2AV
7435 || cond->op_type == OP_PADAV
7436 || cond->op_type == OP_RV2HV
7437 || cond->op_type == OP_PADHV))
7439 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7442 && (cond->op_type == OP_ASLICE
7443 || cond->op_type == OP_KVASLICE
7444 || cond->op_type == OP_HSLICE
7445 || cond->op_type == OP_KVHSLICE)) {
7447 /* anonlist now needs a list from this op, was previously used in
7449 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7450 cond->op_flags |= OPf_WANT_LIST;
7452 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7459 /* These construct the optree fragments representing given()
7462 entergiven and enterwhen are LOGOPs; the op_other pointer
7463 points up to the associated leave op. We need this so we
7464 can put it in the context and make break/continue work.
7465 (Also, of course, pp_enterwhen will jump straight to
7466 op_other if the match fails.)
7470 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7471 I32 enter_opcode, I32 leave_opcode,
7472 PADOFFSET entertarg)
7478 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7479 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7481 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7482 enterop->op_targ = 0;
7483 enterop->op_private = 0;
7485 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7488 /* prepend cond if we have one */
7489 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7491 o->op_next = LINKLIST(cond);
7492 cond->op_next = (OP *) enterop;
7495 /* This is a default {} block */
7496 enterop->op_flags |= OPf_SPECIAL;
7497 o ->op_flags |= OPf_SPECIAL;
7499 o->op_next = (OP *) enterop;
7502 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7503 entergiven and enterwhen both
7506 enterop->op_next = LINKLIST(block);
7507 block->op_next = enterop->op_other = o;
7512 /* Does this look like a boolean operation? For these purposes
7513 a boolean operation is:
7514 - a subroutine call [*]
7515 - a logical connective
7516 - a comparison operator
7517 - a filetest operator, with the exception of -s -M -A -C
7518 - defined(), exists() or eof()
7519 - /$re/ or $foo =~ /$re/
7521 [*] possibly surprising
7524 S_looks_like_bool(pTHX_ const OP *o)
7526 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7528 switch(o->op_type) {
7531 return looks_like_bool(cLOGOPo->op_first);
7535 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7538 looks_like_bool(cLOGOPo->op_first)
7539 && looks_like_bool(sibl));
7545 o->op_flags & OPf_KIDS
7546 && looks_like_bool(cUNOPo->op_first));
7550 case OP_NOT: case OP_XOR:
7552 case OP_EQ: case OP_NE: case OP_LT:
7553 case OP_GT: case OP_LE: case OP_GE:
7555 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7556 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7558 case OP_SEQ: case OP_SNE: case OP_SLT:
7559 case OP_SGT: case OP_SLE: case OP_SGE:
7563 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7564 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7565 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7566 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7567 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7568 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7569 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7570 case OP_FTTEXT: case OP_FTBINARY:
7572 case OP_DEFINED: case OP_EXISTS:
7573 case OP_MATCH: case OP_EOF:
7580 /* Detect comparisons that have been optimized away */
7581 if (cSVOPo->op_sv == &PL_sv_yes
7582 || cSVOPo->op_sv == &PL_sv_no)
7595 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7597 Constructs, checks, and returns an op tree expressing a C<given> block.
7598 C<cond> supplies the expression that will be locally assigned to a lexical
7599 variable, and C<block> supplies the body of the C<given> construct; they
7600 are consumed by this function and become part of the constructed op tree.
7601 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7607 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7609 PERL_ARGS_ASSERT_NEWGIVENOP;
7610 PERL_UNUSED_ARG(defsv_off);
7613 return newGIVWHENOP(
7614 ref_array_or_hash(cond),
7616 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7621 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7623 Constructs, checks, and returns an op tree expressing a C<when> block.
7624 C<cond> supplies the test expression, and C<block> supplies the block
7625 that will be executed if the test evaluates to true; they are consumed
7626 by this function and become part of the constructed op tree. C<cond>
7627 will be interpreted DWIMically, often as a comparison against C<$_>,
7628 and may be null to generate a C<default> block.
7634 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7636 const bool cond_llb = (!cond || looks_like_bool(cond));
7639 PERL_ARGS_ASSERT_NEWWHENOP;
7644 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7646 scalar(ref_array_or_hash(cond)));
7649 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7652 /* must not conflict with SVf_UTF8 */
7653 #define CV_CKPROTO_CURSTASH 0x1
7656 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7657 const STRLEN len, const U32 flags)
7659 SV *name = NULL, *msg;
7660 const char * cvp = SvROK(cv)
7661 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7662 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7665 STRLEN clen = CvPROTOLEN(cv), plen = len;
7667 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7669 if (p == NULL && cvp == NULL)
7672 if (!ckWARN_d(WARN_PROTOTYPE))
7676 p = S_strip_spaces(aTHX_ p, &plen);
7677 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7678 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7679 if (plen == clen && memEQ(cvp, p, plen))
7682 if (flags & SVf_UTF8) {
7683 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7687 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7693 msg = sv_newmortal();
7698 gv_efullname3(name = sv_newmortal(), gv, NULL);
7699 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7700 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7701 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7702 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7703 sv_catpvs(name, "::");
7705 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7706 assert (CvNAMED(SvRV_const(gv)));
7707 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7709 else sv_catsv(name, (SV *)gv);
7711 else name = (SV *)gv;
7713 sv_setpvs(msg, "Prototype mismatch:");
7715 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7717 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7718 UTF8fARG(SvUTF8(cv),clen,cvp)
7721 sv_catpvs(msg, ": none");
7722 sv_catpvs(msg, " vs ");
7724 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7726 sv_catpvs(msg, "none");
7727 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7730 static void const_sv_xsub(pTHX_ CV* cv);
7731 static void const_av_xsub(pTHX_ CV* cv);
7735 =head1 Optree Manipulation Functions
7737 =for apidoc cv_const_sv
7739 If C<cv> is a constant sub eligible for inlining, returns the constant
7740 value returned by the sub. Otherwise, returns C<NULL>.
7742 Constant subs can be created with C<newCONSTSUB> or as described in
7743 L<perlsub/"Constant Functions">.
7748 Perl_cv_const_sv(const CV *const cv)
7753 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7755 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7756 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7761 Perl_cv_const_sv_or_av(const CV * const cv)
7765 if (SvROK(cv)) return SvRV((SV *)cv);
7766 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7767 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7770 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7771 * Can be called in 2 ways:
7774 * look for a single OP_CONST with attached value: return the value
7776 * allow_lex && !CvCONST(cv);
7778 * examine the clone prototype, and if contains only a single
7779 * OP_CONST, return the value; or if it contains a single PADSV ref-
7780 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7781 * a candidate for "constizing" at clone time, and return NULL.
7785 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7793 for (; o; o = o->op_next) {
7794 const OPCODE type = o->op_type;
7796 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7798 || type == OP_PUSHMARK)
7800 if (type == OP_DBSTATE)
7802 if (type == OP_LEAVESUB)
7806 if (type == OP_CONST && cSVOPo->op_sv)
7808 else if (type == OP_UNDEF && !o->op_private) {
7812 else if (allow_lex && type == OP_PADSV) {
7813 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7815 sv = &PL_sv_undef; /* an arbitrary non-null value */
7833 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7834 PADNAME * const name, SV ** const const_svp)
7841 if (CvFLAGS(PL_compcv)) {
7842 /* might have had built-in attrs applied */
7843 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7844 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7845 && ckWARN(WARN_MISC))
7847 /* protect against fatal warnings leaking compcv */
7848 SAVEFREESV(PL_compcv);
7849 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7850 SvREFCNT_inc_simple_void_NN(PL_compcv);
7853 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7854 & ~(CVf_LVALUE * pureperl));
7859 /* redundant check for speed: */
7860 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7861 const line_t oldline = CopLINE(PL_curcop);
7864 : sv_2mortal(newSVpvn_utf8(
7865 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7867 if (PL_parser && PL_parser->copline != NOLINE)
7868 /* This ensures that warnings are reported at the first
7869 line of a redefinition, not the last. */
7870 CopLINE_set(PL_curcop, PL_parser->copline);
7871 /* protect against fatal warnings leaking compcv */
7872 SAVEFREESV(PL_compcv);
7873 report_redefined_cv(namesv, cv, const_svp);
7874 SvREFCNT_inc_simple_void_NN(PL_compcv);
7875 CopLINE_set(PL_curcop, oldline);
7882 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7887 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7890 CV *compcv = PL_compcv;
7893 PADOFFSET pax = o->op_targ;
7894 CV *outcv = CvOUTSIDE(PL_compcv);
7897 bool reusable = FALSE;
7899 #ifdef PERL_DEBUG_READONLY_OPS
7900 OPSLAB *slab = NULL;
7903 PERL_ARGS_ASSERT_NEWMYSUB;
7905 /* Find the pad slot for storing the new sub.
7906 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7907 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7908 ing sub. And then we need to dig deeper if this is a lexical from
7910 my sub foo; sub { sub foo { } }
7913 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7914 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7915 pax = PARENT_PAD_INDEX(name);
7916 outcv = CvOUTSIDE(outcv);
7921 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7922 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7923 spot = (CV **)svspot;
7925 if (!(PL_parser && PL_parser->error_count))
7926 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
7929 assert(proto->op_type == OP_CONST);
7930 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7931 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7941 if (PL_parser && PL_parser->error_count) {
7943 SvREFCNT_dec(PL_compcv);
7948 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7950 svspot = (SV **)(spot = &clonee);
7952 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7955 assert (SvTYPE(*spot) == SVt_PVCV);
7957 hek = CvNAME_HEK(*spot);
7961 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7962 CvNAME_HEK_set(*spot, hek =
7965 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
7969 CvLEXICAL_on(*spot);
7971 cv = PadnamePROTOCV(name);
7972 svspot = (SV **)(spot = &PadnamePROTOCV(name));
7976 /* This makes sub {}; work as expected. */
7977 if (block->op_type == OP_STUB) {
7978 const line_t l = PL_parser->copline;
7980 block = newSTATEOP(0, NULL, 0);
7981 PL_parser->copline = l;
7983 block = CvLVALUE(compcv)
7984 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
7985 ? newUNOP(OP_LEAVESUBLV, 0,
7986 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7987 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7988 start = LINKLIST(block);
7990 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
7991 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
7999 const bool exists = CvROOT(cv) || CvXSUB(cv);
8001 /* if the subroutine doesn't exist and wasn't pre-declared
8002 * with a prototype, assume it will be AUTOLOADed,
8003 * skipping the prototype check
8005 if (exists || SvPOK(cv))
8006 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8008 /* already defined? */
8010 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8013 if (attrs) goto attrs;
8014 /* just a "sub foo;" when &foo is already defined */
8019 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8025 SvREFCNT_inc_simple_void_NN(const_sv);
8026 SvFLAGS(const_sv) |= SVs_PADTMP;
8028 assert(!CvROOT(cv) && !CvCONST(cv));
8032 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8033 CvFILE_set_from_cop(cv, PL_curcop);
8034 CvSTASH_set(cv, PL_curstash);
8037 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8038 CvXSUBANY(cv).any_ptr = const_sv;
8039 CvXSUB(cv) = const_sv_xsub;
8043 CvFLAGS(cv) |= CvMETHOD(compcv);
8045 SvREFCNT_dec(compcv);
8049 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8050 determine whether this sub definition is in the same scope as its
8051 declaration. If this sub definition is inside an inner named pack-
8052 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8053 the package sub. So check PadnameOUTER(name) too.
8055 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8056 assert(!CvWEAKOUTSIDE(compcv));
8057 SvREFCNT_dec(CvOUTSIDE(compcv));
8058 CvWEAKOUTSIDE_on(compcv);
8060 /* XXX else do we have a circular reference? */
8061 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8062 /* transfer PL_compcv to cv */
8065 cv_flags_t preserved_flags =
8066 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8067 PADLIST *const temp_padl = CvPADLIST(cv);
8068 CV *const temp_cv = CvOUTSIDE(cv);
8069 const cv_flags_t other_flags =
8070 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8071 OP * const cvstart = CvSTART(cv);
8075 CvFLAGS(compcv) | preserved_flags;
8076 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8077 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8078 CvPADLIST_set(cv, CvPADLIST(compcv));
8079 CvOUTSIDE(compcv) = temp_cv;
8080 CvPADLIST_set(compcv, temp_padl);
8081 CvSTART(cv) = CvSTART(compcv);
8082 CvSTART(compcv) = cvstart;
8083 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8084 CvFLAGS(compcv) |= other_flags;
8086 if (CvFILE(cv) && CvDYNFILE(cv)) {
8087 Safefree(CvFILE(cv));
8090 /* inner references to compcv must be fixed up ... */
8091 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8092 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8093 ++PL_sub_generation;
8096 /* Might have had built-in attributes applied -- propagate them. */
8097 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8099 /* ... before we throw it away */
8100 SvREFCNT_dec(compcv);
8101 PL_compcv = compcv = cv;
8109 if (!CvNAME_HEK(cv)) {
8110 if (hek) (void)share_hek_hek(hek);
8114 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8115 hek = share_hek(PadnamePV(name)+1,
8116 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8119 CvNAME_HEK_set(cv, hek);
8121 if (const_sv) goto clone;
8123 CvFILE_set_from_cop(cv, PL_curcop);
8124 CvSTASH_set(cv, PL_curstash);
8127 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8128 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8134 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8135 the debugger could be able to set a breakpoint in, so signal to
8136 pp_entereval that it should not throw away any saved lines at scope
8139 PL_breakable_sub_gen++;
8141 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8142 OpREFCNT_set(CvROOT(cv), 1);
8143 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8144 itself has a refcount. */
8146 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8147 #ifdef PERL_DEBUG_READONLY_OPS
8148 slab = (OPSLAB *)CvSTART(cv);
8150 CvSTART(cv) = start;
8152 finalize_optree(CvROOT(cv));
8153 S_prune_chain_head(&CvSTART(cv));
8155 /* now that optimizer has done its work, adjust pad values */
8157 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8161 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8162 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8166 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8167 SV * const tmpstr = sv_newmortal();
8168 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8169 GV_ADDMULTI, SVt_PVHV);
8171 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8174 (long)CopLINE(PL_curcop));
8175 if (HvNAME_HEK(PL_curstash)) {
8176 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8177 sv_catpvs(tmpstr, "::");
8179 else sv_setpvs(tmpstr, "__ANON__::");
8180 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8181 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8182 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8183 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8184 hv = GvHVn(db_postponed);
8185 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8186 CV * const pcv = GvCV(db_postponed);
8192 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8200 assert(CvDEPTH(outcv));
8202 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8203 if (reusable) cv_clone_into(clonee, *spot);
8204 else *spot = cv_clone(clonee);
8205 SvREFCNT_dec_NN(clonee);
8208 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8209 PADOFFSET depth = CvDEPTH(outcv);
8212 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8214 *svspot = SvREFCNT_inc_simple_NN(cv);
8215 SvREFCNT_dec(oldcv);
8221 PL_parser->copline = NOLINE;
8223 #ifdef PERL_DEBUG_READONLY_OPS
8233 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8234 OP *block, bool o_is_gv)
8238 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8242 const bool ec = PL_parser && PL_parser->error_count;
8243 /* If the subroutine has no body, no attributes, and no builtin attributes
8244 then it's just a sub declaration, and we may be able to get away with
8245 storing with a placeholder scalar in the symbol table, rather than a
8246 full CV. If anything is present then it will take a full CV to
8248 const I32 gv_fetch_flags
8249 = ec ? GV_NOADD_NOINIT :
8250 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8251 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8253 const char * const name =
8254 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8256 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8257 bool evanescent = FALSE;
8259 #ifdef PERL_DEBUG_READONLY_OPS
8260 OPSLAB *slab = NULL;
8268 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8269 hek and CvSTASH pointer together can imply the GV. If the name
8270 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8271 CvSTASH, so forego the optimisation if we find any.
8272 Also, we may be called from load_module at run time, so
8273 PL_curstash (which sets CvSTASH) may not point to the stash the
8274 sub is stored in. */
8276 ec ? GV_NOADD_NOINIT
8277 : PL_curstash != CopSTASH(PL_curcop)
8278 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8280 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8281 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8283 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8284 SV * const sv = sv_newmortal();
8285 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8286 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8287 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8288 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8290 } else if (PL_curstash) {
8291 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8294 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8299 move_proto_attr(&proto, &attrs, gv);
8302 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8307 assert(proto->op_type == OP_CONST);
8308 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8309 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8323 if (name) SvREFCNT_dec(PL_compcv);
8324 else cv = PL_compcv;
8326 if (name && block) {
8327 const char *s = strrchr(name, ':');
8329 if (strEQ(s, "BEGIN")) {
8330 if (PL_in_eval & EVAL_KEEPERR)
8331 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8333 SV * const errsv = ERRSV;
8334 /* force display of errors found but not reported */
8335 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8336 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8343 if (!block && SvTYPE(gv) != SVt_PVGV) {
8344 /* If we are not defining a new sub and the existing one is not a
8346 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8347 /* We are applying attributes to an existing sub, so we need it
8348 upgraded if it is a constant. */
8349 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8350 gv_init_pvn(gv, PL_curstash, name, namlen,
8351 SVf_UTF8 * name_is_utf8);
8353 else { /* Maybe prototype now, and had at maximum
8354 a prototype or const/sub ref before. */
8355 if (SvTYPE(gv) > SVt_NULL) {
8356 cv_ckproto_len_flags((const CV *)gv,
8357 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8362 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8363 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8366 sv_setiv(MUTABLE_SV(gv), -1);
8369 SvREFCNT_dec(PL_compcv);
8370 cv = PL_compcv = NULL;
8375 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8379 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8384 /* This makes sub {}; work as expected. */
8385 if (block->op_type == OP_STUB) {
8386 const line_t l = PL_parser->copline;
8388 block = newSTATEOP(0, NULL, 0);
8389 PL_parser->copline = l;
8391 block = CvLVALUE(PL_compcv)
8392 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8393 && (!isGV(gv) || !GvASSUMECV(gv)))
8394 ? newUNOP(OP_LEAVESUBLV, 0,
8395 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8396 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8397 start = LINKLIST(block);
8399 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8401 S_op_const_sv(aTHX_ start, PL_compcv,
8402 cBOOL(CvCLONE(PL_compcv)));
8409 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8410 cv_ckproto_len_flags((const CV *)gv,
8411 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8412 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8414 /* All the other code for sub redefinition warnings expects the
8415 clobbered sub to be a CV. Instead of making all those code
8416 paths more complex, just inline the RV version here. */
8417 const line_t oldline = CopLINE(PL_curcop);
8418 assert(IN_PERL_COMPILETIME);
8419 if (PL_parser && PL_parser->copline != NOLINE)
8420 /* This ensures that warnings are reported at the first
8421 line of a redefinition, not the last. */
8422 CopLINE_set(PL_curcop, PL_parser->copline);
8423 /* protect against fatal warnings leaking compcv */
8424 SAVEFREESV(PL_compcv);
8426 if (ckWARN(WARN_REDEFINE)
8427 || ( ckWARN_d(WARN_REDEFINE)
8428 && ( !const_sv || SvRV(gv) == const_sv
8429 || sv_cmp(SvRV(gv), const_sv) )))
8430 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8431 "Constant subroutine %"SVf" redefined",
8432 SVfARG(cSVOPo->op_sv));
8434 SvREFCNT_inc_simple_void_NN(PL_compcv);
8435 CopLINE_set(PL_curcop, oldline);
8436 SvREFCNT_dec(SvRV(gv));
8441 const bool exists = CvROOT(cv) || CvXSUB(cv);
8443 /* if the subroutine doesn't exist and wasn't pre-declared
8444 * with a prototype, assume it will be AUTOLOADed,
8445 * skipping the prototype check
8447 if (exists || SvPOK(cv))
8448 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8449 /* already defined (or promised)? */
8450 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8451 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8454 if (attrs) goto attrs;
8455 /* just a "sub foo;" when &foo is already defined */
8456 SAVEFREESV(PL_compcv);
8462 SvREFCNT_inc_simple_void_NN(const_sv);
8463 SvFLAGS(const_sv) |= SVs_PADTMP;
8465 assert(!CvROOT(cv) && !CvCONST(cv));
8467 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8468 CvXSUBANY(cv).any_ptr = const_sv;
8469 CvXSUB(cv) = const_sv_xsub;
8473 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8476 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8477 if (name && isGV(gv))
8479 cv = newCONSTSUB_flags(
8480 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8483 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8487 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8488 prepare_SV_for_RV((SV *)gv);
8492 SvRV_set(gv, const_sv);
8496 SvREFCNT_dec(PL_compcv);
8500 if (cv) { /* must reuse cv if autoloaded */
8501 /* transfer PL_compcv to cv */
8504 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8505 PADLIST *const temp_av = CvPADLIST(cv);
8506 CV *const temp_cv = CvOUTSIDE(cv);
8507 const cv_flags_t other_flags =
8508 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8509 OP * const cvstart = CvSTART(cv);
8513 assert(!CvCVGV_RC(cv));
8514 assert(CvGV(cv) == gv);
8519 PERL_HASH(hash, name, namlen);
8529 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8531 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8532 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8533 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8534 CvOUTSIDE(PL_compcv) = temp_cv;
8535 CvPADLIST_set(PL_compcv, temp_av);
8536 CvSTART(cv) = CvSTART(PL_compcv);
8537 CvSTART(PL_compcv) = cvstart;
8538 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8539 CvFLAGS(PL_compcv) |= other_flags;
8541 if (CvFILE(cv) && CvDYNFILE(cv)) {
8542 Safefree(CvFILE(cv));
8544 CvFILE_set_from_cop(cv, PL_curcop);
8545 CvSTASH_set(cv, PL_curstash);
8547 /* inner references to PL_compcv must be fixed up ... */
8548 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8549 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8550 ++PL_sub_generation;
8553 /* Might have had built-in attributes applied -- propagate them. */
8554 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8556 /* ... before we throw it away */
8557 SvREFCNT_dec(PL_compcv);
8562 if (name && isGV(gv)) {
8565 if (HvENAME_HEK(GvSTASH(gv)))
8566 /* sub Foo::bar { (shift)+1 } */
8567 gv_method_changed(gv);
8571 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8572 prepare_SV_for_RV((SV *)gv);
8576 SvRV_set(gv, (SV *)cv);
8580 if (isGV(gv)) CvGV_set(cv, gv);
8584 PERL_HASH(hash, name, namlen);
8585 CvNAME_HEK_set(cv, share_hek(name,
8591 CvFILE_set_from_cop(cv, PL_curcop);
8592 CvSTASH_set(cv, PL_curstash);
8596 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8597 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8603 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8604 the debugger could be able to set a breakpoint in, so signal to
8605 pp_entereval that it should not throw away any saved lines at scope
8608 PL_breakable_sub_gen++;
8610 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8611 OpREFCNT_set(CvROOT(cv), 1);
8612 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8613 itself has a refcount. */
8615 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8616 #ifdef PERL_DEBUG_READONLY_OPS
8617 slab = (OPSLAB *)CvSTART(cv);
8619 CvSTART(cv) = start;
8621 finalize_optree(CvROOT(cv));
8622 S_prune_chain_head(&CvSTART(cv));
8624 /* now that optimizer has done its work, adjust pad values */
8626 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8630 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8631 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8634 if (!name) SAVEFREESV(cv);
8635 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8636 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8639 if (block && has_name) {
8640 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8641 SV * const tmpstr = cv_name(cv,NULL,0);
8642 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8643 GV_ADDMULTI, SVt_PVHV);
8645 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8648 (long)CopLINE(PL_curcop));
8649 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8650 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8651 hv = GvHVn(db_postponed);
8652 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8653 CV * const pcv = GvCV(db_postponed);
8659 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8665 if (PL_parser && PL_parser->error_count)
8666 clear_special_blocks(name, gv, cv);
8669 process_special_blocks(floor, name, gv, cv);
8675 PL_parser->copline = NOLINE;
8678 #ifdef PERL_DEBUG_READONLY_OPS
8682 if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8683 pad_add_weakref(cv);
8689 S_clear_special_blocks(pTHX_ const char *const fullname,
8690 GV *const gv, CV *const cv) {
8694 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8696 colon = strrchr(fullname,':');
8697 name = colon ? colon + 1 : fullname;
8699 if ((*name == 'B' && strEQ(name, "BEGIN"))
8700 || (*name == 'E' && strEQ(name, "END"))
8701 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8702 || (*name == 'C' && strEQ(name, "CHECK"))
8703 || (*name == 'I' && strEQ(name, "INIT"))) {
8709 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8713 /* Returns true if the sub has been freed. */
8715 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8719 const char *const colon = strrchr(fullname,':');
8720 const char *const name = colon ? colon + 1 : fullname;
8722 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8725 if (strEQ(name, "BEGIN")) {
8726 const I32 oldscope = PL_scopestack_ix;
8729 if (floor) LEAVE_SCOPE(floor);
8731 PUSHSTACKi(PERLSI_REQUIRE);
8732 SAVECOPFILE(&PL_compiling);
8733 SAVECOPLINE(&PL_compiling);
8734 SAVEVPTR(PL_curcop);
8736 DEBUG_x( dump_sub(gv) );
8737 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8738 GvCV_set(gv,0); /* cv has been hijacked */
8739 call_list(oldscope, PL_beginav);
8743 return !PL_savebegin;
8749 if strEQ(name, "END") {
8750 DEBUG_x( dump_sub(gv) );
8751 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8754 } else if (*name == 'U') {
8755 if (strEQ(name, "UNITCHECK")) {
8756 /* It's never too late to run a unitcheck block */
8757 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8761 } else if (*name == 'C') {
8762 if (strEQ(name, "CHECK")) {
8764 /* diag_listed_as: Too late to run %s block */
8765 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8766 "Too late to run CHECK block");
8767 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8771 } else if (*name == 'I') {
8772 if (strEQ(name, "INIT")) {
8774 /* diag_listed_as: Too late to run %s block */
8775 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8776 "Too late to run INIT block");
8777 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8783 DEBUG_x( dump_sub(gv) );
8785 GvCV_set(gv,0); /* cv has been hijacked */
8791 =for apidoc newCONSTSUB
8793 See L</newCONSTSUB_flags>.
8799 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8801 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8805 =for apidoc newCONSTSUB_flags
8807 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
8808 eligible for inlining at compile-time.
8810 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
8812 The newly created subroutine takes ownership of a reference to the passed in
8815 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
8816 which won't be called if used as a destructor, but will suppress the overhead
8817 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8824 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8828 const char *const file = CopFILE(PL_curcop);
8832 if (IN_PERL_RUNTIME) {
8833 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8834 * an op shared between threads. Use a non-shared COP for our
8836 SAVEVPTR(PL_curcop);
8837 SAVECOMPILEWARNINGS();
8838 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8839 PL_curcop = &PL_compiling;
8841 SAVECOPLINE(PL_curcop);
8842 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8845 PL_hints &= ~HINT_BLOCK_SCOPE;
8848 SAVEGENERICSV(PL_curstash);
8849 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8852 /* Protect sv against leakage caused by fatal warnings. */
8853 if (sv) SAVEFREESV(sv);
8855 /* file becomes the CvFILE. For an XS, it's usually static storage,
8856 and so doesn't get free()d. (It's expected to be from the C pre-
8857 processor __FILE__ directive). But we need a dynamically allocated one,
8858 and we need it to get freed. */
8859 cv = newXS_len_flags(name, len,
8860 sv && SvTYPE(sv) == SVt_PVAV
8863 file ? file : "", "",
8864 &sv, XS_DYNAMIC_FILENAME | flags);
8865 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8874 =for apidoc U||newXS
8876 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
8877 static storage, as it is used directly as CvFILE(), without a copy being made.
8883 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8885 PERL_ARGS_ASSERT_NEWXS;
8886 return newXS_len_flags(
8887 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8892 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8893 const char *const filename, const char *const proto,
8896 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8897 return newXS_len_flags(
8898 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8903 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
8905 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
8906 return newXS_len_flags(
8907 name, strlen(name), subaddr, NULL, NULL, NULL, 0
8912 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8913 XSUBADDR_t subaddr, const char *const filename,
8914 const char *const proto, SV **const_svp,
8918 bool interleave = FALSE;
8920 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8923 GV * const gv = gv_fetchpvn(
8924 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8925 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8926 sizeof("__ANON__::__ANON__") - 1,
8927 GV_ADDMULTI | flags, SVt_PVCV);
8929 if ((cv = (name ? GvCV(gv) : NULL))) {
8931 /* just a cached method */
8935 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8936 /* already defined (or promised) */
8937 /* Redundant check that allows us to avoid creating an SV
8938 most of the time: */
8939 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8940 report_redefined_cv(newSVpvn_flags(
8941 name,len,(flags&SVf_UTF8)|SVs_TEMP
8952 if (cv) /* must reuse cv if autoloaded */
8955 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8959 if (HvENAME_HEK(GvSTASH(gv)))
8960 gv_method_changed(gv); /* newXS */
8966 /* XSUBs can't be perl lang/perl5db.pl debugged
8967 if (PERLDB_LINE_OR_SAVESRC)
8968 (void)gv_fetchfile(filename); */
8969 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8970 if (flags & XS_DYNAMIC_FILENAME) {
8972 CvFILE(cv) = savepv(filename);
8974 /* NOTE: not copied, as it is expected to be an external constant string */
8975 CvFILE(cv) = (char *)filename;
8978 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
8979 CvFILE(cv) = (char*)PL_xsubfilename;
8982 CvXSUB(cv) = subaddr;
8983 #ifndef PERL_IMPLICIT_CONTEXT
8984 CvHSCXT(cv) = &PL_stack_sp;
8990 process_special_blocks(0, name, gv, cv);
8993 } /* <- not a conditional branch */
8996 sv_setpv(MUTABLE_SV(cv), proto);
8997 if (interleave) LEAVE;
9002 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9004 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9006 PERL_ARGS_ASSERT_NEWSTUB;
9010 if (!fake && HvENAME_HEK(GvSTASH(gv)))
9011 gv_method_changed(gv);
9013 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9018 CvFILE_set_from_cop(cv, PL_curcop);
9019 CvSTASH_set(cv, PL_curstash);
9025 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9031 if (PL_parser && PL_parser->error_count) {
9037 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9038 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9041 if ((cv = GvFORM(gv))) {
9042 if (ckWARN(WARN_REDEFINE)) {
9043 const line_t oldline = CopLINE(PL_curcop);
9044 if (PL_parser && PL_parser->copline != NOLINE)
9045 CopLINE_set(PL_curcop, PL_parser->copline);
9047 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9048 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9050 /* diag_listed_as: Format %s redefined */
9051 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9052 "Format STDOUT redefined");
9054 CopLINE_set(PL_curcop, oldline);
9059 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9061 CvFILE_set_from_cop(cv, PL_curcop);
9064 pad_tidy(padtidy_FORMAT);
9065 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9066 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9067 OpREFCNT_set(CvROOT(cv), 1);
9068 CvSTART(cv) = LINKLIST(CvROOT(cv));
9069 CvROOT(cv)->op_next = 0;
9070 CALL_PEEP(CvSTART(cv));
9071 finalize_optree(CvROOT(cv));
9072 S_prune_chain_head(&CvSTART(cv));
9078 PL_parser->copline = NOLINE;
9080 PL_compiling.cop_seq = 0;
9084 Perl_newANONLIST(pTHX_ OP *o)
9086 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9090 Perl_newANONHASH(pTHX_ OP *o)
9092 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9096 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9098 return newANONATTRSUB(floor, proto, NULL, block);
9102 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9104 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9106 newSVOP(OP_ANONCODE, 0,
9108 if (CvANONCONST(cv))
9109 anoncode = newUNOP(OP_ANONCONST, 0,
9110 op_convert_list(OP_ENTERSUB,
9111 OPf_STACKED|OPf_WANT_SCALAR,
9113 return newUNOP(OP_REFGEN, 0, anoncode);
9117 Perl_oopsAV(pTHX_ OP *o)
9121 PERL_ARGS_ASSERT_OOPSAV;
9123 switch (o->op_type) {
9126 OpTYPE_set(o, OP_PADAV);
9127 return ref(o, OP_RV2AV);
9131 OpTYPE_set(o, OP_RV2AV);
9136 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9143 Perl_oopsHV(pTHX_ OP *o)
9147 PERL_ARGS_ASSERT_OOPSHV;
9149 switch (o->op_type) {
9152 OpTYPE_set(o, OP_PADHV);
9153 return ref(o, OP_RV2HV);
9157 OpTYPE_set(o, OP_RV2HV);
9162 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9169 Perl_newAVREF(pTHX_ OP *o)
9173 PERL_ARGS_ASSERT_NEWAVREF;
9175 if (o->op_type == OP_PADANY) {
9176 OpTYPE_set(o, OP_PADAV);
9179 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9180 Perl_croak(aTHX_ "Can't use an array as a reference");
9182 return newUNOP(OP_RV2AV, 0, scalar(o));
9186 Perl_newGVREF(pTHX_ I32 type, OP *o)
9188 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9189 return newUNOP(OP_NULL, 0, o);
9190 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9194 Perl_newHVREF(pTHX_ OP *o)
9198 PERL_ARGS_ASSERT_NEWHVREF;
9200 if (o->op_type == OP_PADANY) {
9201 OpTYPE_set(o, OP_PADHV);
9204 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9205 Perl_croak(aTHX_ "Can't use a hash as a reference");
9207 return newUNOP(OP_RV2HV, 0, scalar(o));
9211 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9213 if (o->op_type == OP_PADANY) {
9215 OpTYPE_set(o, OP_PADCV);
9217 return newUNOP(OP_RV2CV, flags, scalar(o));
9221 Perl_newSVREF(pTHX_ OP *o)
9225 PERL_ARGS_ASSERT_NEWSVREF;
9227 if (o->op_type == OP_PADANY) {
9228 OpTYPE_set(o, OP_PADSV);
9232 return newUNOP(OP_RV2SV, 0, scalar(o));
9235 /* Check routines. See the comments at the top of this file for details
9236 * on when these are called */
9239 Perl_ck_anoncode(pTHX_ OP *o)
9241 PERL_ARGS_ASSERT_CK_ANONCODE;
9243 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9244 cSVOPo->op_sv = NULL;
9249 S_io_hints(pTHX_ OP *o)
9251 #if O_BINARY != 0 || O_TEXT != 0
9253 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9255 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9258 const char *d = SvPV_const(*svp, len);
9259 const I32 mode = mode_from_discipline(d, len);
9260 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9262 if (mode & O_BINARY)
9263 o->op_private |= OPpOPEN_IN_RAW;
9267 o->op_private |= OPpOPEN_IN_CRLF;
9271 svp = hv_fetchs(table, "open_OUT", FALSE);
9274 const char *d = SvPV_const(*svp, len);
9275 const I32 mode = mode_from_discipline(d, len);
9276 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9278 if (mode & O_BINARY)
9279 o->op_private |= OPpOPEN_OUT_RAW;
9283 o->op_private |= OPpOPEN_OUT_CRLF;
9288 PERL_UNUSED_CONTEXT;
9294 Perl_ck_backtick(pTHX_ OP *o)
9299 PERL_ARGS_ASSERT_CK_BACKTICK;
9300 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9301 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9302 && (gv = gv_override("readpipe",8)))
9304 /* detach rest of siblings from o and its first child */
9305 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9306 newop = S_new_entersubop(aTHX_ gv, sibl);
9308 else if (!(o->op_flags & OPf_KIDS))
9309 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9314 S_io_hints(aTHX_ o);
9319 Perl_ck_bitop(pTHX_ OP *o)
9321 PERL_ARGS_ASSERT_CK_BITOP;
9323 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9325 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9326 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9327 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9328 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9329 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9330 "The bitwise feature is experimental");
9331 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9332 && OP_IS_INFIX_BIT(o->op_type))
9334 const OP * const left = cBINOPo->op_first;
9335 const OP * const right = OpSIBLING(left);
9336 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9337 (left->op_flags & OPf_PARENS) == 0) ||
9338 (OP_IS_NUMCOMPARE(right->op_type) &&
9339 (right->op_flags & OPf_PARENS) == 0))
9340 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9341 "Possible precedence problem on bitwise %s operator",
9342 o->op_type == OP_BIT_OR
9343 ||o->op_type == OP_NBIT_OR ? "|"
9344 : o->op_type == OP_BIT_AND
9345 ||o->op_type == OP_NBIT_AND ? "&"
9346 : o->op_type == OP_BIT_XOR
9347 ||o->op_type == OP_NBIT_XOR ? "^"
9348 : o->op_type == OP_SBIT_OR ? "|."
9349 : o->op_type == OP_SBIT_AND ? "&." : "^."
9355 PERL_STATIC_INLINE bool
9356 is_dollar_bracket(pTHX_ const OP * const o)
9359 PERL_UNUSED_CONTEXT;
9360 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9361 && (kid = cUNOPx(o)->op_first)
9362 && kid->op_type == OP_GV
9363 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9367 Perl_ck_cmp(pTHX_ OP *o)
9369 PERL_ARGS_ASSERT_CK_CMP;
9370 if (ckWARN(WARN_SYNTAX)) {
9371 const OP *kid = cUNOPo->op_first;
9374 ( is_dollar_bracket(aTHX_ kid)
9375 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9377 || ( kid->op_type == OP_CONST
9378 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9382 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9383 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9389 Perl_ck_concat(pTHX_ OP *o)
9391 const OP * const kid = cUNOPo->op_first;
9393 PERL_ARGS_ASSERT_CK_CONCAT;
9394 PERL_UNUSED_CONTEXT;
9396 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9397 !(kUNOP->op_first->op_flags & OPf_MOD))
9398 o->op_flags |= OPf_STACKED;
9403 Perl_ck_spair(pTHX_ OP *o)
9407 PERL_ARGS_ASSERT_CK_SPAIR;
9409 if (o->op_flags & OPf_KIDS) {
9413 const OPCODE type = o->op_type;
9414 o = modkids(ck_fun(o), type);
9415 kid = cUNOPo->op_first;
9416 kidkid = kUNOP->op_first;
9417 newop = OpSIBLING(kidkid);
9419 const OPCODE type = newop->op_type;
9420 if (OpHAS_SIBLING(newop))
9422 if (o->op_type == OP_REFGEN
9423 && ( type == OP_RV2CV
9424 || ( !(newop->op_flags & OPf_PARENS)
9425 && ( type == OP_RV2AV || type == OP_PADAV
9426 || type == OP_RV2HV || type == OP_PADHV))))
9427 NOOP; /* OK (allow srefgen for \@a and \%h) */
9428 else if (OP_GIMME(newop,0) != G_SCALAR)
9431 /* excise first sibling */
9432 op_sibling_splice(kid, NULL, 1, NULL);
9435 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9436 * and OP_CHOMP into OP_SCHOMP */
9437 o->op_ppaddr = PL_ppaddr[++o->op_type];
9442 Perl_ck_delete(pTHX_ OP *o)
9444 PERL_ARGS_ASSERT_CK_DELETE;
9448 if (o->op_flags & OPf_KIDS) {
9449 OP * const kid = cUNOPo->op_first;
9450 switch (kid->op_type) {
9452 o->op_flags |= OPf_SPECIAL;
9455 o->op_private |= OPpSLICE;
9458 o->op_flags |= OPf_SPECIAL;
9463 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9464 " use array slice");
9466 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9469 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9470 "element or slice");
9472 if (kid->op_private & OPpLVAL_INTRO)
9473 o->op_private |= OPpLVAL_INTRO;
9480 Perl_ck_eof(pTHX_ OP *o)
9482 PERL_ARGS_ASSERT_CK_EOF;
9484 if (o->op_flags & OPf_KIDS) {
9486 if (cLISTOPo->op_first->op_type == OP_STUB) {
9488 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9493 kid = cLISTOPo->op_first;
9494 if (kid->op_type == OP_RV2GV)
9495 kid->op_private |= OPpALLOW_FAKE;
9501 Perl_ck_eval(pTHX_ OP *o)
9505 PERL_ARGS_ASSERT_CK_EVAL;
9507 PL_hints |= HINT_BLOCK_SCOPE;
9508 if (o->op_flags & OPf_KIDS) {
9509 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9512 if (o->op_type == OP_ENTERTRY) {
9515 /* cut whole sibling chain free from o */
9516 op_sibling_splice(o, NULL, -1, NULL);
9519 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9521 /* establish postfix order */
9522 enter->op_next = (OP*)enter;
9524 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9525 OpTYPE_set(o, OP_LEAVETRY);
9526 enter->op_other = o;
9531 S_set_haseval(aTHX);
9535 const U8 priv = o->op_private;
9537 /* the newUNOP will recursively call ck_eval(), which will handle
9538 * all the stuff at the end of this function, like adding
9541 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9543 o->op_targ = (PADOFFSET)PL_hints;
9544 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9545 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9546 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9547 /* Store a copy of %^H that pp_entereval can pick up. */
9548 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9549 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9550 /* append hhop to only child */
9551 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9553 o->op_private |= OPpEVAL_HAS_HH;
9555 if (!(o->op_private & OPpEVAL_BYTES)
9556 && FEATURE_UNIEVAL_IS_ENABLED)
9557 o->op_private |= OPpEVAL_UNICODE;
9562 Perl_ck_exec(pTHX_ OP *o)
9564 PERL_ARGS_ASSERT_CK_EXEC;
9566 if (o->op_flags & OPf_STACKED) {
9569 kid = OpSIBLING(cUNOPo->op_first);
9570 if (kid->op_type == OP_RV2GV)
9579 Perl_ck_exists(pTHX_ OP *o)
9581 PERL_ARGS_ASSERT_CK_EXISTS;
9584 if (o->op_flags & OPf_KIDS) {
9585 OP * const kid = cUNOPo->op_first;
9586 if (kid->op_type == OP_ENTERSUB) {
9587 (void) ref(kid, o->op_type);
9588 if (kid->op_type != OP_RV2CV
9589 && !(PL_parser && PL_parser->error_count))
9591 "exists argument is not a subroutine name");
9592 o->op_private |= OPpEXISTS_SUB;
9594 else if (kid->op_type == OP_AELEM)
9595 o->op_flags |= OPf_SPECIAL;
9596 else if (kid->op_type != OP_HELEM)
9597 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9598 "element or a subroutine");
9605 Perl_ck_rvconst(pTHX_ OP *o)
9608 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9610 PERL_ARGS_ASSERT_CK_RVCONST;
9612 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9614 if (kid->op_type == OP_CONST) {
9617 SV * const kidsv = kid->op_sv;
9619 /* Is it a constant from cv_const_sv()? */
9620 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9623 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9624 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9625 const char *badthing;
9626 switch (o->op_type) {
9628 badthing = "a SCALAR";
9631 badthing = "an ARRAY";
9634 badthing = "a HASH";
9642 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9643 SVfARG(kidsv), badthing);
9646 * This is a little tricky. We only want to add the symbol if we
9647 * didn't add it in the lexer. Otherwise we get duplicate strict
9648 * warnings. But if we didn't add it in the lexer, we must at
9649 * least pretend like we wanted to add it even if it existed before,
9650 * or we get possible typo warnings. OPpCONST_ENTERED says
9651 * whether the lexer already added THIS instance of this symbol.
9653 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9654 gv = gv_fetchsv(kidsv,
9655 o->op_type == OP_RV2CV
9656 && o->op_private & OPpMAY_RETURN_CONSTANT
9658 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9661 : o->op_type == OP_RV2SV
9663 : o->op_type == OP_RV2AV
9665 : o->op_type == OP_RV2HV
9672 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9673 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9674 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9676 OpTYPE_set(kid, OP_GV);
9677 SvREFCNT_dec(kid->op_sv);
9679 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9680 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9681 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9682 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9683 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9685 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9687 kid->op_private = 0;
9688 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9696 Perl_ck_ftst(pTHX_ OP *o)
9699 const I32 type = o->op_type;
9701 PERL_ARGS_ASSERT_CK_FTST;
9703 if (o->op_flags & OPf_REF) {
9706 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9707 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9708 const OPCODE kidtype = kid->op_type;
9710 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9711 && !kid->op_folded) {
9712 OP * const newop = newGVOP(type, OPf_REF,
9713 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9718 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9719 o->op_private |= OPpFT_ACCESS;
9720 if (type != OP_STAT && type != OP_LSTAT
9721 && PL_check[kidtype] == Perl_ck_ftst
9722 && kidtype != OP_STAT && kidtype != OP_LSTAT
9724 o->op_private |= OPpFT_STACKED;
9725 kid->op_private |= OPpFT_STACKING;
9726 if (kidtype == OP_FTTTY && (
9727 !(kid->op_private & OPpFT_STACKED)
9728 || kid->op_private & OPpFT_AFTER_t
9730 o->op_private |= OPpFT_AFTER_t;
9735 if (type == OP_FTTTY)
9736 o = newGVOP(type, OPf_REF, PL_stdingv);
9738 o = newUNOP(type, 0, newDEFSVOP());
9744 Perl_ck_fun(pTHX_ OP *o)
9746 const int type = o->op_type;
9747 I32 oa = PL_opargs[type] >> OASHIFT;
9749 PERL_ARGS_ASSERT_CK_FUN;
9751 if (o->op_flags & OPf_STACKED) {
9752 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9755 return no_fh_allowed(o);
9758 if (o->op_flags & OPf_KIDS) {
9759 OP *prev_kid = NULL;
9760 OP *kid = cLISTOPo->op_first;
9762 bool seen_optional = FALSE;
9764 if (kid->op_type == OP_PUSHMARK ||
9765 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9768 kid = OpSIBLING(kid);
9770 if (kid && kid->op_type == OP_COREARGS) {
9771 bool optional = FALSE;
9774 if (oa & OA_OPTIONAL) optional = TRUE;
9777 if (optional) o->op_private |= numargs;
9782 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9783 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9785 /* append kid to chain */
9786 op_sibling_splice(o, prev_kid, 0, kid);
9788 seen_optional = TRUE;
9795 /* list seen where single (scalar) arg expected? */
9796 if (numargs == 1 && !(oa >> 4)
9797 && kid->op_type == OP_LIST && type != OP_SCALAR)
9799 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9801 if (type != OP_DELETE) scalar(kid);
9812 if ((type == OP_PUSH || type == OP_UNSHIFT)
9813 && !OpHAS_SIBLING(kid))
9814 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9815 "Useless use of %s with no values",
9818 if (kid->op_type == OP_CONST
9819 && ( !SvROK(cSVOPx_sv(kid))
9820 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9822 bad_type_pv(numargs, "array", o, kid);
9823 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9824 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9825 PL_op_desc[type]), 0);
9828 op_lvalue(kid, type);
9832 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9833 bad_type_pv(numargs, "hash", o, kid);
9834 op_lvalue(kid, type);
9838 /* replace kid with newop in chain */
9840 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9841 newop->op_next = newop;
9846 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9847 if (kid->op_type == OP_CONST &&
9848 (kid->op_private & OPpCONST_BARE))
9850 OP * const newop = newGVOP(OP_GV, 0,
9851 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9852 /* replace kid with newop in chain */
9853 op_sibling_splice(o, prev_kid, 1, newop);
9857 else if (kid->op_type == OP_READLINE) {
9858 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9859 bad_type_pv(numargs, "HANDLE", o, kid);
9862 I32 flags = OPf_SPECIAL;
9866 /* is this op a FH constructor? */
9867 if (is_handle_constructor(o,numargs)) {
9868 const char *name = NULL;
9871 bool want_dollar = TRUE;
9874 /* Set a flag to tell rv2gv to vivify
9875 * need to "prove" flag does not mean something
9876 * else already - NI-S 1999/05/07
9879 if (kid->op_type == OP_PADSV) {
9881 = PAD_COMPNAME_SV(kid->op_targ);
9882 name = PadnamePV (pn);
9883 len = PadnameLEN(pn);
9884 name_utf8 = PadnameUTF8(pn);
9886 else if (kid->op_type == OP_RV2SV
9887 && kUNOP->op_first->op_type == OP_GV)
9889 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9891 len = GvNAMELEN(gv);
9892 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9894 else if (kid->op_type == OP_AELEM
9895 || kid->op_type == OP_HELEM)
9898 OP *op = ((BINOP*)kid)->op_first;
9902 const char * const a =
9903 kid->op_type == OP_AELEM ?
9905 if (((op->op_type == OP_RV2AV) ||
9906 (op->op_type == OP_RV2HV)) &&
9907 (firstop = ((UNOP*)op)->op_first) &&
9908 (firstop->op_type == OP_GV)) {
9909 /* packagevar $a[] or $h{} */
9910 GV * const gv = cGVOPx_gv(firstop);
9918 else if (op->op_type == OP_PADAV
9919 || op->op_type == OP_PADHV) {
9920 /* lexicalvar $a[] or $h{} */
9921 const char * const padname =
9922 PAD_COMPNAME_PV(op->op_targ);
9931 name = SvPV_const(tmpstr, len);
9932 name_utf8 = SvUTF8(tmpstr);
9937 name = "__ANONIO__";
9939 want_dollar = FALSE;
9941 op_lvalue(kid, type);
9945 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9946 namesv = PAD_SVl(targ);
9947 if (want_dollar && *name != '$')
9948 sv_setpvs(namesv, "$");
9950 sv_setpvs(namesv, "");
9951 sv_catpvn(namesv, name, len);
9952 if ( name_utf8 ) SvUTF8_on(namesv);
9956 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9958 kid->op_targ = targ;
9959 kid->op_private |= priv;
9965 if ((type == OP_UNDEF || type == OP_POS)
9966 && numargs == 1 && !(oa >> 4)
9967 && kid->op_type == OP_LIST)
9968 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9969 op_lvalue(scalar(kid), type);
9974 kid = OpSIBLING(kid);
9976 /* FIXME - should the numargs or-ing move after the too many
9977 * arguments check? */
9978 o->op_private |= numargs;
9980 return too_many_arguments_pv(o,OP_DESC(o), 0);
9983 else if (PL_opargs[type] & OA_DEFGV) {
9984 /* Ordering of these two is important to keep f_map.t passing. */
9986 return newUNOP(type, 0, newDEFSVOP());
9990 while (oa & OA_OPTIONAL)
9992 if (oa && oa != OA_LIST)
9993 return too_few_arguments_pv(o,OP_DESC(o), 0);
9999 Perl_ck_glob(pTHX_ OP *o)
10003 PERL_ARGS_ASSERT_CK_GLOB;
10006 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10007 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10009 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10013 * \ null - const(wildcard)
10018 * \ mark - glob - rv2cv
10019 * | \ gv(CORE::GLOBAL::glob)
10021 * \ null - const(wildcard)
10023 o->op_flags |= OPf_SPECIAL;
10024 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10025 o = S_new_entersubop(aTHX_ gv, o);
10026 o = newUNOP(OP_NULL, 0, o);
10027 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10030 else o->op_flags &= ~OPf_SPECIAL;
10031 #if !defined(PERL_EXTERNAL_GLOB)
10032 if (!PL_globhook) {
10034 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10035 newSVpvs("File::Glob"), NULL, NULL, NULL);
10038 #endif /* !PERL_EXTERNAL_GLOB */
10039 gv = (GV *)newSV(0);
10040 gv_init(gv, 0, "", 0, 0);
10042 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10043 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10049 Perl_ck_grep(pTHX_ OP *o)
10053 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10055 PERL_ARGS_ASSERT_CK_GREP;
10057 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10059 if (o->op_flags & OPf_STACKED) {
10060 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10061 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10062 return no_fh_allowed(o);
10063 o->op_flags &= ~OPf_STACKED;
10065 kid = OpSIBLING(cLISTOPo->op_first);
10066 if (type == OP_MAPWHILE)
10071 if (PL_parser && PL_parser->error_count)
10073 kid = OpSIBLING(cLISTOPo->op_first);
10074 if (kid->op_type != OP_NULL)
10075 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10076 kid = kUNOP->op_first;
10078 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10079 kid->op_next = (OP*)gwop;
10080 o->op_private = gwop->op_private = 0;
10081 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10083 kid = OpSIBLING(cLISTOPo->op_first);
10084 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10085 op_lvalue(kid, OP_GREPSTART);
10091 Perl_ck_index(pTHX_ OP *o)
10093 PERL_ARGS_ASSERT_CK_INDEX;
10095 if (o->op_flags & OPf_KIDS) {
10096 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10098 kid = OpSIBLING(kid); /* get past "big" */
10099 if (kid && kid->op_type == OP_CONST) {
10100 const bool save_taint = TAINT_get;
10101 SV *sv = kSVOP->op_sv;
10102 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10104 sv_copypv(sv, kSVOP->op_sv);
10105 SvREFCNT_dec_NN(kSVOP->op_sv);
10108 if (SvOK(sv)) fbm_compile(sv, 0);
10109 TAINT_set(save_taint);
10110 #ifdef NO_TAINT_SUPPORT
10111 PERL_UNUSED_VAR(save_taint);
10119 Perl_ck_lfun(pTHX_ OP *o)
10121 const OPCODE type = o->op_type;
10123 PERL_ARGS_ASSERT_CK_LFUN;
10125 return modkids(ck_fun(o), type);
10129 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10131 PERL_ARGS_ASSERT_CK_DEFINED;
10133 if ((o->op_flags & OPf_KIDS)) {
10134 switch (cUNOPo->op_first->op_type) {
10137 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10138 " (Maybe you should just omit the defined()?)");
10142 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10143 " (Maybe you should just omit the defined()?)");
10154 Perl_ck_readline(pTHX_ OP *o)
10156 PERL_ARGS_ASSERT_CK_READLINE;
10158 if (o->op_flags & OPf_KIDS) {
10159 OP *kid = cLISTOPo->op_first;
10160 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10164 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10172 Perl_ck_rfun(pTHX_ OP *o)
10174 const OPCODE type = o->op_type;
10176 PERL_ARGS_ASSERT_CK_RFUN;
10178 return refkids(ck_fun(o), type);
10182 Perl_ck_listiob(pTHX_ OP *o)
10186 PERL_ARGS_ASSERT_CK_LISTIOB;
10188 kid = cLISTOPo->op_first;
10190 o = force_list(o, 1);
10191 kid = cLISTOPo->op_first;
10193 if (kid->op_type == OP_PUSHMARK)
10194 kid = OpSIBLING(kid);
10195 if (kid && o->op_flags & OPf_STACKED)
10196 kid = OpSIBLING(kid);
10197 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10198 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10199 && !kid->op_folded) {
10200 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10202 /* replace old const op with new OP_RV2GV parent */
10203 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10204 OP_RV2GV, OPf_REF);
10205 kid = OpSIBLING(kid);
10210 op_append_elem(o->op_type, o, newDEFSVOP());
10212 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10213 return listkids(o);
10217 Perl_ck_smartmatch(pTHX_ OP *o)
10220 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10221 if (0 == (o->op_flags & OPf_SPECIAL)) {
10222 OP *first = cBINOPo->op_first;
10223 OP *second = OpSIBLING(first);
10225 /* Implicitly take a reference to an array or hash */
10227 /* remove the original two siblings, then add back the
10228 * (possibly different) first and second sibs.
10230 op_sibling_splice(o, NULL, 1, NULL);
10231 op_sibling_splice(o, NULL, 1, NULL);
10232 first = ref_array_or_hash(first);
10233 second = ref_array_or_hash(second);
10234 op_sibling_splice(o, NULL, 0, second);
10235 op_sibling_splice(o, NULL, 0, first);
10237 /* Implicitly take a reference to a regular expression */
10238 if (first->op_type == OP_MATCH) {
10239 OpTYPE_set(first, OP_QR);
10241 if (second->op_type == OP_MATCH) {
10242 OpTYPE_set(second, OP_QR);
10251 S_maybe_targlex(pTHX_ OP *o)
10253 OP * const kid = cLISTOPo->op_first;
10254 /* has a disposable target? */
10255 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10256 && !(kid->op_flags & OPf_STACKED)
10257 /* Cannot steal the second time! */
10258 && !(kid->op_private & OPpTARGET_MY)
10261 OP * const kkid = OpSIBLING(kid);
10263 /* Can just relocate the target. */
10264 if (kkid && kkid->op_type == OP_PADSV
10265 && (!(kkid->op_private & OPpLVAL_INTRO)
10266 || kkid->op_private & OPpPAD_STATE))
10268 kid->op_targ = kkid->op_targ;
10270 /* Now we do not need PADSV and SASSIGN.
10271 * Detach kid and free the rest. */
10272 op_sibling_splice(o, NULL, 1, NULL);
10274 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10282 Perl_ck_sassign(pTHX_ OP *o)
10285 OP * const kid = cLISTOPo->op_first;
10287 PERL_ARGS_ASSERT_CK_SASSIGN;
10289 if (OpHAS_SIBLING(kid)) {
10290 OP *kkid = OpSIBLING(kid);
10291 /* For state variable assignment with attributes, kkid is a list op
10292 whose op_last is a padsv. */
10293 if ((kkid->op_type == OP_PADSV ||
10294 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10295 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10298 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10299 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10300 const PADOFFSET target = kkid->op_targ;
10301 OP *const other = newOP(OP_PADSV,
10303 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10304 OP *const first = newOP(OP_NULL, 0);
10306 newCONDOP(0, first, o, other);
10307 /* XXX targlex disabled for now; see ticket #124160
10308 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10310 OP *const condop = first->op_next;
10312 OpTYPE_set(condop, OP_ONCE);
10313 other->op_targ = target;
10314 nullop->op_flags |= OPf_WANT_SCALAR;
10316 /* Store the initializedness of state vars in a separate
10319 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10320 /* hijacking PADSTALE for uninitialized state variables */
10321 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10326 return S_maybe_targlex(aTHX_ o);
10330 Perl_ck_match(pTHX_ OP *o)
10332 PERL_UNUSED_CONTEXT;
10333 PERL_ARGS_ASSERT_CK_MATCH;
10335 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10336 o->op_private |= OPpRUNTIME;
10341 Perl_ck_method(pTHX_ OP *o)
10343 SV *sv, *methsv, *rclass;
10344 const char* method;
10347 STRLEN len, nsplit = 0, i;
10349 OP * const kid = cUNOPo->op_first;
10351 PERL_ARGS_ASSERT_CK_METHOD;
10352 if (kid->op_type != OP_CONST) return o;
10356 /* replace ' with :: */
10357 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10359 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10362 method = SvPVX_const(sv);
10364 utf8 = SvUTF8(sv) ? -1 : 1;
10366 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10371 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10373 if (!nsplit) { /* $proto->method() */
10375 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10378 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10380 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10383 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10384 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10385 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10386 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10388 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10389 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10391 #ifdef USE_ITHREADS
10392 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10394 cMETHOPx(new_op)->op_rclass_sv = rclass;
10401 Perl_ck_null(pTHX_ OP *o)
10403 PERL_ARGS_ASSERT_CK_NULL;
10404 PERL_UNUSED_CONTEXT;
10409 Perl_ck_open(pTHX_ OP *o)
10411 PERL_ARGS_ASSERT_CK_OPEN;
10413 S_io_hints(aTHX_ o);
10415 /* In case of three-arg dup open remove strictness
10416 * from the last arg if it is a bareword. */
10417 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10418 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10422 if ((last->op_type == OP_CONST) && /* The bareword. */
10423 (last->op_private & OPpCONST_BARE) &&
10424 (last->op_private & OPpCONST_STRICT) &&
10425 (oa = OpSIBLING(first)) && /* The fh. */
10426 (oa = OpSIBLING(oa)) && /* The mode. */
10427 (oa->op_type == OP_CONST) &&
10428 SvPOK(((SVOP*)oa)->op_sv) &&
10429 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10430 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10431 (last == OpSIBLING(oa))) /* The bareword. */
10432 last->op_private &= ~OPpCONST_STRICT;
10438 Perl_ck_prototype(pTHX_ OP *o)
10440 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10441 if (!(o->op_flags & OPf_KIDS)) {
10443 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10449 Perl_ck_refassign(pTHX_ OP *o)
10451 OP * const right = cLISTOPo->op_first;
10452 OP * const left = OpSIBLING(right);
10453 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10456 PERL_ARGS_ASSERT_CK_REFASSIGN;
10458 assert (left->op_type == OP_SREFGEN);
10461 /* we use OPpPAD_STATE in refassign to mean either of those things,
10462 * and the code assumes the two flags occupy the same bit position
10463 * in the various ops below */
10464 assert(OPpPAD_STATE == OPpOUR_INTRO);
10466 switch (varop->op_type) {
10468 o->op_private |= OPpLVREF_AV;
10471 o->op_private |= OPpLVREF_HV;
10475 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10476 o->op_targ = varop->op_targ;
10477 varop->op_targ = 0;
10478 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10482 o->op_private |= OPpLVREF_AV;
10484 NOT_REACHED; /* NOTREACHED */
10486 o->op_private |= OPpLVREF_HV;
10490 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10491 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10493 /* Point varop to its GV kid, detached. */
10494 varop = op_sibling_splice(varop, NULL, -1, NULL);
10498 OP * const kidparent =
10499 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10500 OP * const kid = cUNOPx(kidparent)->op_first;
10501 o->op_private |= OPpLVREF_CV;
10502 if (kid->op_type == OP_GV) {
10504 goto detach_and_stack;
10506 if (kid->op_type != OP_PADCV) goto bad;
10507 o->op_targ = kid->op_targ;
10513 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10514 o->op_private |= OPpLVREF_ELEM;
10517 /* Detach varop. */
10518 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10522 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10523 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10528 if (!FEATURE_REFALIASING_IS_ENABLED)
10530 "Experimental aliasing via reference not enabled");
10531 Perl_ck_warner_d(aTHX_
10532 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10533 "Aliasing via reference is experimental");
10535 o->op_flags |= OPf_STACKED;
10536 op_sibling_splice(o, right, 1, varop);
10539 o->op_flags &=~ OPf_STACKED;
10540 op_sibling_splice(o, right, 1, NULL);
10547 Perl_ck_repeat(pTHX_ OP *o)
10549 PERL_ARGS_ASSERT_CK_REPEAT;
10551 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10553 o->op_private |= OPpREPEAT_DOLIST;
10554 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10555 kids = force_list(kids, 1); /* promote it to a list */
10556 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10564 Perl_ck_require(pTHX_ OP *o)
10568 PERL_ARGS_ASSERT_CK_REQUIRE;
10570 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10571 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10576 if (kid->op_type == OP_CONST) {
10577 SV * const sv = kid->op_sv;
10578 U32 const was_readonly = SvREADONLY(sv);
10579 if (kid->op_private & OPpCONST_BARE) {
10583 if (was_readonly) {
10584 SvREADONLY_off(sv);
10586 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10591 for (; s < end; s++) {
10592 if (*s == ':' && s[1] == ':') {
10594 Move(s+2, s+1, end - s - 1, char);
10598 SvEND_set(sv, end);
10599 sv_catpvs(sv, ".pm");
10600 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10601 hek = share_hek(SvPVX(sv),
10602 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10604 sv_sethek(sv, hek);
10606 SvFLAGS(sv) |= was_readonly;
10608 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10611 if (SvREFCNT(sv) > 1) {
10612 kid->op_sv = newSVpvn_share(
10613 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10614 SvREFCNT_dec_NN(sv);
10618 if (was_readonly) SvREADONLY_off(sv);
10619 PERL_HASH(hash, s, len);
10621 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10623 sv_sethek(sv, hek);
10625 SvFLAGS(sv) |= was_readonly;
10631 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10632 /* handle override, if any */
10633 && (gv = gv_override("require", 7))) {
10635 if (o->op_flags & OPf_KIDS) {
10636 kid = cUNOPo->op_first;
10637 op_sibling_splice(o, NULL, -1, NULL);
10640 kid = newDEFSVOP();
10643 newop = S_new_entersubop(aTHX_ gv, kid);
10651 Perl_ck_return(pTHX_ OP *o)
10655 PERL_ARGS_ASSERT_CK_RETURN;
10657 kid = OpSIBLING(cLISTOPo->op_first);
10658 if (CvLVALUE(PL_compcv)) {
10659 for (; kid; kid = OpSIBLING(kid))
10660 op_lvalue(kid, OP_LEAVESUBLV);
10667 Perl_ck_select(pTHX_ OP *o)
10672 PERL_ARGS_ASSERT_CK_SELECT;
10674 if (o->op_flags & OPf_KIDS) {
10675 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10676 if (kid && OpHAS_SIBLING(kid)) {
10677 OpTYPE_set(o, OP_SSELECT);
10679 return fold_constants(op_integerize(op_std_init(o)));
10683 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10684 if (kid && kid->op_type == OP_RV2GV)
10685 kid->op_private &= ~HINT_STRICT_REFS;
10690 Perl_ck_shift(pTHX_ OP *o)
10692 const I32 type = o->op_type;
10694 PERL_ARGS_ASSERT_CK_SHIFT;
10696 if (!(o->op_flags & OPf_KIDS)) {
10699 if (!CvUNIQUE(PL_compcv)) {
10700 o->op_flags |= OPf_SPECIAL;
10704 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10706 return newUNOP(type, 0, scalar(argop));
10708 return scalar(ck_fun(o));
10712 Perl_ck_sort(pTHX_ OP *o)
10716 HV * const hinthv =
10717 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10720 PERL_ARGS_ASSERT_CK_SORT;
10723 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10725 const I32 sorthints = (I32)SvIV(*svp);
10726 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10727 o->op_private |= OPpSORT_QSORT;
10728 if ((sorthints & HINT_SORT_STABLE) != 0)
10729 o->op_private |= OPpSORT_STABLE;
10733 if (o->op_flags & OPf_STACKED)
10735 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10737 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10738 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10740 /* if the first arg is a code block, process it and mark sort as
10742 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10744 if (kid->op_type == OP_LEAVE)
10745 op_null(kid); /* wipe out leave */
10746 /* Prevent execution from escaping out of the sort block. */
10749 /* provide scalar context for comparison function/block */
10750 kid = scalar(firstkid);
10751 kid->op_next = kid;
10752 o->op_flags |= OPf_SPECIAL;
10754 else if (kid->op_type == OP_CONST
10755 && kid->op_private & OPpCONST_BARE) {
10759 const char * const name = SvPV(kSVOP_sv, len);
10761 assert (len < 256);
10762 Copy(name, tmpbuf+1, len, char);
10763 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10764 if (off != NOT_IN_PAD) {
10765 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10767 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10768 sv_catpvs(fq, "::");
10769 sv_catsv(fq, kSVOP_sv);
10770 SvREFCNT_dec_NN(kSVOP_sv);
10774 OP * const padop = newOP(OP_PADCV, 0);
10775 padop->op_targ = off;
10776 /* replace the const op with the pad op */
10777 op_sibling_splice(firstkid, NULL, 1, padop);
10783 firstkid = OpSIBLING(firstkid);
10786 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10787 /* provide list context for arguments */
10790 op_lvalue(kid, OP_GREPSTART);
10796 /* for sort { X } ..., where X is one of
10797 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10798 * elide the second child of the sort (the one containing X),
10799 * and set these flags as appropriate
10803 * Also, check and warn on lexical $a, $b.
10807 S_simplify_sort(pTHX_ OP *o)
10809 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10813 const char *gvname;
10816 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10818 kid = kUNOP->op_first; /* get past null */
10819 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10820 && kid->op_type != OP_LEAVE)
10822 kid = kLISTOP->op_last; /* get past scope */
10823 switch(kid->op_type) {
10827 if (!have_scopeop) goto padkids;
10832 k = kid; /* remember this node*/
10833 if (kBINOP->op_first->op_type != OP_RV2SV
10834 || kBINOP->op_last ->op_type != OP_RV2SV)
10837 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10838 then used in a comparison. This catches most, but not
10839 all cases. For instance, it catches
10840 sort { my($a); $a <=> $b }
10842 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10843 (although why you'd do that is anyone's guess).
10847 if (!ckWARN(WARN_SYNTAX)) return;
10848 kid = kBINOP->op_first;
10850 if (kid->op_type == OP_PADSV) {
10851 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
10852 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
10853 && ( PadnamePV(name)[1] == 'a'
10854 || PadnamePV(name)[1] == 'b' ))
10855 /* diag_listed_as: "my %s" used in sort comparison */
10856 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10857 "\"%s %s\" used in sort comparison",
10858 PadnameIsSTATE(name)
10863 } while ((kid = OpSIBLING(kid)));
10866 kid = kBINOP->op_first; /* get past cmp */
10867 if (kUNOP->op_first->op_type != OP_GV)
10869 kid = kUNOP->op_first; /* get past rv2sv */
10871 if (GvSTASH(gv) != PL_curstash)
10873 gvname = GvNAME(gv);
10874 if (*gvname == 'a' && gvname[1] == '\0')
10876 else if (*gvname == 'b' && gvname[1] == '\0')
10881 kid = k; /* back to cmp */
10882 /* already checked above that it is rv2sv */
10883 kid = kBINOP->op_last; /* down to 2nd arg */
10884 if (kUNOP->op_first->op_type != OP_GV)
10886 kid = kUNOP->op_first; /* get past rv2sv */
10888 if (GvSTASH(gv) != PL_curstash)
10890 gvname = GvNAME(gv);
10892 ? !(*gvname == 'a' && gvname[1] == '\0')
10893 : !(*gvname == 'b' && gvname[1] == '\0'))
10895 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10897 o->op_private |= OPpSORT_DESCEND;
10898 if (k->op_type == OP_NCMP)
10899 o->op_private |= OPpSORT_NUMERIC;
10900 if (k->op_type == OP_I_NCMP)
10901 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10902 kid = OpSIBLING(cLISTOPo->op_first);
10903 /* cut out and delete old block (second sibling) */
10904 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10909 Perl_ck_split(pTHX_ OP *o)
10914 PERL_ARGS_ASSERT_CK_SPLIT;
10916 if (o->op_flags & OPf_STACKED)
10917 return no_fh_allowed(o);
10919 kid = cLISTOPo->op_first;
10920 if (kid->op_type != OP_NULL)
10921 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10922 /* delete leading NULL node, then add a CONST if no other nodes */
10923 op_sibling_splice(o, NULL, 1,
10924 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10926 kid = cLISTOPo->op_first;
10928 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10929 /* remove kid, and replace with new optree */
10930 op_sibling_splice(o, NULL, 1, NULL);
10931 /* OPf_SPECIAL is used to trigger split " " behavior */
10932 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
10933 op_sibling_splice(o, NULL, 0, kid);
10935 OpTYPE_set(kid, OP_PUSHRE);
10936 /* target implies @ary=..., so wipe it */
10939 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10940 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10941 "Use of /g modifier is meaningless in split");
10944 if (!OpHAS_SIBLING(kid))
10945 op_append_elem(OP_SPLIT, o, newDEFSVOP());
10947 kid = OpSIBLING(kid);
10951 if (!OpHAS_SIBLING(kid))
10953 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10954 o->op_private |= OPpSPLIT_IMPLIM;
10956 assert(OpHAS_SIBLING(kid));
10958 kid = OpSIBLING(kid);
10961 if (OpHAS_SIBLING(kid))
10962 return too_many_arguments_pv(o,OP_DESC(o), 0);
10968 Perl_ck_stringify(pTHX_ OP *o)
10970 OP * const kid = OpSIBLING(cUNOPo->op_first);
10971 PERL_ARGS_ASSERT_CK_STRINGIFY;
10972 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
10973 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
10974 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
10975 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
10977 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10985 Perl_ck_join(pTHX_ OP *o)
10987 OP * const kid = OpSIBLING(cLISTOPo->op_first);
10989 PERL_ARGS_ASSERT_CK_JOIN;
10991 if (kid && kid->op_type == OP_MATCH) {
10992 if (ckWARN(WARN_SYNTAX)) {
10993 const REGEXP *re = PM_GETRE(kPMOP);
10995 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10996 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10997 : newSVpvs_flags( "STRING", SVs_TEMP );
10998 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10999 "/%"SVf"/ should probably be written as \"%"SVf"\"",
11000 SVfARG(msg), SVfARG(msg));
11004 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11005 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11006 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11007 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11009 const OP * const bairn = OpSIBLING(kid); /* the list */
11010 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11011 && OP_GIMME(bairn,0) == G_SCALAR)
11013 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11014 op_sibling_splice(o, kid, 1, NULL));
11024 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11026 Examines an op, which is expected to identify a subroutine at runtime,
11027 and attempts to determine at compile time which subroutine it identifies.
11028 This is normally used during Perl compilation to determine whether
11029 a prototype can be applied to a function call. C<cvop> is the op
11030 being considered, normally an C<rv2cv> op. A pointer to the identified
11031 subroutine is returned, if it could be determined statically, and a null
11032 pointer is returned if it was not possible to determine statically.
11034 Currently, the subroutine can be identified statically if the RV that the
11035 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11036 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11037 suitable if the constant value must be an RV pointing to a CV. Details of
11038 this process may change in future versions of Perl. If the C<rv2cv> op
11039 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11040 the subroutine statically: this flag is used to suppress compile-time
11041 magic on a subroutine call, forcing it to use default runtime behaviour.
11043 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11044 of a GV reference is modified. If a GV was examined and its CV slot was
11045 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11046 If the op is not optimised away, and the CV slot is later populated with
11047 a subroutine having a prototype, that flag eventually triggers the warning
11048 "called too early to check prototype".
11050 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11051 of returning a pointer to the subroutine it returns a pointer to the
11052 GV giving the most appropriate name for the subroutine in this context.
11053 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11054 (C<CvANON>) subroutine that is referenced through a GV it will be the
11055 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11056 A null pointer is returned as usual if there is no statically-determinable
11062 /* shared by toke.c:yylex */
11064 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11066 PADNAME *name = PAD_COMPNAME(off);
11067 CV *compcv = PL_compcv;
11068 while (PadnameOUTER(name)) {
11069 assert(PARENT_PAD_INDEX(name));
11070 compcv = CvOUTSIDE(compcv);
11071 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11072 [off = PARENT_PAD_INDEX(name)];
11074 assert(!PadnameIsOUR(name));
11075 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11076 return PadnamePROTOCV(name);
11078 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11082 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11087 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11088 if (flags & ~RV2CVOPCV_FLAG_MASK)
11089 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11090 if (cvop->op_type != OP_RV2CV)
11092 if (cvop->op_private & OPpENTERSUB_AMPER)
11094 if (!(cvop->op_flags & OPf_KIDS))
11096 rvop = cUNOPx(cvop)->op_first;
11097 switch (rvop->op_type) {
11099 gv = cGVOPx_gv(rvop);
11101 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11102 cv = MUTABLE_CV(SvRV(gv));
11106 if (flags & RV2CVOPCV_RETURN_STUB)
11112 if (flags & RV2CVOPCV_MARK_EARLY)
11113 rvop->op_private |= OPpEARLY_CV;
11118 SV *rv = cSVOPx_sv(rvop);
11121 cv = (CV*)SvRV(rv);
11125 cv = find_lexical_cv(rvop->op_targ);
11130 } NOT_REACHED; /* NOTREACHED */
11132 if (SvTYPE((SV*)cv) != SVt_PVCV)
11134 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11135 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11136 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11145 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11147 Performs the default fixup of the arguments part of an C<entersub>
11148 op tree. This consists of applying list context to each of the
11149 argument ops. This is the standard treatment used on a call marked
11150 with C<&>, or a method call, or a call through a subroutine reference,
11151 or any other call where the callee can't be identified at compile time,
11152 or a call where the callee has no prototype.
11158 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11162 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11164 aop = cUNOPx(entersubop)->op_first;
11165 if (!OpHAS_SIBLING(aop))
11166 aop = cUNOPx(aop)->op_first;
11167 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11168 /* skip the extra attributes->import() call implicitly added in
11169 * something like foo(my $x : bar)
11171 if ( aop->op_type == OP_ENTERSUB
11172 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11176 op_lvalue(aop, OP_ENTERSUB);
11182 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11184 Performs the fixup of the arguments part of an C<entersub> op tree
11185 based on a subroutine prototype. This makes various modifications to
11186 the argument ops, from applying context up to inserting C<refgen> ops,
11187 and checking the number and syntactic types of arguments, as directed by
11188 the prototype. This is the standard treatment used on a subroutine call,
11189 not marked with C<&>, where the callee can be identified at compile time
11190 and has a prototype.
11192 C<protosv> supplies the subroutine prototype to be applied to the call.
11193 It may be a normal defined scalar, of which the string value will be used.
11194 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11195 that has been cast to C<SV*>) which has a prototype. The prototype
11196 supplied, in whichever form, does not need to match the actual callee
11197 referenced by the op tree.
11199 If the argument ops disagree with the prototype, for example by having
11200 an unacceptable number of arguments, a valid op tree is returned anyway.
11201 The error is reflected in the parser state, normally resulting in a single
11202 exception at the top level of parsing which covers all the compilation
11203 errors that occurred. In the error message, the callee is referred to
11204 by the name defined by the C<namegv> parameter.
11210 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11213 const char *proto, *proto_end;
11214 OP *aop, *prev, *cvop, *parent;
11217 I32 contextclass = 0;
11218 const char *e = NULL;
11219 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11220 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11221 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11222 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11223 if (SvTYPE(protosv) == SVt_PVCV)
11224 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11225 else proto = SvPV(protosv, proto_len);
11226 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11227 proto_end = proto + proto_len;
11228 parent = entersubop;
11229 aop = cUNOPx(entersubop)->op_first;
11230 if (!OpHAS_SIBLING(aop)) {
11232 aop = cUNOPx(aop)->op_first;
11235 aop = OpSIBLING(aop);
11236 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11237 while (aop != cvop) {
11240 if (proto >= proto_end)
11242 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11243 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11244 SVfARG(namesv)), SvUTF8(namesv));
11254 /* _ must be at the end */
11255 if (proto[1] && !strchr(";@%", proto[1]))
11271 if ( o3->op_type != OP_UNDEF
11272 && (o3->op_type != OP_SREFGEN
11273 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11275 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11277 bad_type_gv(arg, namegv, o3,
11278 arg == 1 ? "block or sub {}" : "sub {}");
11281 /* '*' allows any scalar type, including bareword */
11284 if (o3->op_type == OP_RV2GV)
11285 goto wrapref; /* autoconvert GLOB -> GLOBref */
11286 else if (o3->op_type == OP_CONST)
11287 o3->op_private &= ~OPpCONST_STRICT;
11293 if (o3->op_type == OP_RV2AV ||
11294 o3->op_type == OP_PADAV ||
11295 o3->op_type == OP_RV2HV ||
11296 o3->op_type == OP_PADHV
11302 case '[': case ']':
11309 switch (*proto++) {
11311 if (contextclass++ == 0) {
11312 e = strchr(proto, ']');
11313 if (!e || e == proto)
11321 if (contextclass) {
11322 const char *p = proto;
11323 const char *const end = proto;
11325 while (*--p != '[')
11326 /* \[$] accepts any scalar lvalue */
11328 && Perl_op_lvalue_flags(aTHX_
11330 OP_READ, /* not entersub */
11333 bad_type_gv(arg, namegv, o3,
11334 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11339 if (o3->op_type == OP_RV2GV)
11342 bad_type_gv(arg, namegv, o3, "symbol");
11345 if (o3->op_type == OP_ENTERSUB
11346 && !(o3->op_flags & OPf_STACKED))
11349 bad_type_gv(arg, namegv, o3, "subroutine");
11352 if (o3->op_type == OP_RV2SV ||
11353 o3->op_type == OP_PADSV ||
11354 o3->op_type == OP_HELEM ||
11355 o3->op_type == OP_AELEM)
11357 if (!contextclass) {
11358 /* \$ accepts any scalar lvalue */
11359 if (Perl_op_lvalue_flags(aTHX_
11361 OP_READ, /* not entersub */
11364 bad_type_gv(arg, namegv, o3, "scalar");
11368 if (o3->op_type == OP_RV2AV ||
11369 o3->op_type == OP_PADAV)
11371 o3->op_flags &=~ OPf_PARENS;
11375 bad_type_gv(arg, namegv, o3, "array");
11378 if (o3->op_type == OP_RV2HV ||
11379 o3->op_type == OP_PADHV)
11381 o3->op_flags &=~ OPf_PARENS;
11385 bad_type_gv(arg, namegv, o3, "hash");
11388 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11390 if (contextclass && e) {
11395 default: goto oops;
11405 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11406 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11411 op_lvalue(aop, OP_ENTERSUB);
11413 aop = OpSIBLING(aop);
11415 if (aop == cvop && *proto == '_') {
11416 /* generate an access to $_ */
11417 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11419 if (!optional && proto_end > proto &&
11420 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11422 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11423 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11424 SVfARG(namesv)), SvUTF8(namesv));
11430 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11432 Performs the fixup of the arguments part of an C<entersub> op tree either
11433 based on a subroutine prototype or using default list-context processing.
11434 This is the standard treatment used on a subroutine call, not marked
11435 with C<&>, where the callee can be identified at compile time.
11437 C<protosv> supplies the subroutine prototype to be applied to the call,
11438 or indicates that there is no prototype. It may be a normal scalar,
11439 in which case if it is defined then the string value will be used
11440 as a prototype, and if it is undefined then there is no prototype.
11441 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11442 that has been cast to C<SV*>), of which the prototype will be used if it
11443 has one. The prototype (or lack thereof) supplied, in whichever form,
11444 does not need to match the actual callee referenced by the op tree.
11446 If the argument ops disagree with the prototype, for example by having
11447 an unacceptable number of arguments, a valid op tree is returned anyway.
11448 The error is reflected in the parser state, normally resulting in a single
11449 exception at the top level of parsing which covers all the compilation
11450 errors that occurred. In the error message, the callee is referred to
11451 by the name defined by the C<namegv> parameter.
11457 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11458 GV *namegv, SV *protosv)
11460 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11461 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11462 return ck_entersub_args_proto(entersubop, namegv, protosv);
11464 return ck_entersub_args_list(entersubop);
11468 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11470 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11471 OP *aop = cUNOPx(entersubop)->op_first;
11473 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11477 if (!OpHAS_SIBLING(aop))
11478 aop = cUNOPx(aop)->op_first;
11479 aop = OpSIBLING(aop);
11480 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11482 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11484 op_free(entersubop);
11485 switch(GvNAME(namegv)[2]) {
11486 case 'F': return newSVOP(OP_CONST, 0,
11487 newSVpv(CopFILE(PL_curcop),0));
11488 case 'L': return newSVOP(
11490 Perl_newSVpvf(aTHX_
11491 "%"IVdf, (IV)CopLINE(PL_curcop)
11494 case 'P': return newSVOP(OP_CONST, 0,
11496 ? newSVhek(HvNAME_HEK(PL_curstash))
11501 NOT_REACHED; /* NOTREACHED */
11504 OP *prev, *cvop, *first, *parent;
11507 parent = entersubop;
11508 if (!OpHAS_SIBLING(aop)) {
11510 aop = cUNOPx(aop)->op_first;
11513 first = prev = aop;
11514 aop = OpSIBLING(aop);
11515 /* find last sibling */
11517 OpHAS_SIBLING(cvop);
11518 prev = cvop, cvop = OpSIBLING(cvop))
11520 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11521 /* Usually, OPf_SPECIAL on an op with no args means that it had
11522 * parens, but these have their own meaning for that flag: */
11523 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11524 && opnum != OP_DELETE && opnum != OP_EXISTS)
11525 flags |= OPf_SPECIAL;
11526 /* excise cvop from end of sibling chain */
11527 op_sibling_splice(parent, prev, 1, NULL);
11529 if (aop == cvop) aop = NULL;
11531 /* detach remaining siblings from the first sibling, then
11532 * dispose of original optree */
11535 op_sibling_splice(parent, first, -1, NULL);
11536 op_free(entersubop);
11538 if (opnum == OP_ENTEREVAL
11539 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11540 flags |= OPpEVAL_BYTES <<8;
11542 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11544 case OA_BASEOP_OR_UNOP:
11545 case OA_FILESTATOP:
11546 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11549 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11552 return opnum == OP_RUNCV
11553 ? newPVOP(OP_RUNCV,0,NULL)
11556 return op_convert_list(opnum,0,aop);
11559 NOT_REACHED; /* NOTREACHED */
11564 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11566 Retrieves the function that will be used to fix up a call to C<cv>.
11567 Specifically, the function is applied to an C<entersub> op tree for a
11568 subroutine call, not marked with C<&>, where the callee can be identified
11569 at compile time as C<cv>.
11571 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11572 argument for it is returned in C<*ckobj_p>. The function is intended
11573 to be called in this manner:
11575 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11577 In this call, C<entersubop> is a pointer to the C<entersub> op,
11578 which may be replaced by the check function, and C<namegv> is a GV
11579 supplying the name that should be used by the check function to refer
11580 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11581 It is permitted to apply the check function in non-standard situations,
11582 such as to a call to a different subroutine or to a method call.
11584 By default, the function is
11585 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11586 and the SV parameter is C<cv> itself. This implements standard
11587 prototype processing. It can be changed, for a particular subroutine,
11588 by L</cv_set_call_checker>.
11594 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11598 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11600 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11601 *ckobj_p = callmg->mg_obj;
11602 if (flagsp) *flagsp = callmg->mg_flags;
11604 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11605 *ckobj_p = (SV*)cv;
11606 if (flagsp) *flagsp = 0;
11611 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11613 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11614 PERL_UNUSED_CONTEXT;
11615 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11619 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11621 Sets the function that will be used to fix up a call to C<cv>.
11622 Specifically, the function is applied to an C<entersub> op tree for a
11623 subroutine call, not marked with C<&>, where the callee can be identified
11624 at compile time as C<cv>.
11626 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11627 for it is supplied in C<ckobj>. The function should be defined like this:
11629 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11631 It is intended to be called in this manner:
11633 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11635 In this call, C<entersubop> is a pointer to the C<entersub> op,
11636 which may be replaced by the check function, and C<namegv> supplies
11637 the name that should be used by the check function to refer
11638 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11639 It is permitted to apply the check function in non-standard situations,
11640 such as to a call to a different subroutine or to a method call.
11642 C<namegv> may not actually be a GV. For efficiency, perl may pass a
11643 CV or other SV instead. Whatever is passed can be used as the first
11644 argument to L</cv_name>. You can force perl to pass a GV by including
11645 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11647 The current setting for a particular CV can be retrieved by
11648 L</cv_get_call_checker>.
11650 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11652 The original form of L</cv_set_call_checker_flags>, which passes it the
11653 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11659 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11661 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11662 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11666 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11667 SV *ckobj, U32 flags)
11669 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11670 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11671 if (SvMAGICAL((SV*)cv))
11672 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11675 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11676 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11678 if (callmg->mg_flags & MGf_REFCOUNTED) {
11679 SvREFCNT_dec(callmg->mg_obj);
11680 callmg->mg_flags &= ~MGf_REFCOUNTED;
11682 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11683 callmg->mg_obj = ckobj;
11684 if (ckobj != (SV*)cv) {
11685 SvREFCNT_inc_simple_void_NN(ckobj);
11686 callmg->mg_flags |= MGf_REFCOUNTED;
11688 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11689 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11694 S_entersub_alloc_targ(pTHX_ OP * const o)
11696 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11697 o->op_private |= OPpENTERSUB_HASTARG;
11701 Perl_ck_subr(pTHX_ OP *o)
11706 SV **const_class = NULL;
11708 PERL_ARGS_ASSERT_CK_SUBR;
11710 aop = cUNOPx(o)->op_first;
11711 if (!OpHAS_SIBLING(aop))
11712 aop = cUNOPx(aop)->op_first;
11713 aop = OpSIBLING(aop);
11714 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11715 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11716 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11718 o->op_private &= ~1;
11719 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11720 if (PERLDB_SUB && PL_curstash != PL_debstash)
11721 o->op_private |= OPpENTERSUB_DB;
11722 switch (cvop->op_type) {
11724 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11728 case OP_METHOD_NAMED:
11729 case OP_METHOD_SUPER:
11730 case OP_METHOD_REDIR:
11731 case OP_METHOD_REDIR_SUPER:
11732 if (aop->op_type == OP_CONST) {
11733 aop->op_private &= ~OPpCONST_STRICT;
11734 const_class = &cSVOPx(aop)->op_sv;
11736 else if (aop->op_type == OP_LIST) {
11737 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11738 if (sib && sib->op_type == OP_CONST) {
11739 sib->op_private &= ~OPpCONST_STRICT;
11740 const_class = &cSVOPx(sib)->op_sv;
11743 /* make class name a shared cow string to speedup method calls */
11744 /* constant string might be replaced with object, f.e. bigint */
11745 if (const_class && SvPOK(*const_class)) {
11747 const char* str = SvPV(*const_class, len);
11749 SV* const shared = newSVpvn_share(
11750 str, SvUTF8(*const_class)
11751 ? -(SSize_t)len : (SSize_t)len,
11754 if (SvREADONLY(*const_class))
11755 SvREADONLY_on(shared);
11756 SvREFCNT_dec(*const_class);
11757 *const_class = shared;
11764 S_entersub_alloc_targ(aTHX_ o);
11765 return ck_entersub_args_list(o);
11767 Perl_call_checker ckfun;
11770 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11771 if (CvISXSUB(cv) || !CvROOT(cv))
11772 S_entersub_alloc_targ(aTHX_ o);
11774 /* The original call checker API guarantees that a GV will be
11775 be provided with the right name. So, if the old API was
11776 used (or the REQUIRE_GV flag was passed), we have to reify
11777 the CV’s GV, unless this is an anonymous sub. This is not
11778 ideal for lexical subs, as its stringification will include
11779 the package. But it is the best we can do. */
11780 if (flags & MGf_REQUIRE_GV) {
11781 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11784 else namegv = MUTABLE_GV(cv);
11785 /* After a syntax error in a lexical sub, the cv that
11786 rv2cv_op_cv returns may be a nameless stub. */
11787 if (!namegv) return ck_entersub_args_list(o);
11790 return ckfun(aTHX_ o, namegv, ckobj);
11795 Perl_ck_svconst(pTHX_ OP *o)
11797 SV * const sv = cSVOPo->op_sv;
11798 PERL_ARGS_ASSERT_CK_SVCONST;
11799 PERL_UNUSED_CONTEXT;
11800 #ifdef PERL_COPY_ON_WRITE
11801 /* Since the read-only flag may be used to protect a string buffer, we
11802 cannot do copy-on-write with existing read-only scalars that are not
11803 already copy-on-write scalars. To allow $_ = "hello" to do COW with
11804 that constant, mark the constant as COWable here, if it is not
11805 already read-only. */
11806 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11809 # ifdef PERL_DEBUG_READONLY_COW
11819 Perl_ck_trunc(pTHX_ OP *o)
11821 PERL_ARGS_ASSERT_CK_TRUNC;
11823 if (o->op_flags & OPf_KIDS) {
11824 SVOP *kid = (SVOP*)cUNOPo->op_first;
11826 if (kid->op_type == OP_NULL)
11827 kid = (SVOP*)OpSIBLING(kid);
11828 if (kid && kid->op_type == OP_CONST &&
11829 (kid->op_private & OPpCONST_BARE) &&
11832 o->op_flags |= OPf_SPECIAL;
11833 kid->op_private &= ~OPpCONST_STRICT;
11840 Perl_ck_substr(pTHX_ OP *o)
11842 PERL_ARGS_ASSERT_CK_SUBSTR;
11845 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11846 OP *kid = cLISTOPo->op_first;
11848 if (kid->op_type == OP_NULL)
11849 kid = OpSIBLING(kid);
11851 kid->op_flags |= OPf_MOD;
11858 Perl_ck_tell(pTHX_ OP *o)
11860 PERL_ARGS_ASSERT_CK_TELL;
11862 if (o->op_flags & OPf_KIDS) {
11863 OP *kid = cLISTOPo->op_first;
11864 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
11865 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11871 Perl_ck_each(pTHX_ OP *o)
11874 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11875 const unsigned orig_type = o->op_type;
11877 PERL_ARGS_ASSERT_CK_EACH;
11880 switch (kid->op_type) {
11886 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
11887 : orig_type == OP_KEYS ? OP_AKEYS
11891 if (kid->op_private == OPpCONST_BARE
11892 || !SvROK(cSVOPx_sv(kid))
11893 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11894 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
11896 /* we let ck_fun handle it */
11899 Perl_croak_nocontext(
11900 "Experimental %s on scalar is now forbidden",
11901 PL_op_desc[orig_type]);
11909 Perl_ck_length(pTHX_ OP *o)
11911 PERL_ARGS_ASSERT_CK_LENGTH;
11915 if (ckWARN(WARN_SYNTAX)) {
11916 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11920 const bool hash = kid->op_type == OP_PADHV
11921 || kid->op_type == OP_RV2HV;
11922 switch (kid->op_type) {
11927 name = S_op_varname(aTHX_ kid);
11933 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11934 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11936 SVfARG(name), hash ? "keys " : "", SVfARG(name)
11939 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11940 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11941 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11943 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11944 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11945 "length() used on @array (did you mean \"scalar(@array)\"?)");
11955 ---------------------------------------------------------
11957 Common vars in list assignment
11959 There now follows some enums and static functions for detecting
11960 common variables in list assignments. Here is a little essay I wrote
11961 for myself when trying to get my head around this. DAPM.
11965 First some random observations:
11967 * If a lexical var is an alias of something else, e.g.
11968 for my $x ($lex, $pkg, $a[0]) {...}
11969 then the act of aliasing will increase the reference count of the SV
11971 * If a package var is an alias of something else, it may still have a
11972 reference count of 1, depending on how the alias was created, e.g.
11973 in *a = *b, $a may have a refcount of 1 since the GP is shared
11974 with a single GvSV pointer to the SV. So If it's an alias of another
11975 package var, then RC may be 1; if it's an alias of another scalar, e.g.
11976 a lexical var or an array element, then it will have RC > 1.
11978 * There are many ways to create a package alias; ultimately, XS code
11979 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
11980 run-time tracing mechanisms are unlikely to be able to catch all cases.
11982 * When the LHS is all my declarations, the same vars can't appear directly
11983 on the RHS, but they can indirectly via closures, aliasing and lvalue
11984 subs. But those techniques all involve an increase in the lexical
11985 scalar's ref count.
11987 * When the LHS is all lexical vars (but not necessarily my declarations),
11988 it is possible for the same lexicals to appear directly on the RHS, and
11989 without an increased ref count, since the stack isn't refcounted.
11990 This case can be detected at compile time by scanning for common lex
11991 vars with PL_generation.
11993 * lvalue subs defeat common var detection, but they do at least
11994 return vars with a temporary ref count increment. Also, you can't
11995 tell at compile time whether a sub call is lvalue.
12000 A: There are a few circumstances where there definitely can't be any
12003 LHS empty: () = (...);
12004 RHS empty: (....) = ();
12005 RHS contains only constants or other 'can't possibly be shared'
12006 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
12007 i.e. they only contain ops not marked as dangerous, whose children
12008 are also not dangerous;
12010 LHS contains a single scalar element: e.g. ($x) = (....); because
12011 after $x has been modified, it won't be used again on the RHS;
12012 RHS contains a single element with no aggregate on LHS: e.g.
12013 ($a,$b,$c) = ($x); again, once $a has been modified, its value
12014 won't be used again.
12016 B: If LHS are all 'my' lexical var declarations (or safe ops, which
12019 my ($a, $b, @c) = ...;
12021 Due to closure and goto tricks, these vars may already have content.
12022 For the same reason, an element on the RHS may be a lexical or package
12023 alias of one of the vars on the left, or share common elements, for
12026 my ($x,$y) = f(); # $x and $y on both sides
12027 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12032 my @a = @$ra; # elements of @a on both sides
12033 sub f { @a = 1..4; \@a }
12036 First, just consider scalar vars on LHS:
12038 RHS is safe only if (A), or in addition,
12039 * contains only lexical *scalar* vars, where neither side's
12040 lexicals have been flagged as aliases
12042 If RHS is not safe, then it's always legal to check LHS vars for
12043 RC==1, since the only RHS aliases will always be associated
12046 Note that in particular, RHS is not safe if:
12048 * it contains package scalar vars; e.g.:
12051 my ($x, $y) = (2, $x_alias);
12052 sub f { $x = 1; *x_alias = \$x; }
12054 * It contains other general elements, such as flattened or
12055 * spliced or single array or hash elements, e.g.
12058 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12062 use feature 'refaliasing';
12063 \($a[0], $a[1]) = \($y,$x);
12066 It doesn't matter if the array/hash is lexical or package.
12068 * it contains a function call that happens to be an lvalue
12069 sub which returns one or more of the above, e.g.
12080 (so a sub call on the RHS should be treated the same
12081 as having a package var on the RHS).
12083 * any other "dangerous" thing, such an op or built-in that
12084 returns one of the above, e.g. pp_preinc
12087 If RHS is not safe, what we can do however is at compile time flag
12088 that the LHS are all my declarations, and at run time check whether
12089 all the LHS have RC == 1, and if so skip the full scan.
12091 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12093 Here the issue is whether there can be elements of @a on the RHS
12094 which will get prematurely freed when @a is cleared prior to
12095 assignment. This is only a problem if the aliasing mechanism
12096 is one which doesn't increase the refcount - only if RC == 1
12097 will the RHS element be prematurely freed.
12099 Because the array/hash is being INTROed, it or its elements
12100 can't directly appear on the RHS:
12102 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12104 but can indirectly, e.g.:
12108 sub f { @a = 1..3; \@a }
12110 So if the RHS isn't safe as defined by (A), we must always
12111 mortalise and bump the ref count of any remaining RHS elements
12112 when assigning to a non-empty LHS aggregate.
12114 Lexical scalars on the RHS aren't safe if they've been involved in
12117 use feature 'refaliasing';
12120 \(my $lex) = \$pkg;
12121 my @a = ($lex,3); # equivalent to ($a[0],3)
12128 Similarly with lexical arrays and hashes on the RHS:
12142 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12143 my $a; ($a, my $b) = (....);
12145 The difference between (B) and (C) is that it is now physically
12146 possible for the LHS vars to appear on the RHS too, where they
12147 are not reference counted; but in this case, the compile-time
12148 PL_generation sweep will detect such common vars.
12150 So the rules for (C) differ from (B) in that if common vars are
12151 detected, the runtime "test RC==1" optimisation can no longer be used,
12152 and a full mark and sweep is required
12154 D: As (C), but in addition the LHS may contain package vars.
12156 Since package vars can be aliased without a corresponding refcount
12157 increase, all bets are off. It's only safe if (A). E.g.
12159 my ($x, $y) = (1,2);
12161 for $x_alias ($x) {
12162 ($x_alias, $y) = (3, $x); # whoops
12165 Ditto for LHS aggregate package vars.
12167 E: Any other dangerous ops on LHS, e.g.
12168 (f(), $a[0], @$r) = (...);
12170 this is similar to (E) in that all bets are off. In addition, it's
12171 impossible to determine at compile time whether the LHS
12172 contains a scalar or an aggregate, e.g.
12174 sub f : lvalue { @a }
12177 * ---------------------------------------------------------
12181 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12182 * that at least one of the things flagged was seen.
12186 AAS_MY_SCALAR = 0x001, /* my $scalar */
12187 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
12188 AAS_LEX_SCALAR = 0x004, /* $lexical */
12189 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
12190 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12191 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
12192 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
12193 AAS_DANGEROUS = 0x080, /* an op (other than the above)
12194 that's flagged OA_DANGEROUS */
12195 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
12196 not in any of the categories above */
12197 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
12202 /* helper function for S_aassign_scan().
12203 * check a PAD-related op for commonality and/or set its generation number.
12204 * Returns a boolean indicating whether its shared */
12207 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12209 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12210 /* lexical used in aliasing */
12214 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12216 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12223 Helper function for OPpASSIGN_COMMON* detection in rpeep().
12224 It scans the left or right hand subtree of the aassign op, and returns a
12225 set of flags indicating what sorts of things it found there.
12226 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12227 set PL_generation on lexical vars; if the latter, we see if
12228 PL_generation matches.
12229 'top' indicates whether we're recursing or at the top level.
12230 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12231 This fn will increment it by the number seen. It's not intended to
12232 be an accurate count (especially as many ops can push a variable
12233 number of SVs onto the stack); rather it's used as to test whether there
12234 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12238 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12241 bool kid_top = FALSE;
12243 /* first, look for a solitary @_ on the RHS */
12246 && (o->op_flags & OPf_KIDS)
12247 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12249 OP *kid = cUNOPo->op_first;
12250 if ( ( kid->op_type == OP_PUSHMARK
12251 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12252 && ((kid = OpSIBLING(kid)))
12253 && !OpHAS_SIBLING(kid)
12254 && kid->op_type == OP_RV2AV
12255 && !(kid->op_flags & OPf_REF)
12256 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12257 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12258 && ((kid = cUNOPx(kid)->op_first))
12259 && kid->op_type == OP_GV
12260 && cGVOPx_gv(kid) == PL_defgv
12262 flags |= AAS_DEFAV;
12265 switch (o->op_type) {
12268 return AAS_PKG_SCALAR;
12273 if (top && (o->op_flags & OPf_REF))
12274 return (o->op_private & OPpLVAL_INTRO)
12275 ? AAS_MY_AGG : AAS_LEX_AGG;
12276 return AAS_DANGEROUS;
12280 int comm = S_aassign_padcheck(aTHX_ o, rhs)
12281 ? AAS_LEX_SCALAR_COMM : 0;
12283 return (o->op_private & OPpLVAL_INTRO)
12284 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12290 if (cUNOPx(o)->op_first->op_type != OP_GV)
12291 return AAS_DANGEROUS; /* @{expr}, %{expr} */
12293 if (top && (o->op_flags & OPf_REF))
12294 return AAS_PKG_AGG;
12295 return AAS_DANGEROUS;
12299 if (cUNOPx(o)->op_first->op_type != OP_GV) {
12301 return AAS_DANGEROUS; /* ${expr} */
12303 return AAS_PKG_SCALAR; /* $pkg */
12306 if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
12307 /* "@foo = split... " optimises away the aassign and stores its
12308 * destination array in the OP_PUSHRE that precedes it.
12309 * A flattened array is always dangerous.
12312 return AAS_DANGEROUS;
12317 /* undef counts as a scalar on the RHS:
12318 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
12319 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
12323 flags = AAS_SAFE_SCALAR;
12328 /* these are all no-ops; they don't push a potentially common SV
12329 * onto the stack, so they are neither AAS_DANGEROUS nor
12330 * AAS_SAFE_SCALAR */
12333 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12338 /* these do nothing but may have children; but their children
12339 * should also be treated as top-level */
12344 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12346 flags = AAS_DANGEROUS;
12350 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
12351 && (o->op_private & OPpTARGET_MY))
12354 return S_aassign_padcheck(aTHX_ o, rhs)
12355 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12358 /* if its an unrecognised, non-dangerous op, assume that it
12359 * it the cause of at least one safe scalar */
12361 flags = AAS_SAFE_SCALAR;
12365 if (o->op_flags & OPf_KIDS) {
12367 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12368 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12374 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12375 and modify the optree to make them work inplace */
12378 S_inplace_aassign(pTHX_ OP *o) {
12380 OP *modop, *modop_pushmark;
12382 OP *oleft, *oleft_pushmark;
12384 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12386 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12388 assert(cUNOPo->op_first->op_type == OP_NULL);
12389 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12390 assert(modop_pushmark->op_type == OP_PUSHMARK);
12391 modop = OpSIBLING(modop_pushmark);
12393 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12396 /* no other operation except sort/reverse */
12397 if (OpHAS_SIBLING(modop))
12400 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12401 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12403 if (modop->op_flags & OPf_STACKED) {
12404 /* skip sort subroutine/block */
12405 assert(oright->op_type == OP_NULL);
12406 oright = OpSIBLING(oright);
12409 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12410 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12411 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12412 oleft = OpSIBLING(oleft_pushmark);
12414 /* Check the lhs is an array */
12416 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12417 || OpHAS_SIBLING(oleft)
12418 || (oleft->op_private & OPpLVAL_INTRO)
12422 /* Only one thing on the rhs */
12423 if (OpHAS_SIBLING(oright))
12426 /* check the array is the same on both sides */
12427 if (oleft->op_type == OP_RV2AV) {
12428 if (oright->op_type != OP_RV2AV
12429 || !cUNOPx(oright)->op_first
12430 || cUNOPx(oright)->op_first->op_type != OP_GV
12431 || cUNOPx(oleft )->op_first->op_type != OP_GV
12432 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12433 cGVOPx_gv(cUNOPx(oright)->op_first)
12437 else if (oright->op_type != OP_PADAV
12438 || oright->op_targ != oleft->op_targ
12442 /* This actually is an inplace assignment */
12444 modop->op_private |= OPpSORT_INPLACE;
12446 /* transfer MODishness etc from LHS arg to RHS arg */
12447 oright->op_flags = oleft->op_flags;
12449 /* remove the aassign op and the lhs */
12451 op_null(oleft_pushmark);
12452 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12453 op_null(cUNOPx(oleft)->op_first);
12459 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12460 * that potentially represent a series of one or more aggregate derefs
12461 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12462 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12463 * additional ops left in too).
12465 * The caller will have already verified that the first few ops in the
12466 * chain following 'start' indicate a multideref candidate, and will have
12467 * set 'orig_o' to the point further on in the chain where the first index
12468 * expression (if any) begins. 'orig_action' specifies what type of
12469 * beginning has already been determined by the ops between start..orig_o
12470 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12472 * 'hints' contains any hints flags that need adding (currently just
12473 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12477 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12481 UNOP_AUX_item *arg_buf = NULL;
12482 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12483 int index_skip = -1; /* don't output index arg on this action */
12485 /* similar to regex compiling, do two passes; the first pass
12486 * determines whether the op chain is convertible and calculates the
12487 * buffer size; the second pass populates the buffer and makes any
12488 * changes necessary to ops (such as moving consts to the pad on
12489 * threaded builds).
12491 * NB: for things like Coverity, note that both passes take the same
12492 * path through the logic tree (except for 'if (pass)' bits), since
12493 * both passes are following the same op_next chain; and in
12494 * particular, if it would return early on the second pass, it would
12495 * already have returned early on the first pass.
12497 for (pass = 0; pass < 2; pass++) {
12499 UV action = orig_action;
12500 OP *first_elem_op = NULL; /* first seen aelem/helem */
12501 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12502 int action_count = 0; /* number of actions seen so far */
12503 int action_ix = 0; /* action_count % (actions per IV) */
12504 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12505 bool is_last = FALSE; /* no more derefs to follow */
12506 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12507 UNOP_AUX_item *arg = arg_buf;
12508 UNOP_AUX_item *action_ptr = arg_buf;
12511 action_ptr->uv = 0;
12515 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12516 case MDEREF_HV_gvhv_helem:
12517 next_is_hash = TRUE;
12519 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12520 case MDEREF_AV_gvav_aelem:
12522 #ifdef USE_ITHREADS
12523 arg->pad_offset = cPADOPx(start)->op_padix;
12524 /* stop it being swiped when nulled */
12525 cPADOPx(start)->op_padix = 0;
12527 arg->sv = cSVOPx(start)->op_sv;
12528 cSVOPx(start)->op_sv = NULL;
12534 case MDEREF_HV_padhv_helem:
12535 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12536 next_is_hash = TRUE;
12538 case MDEREF_AV_padav_aelem:
12539 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12541 arg->pad_offset = start->op_targ;
12542 /* we skip setting op_targ = 0 for now, since the intact
12543 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12544 reset_start_targ = TRUE;
12549 case MDEREF_HV_pop_rv2hv_helem:
12550 next_is_hash = TRUE;
12552 case MDEREF_AV_pop_rv2av_aelem:
12556 NOT_REACHED; /* NOTREACHED */
12561 /* look for another (rv2av/hv; get index;
12562 * aelem/helem/exists/delele) sequence */
12567 UV index_type = MDEREF_INDEX_none;
12569 if (action_count) {
12570 /* if this is not the first lookup, consume the rv2av/hv */
12572 /* for N levels of aggregate lookup, we normally expect
12573 * that the first N-1 [ah]elem ops will be flagged as
12574 * /DEREF (so they autovivifiy if necessary), and the last
12575 * lookup op not to be.
12576 * For other things (like @{$h{k1}{k2}}) extra scope or
12577 * leave ops can appear, so abandon the effort in that
12579 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12582 /* rv2av or rv2hv sKR/1 */
12584 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12585 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12586 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12589 /* at this point, we wouldn't expect any of these
12590 * possible private flags:
12591 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12592 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12594 ASSUME(!(o->op_private &
12595 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12597 hints = (o->op_private & OPpHINT_STRICT_REFS);
12599 /* make sure the type of the previous /DEREF matches the
12600 * type of the next lookup */
12601 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12604 action = next_is_hash
12605 ? MDEREF_HV_vivify_rv2hv_helem
12606 : MDEREF_AV_vivify_rv2av_aelem;
12610 /* if this is the second pass, and we're at the depth where
12611 * previously we encountered a non-simple index expression,
12612 * stop processing the index at this point */
12613 if (action_count != index_skip) {
12615 /* look for one or more simple ops that return an array
12616 * index or hash key */
12618 switch (o->op_type) {
12620 /* it may be a lexical var index */
12621 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12622 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12623 ASSUME(!(o->op_private &
12624 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12626 if ( OP_GIMME(o,0) == G_SCALAR
12627 && !(o->op_flags & (OPf_REF|OPf_MOD))
12628 && o->op_private == 0)
12631 arg->pad_offset = o->op_targ;
12633 index_type = MDEREF_INDEX_padsv;
12639 if (next_is_hash) {
12640 /* it's a constant hash index */
12641 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12642 /* "use constant foo => FOO; $h{+foo}" for
12643 * some weird FOO, can leave you with constants
12644 * that aren't simple strings. It's not worth
12645 * the extra hassle for those edge cases */
12650 OP * helem_op = o->op_next;
12652 ASSUME( helem_op->op_type == OP_HELEM
12653 || helem_op->op_type == OP_NULL);
12654 if (helem_op->op_type == OP_HELEM) {
12655 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12656 if ( helem_op->op_private & OPpLVAL_INTRO
12657 || rop->op_type != OP_RV2HV
12661 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12663 #ifdef USE_ITHREADS
12664 /* Relocate sv to the pad for thread safety */
12665 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12666 arg->pad_offset = o->op_targ;
12669 arg->sv = cSVOPx_sv(o);
12674 /* it's a constant array index */
12676 SV *ix_sv = cSVOPo->op_sv;
12681 if ( action_count == 0
12684 && ( action == MDEREF_AV_padav_aelem
12685 || action == MDEREF_AV_gvav_aelem)
12687 maybe_aelemfast = TRUE;
12691 SvREFCNT_dec_NN(cSVOPo->op_sv);
12695 /* we've taken ownership of the SV */
12696 cSVOPo->op_sv = NULL;
12698 index_type = MDEREF_INDEX_const;
12703 /* it may be a package var index */
12705 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12706 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12707 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12708 || o->op_private != 0
12713 if (kid->op_type != OP_RV2SV)
12716 ASSUME(!(kid->op_flags &
12717 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12718 |OPf_SPECIAL|OPf_PARENS)));
12719 ASSUME(!(kid->op_private &
12721 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12722 |OPpDEREF|OPpLVAL_INTRO)));
12723 if( (kid->op_flags &~ OPf_PARENS)
12724 != (OPf_WANT_SCALAR|OPf_KIDS)
12725 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12730 #ifdef USE_ITHREADS
12731 arg->pad_offset = cPADOPx(o)->op_padix;
12732 /* stop it being swiped when nulled */
12733 cPADOPx(o)->op_padix = 0;
12735 arg->sv = cSVOPx(o)->op_sv;
12736 cSVOPo->op_sv = NULL;
12740 index_type = MDEREF_INDEX_gvsv;
12745 } /* action_count != index_skip */
12747 action |= index_type;
12750 /* at this point we have either:
12751 * * detected what looks like a simple index expression,
12752 * and expect the next op to be an [ah]elem, or
12753 * an nulled [ah]elem followed by a delete or exists;
12754 * * found a more complex expression, so something other
12755 * than the above follows.
12758 /* possibly an optimised away [ah]elem (where op_next is
12759 * exists or delete) */
12760 if (o->op_type == OP_NULL)
12763 /* at this point we're looking for an OP_AELEM, OP_HELEM,
12764 * OP_EXISTS or OP_DELETE */
12766 /* if something like arybase (a.k.a $[ ) is in scope,
12767 * abandon optimisation attempt */
12768 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12769 && PL_check[o->op_type] != Perl_ck_null)
12772 if ( o->op_type != OP_AELEM
12773 || (o->op_private &
12774 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12776 maybe_aelemfast = FALSE;
12778 /* look for aelem/helem/exists/delete. If it's not the last elem
12779 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12780 * flags; if it's the last, then it mustn't have
12781 * OPpDEREF_AV/HV, but may have lots of other flags, like
12782 * OPpLVAL_INTRO etc
12785 if ( index_type == MDEREF_INDEX_none
12786 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
12787 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12791 /* we have aelem/helem/exists/delete with valid simple index */
12793 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12794 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
12795 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12798 ASSUME(!(o->op_flags &
12799 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12800 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12802 ok = (o->op_flags &~ OPf_PARENS)
12803 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12804 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12806 else if (o->op_type == OP_EXISTS) {
12807 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12808 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12809 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12810 ok = !(o->op_private & ~OPpARG1_MASK);
12812 else if (o->op_type == OP_DELETE) {
12813 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12814 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12815 ASSUME(!(o->op_private &
12816 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12817 /* don't handle slices or 'local delete'; the latter
12818 * is fairly rare, and has a complex runtime */
12819 ok = !(o->op_private & ~OPpARG1_MASK);
12820 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12821 /* skip handling run-tome error */
12822 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12825 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12826 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12827 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12828 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12829 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12830 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12835 if (!first_elem_op)
12839 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12844 action |= MDEREF_FLAG_last;
12848 /* at this point we have something that started
12849 * promisingly enough (with rv2av or whatever), but failed
12850 * to find a simple index followed by an
12851 * aelem/helem/exists/delete. If this is the first action,
12852 * give up; but if we've already seen at least one
12853 * aelem/helem, then keep them and add a new action with
12854 * MDEREF_INDEX_none, which causes it to do the vivify
12855 * from the end of the previous lookup, and do the deref,
12856 * but stop at that point. So $a[0][expr] will do one
12857 * av_fetch, vivify and deref, then continue executing at
12862 index_skip = action_count;
12863 action |= MDEREF_FLAG_last;
12867 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12870 /* if there's no space for the next action, create a new slot
12871 * for it *before* we start adding args for that action */
12872 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12879 } /* while !is_last */
12887 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12888 if (index_skip == -1) {
12889 mderef->op_flags = o->op_flags
12890 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12891 if (o->op_type == OP_EXISTS)
12892 mderef->op_private = OPpMULTIDEREF_EXISTS;
12893 else if (o->op_type == OP_DELETE)
12894 mderef->op_private = OPpMULTIDEREF_DELETE;
12896 mderef->op_private = o->op_private
12897 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12899 /* accumulate strictness from every level (although I don't think
12900 * they can actually vary) */
12901 mderef->op_private |= hints;
12903 /* integrate the new multideref op into the optree and the
12906 * In general an op like aelem or helem has two child
12907 * sub-trees: the aggregate expression (a_expr) and the
12908 * index expression (i_expr):
12914 * The a_expr returns an AV or HV, while the i-expr returns an
12915 * index. In general a multideref replaces most or all of a
12916 * multi-level tree, e.g.
12932 * With multideref, all the i_exprs will be simple vars or
12933 * constants, except that i_expr1 may be arbitrary in the case
12934 * of MDEREF_INDEX_none.
12936 * The bottom-most a_expr will be either:
12937 * 1) a simple var (so padXv or gv+rv2Xv);
12938 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
12939 * so a simple var with an extra rv2Xv;
12940 * 3) or an arbitrary expression.
12942 * 'start', the first op in the execution chain, will point to
12943 * 1),2): the padXv or gv op;
12944 * 3): the rv2Xv which forms the last op in the a_expr
12945 * execution chain, and the top-most op in the a_expr
12948 * For all cases, the 'start' node is no longer required,
12949 * but we can't free it since one or more external nodes
12950 * may point to it. E.g. consider
12951 * $h{foo} = $a ? $b : $c
12952 * Here, both the op_next and op_other branches of the
12953 * cond_expr point to the gv[*h] of the hash expression, so
12954 * we can't free the 'start' op.
12956 * For expr->[...], we need to save the subtree containing the
12957 * expression; for the other cases, we just need to save the
12959 * So in all cases, we null the start op and keep it around by
12960 * making it the child of the multideref op; for the expr->
12961 * case, the expr will be a subtree of the start node.
12963 * So in the simple 1,2 case the optree above changes to
12969 * ex-gv (or ex-padxv)
12971 * with the op_next chain being
12973 * -> ex-gv -> multideref -> op-following-ex-exists ->
12975 * In the 3 case, we have
12988 * -> rest-of-a_expr subtree ->
12989 * ex-rv2xv -> multideref -> op-following-ex-exists ->
12992 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
12993 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
12994 * multideref attached as the child, e.g.
13000 * ex-rv2av - i_expr1
13008 /* if we free this op, don't free the pad entry */
13009 if (reset_start_targ)
13010 start->op_targ = 0;
13013 /* Cut the bit we need to save out of the tree and attach to
13014 * the multideref op, then free the rest of the tree */
13016 /* find parent of node to be detached (for use by splice) */
13018 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
13019 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13021 /* there is an arbitrary expression preceding us, e.g.
13022 * expr->[..]? so we need to save the 'expr' subtree */
13023 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13024 p = cUNOPx(p)->op_first;
13025 ASSUME( start->op_type == OP_RV2AV
13026 || start->op_type == OP_RV2HV);
13029 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13030 * above for exists/delete. */
13031 while ( (p->op_flags & OPf_KIDS)
13032 && cUNOPx(p)->op_first != start
13034 p = cUNOPx(p)->op_first;
13036 ASSUME(cUNOPx(p)->op_first == start);
13038 /* detach from main tree, and re-attach under the multideref */
13039 op_sibling_splice(mderef, NULL, 0,
13040 op_sibling_splice(p, NULL, 1, NULL));
13043 start->op_next = mderef;
13045 mderef->op_next = index_skip == -1 ? o->op_next : o;
13047 /* excise and free the original tree, and replace with
13048 * the multideref op */
13049 p = op_sibling_splice(top_op, NULL, -1, mderef);
13058 Size_t size = arg - arg_buf;
13060 if (maybe_aelemfast && action_count == 1)
13063 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13064 sizeof(UNOP_AUX_item) * (size + 1));
13065 /* for dumping etc: store the length in a hidden first slot;
13066 * we set the op_aux pointer to the second slot */
13067 arg_buf->uv = size;
13070 } /* for (pass = ...) */
13075 /* mechanism for deferring recursion in rpeep() */
13077 #define MAX_DEFERRED 4
13081 if (defer_ix == (MAX_DEFERRED-1)) { \
13082 OP **defer = defer_queue[defer_base]; \
13083 CALL_RPEEP(*defer); \
13084 S_prune_chain_head(defer); \
13085 defer_base = (defer_base + 1) % MAX_DEFERRED; \
13088 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13091 #define IS_AND_OP(o) (o->op_type == OP_AND)
13092 #define IS_OR_OP(o) (o->op_type == OP_OR)
13095 /* A peephole optimizer. We visit the ops in the order they're to execute.
13096 * See the comments at the top of this file for more details about when
13097 * peep() is called */
13100 Perl_rpeep(pTHX_ OP *o)
13104 OP* oldoldop = NULL;
13105 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13106 int defer_base = 0;
13111 if (!o || o->op_opt)
13115 SAVEVPTR(PL_curcop);
13116 for (;; o = o->op_next) {
13117 if (o && o->op_opt)
13120 while (defer_ix >= 0) {
13122 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13123 CALL_RPEEP(*defer);
13124 S_prune_chain_head(defer);
13131 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13132 assert(!oldoldop || oldoldop->op_next == oldop);
13133 assert(!oldop || oldop->op_next == o);
13135 /* By default, this op has now been optimised. A couple of cases below
13136 clear this again. */
13140 /* look for a series of 1 or more aggregate derefs, e.g.
13141 * $a[1]{foo}[$i]{$k}
13142 * and replace with a single OP_MULTIDEREF op.
13143 * Each index must be either a const, or a simple variable,
13145 * First, look for likely combinations of starting ops,
13146 * corresponding to (global and lexical variants of)
13148 * $r->[...] $r->{...}
13149 * (preceding expression)->[...]
13150 * (preceding expression)->{...}
13151 * and if so, call maybe_multideref() to do a full inspection
13152 * of the op chain and if appropriate, replace with an
13160 switch (o2->op_type) {
13162 /* $pkg[..] : gv[*pkg]
13163 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
13165 /* Fail if there are new op flag combinations that we're
13166 * not aware of, rather than:
13167 * * silently failing to optimise, or
13168 * * silently optimising the flag away.
13169 * If this ASSUME starts failing, examine what new flag
13170 * has been added to the op, and decide whether the
13171 * optimisation should still occur with that flag, then
13172 * update the code accordingly. This applies to all the
13173 * other ASSUMEs in the block of code too.
13175 ASSUME(!(o2->op_flags &
13176 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13177 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13181 if (o2->op_type == OP_RV2AV) {
13182 action = MDEREF_AV_gvav_aelem;
13186 if (o2->op_type == OP_RV2HV) {
13187 action = MDEREF_HV_gvhv_helem;
13191 if (o2->op_type != OP_RV2SV)
13194 /* at this point we've seen gv,rv2sv, so the only valid
13195 * construct left is $pkg->[] or $pkg->{} */
13197 ASSUME(!(o2->op_flags & OPf_STACKED));
13198 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13199 != (OPf_WANT_SCALAR|OPf_MOD))
13202 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13203 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13204 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13206 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
13207 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13211 if (o2->op_type == OP_RV2AV) {
13212 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13215 if (o2->op_type == OP_RV2HV) {
13216 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13222 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13224 ASSUME(!(o2->op_flags &
13225 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13226 if ((o2->op_flags &
13227 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13228 != (OPf_WANT_SCALAR|OPf_MOD))
13231 ASSUME(!(o2->op_private &
13232 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13233 /* skip if state or intro, or not a deref */
13234 if ( o2->op_private != OPpDEREF_AV
13235 && o2->op_private != OPpDEREF_HV)
13239 if (o2->op_type == OP_RV2AV) {
13240 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13243 if (o2->op_type == OP_RV2HV) {
13244 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13251 /* $lex[..]: padav[@lex:1,2] sR *
13252 * or $lex{..}: padhv[%lex:1,2] sR */
13253 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13254 OPf_REF|OPf_SPECIAL)));
13255 if ((o2->op_flags &
13256 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13257 != (OPf_WANT_SCALAR|OPf_REF))
13259 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13261 /* OPf_PARENS isn't currently used in this case;
13262 * if that changes, let us know! */
13263 ASSUME(!(o2->op_flags & OPf_PARENS));
13265 /* at this point, we wouldn't expect any of the remaining
13266 * possible private flags:
13267 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13268 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13270 * OPpSLICEWARNING shouldn't affect runtime
13272 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13274 action = o2->op_type == OP_PADAV
13275 ? MDEREF_AV_padav_aelem
13276 : MDEREF_HV_padhv_helem;
13278 S_maybe_multideref(aTHX_ o, o2, action, 0);
13284 action = o2->op_type == OP_RV2AV
13285 ? MDEREF_AV_pop_rv2av_aelem
13286 : MDEREF_HV_pop_rv2hv_helem;
13289 /* (expr)->[...]: rv2av sKR/1;
13290 * (expr)->{...}: rv2hv sKR/1; */
13292 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13294 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13295 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13296 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13299 /* at this point, we wouldn't expect any of these
13300 * possible private flags:
13301 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13302 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13304 ASSUME(!(o2->op_private &
13305 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13307 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13311 S_maybe_multideref(aTHX_ o, o2, action, hints);
13320 switch (o->op_type) {
13322 PL_curcop = ((COP*)o); /* for warnings */
13325 PL_curcop = ((COP*)o); /* for warnings */
13327 /* Optimise a "return ..." at the end of a sub to just be "...".
13328 * This saves 2 ops. Before:
13329 * 1 <;> nextstate(main 1 -e:1) v ->2
13330 * 4 <@> return K ->5
13331 * 2 <0> pushmark s ->3
13332 * - <1> ex-rv2sv sK/1 ->4
13333 * 3 <#> gvsv[*cat] s ->4
13336 * - <@> return K ->-
13337 * - <0> pushmark s ->2
13338 * - <1> ex-rv2sv sK/1 ->-
13339 * 2 <$> gvsv(*cat) s ->3
13342 OP *next = o->op_next;
13343 OP *sibling = OpSIBLING(o);
13344 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13345 && OP_TYPE_IS(sibling, OP_RETURN)
13346 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13347 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13348 ||OP_TYPE_IS(sibling->op_next->op_next,
13350 && cUNOPx(sibling)->op_first == next
13351 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13354 /* Look through the PUSHMARK's siblings for one that
13355 * points to the RETURN */
13356 OP *top = OpSIBLING(next);
13357 while (top && top->op_next) {
13358 if (top->op_next == sibling) {
13359 top->op_next = sibling->op_next;
13360 o->op_next = next->op_next;
13363 top = OpSIBLING(top);
13368 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13370 * This latter form is then suitable for conversion into padrange
13371 * later on. Convert:
13373 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13377 * nextstate1 -> listop -> nextstate3
13379 * pushmark -> padop1 -> padop2
13381 if (o->op_next && (
13382 o->op_next->op_type == OP_PADSV
13383 || o->op_next->op_type == OP_PADAV
13384 || o->op_next->op_type == OP_PADHV
13386 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13387 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13388 && o->op_next->op_next->op_next && (
13389 o->op_next->op_next->op_next->op_type == OP_PADSV
13390 || o->op_next->op_next->op_next->op_type == OP_PADAV
13391 || o->op_next->op_next->op_next->op_type == OP_PADHV
13393 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13394 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13395 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13396 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13398 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13401 ns2 = pad1->op_next;
13402 pad2 = ns2->op_next;
13403 ns3 = pad2->op_next;
13405 /* we assume here that the op_next chain is the same as
13406 * the op_sibling chain */
13407 assert(OpSIBLING(o) == pad1);
13408 assert(OpSIBLING(pad1) == ns2);
13409 assert(OpSIBLING(ns2) == pad2);
13410 assert(OpSIBLING(pad2) == ns3);
13412 /* excise and delete ns2 */
13413 op_sibling_splice(NULL, pad1, 1, NULL);
13416 /* excise pad1 and pad2 */
13417 op_sibling_splice(NULL, o, 2, NULL);
13419 /* create new listop, with children consisting of:
13420 * a new pushmark, pad1, pad2. */
13421 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13422 newop->op_flags |= OPf_PARENS;
13423 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13425 /* insert newop between o and ns3 */
13426 op_sibling_splice(NULL, o, 0, newop);
13428 /*fixup op_next chain */
13429 newpm = cUNOPx(newop)->op_first; /* pushmark */
13430 o ->op_next = newpm;
13431 newpm->op_next = pad1;
13432 pad1 ->op_next = pad2;
13433 pad2 ->op_next = newop; /* listop */
13434 newop->op_next = ns3;
13436 /* Ensure pushmark has this flag if padops do */
13437 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13438 newpm->op_flags |= OPf_MOD;
13444 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13445 to carry two labels. For now, take the easier option, and skip
13446 this optimisation if the first NEXTSTATE has a label. */
13447 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13448 OP *nextop = o->op_next;
13449 while (nextop && nextop->op_type == OP_NULL)
13450 nextop = nextop->op_next;
13452 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13455 oldop->op_next = nextop;
13457 /* Skip (old)oldop assignment since the current oldop's
13458 op_next already points to the next op. */
13465 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13466 if (o->op_next->op_private & OPpTARGET_MY) {
13467 if (o->op_flags & OPf_STACKED) /* chained concats */
13468 break; /* ignore_optimization */
13470 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13471 o->op_targ = o->op_next->op_targ;
13472 o->op_next->op_targ = 0;
13473 o->op_private |= OPpTARGET_MY;
13476 op_null(o->op_next);
13480 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13481 break; /* Scalar stub must produce undef. List stub is noop */
13485 if (o->op_targ == OP_NEXTSTATE
13486 || o->op_targ == OP_DBSTATE)
13488 PL_curcop = ((COP*)o);
13490 /* XXX: We avoid setting op_seq here to prevent later calls
13491 to rpeep() from mistakenly concluding that optimisation
13492 has already occurred. This doesn't fix the real problem,
13493 though (See 20010220.007). AMS 20010719 */
13494 /* op_seq functionality is now replaced by op_opt */
13502 oldop->op_next = o->op_next;
13516 convert repeat into a stub with no kids.
13518 if (o->op_next->op_type == OP_CONST
13519 || ( o->op_next->op_type == OP_PADSV
13520 && !(o->op_next->op_private & OPpLVAL_INTRO))
13521 || ( o->op_next->op_type == OP_GV
13522 && o->op_next->op_next->op_type == OP_RV2SV
13523 && !(o->op_next->op_next->op_private
13524 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13526 const OP *kid = o->op_next->op_next;
13527 if (o->op_next->op_type == OP_GV)
13528 kid = kid->op_next;
13529 /* kid is now the ex-list. */
13530 if (kid->op_type == OP_NULL
13531 && (kid = kid->op_next)->op_type == OP_CONST
13532 /* kid is now the repeat count. */
13533 && kid->op_next->op_type == OP_REPEAT
13534 && kid->op_next->op_private & OPpREPEAT_DOLIST
13535 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13536 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13538 o = kid->op_next; /* repeat */
13540 oldop->op_next = o;
13541 op_free(cBINOPo->op_first);
13542 op_free(cBINOPo->op_last );
13543 o->op_flags &=~ OPf_KIDS;
13544 /* stub is a baseop; repeat is a binop */
13545 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13546 OpTYPE_set(o, OP_STUB);
13552 /* Convert a series of PAD ops for my vars plus support into a
13553 * single padrange op. Basically
13555 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13557 * becomes, depending on circumstances, one of
13559 * padrange ----------------------------------> (list) -> rest
13560 * padrange --------------------------------------------> rest
13562 * where all the pad indexes are sequential and of the same type
13564 * We convert the pushmark into a padrange op, then skip
13565 * any other pad ops, and possibly some trailing ops.
13566 * Note that we don't null() the skipped ops, to make it
13567 * easier for Deparse to undo this optimisation (and none of
13568 * the skipped ops are holding any resourses). It also makes
13569 * it easier for find_uninit_var(), as it can just ignore
13570 * padrange, and examine the original pad ops.
13574 OP *followop = NULL; /* the op that will follow the padrange op */
13577 PADOFFSET base = 0; /* init only to stop compiler whining */
13578 bool gvoid = 0; /* init only to stop compiler whining */
13579 bool defav = 0; /* seen (...) = @_ */
13580 bool reuse = 0; /* reuse an existing padrange op */
13582 /* look for a pushmark -> gv[_] -> rv2av */
13587 if ( p->op_type == OP_GV
13588 && cGVOPx_gv(p) == PL_defgv
13589 && (rv2av = p->op_next)
13590 && rv2av->op_type == OP_RV2AV
13591 && !(rv2av->op_flags & OPf_REF)
13592 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13593 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13595 q = rv2av->op_next;
13596 if (q->op_type == OP_NULL)
13598 if (q->op_type == OP_PUSHMARK) {
13608 /* scan for PAD ops */
13610 for (p = p->op_next; p; p = p->op_next) {
13611 if (p->op_type == OP_NULL)
13614 if (( p->op_type != OP_PADSV
13615 && p->op_type != OP_PADAV
13616 && p->op_type != OP_PADHV
13618 /* any private flag other than INTRO? e.g. STATE */
13619 || (p->op_private & ~OPpLVAL_INTRO)
13623 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13625 if ( p->op_type == OP_PADAV
13627 && p->op_next->op_type == OP_CONST
13628 && p->op_next->op_next
13629 && p->op_next->op_next->op_type == OP_AELEM
13633 /* for 1st padop, note what type it is and the range
13634 * start; for the others, check that it's the same type
13635 * and that the targs are contiguous */
13637 intro = (p->op_private & OPpLVAL_INTRO);
13639 gvoid = OP_GIMME(p,0) == G_VOID;
13642 if ((p->op_private & OPpLVAL_INTRO) != intro)
13644 /* Note that you'd normally expect targs to be
13645 * contiguous in my($a,$b,$c), but that's not the case
13646 * when external modules start doing things, e.g.
13647 i* Function::Parameters */
13648 if (p->op_targ != base + count)
13650 assert(p->op_targ == base + count);
13651 /* Either all the padops or none of the padops should
13652 be in void context. Since we only do the optimisa-
13653 tion for av/hv when the aggregate itself is pushed
13654 on to the stack (one item), there is no need to dis-
13655 tinguish list from scalar context. */
13656 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13660 /* for AV, HV, only when we're not flattening */
13661 if ( p->op_type != OP_PADSV
13663 && !(p->op_flags & OPf_REF)
13667 if (count >= OPpPADRANGE_COUNTMASK)
13670 /* there's a biggest base we can fit into a
13671 * SAVEt_CLEARPADRANGE in pp_padrange.
13672 * (The sizeof() stuff will be constant-folded, and is
13673 * intended to avoid getting "comparison is always false"
13674 * compiler warnings)
13677 && (8*sizeof(base) >
13678 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13680 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13684 /* Success! We've got another valid pad op to optimise away */
13686 followop = p->op_next;
13689 if (count < 1 || (count == 1 && !defav))
13692 /* pp_padrange in specifically compile-time void context
13693 * skips pushing a mark and lexicals; in all other contexts
13694 * (including unknown till runtime) it pushes a mark and the
13695 * lexicals. We must be very careful then, that the ops we
13696 * optimise away would have exactly the same effect as the
13698 * In particular in void context, we can only optimise to
13699 * a padrange if see see the complete sequence
13700 * pushmark, pad*v, ...., list
13701 * which has the net effect of of leaving the markstack as it
13702 * was. Not pushing on to the stack (whereas padsv does touch
13703 * the stack) makes no difference in void context.
13707 if (followop->op_type == OP_LIST
13708 && OP_GIMME(followop,0) == G_VOID
13711 followop = followop->op_next; /* skip OP_LIST */
13713 /* consolidate two successive my(...);'s */
13716 && oldoldop->op_type == OP_PADRANGE
13717 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13718 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13719 && !(oldoldop->op_flags & OPf_SPECIAL)
13722 assert(oldoldop->op_next == oldop);
13723 assert( oldop->op_type == OP_NEXTSTATE
13724 || oldop->op_type == OP_DBSTATE);
13725 assert(oldop->op_next == o);
13728 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13730 /* Do not assume pad offsets for $c and $d are con-
13735 if ( oldoldop->op_targ + old_count == base
13736 && old_count < OPpPADRANGE_COUNTMASK - count) {
13737 base = oldoldop->op_targ;
13738 count += old_count;
13743 /* if there's any immediately following singleton
13744 * my var's; then swallow them and the associated
13746 * my ($a,$b); my $c; my $d;
13748 * my ($a,$b,$c,$d);
13751 while ( ((p = followop->op_next))
13752 && ( p->op_type == OP_PADSV
13753 || p->op_type == OP_PADAV
13754 || p->op_type == OP_PADHV)
13755 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13756 && (p->op_private & OPpLVAL_INTRO) == intro
13757 && !(p->op_private & ~OPpLVAL_INTRO)
13759 && ( p->op_next->op_type == OP_NEXTSTATE
13760 || p->op_next->op_type == OP_DBSTATE)
13761 && count < OPpPADRANGE_COUNTMASK
13762 && base + count == p->op_targ
13765 followop = p->op_next;
13773 assert(oldoldop->op_type == OP_PADRANGE);
13774 oldoldop->op_next = followop;
13775 oldoldop->op_private = (intro | count);
13781 /* Convert the pushmark into a padrange.
13782 * To make Deparse easier, we guarantee that a padrange was
13783 * *always* formerly a pushmark */
13784 assert(o->op_type == OP_PUSHMARK);
13785 o->op_next = followop;
13786 OpTYPE_set(o, OP_PADRANGE);
13788 /* bit 7: INTRO; bit 6..0: count */
13789 o->op_private = (intro | count);
13790 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13791 | gvoid * OPf_WANT_VOID
13792 | (defav ? OPf_SPECIAL : 0));
13800 /* Skip over state($x) in void context. */
13801 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13802 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13804 oldop->op_next = o->op_next;
13805 goto redo_nextstate;
13807 if (o->op_type != OP_PADAV)
13811 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13812 OP* const pop = (o->op_type == OP_PADAV) ?
13813 o->op_next : o->op_next->op_next;
13815 if (pop && pop->op_type == OP_CONST &&
13816 ((PL_op = pop->op_next)) &&
13817 pop->op_next->op_type == OP_AELEM &&
13818 !(pop->op_next->op_private &
13819 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13820 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13823 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13824 no_bareword_allowed(pop);
13825 if (o->op_type == OP_GV)
13826 op_null(o->op_next);
13827 op_null(pop->op_next);
13829 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13830 o->op_next = pop->op_next->op_next;
13831 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13832 o->op_private = (U8)i;
13833 if (o->op_type == OP_GV) {
13836 o->op_type = OP_AELEMFAST;
13839 o->op_type = OP_AELEMFAST_LEX;
13841 if (o->op_type != OP_GV)
13845 /* Remove $foo from the op_next chain in void context. */
13847 && ( o->op_next->op_type == OP_RV2SV
13848 || o->op_next->op_type == OP_RV2AV
13849 || o->op_next->op_type == OP_RV2HV )
13850 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13851 && !(o->op_next->op_private & OPpLVAL_INTRO))
13853 oldop->op_next = o->op_next->op_next;
13854 /* Reprocess the previous op if it is a nextstate, to
13855 allow double-nextstate optimisation. */
13857 if (oldop->op_type == OP_NEXTSTATE) {
13864 o = oldop->op_next;
13867 else if (o->op_next->op_type == OP_RV2SV) {
13868 if (!(o->op_next->op_private & OPpDEREF)) {
13869 op_null(o->op_next);
13870 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13872 o->op_next = o->op_next->op_next;
13873 OpTYPE_set(o, OP_GVSV);
13876 else if (o->op_next->op_type == OP_READLINE
13877 && o->op_next->op_next->op_type == OP_CONCAT
13878 && (o->op_next->op_next->op_flags & OPf_STACKED))
13880 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13881 OpTYPE_set(o, OP_RCATLINE);
13882 o->op_flags |= OPf_STACKED;
13883 op_null(o->op_next->op_next);
13884 op_null(o->op_next);
13889 #define HV_OR_SCALARHV(op) \
13890 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13892 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13893 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
13894 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
13895 ? cUNOPx(op)->op_first \
13899 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13900 fop->op_private |= OPpTRUEBOOL;
13906 fop = cLOGOP->op_first;
13907 sop = OpSIBLING(fop);
13908 while (cLOGOP->op_other->op_type == OP_NULL)
13909 cLOGOP->op_other = cLOGOP->op_other->op_next;
13910 while (o->op_next && ( o->op_type == o->op_next->op_type
13911 || o->op_next->op_type == OP_NULL))
13912 o->op_next = o->op_next->op_next;
13914 /* if we're an OR and our next is a AND in void context, we'll
13915 follow it's op_other on short circuit, same for reverse.
13916 We can't do this with OP_DOR since if it's true, its return
13917 value is the underlying value which must be evaluated
13921 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13922 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13924 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13926 o->op_next = ((LOGOP*)o->op_next)->op_other;
13928 DEFER(cLOGOP->op_other);
13931 fop = HV_OR_SCALARHV(fop);
13932 if (sop) sop = HV_OR_SCALARHV(sop);
13937 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
13938 while (nop && nop->op_next) {
13939 switch (nop->op_next->op_type) {
13944 lop = nop = nop->op_next;
13947 nop = nop->op_next;
13956 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13957 || o->op_type == OP_AND )
13958 fop->op_private |= OPpTRUEBOOL;
13959 else if (!(lop->op_flags & OPf_WANT))
13960 fop->op_private |= OPpMAYBE_TRUEBOOL;
13962 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13964 sop->op_private |= OPpTRUEBOOL;
13971 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
13972 fop->op_private |= OPpTRUEBOOL;
13973 #undef HV_OR_SCALARHV
13974 /* GERONIMO! */ /* FALLTHROUGH */
13983 while (cLOGOP->op_other->op_type == OP_NULL)
13984 cLOGOP->op_other = cLOGOP->op_other->op_next;
13985 DEFER(cLOGOP->op_other);
13990 while (cLOOP->op_redoop->op_type == OP_NULL)
13991 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
13992 while (cLOOP->op_nextop->op_type == OP_NULL)
13993 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
13994 while (cLOOP->op_lastop->op_type == OP_NULL)
13995 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
13996 /* a while(1) loop doesn't have an op_next that escapes the
13997 * loop, so we have to explicitly follow the op_lastop to
13998 * process the rest of the code */
13999 DEFER(cLOOP->op_lastop);
14003 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14004 DEFER(cLOGOPo->op_other);
14008 assert(!(cPMOP->op_pmflags & PMf_ONCE));
14009 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14010 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14011 cPMOP->op_pmstashstartu.op_pmreplstart
14012 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14013 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14019 if (o->op_flags & OPf_SPECIAL) {
14020 /* first arg is a code block */
14021 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14022 OP * kid = cUNOPx(nullop)->op_first;
14024 assert(nullop->op_type == OP_NULL);
14025 assert(kid->op_type == OP_SCOPE
14026 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14027 /* since OP_SORT doesn't have a handy op_other-style
14028 * field that can point directly to the start of the code
14029 * block, store it in the otherwise-unused op_next field
14030 * of the top-level OP_NULL. This will be quicker at
14031 * run-time, and it will also allow us to remove leading
14032 * OP_NULLs by just messing with op_nexts without
14033 * altering the basic op_first/op_sibling layout. */
14034 kid = kLISTOP->op_first;
14036 (kid->op_type == OP_NULL
14037 && ( kid->op_targ == OP_NEXTSTATE
14038 || kid->op_targ == OP_DBSTATE ))
14039 || kid->op_type == OP_STUB
14040 || kid->op_type == OP_ENTER);
14041 nullop->op_next = kLISTOP->op_next;
14042 DEFER(nullop->op_next);
14045 /* check that RHS of sort is a single plain array */
14046 oright = cUNOPo->op_first;
14047 if (!oright || oright->op_type != OP_PUSHMARK)
14050 if (o->op_private & OPpSORT_INPLACE)
14053 /* reverse sort ... can be optimised. */
14054 if (!OpHAS_SIBLING(cUNOPo)) {
14055 /* Nothing follows us on the list. */
14056 OP * const reverse = o->op_next;
14058 if (reverse->op_type == OP_REVERSE &&
14059 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14060 OP * const pushmark = cUNOPx(reverse)->op_first;
14061 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14062 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14063 /* reverse -> pushmark -> sort */
14064 o->op_private |= OPpSORT_REVERSE;
14066 pushmark->op_next = oright->op_next;
14076 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14078 LISTOP *enter, *exlist;
14080 if (o->op_private & OPpSORT_INPLACE)
14083 enter = (LISTOP *) o->op_next;
14086 if (enter->op_type == OP_NULL) {
14087 enter = (LISTOP *) enter->op_next;
14091 /* for $a (...) will have OP_GV then OP_RV2GV here.
14092 for (...) just has an OP_GV. */
14093 if (enter->op_type == OP_GV) {
14094 gvop = (OP *) enter;
14095 enter = (LISTOP *) enter->op_next;
14098 if (enter->op_type == OP_RV2GV) {
14099 enter = (LISTOP *) enter->op_next;
14105 if (enter->op_type != OP_ENTERITER)
14108 iter = enter->op_next;
14109 if (!iter || iter->op_type != OP_ITER)
14112 expushmark = enter->op_first;
14113 if (!expushmark || expushmark->op_type != OP_NULL
14114 || expushmark->op_targ != OP_PUSHMARK)
14117 exlist = (LISTOP *) OpSIBLING(expushmark);
14118 if (!exlist || exlist->op_type != OP_NULL
14119 || exlist->op_targ != OP_LIST)
14122 if (exlist->op_last != o) {
14123 /* Mmm. Was expecting to point back to this op. */
14126 theirmark = exlist->op_first;
14127 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14130 if (OpSIBLING(theirmark) != o) {
14131 /* There's something between the mark and the reverse, eg
14132 for (1, reverse (...))
14137 ourmark = ((LISTOP *)o)->op_first;
14138 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14141 ourlast = ((LISTOP *)o)->op_last;
14142 if (!ourlast || ourlast->op_next != o)
14145 rv2av = OpSIBLING(ourmark);
14146 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14147 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14148 /* We're just reversing a single array. */
14149 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14150 enter->op_flags |= OPf_STACKED;
14153 /* We don't have control over who points to theirmark, so sacrifice
14155 theirmark->op_next = ourmark->op_next;
14156 theirmark->op_flags = ourmark->op_flags;
14157 ourlast->op_next = gvop ? gvop : (OP *) enter;
14160 enter->op_private |= OPpITER_REVERSED;
14161 iter->op_private |= OPpITER_REVERSED;
14165 o = oldop->op_next;
14173 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14174 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14179 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14180 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14183 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14185 sv = newRV((SV *)PL_compcv);
14189 OpTYPE_set(o, OP_CONST);
14190 o->op_flags |= OPf_SPECIAL;
14191 cSVOPo->op_sv = sv;
14196 if (OP_GIMME(o,0) == G_VOID
14197 || ( o->op_next->op_type == OP_LINESEQ
14198 && ( o->op_next->op_next->op_type == OP_LEAVESUB
14199 || ( o->op_next->op_next->op_type == OP_RETURN
14200 && !CvLVALUE(PL_compcv)))))
14202 OP *right = cBINOP->op_first;
14221 OP *left = OpSIBLING(right);
14222 if (left->op_type == OP_SUBSTR
14223 && (left->op_private & 7) < 4) {
14225 /* cut out right */
14226 op_sibling_splice(o, NULL, 1, NULL);
14227 /* and insert it as second child of OP_SUBSTR */
14228 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14230 left->op_private |= OPpSUBSTR_REPL_FIRST;
14232 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14239 int l, r, lr, lscalars, rscalars;
14241 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14242 Note that we do this now rather than in newASSIGNOP(),
14243 since only by now are aliased lexicals flagged as such
14245 See the essay "Common vars in list assignment" above for
14246 the full details of the rationale behind all the conditions
14249 PL_generation sorcery:
14250 To detect whether there are common vars, the global var
14251 PL_generation is incremented for each assign op we scan.
14252 Then we run through all the lexical variables on the LHS,
14253 of the assignment, setting a spare slot in each of them to
14254 PL_generation. Then we scan the RHS, and if any lexicals
14255 already have that value, we know we've got commonality.
14256 Also, if the generation number is already set to
14257 PERL_INT_MAX, then the variable is involved in aliasing, so
14258 we also have potential commonality in that case.
14264 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
14267 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14271 /* After looking for things which are *always* safe, this main
14272 * if/else chain selects primarily based on the type of the
14273 * LHS, gradually working its way down from the more dangerous
14274 * to the more restrictive and thus safer cases */
14276 if ( !l /* () = ....; */
14277 || !r /* .... = (); */
14278 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14279 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14280 || (lscalars < 2) /* ($x, undef) = ... */
14282 NOOP; /* always safe */
14284 else if (l & AAS_DANGEROUS) {
14285 /* always dangerous */
14286 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14287 o->op_private |= OPpASSIGN_COMMON_AGG;
14289 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14290 /* package vars are always dangerous - too many
14291 * aliasing possibilities */
14292 if (l & AAS_PKG_SCALAR)
14293 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14294 if (l & AAS_PKG_AGG)
14295 o->op_private |= OPpASSIGN_COMMON_AGG;
14297 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14298 |AAS_LEX_SCALAR|AAS_LEX_AGG))
14300 /* LHS contains only lexicals and safe ops */
14302 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14303 o->op_private |= OPpASSIGN_COMMON_AGG;
14305 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14306 if (lr & AAS_LEX_SCALAR_COMM)
14307 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14308 else if ( !(l & AAS_LEX_SCALAR)
14309 && (r & AAS_DEFAV))
14313 * as scalar-safe for performance reasons.
14314 * (it will still have been marked _AGG if necessary */
14317 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14318 o->op_private |= OPpASSIGN_COMMON_RC1;
14323 * may have to handle aggregate on LHS, but we can't
14324 * have common scalars. */
14327 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14333 Perl_cpeep_t cpeep =
14334 XopENTRYCUSTOM(o, xop_peep);
14336 cpeep(aTHX_ o, oldop);
14341 /* did we just null the current op? If so, re-process it to handle
14342 * eliding "empty" ops from the chain */
14343 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14356 Perl_peep(pTHX_ OP *o)
14362 =head1 Custom Operators
14364 =for apidoc Ao||custom_op_xop
14365 Return the XOP structure for a given custom op. This macro should be
14366 considered internal to C<OP_NAME> and the other access macros: use them instead.
14367 This macro does call a function. Prior
14368 to 5.19.6, this was implemented as a
14375 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14381 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14383 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14384 assert(o->op_type == OP_CUSTOM);
14386 /* This is wrong. It assumes a function pointer can be cast to IV,
14387 * which isn't guaranteed, but this is what the old custom OP code
14388 * did. In principle it should be safer to Copy the bytes of the
14389 * pointer into a PV: since the new interface is hidden behind
14390 * functions, this can be changed later if necessary. */
14391 /* Change custom_op_xop if this ever happens */
14392 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14395 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14397 /* assume noone will have just registered a desc */
14398 if (!he && PL_custom_op_names &&
14399 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14404 /* XXX does all this need to be shared mem? */
14405 Newxz(xop, 1, XOP);
14406 pv = SvPV(HeVAL(he), l);
14407 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14408 if (PL_custom_op_descs &&
14409 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14411 pv = SvPV(HeVAL(he), l);
14412 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14414 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14418 xop = (XOP *)&xop_null;
14420 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14424 if(field == XOPe_xop_ptr) {
14427 const U32 flags = XopFLAGS(xop);
14428 if(flags & field) {
14430 case XOPe_xop_name:
14431 any.xop_name = xop->xop_name;
14433 case XOPe_xop_desc:
14434 any.xop_desc = xop->xop_desc;
14436 case XOPe_xop_class:
14437 any.xop_class = xop->xop_class;
14439 case XOPe_xop_peep:
14440 any.xop_peep = xop->xop_peep;
14443 NOT_REACHED; /* NOTREACHED */
14448 case XOPe_xop_name:
14449 any.xop_name = XOPd_xop_name;
14451 case XOPe_xop_desc:
14452 any.xop_desc = XOPd_xop_desc;
14454 case XOPe_xop_class:
14455 any.xop_class = XOPd_xop_class;
14457 case XOPe_xop_peep:
14458 any.xop_peep = XOPd_xop_peep;
14461 NOT_REACHED; /* NOTREACHED */
14466 /* Some gcc releases emit a warning for this function:
14467 * op.c: In function 'Perl_custom_op_get_field':
14468 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14469 * Whether this is true, is currently unknown. */
14475 =for apidoc Ao||custom_op_register
14476 Register a custom op. See L<perlguts/"Custom Operators">.
14482 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14486 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14488 /* see the comment in custom_op_xop */
14489 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14491 if (!PL_custom_ops)
14492 PL_custom_ops = newHV();
14494 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14495 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14500 =for apidoc core_prototype
14502 This function assigns the prototype of the named core function to C<sv>, or
14503 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
14504 C<NULL> if the core function has no prototype. C<code> is a code as returned
14505 by C<keyword()>. It must not be equal to 0.
14511 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14514 int i = 0, n = 0, seen_question = 0, defgv = 0;
14516 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14517 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14518 bool nullret = FALSE;
14520 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14524 if (!sv) sv = sv_newmortal();
14526 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14528 switch (code < 0 ? -code : code) {
14529 case KEY_and : case KEY_chop: case KEY_chomp:
14530 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14531 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14532 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14533 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14534 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14535 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14536 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14537 case KEY_x : case KEY_xor :
14538 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14539 case KEY_glob: retsetpvs("_;", OP_GLOB);
14540 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
14541 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
14542 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
14543 case KEY_push: retsetpvs("\\@@", OP_PUSH);
14544 case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
14545 case KEY_pop: retsetpvs(";\\@", OP_POP);
14546 case KEY_shift: retsetpvs(";\\@", OP_SHIFT);
14547 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14549 retsetpvs("\\@;$$@", OP_SPLICE);
14550 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14552 case KEY_evalbytes:
14553 name = "entereval"; break;
14561 while (i < MAXO) { /* The slow way. */
14562 if (strEQ(name, PL_op_name[i])
14563 || strEQ(name, PL_op_desc[i]))
14565 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14572 defgv = PL_opargs[i] & OA_DEFGV;
14573 oa = PL_opargs[i] >> OASHIFT;
14575 if (oa & OA_OPTIONAL && !seen_question && (
14576 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14581 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14582 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14583 /* But globs are already references (kinda) */
14584 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14588 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14589 && !scalar_mod_type(NULL, i)) {
14594 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14598 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14599 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14600 str[n-1] = '_'; defgv = 0;
14604 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14606 sv_setpvn(sv, str, n - 1);
14607 if (opnum) *opnum = i;
14612 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14615 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14618 PERL_ARGS_ASSERT_CORESUB_OP;
14622 return op_append_elem(OP_LINESEQ,
14625 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14629 case OP_SELECT: /* which represents OP_SSELECT as well */
14634 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14635 newSVOP(OP_CONST, 0, newSVuv(1))
14637 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14639 coresub_op(coreargssv, 0, OP_SELECT)
14643 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14645 return op_append_elem(
14648 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14649 ? OPpOFFBYONE << 8 : 0)
14651 case OA_BASEOP_OR_UNOP:
14652 if (opnum == OP_ENTEREVAL) {
14653 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14654 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14656 else o = newUNOP(opnum,0,argop);
14657 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14660 if (is_handle_constructor(o, 1))
14661 argop->op_private |= OPpCOREARGS_DEREF1;
14662 if (scalar_mod_type(NULL, opnum))
14663 argop->op_private |= OPpCOREARGS_SCALARMOD;
14667 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14668 if (is_handle_constructor(o, 2))
14669 argop->op_private |= OPpCOREARGS_DEREF2;
14670 if (opnum == OP_SUBSTR) {
14671 o->op_private |= OPpMAYBE_LVSUB;
14680 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14681 SV * const *new_const_svp)
14683 const char *hvname;
14684 bool is_const = !!CvCONST(old_cv);
14685 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14687 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14689 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14691 /* They are 2 constant subroutines generated from
14692 the same constant. This probably means that
14693 they are really the "same" proxy subroutine
14694 instantiated in 2 places. Most likely this is
14695 when a constant is exported twice. Don't warn.
14698 (ckWARN(WARN_REDEFINE)
14700 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14701 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14702 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14703 strEQ(hvname, "autouse"))
14707 && ckWARN_d(WARN_REDEFINE)
14708 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14711 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14713 ? "Constant subroutine %"SVf" redefined"
14714 : "Subroutine %"SVf" redefined",
14719 =head1 Hook manipulation
14721 These functions provide convenient and thread-safe means of manipulating
14728 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14730 Puts a C function into the chain of check functions for a specified op
14731 type. This is the preferred way to manipulate the L</PL_check> array.
14732 C<opcode> specifies which type of op is to be affected. C<new_checker>
14733 is a pointer to the C function that is to be added to that opcode's
14734 check chain, and C<old_checker_p> points to the storage location where a
14735 pointer to the next function in the chain will be stored. The value of
14736 C<new_pointer> is written into the L</PL_check> array, while the value
14737 previously stored there is written to C<*old_checker_p>.
14739 The function should be defined like this:
14741 static OP *new_checker(pTHX_ OP *op) { ... }
14743 It is intended to be called in this manner:
14745 new_checker(aTHX_ op)
14747 C<old_checker_p> should be defined like this:
14749 static Perl_check_t old_checker_p;
14751 L</PL_check> is global to an entire process, and a module wishing to
14752 hook op checking may find itself invoked more than once per process,
14753 typically in different threads. To handle that situation, this function
14754 is idempotent. The location C<*old_checker_p> must initially (once
14755 per process) contain a null pointer. A C variable of static duration
14756 (declared at file scope, typically also marked C<static> to give
14757 it internal linkage) will be implicitly initialised appropriately,
14758 if it does not have an explicit initialiser. This function will only
14759 actually modify the check chain if it finds C<*old_checker_p> to be null.
14760 This function is also thread safe on the small scale. It uses appropriate
14761 locking to avoid race conditions in accessing L</PL_check>.
14763 When this function is called, the function referenced by C<new_checker>
14764 must be ready to be called, except for C<*old_checker_p> being unfilled.
14765 In a threading situation, C<new_checker> may be called immediately,
14766 even before this function has returned. C<*old_checker_p> will always
14767 be appropriately set before C<new_checker> is called. If C<new_checker>
14768 decides not to do anything special with an op that it is given (which
14769 is the usual case for most uses of op check hooking), it must chain the
14770 check function referenced by C<*old_checker_p>.
14772 If you want to influence compilation of calls to a specific subroutine,
14773 then use L</cv_set_call_checker> rather than hooking checking of all
14780 Perl_wrap_op_checker(pTHX_ Optype opcode,
14781 Perl_check_t new_checker, Perl_check_t *old_checker_p)
14785 PERL_UNUSED_CONTEXT;
14786 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14787 if (*old_checker_p) return;
14788 OP_CHECK_MUTEX_LOCK;
14789 if (!*old_checker_p) {
14790 *old_checker_p = PL_check[opcode];
14791 PL_check[opcode] = new_checker;
14793 OP_CHECK_MUTEX_UNLOCK;
14798 /* Efficient sub that returns a constant scalar value. */
14800 const_sv_xsub(pTHX_ CV* cv)
14803 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14804 PERL_UNUSED_ARG(items);
14814 const_av_xsub(pTHX_ CV* cv)
14817 AV * const av = MUTABLE_AV(XSANY.any_ptr);
14825 if (SvRMAGICAL(av))
14826 Perl_croak(aTHX_ "Magical list constants are not supported");
14827 if (GIMME_V != G_ARRAY) {
14829 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14832 EXTEND(SP, AvFILLp(av)+1);
14833 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14834 XSRETURN(AvFILLp(av)+1);
14838 * ex: set ts=8 sts=4 sw=4 et: