4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
112 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
114 /* Used to avoid recursion through the op tree in scalarvoid() and
118 #define DEFERRED_OP_STEP 100
119 #define DEFER_OP(o) \
121 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
122 defer_stack_alloc += DEFERRED_OP_STEP; \
123 assert(defer_stack_alloc > 0); \
124 Renew(defer_stack, defer_stack_alloc, OP *); \
126 defer_stack[++defer_ix] = o; \
129 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
131 /* remove any leading "empty" ops from the op_next chain whose first
132 * node's address is stored in op_p. Store the updated address of the
133 * first node in op_p.
137 S_prune_chain_head(OP** op_p)
140 && ( (*op_p)->op_type == OP_NULL
141 || (*op_p)->op_type == OP_SCOPE
142 || (*op_p)->op_type == OP_SCALAR
143 || (*op_p)->op_type == OP_LINESEQ)
145 *op_p = (*op_p)->op_next;
149 /* See the explanatory comments above struct opslab in op.h. */
151 #ifdef PERL_DEBUG_READONLY_OPS
152 # define PERL_SLAB_SIZE 128
153 # define PERL_MAX_SLAB_SIZE 4096
154 # include <sys/mman.h>
157 #ifndef PERL_SLAB_SIZE
158 # define PERL_SLAB_SIZE 64
160 #ifndef PERL_MAX_SLAB_SIZE
161 # define PERL_MAX_SLAB_SIZE 2048
164 /* rounds up to nearest pointer */
165 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
166 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
169 S_new_slab(pTHX_ size_t sz)
171 #ifdef PERL_DEBUG_READONLY_OPS
172 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
173 PROT_READ|PROT_WRITE,
174 MAP_ANON|MAP_PRIVATE, -1, 0);
175 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
176 (unsigned long) sz, slab));
177 if (slab == MAP_FAILED) {
178 perror("mmap failed");
181 slab->opslab_size = (U16)sz;
183 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
186 /* The context is unused in non-Windows */
189 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
193 /* requires double parens and aTHX_ */
194 #define DEBUG_S_warn(args) \
196 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
200 Perl_Slab_Alloc(pTHX_ size_t sz)
208 /* We only allocate ops from the slab during subroutine compilation.
209 We find the slab via PL_compcv, hence that must be non-NULL. It could
210 also be pointing to a subroutine which is now fully set up (CvROOT()
211 pointing to the top of the optree for that sub), or a subroutine
212 which isn't using the slab allocator. If our sanity checks aren't met,
213 don't use a slab, but allocate the OP directly from the heap. */
214 if (!PL_compcv || CvROOT(PL_compcv)
215 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
217 o = (OP*)PerlMemShared_calloc(1, sz);
221 /* While the subroutine is under construction, the slabs are accessed via
222 CvSTART(), to avoid needing to expand PVCV by one pointer for something
223 unneeded at runtime. Once a subroutine is constructed, the slabs are
224 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
225 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
227 if (!CvSTART(PL_compcv)) {
229 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
230 CvSLABBED_on(PL_compcv);
231 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
233 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
235 opsz = SIZE_TO_PSIZE(sz);
236 sz = opsz + OPSLOT_HEADER_P;
238 /* The slabs maintain a free list of OPs. In particular, constant folding
239 will free up OPs, so it makes sense to re-use them where possible. A
240 freed up slot is used in preference to a new allocation. */
241 if (slab->opslab_freed) {
242 OP **too = &slab->opslab_freed;
244 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
245 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
246 DEBUG_S_warn((aTHX_ "Alas! too small"));
247 o = *(too = &o->op_next);
248 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
252 Zero(o, opsz, I32 *);
258 #define INIT_OPSLOT \
259 slot->opslot_slab = slab; \
260 slot->opslot_next = slab2->opslab_first; \
261 slab2->opslab_first = slot; \
262 o = &slot->opslot_op; \
265 /* The partially-filled slab is next in the chain. */
266 slab2 = slab->opslab_next ? slab->opslab_next : slab;
267 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
268 /* Remaining space is too small. */
270 /* If we can fit a BASEOP, add it to the free chain, so as not
272 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
273 slot = &slab2->opslab_slots;
275 o->op_type = OP_FREED;
276 o->op_next = slab->opslab_freed;
277 slab->opslab_freed = o;
280 /* Create a new slab. Make this one twice as big. */
281 slot = slab2->opslab_first;
282 while (slot->opslot_next) slot = slot->opslot_next;
283 slab2 = S_new_slab(aTHX_
284 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
286 : (DIFF(slab2, slot)+1)*2);
287 slab2->opslab_next = slab->opslab_next;
288 slab->opslab_next = slab2;
290 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
292 /* Create a new op slot */
293 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
294 assert(slot >= &slab2->opslab_slots);
295 if (DIFF(&slab2->opslab_slots, slot)
296 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
297 slot = &slab2->opslab_slots;
299 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
302 #ifdef PERL_OP_PARENT
303 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
304 assert(!o->op_moresib);
305 assert(!o->op_sibparent);
313 #ifdef PERL_DEBUG_READONLY_OPS
315 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
317 PERL_ARGS_ASSERT_SLAB_TO_RO;
319 if (slab->opslab_readonly) return;
320 slab->opslab_readonly = 1;
321 for (; slab; slab = slab->opslab_next) {
322 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
323 (unsigned long) slab->opslab_size, slab));*/
324 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
325 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
326 (unsigned long)slab->opslab_size, errno);
331 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
335 PERL_ARGS_ASSERT_SLAB_TO_RW;
337 if (!slab->opslab_readonly) return;
339 for (; slab2; slab2 = slab2->opslab_next) {
340 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
341 (unsigned long) size, slab2));*/
342 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
343 PROT_READ|PROT_WRITE)) {
344 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
345 (unsigned long)slab2->opslab_size, errno);
348 slab->opslab_readonly = 0;
352 # define Slab_to_rw(op) NOOP
355 /* This cannot possibly be right, but it was copied from the old slab
356 allocator, to which it was originally added, without explanation, in
359 # define PerlMemShared PerlMem
363 Perl_Slab_Free(pTHX_ void *op)
365 OP * const o = (OP *)op;
368 PERL_ARGS_ASSERT_SLAB_FREE;
370 if (!o->op_slabbed) {
372 PerlMemShared_free(op);
377 /* If this op is already freed, our refcount will get screwy. */
378 assert(o->op_type != OP_FREED);
379 o->op_type = OP_FREED;
380 o->op_next = slab->opslab_freed;
381 slab->opslab_freed = o;
382 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
383 OpslabREFCNT_dec_padok(slab);
387 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
389 const bool havepad = !!PL_comppad;
390 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
393 PAD_SAVE_SETNULLPAD();
400 Perl_opslab_free(pTHX_ OPSLAB *slab)
403 PERL_ARGS_ASSERT_OPSLAB_FREE;
405 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
406 assert(slab->opslab_refcnt == 1);
408 slab2 = slab->opslab_next;
410 slab->opslab_refcnt = ~(size_t)0;
412 #ifdef PERL_DEBUG_READONLY_OPS
413 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
415 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
416 perror("munmap failed");
420 PerlMemShared_free(slab);
427 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
432 size_t savestack_count = 0;
434 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
437 for (slot = slab2->opslab_first;
439 slot = slot->opslot_next) {
440 if (slot->opslot_op.op_type != OP_FREED
441 && !(slot->opslot_op.op_savefree
447 assert(slot->opslot_op.op_slabbed);
448 op_free(&slot->opslot_op);
449 if (slab->opslab_refcnt == 1) goto free;
452 } while ((slab2 = slab2->opslab_next));
453 /* > 1 because the CV still holds a reference count. */
454 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
456 assert(savestack_count == slab->opslab_refcnt-1);
458 /* Remove the CV’s reference count. */
459 slab->opslab_refcnt--;
466 #ifdef PERL_DEBUG_READONLY_OPS
468 Perl_op_refcnt_inc(pTHX_ OP *o)
471 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
472 if (slab && slab->opslab_readonly) {
485 Perl_op_refcnt_dec(pTHX_ OP *o)
488 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
490 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
492 if (slab && slab->opslab_readonly) {
494 result = --o->op_targ;
497 result = --o->op_targ;
503 * In the following definition, the ", (OP*)0" is just to make the compiler
504 * think the expression is of the right type: croak actually does a Siglongjmp.
506 #define CHECKOP(type,o) \
507 ((PL_op_mask && PL_op_mask[type]) \
508 ? ( op_free((OP*)o), \
509 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
511 : PL_check[type](aTHX_ (OP*)o))
513 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
515 #define OpTYPE_set(o,type) \
517 o->op_type = (OPCODE)type; \
518 o->op_ppaddr = PL_ppaddr[type]; \
522 S_no_fh_allowed(pTHX_ OP *o)
524 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
526 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
532 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
534 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
535 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
540 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
542 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
544 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
549 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
551 PERL_ARGS_ASSERT_BAD_TYPE_PV;
553 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
554 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
557 /* remove flags var, its unused in all callers, move to to right end since gv
558 and kid are always the same */
560 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
562 SV * const namesv = cv_name((CV *)gv, NULL, 0);
563 PERL_ARGS_ASSERT_BAD_TYPE_GV;
565 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
566 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
570 S_no_bareword_allowed(pTHX_ OP *o)
572 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
574 qerror(Perl_mess(aTHX_
575 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
577 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
580 /* "register" allocation */
583 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
586 const bool is_our = (PL_parser->in_my == KEY_our);
588 PERL_ARGS_ASSERT_ALLOCMY;
590 if (flags & ~SVf_UTF8)
591 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
594 /* complain about "my $<special_var>" etc etc */
598 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
599 (name[1] == '_' && len > 2)))
601 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
603 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
604 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
605 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
606 PL_parser->in_my == KEY_state ? "state" : "my"));
608 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
609 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
613 /* allocate a spare slot and store the name in that slot */
615 off = pad_add_name_pvn(name, len,
616 (is_our ? padadd_OUR :
617 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
618 PL_parser->in_my_stash,
620 /* $_ is always in main::, even with our */
621 ? (PL_curstash && !memEQs(name,len,"$_")
627 /* anon sub prototypes contains state vars should always be cloned,
628 * otherwise the state var would be shared between anon subs */
630 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
631 CvCLONE_on(PL_compcv);
637 =head1 Optree Manipulation Functions
639 =for apidoc alloccopstash
641 Available only under threaded builds, this function allocates an entry in
642 C<PL_stashpad> for the stash passed to it.
649 Perl_alloccopstash(pTHX_ HV *hv)
651 PADOFFSET off = 0, o = 1;
652 bool found_slot = FALSE;
654 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
656 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
658 for (; o < PL_stashpadmax; ++o) {
659 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
660 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
661 found_slot = TRUE, off = o;
664 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
665 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
666 off = PL_stashpadmax;
667 PL_stashpadmax += 10;
670 PL_stashpad[PL_stashpadix = off] = hv;
675 /* free the body of an op without examining its contents.
676 * Always use this rather than FreeOp directly */
679 S_op_destroy(pTHX_ OP *o)
687 =for apidoc Am|void|op_free|OP *o
689 Free an op. Only use this when an op is no longer linked to from any
696 Perl_op_free(pTHX_ OP *o)
700 SSize_t defer_ix = -1;
701 SSize_t defer_stack_alloc = 0;
702 OP **defer_stack = NULL;
706 /* Though ops may be freed twice, freeing the op after its slab is a
708 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
709 /* During the forced freeing of ops after compilation failure, kidops
710 may be freed before their parents. */
711 if (!o || o->op_type == OP_FREED)
716 /* an op should only ever acquire op_private flags that we know about.
717 * If this fails, you may need to fix something in regen/op_private.
718 * Don't bother testing if:
719 * * the op_ppaddr doesn't match the op; someone may have
720 * overridden the op and be doing strange things with it;
721 * * we've errored, as op flags are often left in an
722 * inconsistent state then. Note that an error when
723 * compiling the main program leaves PL_parser NULL, so
724 * we can't spot faults in the main code, only
725 * evaled/required code */
727 if ( o->op_ppaddr == PL_ppaddr[o->op_type]
729 && !PL_parser->error_count)
731 assert(!(o->op_private & ~PL_op_private_valid[type]));
735 if (o->op_private & OPpREFCOUNTED) {
746 refcnt = OpREFCNT_dec(o);
749 /* Need to find and remove any pattern match ops from the list
750 we maintain for reset(). */
751 find_and_forget_pmops(o);
761 /* Call the op_free hook if it has been set. Do it now so that it's called
762 * at the right time for refcounted ops, but still before all of the kids
766 if (o->op_flags & OPf_KIDS) {
768 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
769 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
770 if (!kid || kid->op_type == OP_FREED)
771 /* During the forced freeing of ops after
772 compilation failure, kidops may be freed before
775 if (!(kid->op_flags & OPf_KIDS))
776 /* If it has no kids, just free it now */
783 type = (OPCODE)o->op_targ;
786 Slab_to_rw(OpSLAB(o));
788 /* COP* is not cleared by op_clear() so that we may track line
789 * numbers etc even after null() */
790 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
796 #ifdef DEBUG_LEAKING_SCALARS
800 } while ( (o = POP_DEFERRED_OP()) );
802 Safefree(defer_stack);
805 /* S_op_clear_gv(): free a GV attached to an OP */
809 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
811 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
815 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
816 || o->op_type == OP_MULTIDEREF)
819 ? ((GV*)PAD_SVl(*ixp)) : NULL;
821 ? (GV*)(*svp) : NULL;
823 /* It's possible during global destruction that the GV is freed
824 before the optree. Whilst the SvREFCNT_inc is happy to bump from
825 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
826 will trigger an assertion failure, because the entry to sv_clear
827 checks that the scalar is not already freed. A check of for
828 !SvIS_FREED(gv) turns out to be invalid, because during global
829 destruction the reference count can be forced down to zero
830 (with SVf_BREAK set). In which case raising to 1 and then
831 dropping to 0 triggers cleanup before it should happen. I
832 *think* that this might actually be a general, systematic,
833 weakness of the whole idea of SVf_BREAK, in that code *is*
834 allowed to raise and lower references during global destruction,
835 so any *valid* code that happens to do this during global
836 destruction might well trigger premature cleanup. */
837 bool still_valid = gv && SvREFCNT(gv);
840 SvREFCNT_inc_simple_void(gv);
843 pad_swipe(*ixp, TRUE);
851 int try_downgrade = SvREFCNT(gv) == 2;
854 gv_try_downgrade(gv);
860 Perl_op_clear(pTHX_ OP *o)
865 PERL_ARGS_ASSERT_OP_CLEAR;
867 switch (o->op_type) {
868 case OP_NULL: /* Was holding old type, if any. */
871 case OP_ENTEREVAL: /* Was holding hints. */
875 if (!(o->op_flags & OPf_REF)
876 || (PL_check[o->op_type] != Perl_ck_ftst))
883 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
885 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
888 case OP_METHOD_REDIR:
889 case OP_METHOD_REDIR_SUPER:
891 if (cMETHOPx(o)->op_rclass_targ) {
892 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
893 cMETHOPx(o)->op_rclass_targ = 0;
896 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
897 cMETHOPx(o)->op_rclass_sv = NULL;
899 case OP_METHOD_NAMED:
900 case OP_METHOD_SUPER:
901 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
902 cMETHOPx(o)->op_u.op_meth_sv = NULL;
905 pad_swipe(o->op_targ, 1);
912 SvREFCNT_dec(cSVOPo->op_sv);
913 cSVOPo->op_sv = NULL;
916 Even if op_clear does a pad_free for the target of the op,
917 pad_free doesn't actually remove the sv that exists in the pad;
918 instead it lives on. This results in that it could be reused as
919 a target later on when the pad was reallocated.
922 pad_swipe(o->op_targ,1);
932 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
937 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
938 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
940 if (cPADOPo->op_padix > 0) {
941 pad_swipe(cPADOPo->op_padix, TRUE);
942 cPADOPo->op_padix = 0;
945 SvREFCNT_dec(cSVOPo->op_sv);
946 cSVOPo->op_sv = NULL;
950 PerlMemShared_free(cPVOPo->op_pv);
951 cPVOPo->op_pv = NULL;
955 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
959 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
960 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
963 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
969 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
970 op_free(cPMOPo->op_code_list);
971 cPMOPo->op_code_list = NULL;
973 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
974 /* we use the same protection as the "SAFE" version of the PM_ macros
975 * here since sv_clean_all might release some PMOPs
976 * after PL_regex_padav has been cleared
977 * and the clearing of PL_regex_padav needs to
978 * happen before sv_clean_all
981 if(PL_regex_pad) { /* We could be in destruction */
982 const IV offset = (cPMOPo)->op_pmoffset;
983 ReREFCNT_dec(PM_GETRE(cPMOPo));
984 PL_regex_pad[offset] = &PL_sv_undef;
985 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
989 ReREFCNT_dec(PM_GETRE(cPMOPo));
990 PM_SETRE(cPMOPo, NULL);
997 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
998 UV actions = items->uv;
1000 bool is_hash = FALSE;
1003 switch (actions & MDEREF_ACTION_MASK) {
1006 actions = (++items)->uv;
1009 case MDEREF_HV_padhv_helem:
1011 case MDEREF_AV_padav_aelem:
1012 pad_free((++items)->pad_offset);
1015 case MDEREF_HV_gvhv_helem:
1017 case MDEREF_AV_gvav_aelem:
1019 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1021 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1025 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1027 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1029 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1031 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1033 goto do_vivify_rv2xv_elem;
1035 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1037 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1038 pad_free((++items)->pad_offset);
1039 goto do_vivify_rv2xv_elem;
1041 case MDEREF_HV_pop_rv2hv_helem:
1042 case MDEREF_HV_vivify_rv2hv_helem:
1044 do_vivify_rv2xv_elem:
1045 case MDEREF_AV_pop_rv2av_aelem:
1046 case MDEREF_AV_vivify_rv2av_aelem:
1048 switch (actions & MDEREF_INDEX_MASK) {
1049 case MDEREF_INDEX_none:
1052 case MDEREF_INDEX_const:
1056 pad_swipe((++items)->pad_offset, 1);
1058 SvREFCNT_dec((++items)->sv);
1064 case MDEREF_INDEX_padsv:
1065 pad_free((++items)->pad_offset);
1067 case MDEREF_INDEX_gvsv:
1069 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1071 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1076 if (actions & MDEREF_FLAG_last)
1089 actions >>= MDEREF_SHIFT;
1092 /* start of malloc is at op_aux[-1], where the length is
1094 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1099 if (o->op_targ > 0) {
1100 pad_free(o->op_targ);
1106 S_cop_free(pTHX_ COP* cop)
1108 PERL_ARGS_ASSERT_COP_FREE;
1111 if (! specialWARN(cop->cop_warnings))
1112 PerlMemShared_free(cop->cop_warnings);
1113 cophh_free(CopHINTHASH_get(cop));
1114 if (PL_curcop == cop)
1119 S_forget_pmop(pTHX_ PMOP *const o
1122 HV * const pmstash = PmopSTASH(o);
1124 PERL_ARGS_ASSERT_FORGET_PMOP;
1126 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1127 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1129 PMOP **const array = (PMOP**) mg->mg_ptr;
1130 U32 count = mg->mg_len / sizeof(PMOP**);
1134 if (array[i] == o) {
1135 /* Found it. Move the entry at the end to overwrite it. */
1136 array[i] = array[--count];
1137 mg->mg_len = count * sizeof(PMOP**);
1138 /* Could realloc smaller at this point always, but probably
1139 not worth it. Probably worth free()ing if we're the
1142 Safefree(mg->mg_ptr);
1155 S_find_and_forget_pmops(pTHX_ OP *o)
1157 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1159 if (o->op_flags & OPf_KIDS) {
1160 OP *kid = cUNOPo->op_first;
1162 switch (kid->op_type) {
1167 forget_pmop((PMOP*)kid);
1169 find_and_forget_pmops(kid);
1170 kid = OpSIBLING(kid);
1176 =for apidoc Am|void|op_null|OP *o
1178 Neutralizes an op when it is no longer needed, but is still linked to from
1185 Perl_op_null(pTHX_ OP *o)
1189 PERL_ARGS_ASSERT_OP_NULL;
1191 if (o->op_type == OP_NULL)
1194 o->op_targ = o->op_type;
1195 OpTYPE_set(o, OP_NULL);
1199 Perl_op_refcnt_lock(pTHX)
1200 PERL_TSA_ACQUIRE(PL_op_mutex)
1205 PERL_UNUSED_CONTEXT;
1210 Perl_op_refcnt_unlock(pTHX)
1211 PERL_TSA_RELEASE(PL_op_mutex)
1216 PERL_UNUSED_CONTEXT;
1222 =for apidoc op_sibling_splice
1224 A general function for editing the structure of an existing chain of
1225 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1226 you to delete zero or more sequential nodes, replacing them with zero or
1227 more different nodes. Performs the necessary op_first/op_last
1228 housekeeping on the parent node and op_sibling manipulation on the
1229 children. The last deleted node will be marked as as the last node by
1230 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1232 Note that op_next is not manipulated, and nodes are not freed; that is the
1233 responsibility of the caller. It also won't create a new list op for an
1234 empty list etc; use higher-level functions like op_append_elem() for that.
1236 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1237 the splicing doesn't affect the first or last op in the chain.
1239 C<start> is the node preceding the first node to be spliced. Node(s)
1240 following it will be deleted, and ops will be inserted after it. If it is
1241 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1244 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1245 If -1 or greater than or equal to the number of remaining kids, all
1246 remaining kids are deleted.
1248 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1249 If C<NULL>, no nodes are inserted.
1251 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1256 action before after returns
1257 ------ ----- ----- -------
1260 splice(P, A, 2, X-Y-Z) | | B-C
1264 splice(P, NULL, 1, X-Y) | | A
1268 splice(P, NULL, 3, NULL) | | A-B-C
1272 splice(P, B, 0, X-Y) | | NULL
1276 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1277 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1283 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1287 OP *last_del = NULL;
1288 OP *last_ins = NULL;
1291 first = OpSIBLING(start);
1295 first = cLISTOPx(parent)->op_first;
1297 assert(del_count >= -1);
1299 if (del_count && first) {
1301 while (--del_count && OpHAS_SIBLING(last_del))
1302 last_del = OpSIBLING(last_del);
1303 rest = OpSIBLING(last_del);
1304 OpLASTSIB_set(last_del, NULL);
1311 while (OpHAS_SIBLING(last_ins))
1312 last_ins = OpSIBLING(last_ins);
1313 OpMAYBESIB_set(last_ins, rest, NULL);
1319 OpMAYBESIB_set(start, insert, NULL);
1324 cLISTOPx(parent)->op_first = insert;
1326 parent->op_flags |= OPf_KIDS;
1328 parent->op_flags &= ~OPf_KIDS;
1332 /* update op_last etc */
1339 /* ought to use OP_CLASS(parent) here, but that can't handle
1340 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1342 type = parent->op_type;
1343 if (type == OP_CUSTOM) {
1345 type = XopENTRYCUSTOM(parent, xop_class);
1348 if (type == OP_NULL)
1349 type = parent->op_targ;
1350 type = PL_opargs[type] & OA_CLASS_MASK;
1353 lastop = last_ins ? last_ins : start ? start : NULL;
1354 if ( type == OA_BINOP
1355 || type == OA_LISTOP
1359 cLISTOPx(parent)->op_last = lastop;
1362 OpLASTSIB_set(lastop, parent);
1364 return last_del ? first : NULL;
1367 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1371 #ifdef PERL_OP_PARENT
1374 =for apidoc op_parent
1376 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1377 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1383 Perl_op_parent(OP *o)
1385 PERL_ARGS_ASSERT_OP_PARENT;
1386 while (OpHAS_SIBLING(o))
1388 return o->op_sibparent;
1394 /* replace the sibling following start with a new UNOP, which becomes
1395 * the parent of the original sibling; e.g.
1397 * op_sibling_newUNOP(P, A, unop-args...)
1405 * where U is the new UNOP.
1407 * parent and start args are the same as for op_sibling_splice();
1408 * type and flags args are as newUNOP().
1410 * Returns the new UNOP.
1414 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1418 kid = op_sibling_splice(parent, start, 1, NULL);
1419 newop = newUNOP(type, flags, kid);
1420 op_sibling_splice(parent, start, 0, newop);
1425 /* lowest-level newLOGOP-style function - just allocates and populates
1426 * the struct. Higher-level stuff should be done by S_new_logop() /
1427 * newLOGOP(). This function exists mainly to avoid op_first assignment
1428 * being spread throughout this file.
1432 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1437 NewOp(1101, logop, 1, LOGOP);
1438 OpTYPE_set(logop, type);
1439 logop->op_first = first;
1440 logop->op_other = other;
1441 logop->op_flags = OPf_KIDS;
1442 while (kid && OpHAS_SIBLING(kid))
1443 kid = OpSIBLING(kid);
1445 OpLASTSIB_set(kid, (OP*)logop);
1450 /* Contextualizers */
1453 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1455 Applies a syntactic context to an op tree representing an expression.
1456 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1457 or C<G_VOID> to specify the context to apply. The modified op tree
1464 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1466 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1468 case G_SCALAR: return scalar(o);
1469 case G_ARRAY: return list(o);
1470 case G_VOID: return scalarvoid(o);
1472 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1479 =for apidoc Am|OP*|op_linklist|OP *o
1480 This function is the implementation of the L</LINKLIST> macro. It should
1481 not be called directly.
1487 Perl_op_linklist(pTHX_ OP *o)
1491 PERL_ARGS_ASSERT_OP_LINKLIST;
1496 /* establish postfix order */
1497 first = cUNOPo->op_first;
1500 o->op_next = LINKLIST(first);
1503 OP *sibl = OpSIBLING(kid);
1505 kid->op_next = LINKLIST(sibl);
1520 S_scalarkids(pTHX_ OP *o)
1522 if (o && o->op_flags & OPf_KIDS) {
1524 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1531 S_scalarboolean(pTHX_ OP *o)
1533 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1535 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1536 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1537 if (ckWARN(WARN_SYNTAX)) {
1538 const line_t oldline = CopLINE(PL_curcop);
1540 if (PL_parser && PL_parser->copline != NOLINE) {
1541 /* This ensures that warnings are reported at the first line
1542 of the conditional, not the last. */
1543 CopLINE_set(PL_curcop, PL_parser->copline);
1545 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1546 CopLINE_set(PL_curcop, oldline);
1553 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1556 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1557 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1559 const char funny = o->op_type == OP_PADAV
1560 || o->op_type == OP_RV2AV ? '@' : '%';
1561 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1563 if (cUNOPo->op_first->op_type != OP_GV
1564 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1566 return varname(gv, funny, 0, NULL, 0, subscript_type);
1569 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1574 S_op_varname(pTHX_ const OP *o)
1576 return S_op_varname_subscript(aTHX_ o, 1);
1580 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1581 { /* or not so pretty :-) */
1582 if (o->op_type == OP_CONST) {
1584 if (SvPOK(*retsv)) {
1586 *retsv = sv_newmortal();
1587 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1588 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1590 else if (!SvOK(*retsv))
1593 else *retpv = "...";
1597 S_scalar_slice_warning(pTHX_ const OP *o)
1601 o->op_type == OP_HSLICE ? '{' : '[';
1603 o->op_type == OP_HSLICE ? '}' : ']';
1605 SV *keysv = NULL; /* just to silence compiler warnings */
1606 const char *key = NULL;
1608 if (!(o->op_private & OPpSLICEWARNING))
1610 if (PL_parser && PL_parser->error_count)
1611 /* This warning can be nonsensical when there is a syntax error. */
1614 kid = cLISTOPo->op_first;
1615 kid = OpSIBLING(kid); /* get past pushmark */
1616 /* weed out false positives: any ops that can return lists */
1617 switch (kid->op_type) {
1643 /* Don't warn if we have a nulled list either. */
1644 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1647 assert(OpSIBLING(kid));
1648 name = S_op_varname(aTHX_ OpSIBLING(kid));
1649 if (!name) /* XS module fiddling with the op tree */
1651 S_op_pretty(aTHX_ kid, &keysv, &key);
1652 assert(SvPOK(name));
1653 sv_chop(name,SvPVX(name)+1);
1655 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1656 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1657 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1659 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1660 lbrack, key, rbrack);
1662 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1663 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1664 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1666 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1667 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1671 Perl_scalar(pTHX_ OP *o)
1675 /* assumes no premature commitment */
1676 if (!o || (PL_parser && PL_parser->error_count)
1677 || (o->op_flags & OPf_WANT)
1678 || o->op_type == OP_RETURN)
1683 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1685 switch (o->op_type) {
1687 scalar(cBINOPo->op_first);
1688 if (o->op_private & OPpREPEAT_DOLIST) {
1689 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1690 assert(kid->op_type == OP_PUSHMARK);
1691 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1692 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1693 o->op_private &=~ OPpREPEAT_DOLIST;
1700 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1710 if (o->op_flags & OPf_KIDS) {
1711 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1717 kid = cLISTOPo->op_first;
1719 kid = OpSIBLING(kid);
1722 OP *sib = OpSIBLING(kid);
1723 if (sib && kid->op_type != OP_LEAVEWHEN
1724 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1725 || ( sib->op_targ != OP_NEXTSTATE
1726 && sib->op_targ != OP_DBSTATE )))
1732 PL_curcop = &PL_compiling;
1737 kid = cLISTOPo->op_first;
1740 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1745 /* Warn about scalar context */
1746 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1747 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1750 const char *key = NULL;
1752 /* This warning can be nonsensical when there is a syntax error. */
1753 if (PL_parser && PL_parser->error_count)
1756 if (!ckWARN(WARN_SYNTAX)) break;
1758 kid = cLISTOPo->op_first;
1759 kid = OpSIBLING(kid); /* get past pushmark */
1760 assert(OpSIBLING(kid));
1761 name = S_op_varname(aTHX_ OpSIBLING(kid));
1762 if (!name) /* XS module fiddling with the op tree */
1764 S_op_pretty(aTHX_ kid, &keysv, &key);
1765 assert(SvPOK(name));
1766 sv_chop(name,SvPVX(name)+1);
1768 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1769 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1770 "%%%"SVf"%c%s%c in scalar context better written "
1772 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1773 lbrack, key, rbrack);
1775 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1776 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1777 "%%%"SVf"%c%"SVf"%c in scalar context better "
1778 "written as $%"SVf"%c%"SVf"%c",
1779 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1780 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1787 Perl_scalarvoid(pTHX_ OP *arg)
1793 SSize_t defer_stack_alloc = 0;
1794 SSize_t defer_ix = -1;
1795 OP **defer_stack = NULL;
1798 PERL_ARGS_ASSERT_SCALARVOID;
1801 SV *useless_sv = NULL;
1802 const char* useless = NULL;
1804 if (o->op_type == OP_NEXTSTATE
1805 || o->op_type == OP_DBSTATE
1806 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1807 || o->op_targ == OP_DBSTATE)))
1808 PL_curcop = (COP*)o; /* for warning below */
1810 /* assumes no premature commitment */
1811 want = o->op_flags & OPf_WANT;
1812 if ((want && want != OPf_WANT_SCALAR)
1813 || (PL_parser && PL_parser->error_count)
1814 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1819 if ((o->op_private & OPpTARGET_MY)
1820 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1822 /* newASSIGNOP has already applied scalar context, which we
1823 leave, as if this op is inside SASSIGN. */
1827 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1829 switch (o->op_type) {
1831 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1835 if (o->op_flags & OPf_STACKED)
1837 if (o->op_type == OP_REPEAT)
1838 scalar(cBINOPo->op_first);
1841 if (o->op_private == 4)
1876 case OP_GETSOCKNAME:
1877 case OP_GETPEERNAME:
1882 case OP_GETPRIORITY:
1907 useless = OP_DESC(o);
1917 case OP_AELEMFAST_LEX:
1921 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1922 /* Otherwise it's "Useless use of grep iterator" */
1923 useless = OP_DESC(o);
1927 kid = cLISTOPo->op_first;
1928 if (kid && kid->op_type == OP_PUSHRE
1930 && !(o->op_flags & OPf_STACKED)
1932 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1934 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1937 useless = OP_DESC(o);
1941 kid = cUNOPo->op_first;
1942 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1943 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1946 useless = "negative pattern binding (!~)";
1950 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1951 useless = "non-destructive substitution (s///r)";
1955 useless = "non-destructive transliteration (tr///r)";
1962 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1963 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1964 useless = "a variable";
1969 if (cSVOPo->op_private & OPpCONST_STRICT)
1970 no_bareword_allowed(o);
1972 if (ckWARN(WARN_VOID)) {
1974 /* don't warn on optimised away booleans, eg
1975 * use constant Foo, 5; Foo || print; */
1976 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1978 /* the constants 0 and 1 are permitted as they are
1979 conventionally used as dummies in constructs like
1980 1 while some_condition_with_side_effects; */
1981 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1983 else if (SvPOK(sv)) {
1984 SV * const dsv = newSVpvs("");
1986 = Perl_newSVpvf(aTHX_
1988 pv_pretty(dsv, SvPVX_const(sv),
1989 SvCUR(sv), 32, NULL, NULL,
1991 | PERL_PV_ESCAPE_NOCLEAR
1992 | PERL_PV_ESCAPE_UNI_DETECT));
1993 SvREFCNT_dec_NN(dsv);
1995 else if (SvOK(sv)) {
1996 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1999 useless = "a constant (undef)";
2002 op_null(o); /* don't execute or even remember it */
2006 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2010 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2014 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2018 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2023 UNOP *refgen, *rv2cv;
2026 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2029 rv2gv = ((BINOP *)o)->op_last;
2030 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2033 refgen = (UNOP *)((BINOP *)o)->op_first;
2035 if (!refgen || (refgen->op_type != OP_REFGEN
2036 && refgen->op_type != OP_SREFGEN))
2039 exlist = (LISTOP *)refgen->op_first;
2040 if (!exlist || exlist->op_type != OP_NULL
2041 || exlist->op_targ != OP_LIST)
2044 if (exlist->op_first->op_type != OP_PUSHMARK
2045 && exlist->op_first != exlist->op_last)
2048 rv2cv = (UNOP*)exlist->op_last;
2050 if (rv2cv->op_type != OP_RV2CV)
2053 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2054 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2055 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2057 o->op_private |= OPpASSIGN_CV_TO_GV;
2058 rv2gv->op_private |= OPpDONT_INIT_GV;
2059 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2071 kid = cLOGOPo->op_first;
2072 if (kid->op_type == OP_NOT
2073 && (kid->op_flags & OPf_KIDS)) {
2074 if (o->op_type == OP_AND) {
2075 OpTYPE_set(o, OP_OR);
2077 OpTYPE_set(o, OP_AND);
2087 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2088 if (!(kid->op_flags & OPf_KIDS))
2095 if (o->op_flags & OPf_STACKED)
2102 if (!(o->op_flags & OPf_KIDS))
2113 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2114 if (!(kid->op_flags & OPf_KIDS))
2120 /* If the first kid after pushmark is something that the padrange
2121 optimisation would reject, then null the list and the pushmark.
2123 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2124 && ( !(kid = OpSIBLING(kid))
2125 || ( kid->op_type != OP_PADSV
2126 && kid->op_type != OP_PADAV
2127 && kid->op_type != OP_PADHV)
2128 || kid->op_private & ~OPpLVAL_INTRO
2129 || !(kid = OpSIBLING(kid))
2130 || ( kid->op_type != OP_PADSV
2131 && kid->op_type != OP_PADAV
2132 && kid->op_type != OP_PADHV)
2133 || kid->op_private & ~OPpLVAL_INTRO)
2135 op_null(cUNOPo->op_first); /* NULL the pushmark */
2136 op_null(o); /* NULL the list */
2148 /* mortalise it, in case warnings are fatal. */
2149 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2150 "Useless use of %"SVf" in void context",
2151 SVfARG(sv_2mortal(useless_sv)));
2154 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2155 "Useless use of %s in void context",
2158 } while ( (o = POP_DEFERRED_OP()) );
2160 Safefree(defer_stack);
2166 S_listkids(pTHX_ OP *o)
2168 if (o && o->op_flags & OPf_KIDS) {
2170 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2177 Perl_list(pTHX_ OP *o)
2181 /* assumes no premature commitment */
2182 if (!o || (o->op_flags & OPf_WANT)
2183 || (PL_parser && PL_parser->error_count)
2184 || o->op_type == OP_RETURN)
2189 if ((o->op_private & OPpTARGET_MY)
2190 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2192 return o; /* As if inside SASSIGN */
2195 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2197 switch (o->op_type) {
2199 list(cBINOPo->op_first);
2202 if (o->op_private & OPpREPEAT_DOLIST
2203 && !(o->op_flags & OPf_STACKED))
2205 list(cBINOPo->op_first);
2206 kid = cBINOPo->op_last;
2207 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2208 && SvIVX(kSVOP_sv) == 1)
2210 op_null(o); /* repeat */
2211 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2213 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2220 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2228 if (!(o->op_flags & OPf_KIDS))
2230 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2231 list(cBINOPo->op_first);
2232 return gen_constant_list(o);
2238 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2239 op_null(cUNOPo->op_first); /* NULL the pushmark */
2240 op_null(o); /* NULL the list */
2245 kid = cLISTOPo->op_first;
2247 kid = OpSIBLING(kid);
2250 OP *sib = OpSIBLING(kid);
2251 if (sib && kid->op_type != OP_LEAVEWHEN)
2257 PL_curcop = &PL_compiling;
2261 kid = cLISTOPo->op_first;
2268 S_scalarseq(pTHX_ OP *o)
2271 const OPCODE type = o->op_type;
2273 if (type == OP_LINESEQ || type == OP_SCOPE ||
2274 type == OP_LEAVE || type == OP_LEAVETRY)
2277 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2278 if ((sib = OpSIBLING(kid))
2279 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2280 || ( sib->op_targ != OP_NEXTSTATE
2281 && sib->op_targ != OP_DBSTATE )))
2286 PL_curcop = &PL_compiling;
2288 o->op_flags &= ~OPf_PARENS;
2289 if (PL_hints & HINT_BLOCK_SCOPE)
2290 o->op_flags |= OPf_PARENS;
2293 o = newOP(OP_STUB, 0);
2298 S_modkids(pTHX_ OP *o, I32 type)
2300 if (o && o->op_flags & OPf_KIDS) {
2302 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2303 op_lvalue(kid, type);
2309 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2310 * const fields. Also, convert CONST keys to HEK-in-SVs.
2311 * rop is the op that retrieves the hash;
2312 * key_op is the first key
2316 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2322 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2324 if (rop->op_first->op_type == OP_PADSV)
2325 /* @$hash{qw(keys here)} */
2326 rop = (UNOP*)rop->op_first;
2328 /* @{$hash}{qw(keys here)} */
2329 if (rop->op_first->op_type == OP_SCOPE
2330 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2332 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2339 lexname = NULL; /* just to silence compiler warnings */
2340 fields = NULL; /* just to silence compiler warnings */
2344 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2345 SvPAD_TYPED(lexname))
2346 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2347 && isGV(*fields) && GvHV(*fields);
2349 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2351 if (key_op->op_type != OP_CONST)
2353 svp = cSVOPx_svp(key_op);
2355 /* make sure it's not a bareword under strict subs */
2356 if (key_op->op_private & OPpCONST_BARE &&
2357 key_op->op_private & OPpCONST_STRICT)
2359 no_bareword_allowed((OP*)key_op);
2362 /* Make the CONST have a shared SV */
2363 if ( !SvIsCOW_shared_hash(sv = *svp)
2364 && SvTYPE(sv) < SVt_PVMG
2369 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2370 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2371 SvREFCNT_dec_NN(sv);
2376 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2378 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2379 "in variable %"PNf" of type %"HEKf,
2380 SVfARG(*svp), PNfARG(lexname),
2381 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2388 =for apidoc finalize_optree
2390 This function finalizes the optree. Should be called directly after
2391 the complete optree is built. It does some additional
2392 checking which can't be done in the normal C<ck_>xxx functions and makes
2393 the tree thread-safe.
2398 Perl_finalize_optree(pTHX_ OP* o)
2400 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2403 SAVEVPTR(PL_curcop);
2411 /* Relocate sv to the pad for thread safety.
2412 * Despite being a "constant", the SV is written to,
2413 * for reference counts, sv_upgrade() etc. */
2414 PERL_STATIC_INLINE void
2415 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2418 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2420 ix = pad_alloc(OP_CONST, SVf_READONLY);
2421 SvREFCNT_dec(PAD_SVl(ix));
2422 PAD_SETSV(ix, *svp);
2423 /* XXX I don't know how this isn't readonly already. */
2424 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2432 S_finalize_op(pTHX_ OP* o)
2434 PERL_ARGS_ASSERT_FINALIZE_OP;
2437 switch (o->op_type) {
2440 PL_curcop = ((COP*)o); /* for warnings */
2443 if (OpHAS_SIBLING(o)) {
2444 OP *sib = OpSIBLING(o);
2445 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2446 && ckWARN(WARN_EXEC)
2447 && OpHAS_SIBLING(sib))
2449 const OPCODE type = OpSIBLING(sib)->op_type;
2450 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2451 const line_t oldline = CopLINE(PL_curcop);
2452 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2453 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2454 "Statement unlikely to be reached");
2455 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2456 "\t(Maybe you meant system() when you said exec()?)\n");
2457 CopLINE_set(PL_curcop, oldline);
2464 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2465 GV * const gv = cGVOPo_gv;
2466 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2467 /* XXX could check prototype here instead of just carping */
2468 SV * const sv = sv_newmortal();
2469 gv_efullname3(sv, gv, NULL);
2470 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2471 "%"SVf"() called too early to check prototype",
2478 if (cSVOPo->op_private & OPpCONST_STRICT)
2479 no_bareword_allowed(o);
2483 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2488 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2489 case OP_METHOD_NAMED:
2490 case OP_METHOD_SUPER:
2491 case OP_METHOD_REDIR:
2492 case OP_METHOD_REDIR_SUPER:
2493 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2502 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2505 rop = (UNOP*)((BINOP*)o)->op_first;
2510 S_scalar_slice_warning(aTHX_ o);
2514 kid = OpSIBLING(cLISTOPo->op_first);
2515 if (/* I bet there's always a pushmark... */
2516 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2517 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2522 key_op = (SVOP*)(kid->op_type == OP_CONST
2524 : OpSIBLING(kLISTOP->op_first));
2526 rop = (UNOP*)((LISTOP*)o)->op_last;
2529 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2531 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2535 S_scalar_slice_warning(aTHX_ o);
2539 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2540 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2547 if (o->op_flags & OPf_KIDS) {
2551 /* check that op_last points to the last sibling, and that
2552 * the last op_sibling/op_sibparent field points back to the
2553 * parent, and that the only ops with KIDS are those which are
2554 * entitled to them */
2555 U32 type = o->op_type;
2559 if (type == OP_NULL) {
2561 /* ck_glob creates a null UNOP with ex-type GLOB
2562 * (which is a list op. So pretend it wasn't a listop */
2563 if (type == OP_GLOB)
2566 family = PL_opargs[type] & OA_CLASS_MASK;
2568 has_last = ( family == OA_BINOP
2569 || family == OA_LISTOP
2570 || family == OA_PMOP
2571 || family == OA_LOOP
2573 assert( has_last /* has op_first and op_last, or ...
2574 ... has (or may have) op_first: */
2575 || family == OA_UNOP
2576 || family == OA_UNOP_AUX
2577 || family == OA_LOGOP
2578 || family == OA_BASEOP_OR_UNOP
2579 || family == OA_FILESTATOP
2580 || family == OA_LOOPEXOP
2581 || family == OA_METHOP
2582 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2583 || type == OP_SASSIGN
2584 || type == OP_CUSTOM
2585 || type == OP_NULL /* new_logop does this */
2588 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2589 # ifdef PERL_OP_PARENT
2590 if (!OpHAS_SIBLING(kid)) {
2592 assert(kid == cLISTOPo->op_last);
2593 assert(kid->op_sibparent == o);
2596 if (has_last && !OpHAS_SIBLING(kid))
2597 assert(kid == cLISTOPo->op_last);
2602 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2608 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2610 Propagate lvalue ("modifiable") context to an op and its children.
2611 C<type> represents the context type, roughly based on the type of op that
2612 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2613 because it has no op type of its own (it is signalled by a flag on
2616 This function detects things that can't be modified, such as C<$x+1>, and
2617 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2618 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2620 It also flags things that need to behave specially in an lvalue context,
2621 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2627 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2630 PadnameLVALUE_on(pn);
2631 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2633 /* RT #127786: cv can be NULL due to an eval within the DB package
2634 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2635 * unless they contain an eval, but calling eval within DB
2636 * pretends the eval was done in the caller's scope.
2640 assert(CvPADLIST(cv));
2642 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2643 assert(PadnameLEN(pn));
2644 PadnameLVALUE_on(pn);
2649 S_vivifies(const OPCODE type)
2652 case OP_RV2AV: case OP_ASLICE:
2653 case OP_RV2HV: case OP_KVASLICE:
2654 case OP_RV2SV: case OP_HSLICE:
2655 case OP_AELEMFAST: case OP_KVHSLICE:
2664 S_lvref(pTHX_ OP *o, I32 type)
2668 switch (o->op_type) {
2670 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2671 kid = OpSIBLING(kid))
2672 S_lvref(aTHX_ kid, type);
2677 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2678 o->op_flags |= OPf_STACKED;
2679 if (o->op_flags & OPf_PARENS) {
2680 if (o->op_private & OPpLVAL_INTRO) {
2681 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2682 "localized parenthesized array in list assignment"));
2686 OpTYPE_set(o, OP_LVAVREF);
2687 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2688 o->op_flags |= OPf_MOD|OPf_REF;
2691 o->op_private |= OPpLVREF_AV;
2694 kid = cUNOPo->op_first;
2695 if (kid->op_type == OP_NULL)
2696 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2698 o->op_private = OPpLVREF_CV;
2699 if (kid->op_type == OP_GV)
2700 o->op_flags |= OPf_STACKED;
2701 else if (kid->op_type == OP_PADCV) {
2702 o->op_targ = kid->op_targ;
2704 op_free(cUNOPo->op_first);
2705 cUNOPo->op_first = NULL;
2706 o->op_flags &=~ OPf_KIDS;
2711 if (o->op_flags & OPf_PARENS) {
2713 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2714 "parenthesized hash in list assignment"));
2717 o->op_private |= OPpLVREF_HV;
2721 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2722 o->op_flags |= OPf_STACKED;
2725 if (o->op_flags & OPf_PARENS) goto parenhash;
2726 o->op_private |= OPpLVREF_HV;
2729 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2732 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2733 if (o->op_flags & OPf_PARENS) goto slurpy;
2734 o->op_private |= OPpLVREF_AV;
2738 o->op_private |= OPpLVREF_ELEM;
2739 o->op_flags |= OPf_STACKED;
2743 OpTYPE_set(o, OP_LVREFSLICE);
2744 o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2747 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2749 else if (!(o->op_flags & OPf_KIDS))
2751 if (o->op_targ != OP_LIST) {
2752 S_lvref(aTHX_ cBINOPo->op_first, type);
2757 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2758 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2759 S_lvref(aTHX_ kid, type);
2763 if (o->op_flags & OPf_PARENS)
2768 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2769 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2770 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2775 OpTYPE_set(o, OP_LVREF);
2777 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2778 if (type == OP_ENTERLOOP)
2779 o->op_private |= OPpLVREF_ITER;
2783 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2787 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2790 if (!o || (PL_parser && PL_parser->error_count))
2793 if ((o->op_private & OPpTARGET_MY)
2794 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2799 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2801 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2803 switch (o->op_type) {
2808 if ((o->op_flags & OPf_PARENS))
2812 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2813 !(o->op_flags & OPf_STACKED)) {
2814 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
2815 assert(cUNOPo->op_first->op_type == OP_NULL);
2816 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2819 else { /* lvalue subroutine call */
2820 o->op_private |= OPpLVAL_INTRO;
2821 PL_modcount = RETURN_UNLIMITED_NUMBER;
2822 if (type == OP_GREPSTART || type == OP_ENTERSUB
2823 || type == OP_REFGEN || type == OP_LEAVESUBLV) {
2824 /* Potential lvalue context: */
2825 o->op_private |= OPpENTERSUB_INARGS;
2828 else { /* Compile-time error message: */
2829 OP *kid = cUNOPo->op_first;
2834 if (kid->op_type != OP_PUSHMARK) {
2835 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2837 "panic: unexpected lvalue entersub "
2838 "args: type/targ %ld:%"UVuf,
2839 (long)kid->op_type, (UV)kid->op_targ);
2840 kid = kLISTOP->op_first;
2842 while (OpHAS_SIBLING(kid))
2843 kid = OpSIBLING(kid);
2844 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2845 break; /* Postpone until runtime */
2848 kid = kUNOP->op_first;
2849 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2850 kid = kUNOP->op_first;
2851 if (kid->op_type == OP_NULL)
2853 "Unexpected constant lvalue entersub "
2854 "entry via type/targ %ld:%"UVuf,
2855 (long)kid->op_type, (UV)kid->op_targ);
2856 if (kid->op_type != OP_GV) {
2863 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2864 ? MUTABLE_CV(SvRV(gv))
2870 if (flags & OP_LVALUE_NO_CROAK)
2873 namesv = cv_name(cv, NULL, 0);
2874 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2875 "subroutine call of &%"SVf" in %s",
2876 SVfARG(namesv), PL_op_desc[type]),
2884 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2885 /* grep, foreach, subcalls, refgen */
2886 if (type == OP_GREPSTART || type == OP_ENTERSUB
2887 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2889 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2890 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2893 type ? PL_op_desc[type] : "local"));
2906 case OP_RIGHT_SHIFT:
2915 if (!(o->op_flags & OPf_STACKED))
2921 if (o->op_flags & OPf_STACKED) {
2925 if (!(o->op_private & OPpREPEAT_DOLIST))
2928 const I32 mods = PL_modcount;
2929 modkids(cBINOPo->op_first, type);
2930 if (type != OP_AASSIGN)
2932 kid = cBINOPo->op_last;
2933 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2934 const IV iv = SvIV(kSVOP_sv);
2935 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2937 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2940 PL_modcount = RETURN_UNLIMITED_NUMBER;
2946 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2947 op_lvalue(kid, type);
2952 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2953 PL_modcount = RETURN_UNLIMITED_NUMBER;
2954 return o; /* Treat \(@foo) like ordinary list. */
2958 if (scalar_mod_type(o, type))
2960 ref(cUNOPo->op_first, o->op_type);
2967 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2968 if (type == OP_LEAVESUBLV && (
2969 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2970 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2972 o->op_private |= OPpMAYBE_LVSUB;
2976 PL_modcount = RETURN_UNLIMITED_NUMBER;
2980 if (type == OP_LEAVESUBLV)
2981 o->op_private |= OPpMAYBE_LVSUB;
2984 PL_hints |= HINT_BLOCK_SCOPE;
2985 if (type == OP_LEAVESUBLV)
2986 o->op_private |= OPpMAYBE_LVSUB;
2990 ref(cUNOPo->op_first, o->op_type);
2994 PL_hints |= HINT_BLOCK_SCOPE;
3004 case OP_AELEMFAST_LEX:
3011 PL_modcount = RETURN_UNLIMITED_NUMBER;
3012 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3013 return o; /* Treat \(@foo) like ordinary list. */
3014 if (scalar_mod_type(o, type))
3016 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3017 && type == OP_LEAVESUBLV)
3018 o->op_private |= OPpMAYBE_LVSUB;
3022 if (!type) /* local() */
3023 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3024 PNfARG(PAD_COMPNAME(o->op_targ)));
3025 if (!(o->op_private & OPpLVAL_INTRO)
3026 || ( type != OP_SASSIGN && type != OP_AASSIGN
3027 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3028 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3036 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
3040 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3046 if (type == OP_LEAVESUBLV)
3047 o->op_private |= OPpMAYBE_LVSUB;
3048 if (o->op_flags & OPf_KIDS)
3049 op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3054 ref(cBINOPo->op_first, o->op_type);
3055 if (type == OP_ENTERSUB &&
3056 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3057 o->op_private |= OPpLVAL_DEFER;
3058 if (type == OP_LEAVESUBLV)
3059 o->op_private |= OPpMAYBE_LVSUB;
3066 o->op_private |= OPpLVALUE;
3072 if (o->op_flags & OPf_KIDS)
3073 op_lvalue(cLISTOPo->op_last, type);
3078 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3080 else if (!(o->op_flags & OPf_KIDS))
3082 if (o->op_targ != OP_LIST) {
3083 op_lvalue(cBINOPo->op_first, type);
3089 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3090 /* elements might be in void context because the list is
3091 in scalar context or because they are attribute sub calls */
3092 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3093 op_lvalue(kid, type);
3101 if (type == OP_LEAVESUBLV
3102 || !S_vivifies(cLOGOPo->op_first->op_type))
3103 op_lvalue(cLOGOPo->op_first, type);
3104 if (type == OP_LEAVESUBLV
3105 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3106 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3110 if (type != OP_AASSIGN && type != OP_SASSIGN
3111 && type != OP_ENTERLOOP)
3113 /* Don’t bother applying lvalue context to the ex-list. */
3114 kid = cUNOPx(cUNOPo->op_first)->op_first;
3115 assert (!OpHAS_SIBLING(kid));
3118 if (type != OP_AASSIGN) goto nomod;
3119 kid = cUNOPo->op_first;
3122 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3123 S_lvref(aTHX_ kid, type);
3124 if (!PL_parser || PL_parser->error_count == ec) {
3125 if (!FEATURE_REFALIASING_IS_ENABLED)
3127 "Experimental aliasing via reference not enabled");
3128 Perl_ck_warner_d(aTHX_
3129 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3130 "Aliasing via reference is experimental");
3133 if (o->op_type == OP_REFGEN)
3134 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3139 kid = cLISTOPo->op_first;
3140 if (kid && kid->op_type == OP_PUSHRE &&
3142 || o->op_flags & OPf_STACKED
3144 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3146 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3149 /* This is actually @array = split. */
3150 PL_modcount = RETURN_UNLIMITED_NUMBER;
3156 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3160 /* [20011101.069] File test operators interpret OPf_REF to mean that
3161 their argument is a filehandle; thus \stat(".") should not set
3163 if (type == OP_REFGEN &&
3164 PL_check[o->op_type] == Perl_ck_ftst)
3167 if (type != OP_LEAVESUBLV)
3168 o->op_flags |= OPf_MOD;
3170 if (type == OP_AASSIGN || type == OP_SASSIGN)
3171 o->op_flags |= OPf_SPECIAL|OPf_REF;
3172 else if (!type) { /* local() */
3175 o->op_private |= OPpLVAL_INTRO;
3176 o->op_flags &= ~OPf_SPECIAL;
3177 PL_hints |= HINT_BLOCK_SCOPE;
3182 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3183 "Useless localization of %s", OP_DESC(o));
3186 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3187 && type != OP_LEAVESUBLV)
3188 o->op_flags |= OPf_REF;
3193 S_scalar_mod_type(const OP *o, I32 type)
3198 if (o && o->op_type == OP_RV2GV)
3222 case OP_RIGHT_SHIFT:
3243 S_is_handle_constructor(const OP *o, I32 numargs)
3245 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3247 switch (o->op_type) {
3255 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3268 S_refkids(pTHX_ OP *o, I32 type)
3270 if (o && o->op_flags & OPf_KIDS) {
3272 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3279 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3284 PERL_ARGS_ASSERT_DOREF;
3286 if (PL_parser && PL_parser->error_count)
3289 switch (o->op_type) {
3291 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3292 !(o->op_flags & OPf_STACKED)) {
3293 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3294 assert(cUNOPo->op_first->op_type == OP_NULL);
3295 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3296 o->op_flags |= OPf_SPECIAL;
3298 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3299 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3300 : type == OP_RV2HV ? OPpDEREF_HV
3302 o->op_flags |= OPf_MOD;
3308 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3309 doref(kid, type, set_op_ref);
3312 if (type == OP_DEFINED)
3313 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3314 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3317 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3318 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3319 : type == OP_RV2HV ? OPpDEREF_HV
3321 o->op_flags |= OPf_MOD;
3328 o->op_flags |= OPf_REF;
3331 if (type == OP_DEFINED)
3332 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3333 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3339 o->op_flags |= OPf_REF;
3344 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3346 doref(cBINOPo->op_first, type, set_op_ref);
3350 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3351 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3352 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3353 : type == OP_RV2HV ? OPpDEREF_HV
3355 o->op_flags |= OPf_MOD;
3365 if (!(o->op_flags & OPf_KIDS))
3367 doref(cLISTOPo->op_last, type, set_op_ref);
3377 S_dup_attrlist(pTHX_ OP *o)
3381 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3383 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3384 * where the first kid is OP_PUSHMARK and the remaining ones
3385 * are OP_CONST. We need to push the OP_CONST values.
3387 if (o->op_type == OP_CONST)
3388 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3390 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3392 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3393 if (o->op_type == OP_CONST)
3394 rop = op_append_elem(OP_LIST, rop,
3395 newSVOP(OP_CONST, o->op_flags,
3396 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3403 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3405 PERL_ARGS_ASSERT_APPLY_ATTRS;
3407 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3409 /* fake up C<use attributes $pkg,$rv,@attrs> */
3411 #define ATTRSMODULE "attributes"
3412 #define ATTRSMODULE_PM "attributes.pm"
3415 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3416 newSVpvs(ATTRSMODULE),
3418 op_prepend_elem(OP_LIST,
3419 newSVOP(OP_CONST, 0, stashsv),
3420 op_prepend_elem(OP_LIST,
3421 newSVOP(OP_CONST, 0,
3423 dup_attrlist(attrs))));
3428 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3430 OP *pack, *imop, *arg;
3431 SV *meth, *stashsv, **svp;
3433 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3438 assert(target->op_type == OP_PADSV ||
3439 target->op_type == OP_PADHV ||
3440 target->op_type == OP_PADAV);
3442 /* Ensure that attributes.pm is loaded. */
3443 /* Don't force the C<use> if we don't need it. */
3444 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3445 if (svp && *svp != &PL_sv_undef)
3446 NOOP; /* already in %INC */
3448 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3449 newSVpvs(ATTRSMODULE), NULL);
3451 /* Need package name for method call. */
3452 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3454 /* Build up the real arg-list. */
3455 stashsv = newSVhek(HvNAME_HEK(stash));
3457 arg = newOP(OP_PADSV, 0);
3458 arg->op_targ = target->op_targ;
3459 arg = op_prepend_elem(OP_LIST,
3460 newSVOP(OP_CONST, 0, stashsv),
3461 op_prepend_elem(OP_LIST,
3462 newUNOP(OP_REFGEN, 0,
3464 dup_attrlist(attrs)));
3466 /* Fake up a method call to import */
3467 meth = newSVpvs_share("import");
3468 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3469 op_append_elem(OP_LIST,
3470 op_prepend_elem(OP_LIST, pack, arg),
3471 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3473 /* Combine the ops. */
3474 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3478 =notfor apidoc apply_attrs_string
3480 Attempts to apply a list of attributes specified by the C<attrstr> and
3481 C<len> arguments to the subroutine identified by the C<cv> argument which
3482 is expected to be associated with the package identified by the C<stashpv>
3483 argument (see L<attributes>). It gets this wrong, though, in that it
3484 does not correctly identify the boundaries of the individual attribute
3485 specifications within C<attrstr>. This is not really intended for the
3486 public API, but has to be listed here for systems such as AIX which
3487 need an explicit export list for symbols. (It's called from XS code
3488 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3489 to respect attribute syntax properly would be welcome.
3495 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3496 const char *attrstr, STRLEN len)
3500 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3503 len = strlen(attrstr);
3507 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3509 const char * const sstr = attrstr;
3510 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3511 attrs = op_append_elem(OP_LIST, attrs,
3512 newSVOP(OP_CONST, 0,
3513 newSVpvn(sstr, attrstr-sstr)));
3517 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3518 newSVpvs(ATTRSMODULE),
3519 NULL, op_prepend_elem(OP_LIST,
3520 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3521 op_prepend_elem(OP_LIST,
3522 newSVOP(OP_CONST, 0,
3523 newRV(MUTABLE_SV(cv))),
3528 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3530 OP *new_proto = NULL;
3535 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3541 if (o->op_type == OP_CONST) {
3542 pv = SvPV(cSVOPo_sv, pvlen);
3543 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3544 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3545 SV ** const tmpo = cSVOPx_svp(o);
3546 SvREFCNT_dec(cSVOPo_sv);
3551 } else if (o->op_type == OP_LIST) {
3553 assert(o->op_flags & OPf_KIDS);
3554 lasto = cLISTOPo->op_first;
3555 assert(lasto->op_type == OP_PUSHMARK);
3556 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3557 if (o->op_type == OP_CONST) {
3558 pv = SvPV(cSVOPo_sv, pvlen);
3559 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3560 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3561 SV ** const tmpo = cSVOPx_svp(o);
3562 SvREFCNT_dec(cSVOPo_sv);
3564 if (new_proto && ckWARN(WARN_MISC)) {
3566 const char * newp = SvPV(cSVOPo_sv, new_len);
3567 Perl_warner(aTHX_ packWARN(WARN_MISC),
3568 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3569 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3575 /* excise new_proto from the list */
3576 op_sibling_splice(*attrs, lasto, 1, NULL);
3583 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3584 would get pulled in with no real need */
3585 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3594 svname = sv_newmortal();
3595 gv_efullname3(svname, name, NULL);
3597 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3598 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3600 svname = (SV *)name;
3601 if (ckWARN(WARN_ILLEGALPROTO))
3602 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3603 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3604 STRLEN old_len, new_len;
3605 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3606 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3608 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3609 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3611 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3612 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3622 S_cant_declare(pTHX_ OP *o)
3624 if (o->op_type == OP_NULL
3625 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3626 o = cUNOPo->op_first;
3627 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3628 o->op_type == OP_NULL
3629 && o->op_flags & OPf_SPECIAL
3632 PL_parser->in_my == KEY_our ? "our" :
3633 PL_parser->in_my == KEY_state ? "state" :
3638 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3641 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3643 PERL_ARGS_ASSERT_MY_KID;
3645 if (!o || (PL_parser && PL_parser->error_count))
3650 if (type == OP_LIST) {
3652 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3653 my_kid(kid, attrs, imopsp);
3655 } else if (type == OP_UNDEF || type == OP_STUB) {
3657 } else if (type == OP_RV2SV || /* "our" declaration */
3659 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3660 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3661 S_cant_declare(aTHX_ o);
3663 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3665 PL_parser->in_my = FALSE;
3666 PL_parser->in_my_stash = NULL;
3667 apply_attrs(GvSTASH(gv),
3668 (type == OP_RV2SV ? GvSV(gv) :
3669 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3670 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3673 o->op_private |= OPpOUR_INTRO;
3676 else if (type != OP_PADSV &&
3679 type != OP_PUSHMARK)
3681 S_cant_declare(aTHX_ o);
3684 else if (attrs && type != OP_PUSHMARK) {
3688 PL_parser->in_my = FALSE;
3689 PL_parser->in_my_stash = NULL;
3691 /* check for C<my Dog $spot> when deciding package */
3692 stash = PAD_COMPNAME_TYPE(o->op_targ);
3694 stash = PL_curstash;
3695 apply_attrs_my(stash, o, attrs, imopsp);
3697 o->op_flags |= OPf_MOD;
3698 o->op_private |= OPpLVAL_INTRO;
3700 o->op_private |= OPpPAD_STATE;
3705 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3708 int maybe_scalar = 0;
3710 PERL_ARGS_ASSERT_MY_ATTRS;
3712 /* [perl #17376]: this appears to be premature, and results in code such as
3713 C< our(%x); > executing in list mode rather than void mode */
3715 if (o->op_flags & OPf_PARENS)
3725 o = my_kid(o, attrs, &rops);
3727 if (maybe_scalar && o->op_type == OP_PADSV) {
3728 o = scalar(op_append_list(OP_LIST, rops, o));
3729 o->op_private |= OPpLVAL_INTRO;
3732 /* The listop in rops might have a pushmark at the beginning,
3733 which will mess up list assignment. */
3734 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3735 if (rops->op_type == OP_LIST &&
3736 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3738 OP * const pushmark = lrops->op_first;
3739 /* excise pushmark */
3740 op_sibling_splice(rops, NULL, 1, NULL);
3743 o = op_append_list(OP_LIST, o, rops);
3746 PL_parser->in_my = FALSE;
3747 PL_parser->in_my_stash = NULL;
3752 Perl_sawparens(pTHX_ OP *o)
3754 PERL_UNUSED_CONTEXT;
3756 o->op_flags |= OPf_PARENS;
3761 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3765 const OPCODE ltype = left->op_type;
3766 const OPCODE rtype = right->op_type;
3768 PERL_ARGS_ASSERT_BIND_MATCH;
3770 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3771 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3773 const char * const desc
3775 rtype == OP_SUBST || rtype == OP_TRANS
3776 || rtype == OP_TRANSR
3778 ? (int)rtype : OP_MATCH];
3779 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3781 S_op_varname(aTHX_ left);
3783 Perl_warner(aTHX_ packWARN(WARN_MISC),
3784 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3785 desc, SVfARG(name), SVfARG(name));
3787 const char * const sample = (isary
3788 ? "@array" : "%hash");
3789 Perl_warner(aTHX_ packWARN(WARN_MISC),
3790 "Applying %s to %s will act on scalar(%s)",
3791 desc, sample, sample);
3795 if (rtype == OP_CONST &&
3796 cSVOPx(right)->op_private & OPpCONST_BARE &&
3797 cSVOPx(right)->op_private & OPpCONST_STRICT)
3799 no_bareword_allowed(right);
3802 /* !~ doesn't make sense with /r, so error on it for now */
3803 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3805 /* diag_listed_as: Using !~ with %s doesn't make sense */
3806 yyerror("Using !~ with s///r doesn't make sense");
3807 if (rtype == OP_TRANSR && type == OP_NOT)
3808 /* diag_listed_as: Using !~ with %s doesn't make sense */
3809 yyerror("Using !~ with tr///r doesn't make sense");
3811 ismatchop = (rtype == OP_MATCH ||
3812 rtype == OP_SUBST ||
3813 rtype == OP_TRANS || rtype == OP_TRANSR)
3814 && !(right->op_flags & OPf_SPECIAL);
3815 if (ismatchop && right->op_private & OPpTARGET_MY) {
3817 right->op_private &= ~OPpTARGET_MY;
3819 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3820 if (left->op_type == OP_PADSV
3821 && !(left->op_private & OPpLVAL_INTRO))
3823 right->op_targ = left->op_targ;
3828 right->op_flags |= OPf_STACKED;
3829 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3830 ! (rtype == OP_TRANS &&
3831 right->op_private & OPpTRANS_IDENTICAL) &&
3832 ! (rtype == OP_SUBST &&
3833 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3834 left = op_lvalue(left, rtype);
3835 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3836 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3838 o = op_prepend_elem(rtype, scalar(left), right);
3841 return newUNOP(OP_NOT, 0, scalar(o));
3845 return bind_match(type, left,
3846 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3850 Perl_invert(pTHX_ OP *o)
3854 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3858 =for apidoc Amx|OP *|op_scope|OP *o
3860 Wraps up an op tree with some additional ops so that at runtime a dynamic
3861 scope will be created. The original ops run in the new dynamic scope,
3862 and then, provided that they exit normally, the scope will be unwound.
3863 The additional ops used to create and unwind the dynamic scope will
3864 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3865 instead if the ops are simple enough to not need the full dynamic scope
3872 Perl_op_scope(pTHX_ OP *o)
3876 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3877 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3878 OpTYPE_set(o, OP_LEAVE);
3880 else if (o->op_type == OP_LINESEQ) {
3882 OpTYPE_set(o, OP_SCOPE);
3883 kid = ((LISTOP*)o)->op_first;
3884 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3887 /* The following deals with things like 'do {1 for 1}' */
3888 kid = OpSIBLING(kid);
3890 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3895 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3901 Perl_op_unscope(pTHX_ OP *o)
3903 if (o && o->op_type == OP_LINESEQ) {
3904 OP *kid = cLISTOPo->op_first;
3905 for(; kid; kid = OpSIBLING(kid))
3906 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3913 =for apidoc Am|int|block_start|int full
3915 Handles compile-time scope entry.
3916 Arranges for hints to be restored on block
3917 exit and also handles pad sequence numbers to make lexical variables scope
3918 right. Returns a savestack index for use with C<block_end>.
3924 Perl_block_start(pTHX_ int full)
3926 const int retval = PL_savestack_ix;
3928 PL_compiling.cop_seq = PL_cop_seqmax;
3930 pad_block_start(full);
3932 PL_hints &= ~HINT_BLOCK_SCOPE;
3933 SAVECOMPILEWARNINGS();
3934 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3935 SAVEI32(PL_compiling.cop_seq);
3936 PL_compiling.cop_seq = 0;
3938 CALL_BLOCK_HOOKS(bhk_start, full);
3944 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3946 Handles compile-time scope exit. C<floor>
3947 is the savestack index returned by
3948 C<block_start>, and C<seq> is the body of the block. Returns the block,
3955 Perl_block_end(pTHX_ I32 floor, OP *seq)
3957 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3958 OP* retval = scalarseq(seq);
3961 /* XXX Is the null PL_parser check necessary here? */
3962 assert(PL_parser); /* Let’s find out under debugging builds. */
3963 if (PL_parser && PL_parser->parsed_sub) {
3964 o = newSTATEOP(0, NULL, NULL);
3966 retval = op_append_elem(OP_LINESEQ, retval, o);
3969 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3973 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3977 /* pad_leavemy has created a sequence of introcv ops for all my
3978 subs declared in the block. We have to replicate that list with
3979 clonecv ops, to deal with this situation:
3984 sub s1 { state sub foo { \&s2 } }
3987 Originally, I was going to have introcv clone the CV and turn
3988 off the stale flag. Since &s1 is declared before &s2, the
3989 introcv op for &s1 is executed (on sub entry) before the one for
3990 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3991 cloned, since it is a state sub) closes over &s2 and expects
3992 to see it in its outer CV’s pad. If the introcv op clones &s1,
3993 then &s2 is still marked stale. Since &s1 is not active, and
3994 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3995 ble will not stay shared’ warning. Because it is the same stub
3996 that will be used when the introcv op for &s2 is executed, clos-
3997 ing over it is safe. Hence, we have to turn off the stale flag
3998 on all lexical subs in the block before we clone any of them.
3999 Hence, having introcv clone the sub cannot work. So we create a
4000 list of ops like this:
4024 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4025 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4026 for (;; kid = OpSIBLING(kid)) {
4027 OP *newkid = newOP(OP_CLONECV, 0);
4028 newkid->op_targ = kid->op_targ;
4029 o = op_append_elem(OP_LINESEQ, o, newkid);
4030 if (kid == last) break;
4032 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4035 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4041 =head1 Compile-time scope hooks
4043 =for apidoc Aox||blockhook_register
4045 Register a set of hooks to be called when the Perl lexical scope changes
4046 at compile time. See L<perlguts/"Compile-time scope hooks">.
4052 Perl_blockhook_register(pTHX_ BHK *hk)
4054 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4056 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4060 Perl_newPROG(pTHX_ OP *o)
4062 PERL_ARGS_ASSERT_NEWPROG;
4069 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4070 ((PL_in_eval & EVAL_KEEPERR)
4071 ? OPf_SPECIAL : 0), o);
4074 assert(CxTYPE(cx) == CXt_EVAL);
4076 if ((cx->blk_gimme & G_WANT) == G_VOID)
4077 scalarvoid(PL_eval_root);
4078 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4081 scalar(PL_eval_root);
4083 PL_eval_start = op_linklist(PL_eval_root);
4084 PL_eval_root->op_private |= OPpREFCOUNTED;
4085 OpREFCNT_set(PL_eval_root, 1);
4086 PL_eval_root->op_next = 0;
4087 i = PL_savestack_ix;
4090 CALL_PEEP(PL_eval_start);
4091 finalize_optree(PL_eval_root);
4092 S_prune_chain_head(&PL_eval_start);
4094 PL_savestack_ix = i;
4097 if (o->op_type == OP_STUB) {
4098 /* This block is entered if nothing is compiled for the main
4099 program. This will be the case for an genuinely empty main
4100 program, or one which only has BEGIN blocks etc, so already
4103 Historically (5.000) the guard above was !o. However, commit
4104 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4105 c71fccf11fde0068, changed perly.y so that newPROG() is now
4106 called with the output of block_end(), which returns a new
4107 OP_STUB for the case of an empty optree. ByteLoader (and
4108 maybe other things) also take this path, because they set up
4109 PL_main_start and PL_main_root directly, without generating an
4112 If the parsing the main program aborts (due to parse errors,
4113 or due to BEGIN or similar calling exit), then newPROG()
4114 isn't even called, and hence this code path and its cleanups
4115 are skipped. This shouldn't make a make a difference:
4116 * a non-zero return from perl_parse is a failure, and
4117 perl_destruct() should be called immediately.
4118 * however, if exit(0) is called during the parse, then
4119 perl_parse() returns 0, and perl_run() is called. As
4120 PL_main_start will be NULL, perl_run() will return
4121 promptly, and the exit code will remain 0.
4124 PL_comppad_name = 0;
4126 S_op_destroy(aTHX_ o);
4129 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4130 PL_curcop = &PL_compiling;
4131 PL_main_start = LINKLIST(PL_main_root);
4132 PL_main_root->op_private |= OPpREFCOUNTED;
4133 OpREFCNT_set(PL_main_root, 1);
4134 PL_main_root->op_next = 0;
4135 CALL_PEEP(PL_main_start);
4136 finalize_optree(PL_main_root);
4137 S_prune_chain_head(&PL_main_start);
4138 cv_forget_slab(PL_compcv);
4141 /* Register with debugger */
4143 CV * const cv = get_cvs("DB::postponed", 0);
4147 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4149 call_sv(MUTABLE_SV(cv), G_DISCARD);
4156 Perl_localize(pTHX_ OP *o, I32 lex)
4158 PERL_ARGS_ASSERT_LOCALIZE;
4160 if (o->op_flags & OPf_PARENS)
4161 /* [perl #17376]: this appears to be premature, and results in code such as
4162 C< our(%x); > executing in list mode rather than void mode */
4169 if ( PL_parser->bufptr > PL_parser->oldbufptr
4170 && PL_parser->bufptr[-1] == ','
4171 && ckWARN(WARN_PARENTHESIS))
4173 char *s = PL_parser->bufptr;
4176 /* some heuristics to detect a potential error */
4177 while (*s && (strchr(", \t\n", *s)))
4181 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4183 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4186 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4188 while (*s && (strchr(", \t\n", *s)))
4194 if (sigil && (*s == ';' || *s == '=')) {
4195 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4196 "Parentheses missing around \"%s\" list",
4198 ? (PL_parser->in_my == KEY_our
4200 : PL_parser->in_my == KEY_state
4210 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4211 PL_parser->in_my = FALSE;
4212 PL_parser->in_my_stash = NULL;
4217 Perl_jmaybe(pTHX_ OP *o)
4219 PERL_ARGS_ASSERT_JMAYBE;
4221 if (o->op_type == OP_LIST) {
4223 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4224 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4229 PERL_STATIC_INLINE OP *
4230 S_op_std_init(pTHX_ OP *o)
4232 I32 type = o->op_type;
4234 PERL_ARGS_ASSERT_OP_STD_INIT;
4236 if (PL_opargs[type] & OA_RETSCALAR)
4238 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4239 o->op_targ = pad_alloc(type, SVs_PADTMP);
4244 PERL_STATIC_INLINE OP *
4245 S_op_integerize(pTHX_ OP *o)
4247 I32 type = o->op_type;
4249 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4251 /* integerize op. */
4252 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4255 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4258 if (type == OP_NEGATE)
4259 /* XXX might want a ck_negate() for this */
4260 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4266 S_fold_constants(pTHX_ OP *o)
4271 VOL I32 type = o->op_type;
4276 SV * const oldwarnhook = PL_warnhook;
4277 SV * const olddiehook = PL_diehook;
4279 U8 oldwarn = PL_dowarn;
4283 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4285 if (!(PL_opargs[type] & OA_FOLDCONST))
4294 #ifdef USE_LOCALE_CTYPE
4295 if (IN_LC_COMPILETIME(LC_CTYPE))
4304 #ifdef USE_LOCALE_COLLATE
4305 if (IN_LC_COMPILETIME(LC_COLLATE))
4310 /* XXX what about the numeric ops? */
4311 #ifdef USE_LOCALE_NUMERIC
4312 if (IN_LC_COMPILETIME(LC_NUMERIC))
4317 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4318 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4321 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4322 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4324 const char *s = SvPVX_const(sv);
4325 while (s < SvEND(sv)) {
4326 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4333 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4336 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4337 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4341 if (PL_parser && PL_parser->error_count)
4342 goto nope; /* Don't try to run w/ errors */
4344 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4345 const OPCODE type = curop->op_type;
4346 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4348 type != OP_SCALAR &&
4350 type != OP_PUSHMARK)
4356 curop = LINKLIST(o);
4357 old_next = o->op_next;
4361 old_cxix = cxstack_ix;
4362 create_eval_scope(NULL, G_FAKINGEVAL);
4364 /* Verify that we don't need to save it: */
4365 assert(PL_curcop == &PL_compiling);
4366 StructCopy(&PL_compiling, ¬_compiling, COP);
4367 PL_curcop = ¬_compiling;
4368 /* The above ensures that we run with all the correct hints of the
4369 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4370 assert(IN_PERL_RUNTIME);
4371 PL_warnhook = PERL_WARNHOOK_FATAL;
4375 /* Effective $^W=1. */
4376 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4377 PL_dowarn |= G_WARN_ON;
4382 sv = *(PL_stack_sp--);
4383 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4384 pad_swipe(o->op_targ, FALSE);
4386 else if (SvTEMP(sv)) { /* grab mortal temp? */
4387 SvREFCNT_inc_simple_void(sv);
4390 else { assert(SvIMMORTAL(sv)); }
4393 /* Something tried to die. Abandon constant folding. */
4394 /* Pretend the error never happened. */
4396 o->op_next = old_next;
4400 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4401 PL_warnhook = oldwarnhook;
4402 PL_diehook = olddiehook;
4403 /* XXX note that this croak may fail as we've already blown away
4404 * the stack - eg any nested evals */
4405 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4408 PL_dowarn = oldwarn;
4409 PL_warnhook = oldwarnhook;
4410 PL_diehook = olddiehook;
4411 PL_curcop = &PL_compiling;
4413 /* if we croaked, depending on how we croaked the eval scope
4414 * may or may not have already been popped */
4415 if (cxstack_ix > old_cxix) {
4416 assert(cxstack_ix == old_cxix + 1);
4417 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4418 delete_eval_scope();
4423 /* OP_STRINGIFY and constant folding are used to implement qq.
4424 Here the constant folding is an implementation detail that we
4425 want to hide. If the stringify op is itself already marked
4426 folded, however, then it is actually a folded join. */
4427 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4432 else if (!SvIMMORTAL(sv)) {
4436 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4437 if (!is_stringify) newop->op_folded = 1;
4445 S_gen_constant_list(pTHX_ OP *o)
4449 const SSize_t oldtmps_floor = PL_tmps_floor;
4454 if (PL_parser && PL_parser->error_count)
4455 return o; /* Don't attempt to run with errors */
4457 curop = LINKLIST(o);
4460 S_prune_chain_head(&curop);
4462 Perl_pp_pushmark(aTHX);
4465 assert (!(curop->op_flags & OPf_SPECIAL));
4466 assert(curop->op_type == OP_RANGE);
4467 Perl_pp_anonlist(aTHX);
4468 PL_tmps_floor = oldtmps_floor;
4470 OpTYPE_set(o, OP_RV2AV);
4471 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4472 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4473 o->op_opt = 0; /* needs to be revisited in rpeep() */
4474 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4476 /* replace subtree with an OP_CONST */
4477 curop = ((UNOP*)o)->op_first;
4478 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4481 if (AvFILLp(av) != -1)
4482 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4485 SvREADONLY_on(*svp);
4492 =head1 Optree Manipulation Functions
4495 /* List constructors */
4498 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4500 Append an item to the list of ops contained directly within a list-type
4501 op, returning the lengthened list. C<first> is the list-type op,
4502 and C<last> is the op to append to the list. C<optype> specifies the
4503 intended opcode for the list. If C<first> is not already a list of the
4504 right type, it will be upgraded into one. If either C<first> or C<last>
4505 is null, the other is returned unchanged.
4511 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4519 if (first->op_type != (unsigned)type
4520 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4522 return newLISTOP(type, 0, first, last);
4525 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4526 first->op_flags |= OPf_KIDS;
4531 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4533 Concatenate the lists of ops contained directly within two list-type ops,
4534 returning the combined list. C<first> and C<last> are the list-type ops
4535 to concatenate. C<optype> specifies the intended opcode for the list.
4536 If either C<first> or C<last> is not already a list of the right type,
4537 it will be upgraded into one. If either C<first> or C<last> is null,
4538 the other is returned unchanged.
4544 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4552 if (first->op_type != (unsigned)type)
4553 return op_prepend_elem(type, first, last);
4555 if (last->op_type != (unsigned)type)
4556 return op_append_elem(type, first, last);
4558 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4559 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4560 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4561 first->op_flags |= (last->op_flags & OPf_KIDS);
4563 S_op_destroy(aTHX_ last);
4569 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4571 Prepend an item to the list of ops contained directly within a list-type
4572 op, returning the lengthened list. C<first> is the op to prepend to the
4573 list, and C<last> is the list-type op. C<optype> specifies the intended
4574 opcode for the list. If C<last> is not already a list of the right type,
4575 it will be upgraded into one. If either C<first> or C<last> is null,
4576 the other is returned unchanged.
4582 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4590 if (last->op_type == (unsigned)type) {
4591 if (type == OP_LIST) { /* already a PUSHMARK there */
4592 /* insert 'first' after pushmark */
4593 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4594 if (!(first->op_flags & OPf_PARENS))
4595 last->op_flags &= ~OPf_PARENS;
4598 op_sibling_splice(last, NULL, 0, first);
4599 last->op_flags |= OPf_KIDS;
4603 return newLISTOP(type, 0, first, last);
4607 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4609 Converts C<o> into a list op if it is not one already, and then converts it
4610 into the specified C<type>, calling its check function, allocating a target if
4611 it needs one, and folding constants.
4613 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4614 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4615 C<op_convert_list> to make it the right type.
4621 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4624 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4625 if (!o || o->op_type != OP_LIST)
4626 o = force_list(o, 0);
4629 o->op_flags &= ~OPf_WANT;
4630 o->op_private &= ~OPpLVAL_INTRO;
4633 if (!(PL_opargs[type] & OA_MARK))
4634 op_null(cLISTOPo->op_first);
4636 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4637 if (kid2 && kid2->op_type == OP_COREARGS) {
4638 op_null(cLISTOPo->op_first);
4639 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4643 OpTYPE_set(o, type);
4644 o->op_flags |= flags;
4645 if (flags & OPf_FOLDED)
4648 o = CHECKOP(type, o);
4649 if (o->op_type != (unsigned)type)
4652 return fold_constants(op_integerize(op_std_init(o)));
4659 =head1 Optree construction
4661 =for apidoc Am|OP *|newNULLLIST
4663 Constructs, checks, and returns a new C<stub> op, which represents an
4664 empty list expression.
4670 Perl_newNULLLIST(pTHX)
4672 return newOP(OP_STUB, 0);
4675 /* promote o and any siblings to be a list if its not already; i.e.
4683 * pushmark - o - A - B
4685 * If nullit it true, the list op is nulled.
4689 S_force_list(pTHX_ OP *o, bool nullit)
4691 if (!o || o->op_type != OP_LIST) {
4694 /* manually detach any siblings then add them back later */
4695 rest = OpSIBLING(o);
4696 OpLASTSIB_set(o, NULL);
4698 o = newLISTOP(OP_LIST, 0, o, NULL);
4700 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4708 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4710 Constructs, checks, and returns an op of any list type. C<type> is
4711 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4712 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
4713 supply up to two ops to be direct children of the list op; they are
4714 consumed by this function and become part of the constructed op tree.
4716 For most list operators, the check function expects all the kid ops to be
4717 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4718 appropriate. What you want to do in that case is create an op of type
4719 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4720 See L</op_convert_list> for more information.
4727 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4732 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4733 || type == OP_CUSTOM);
4735 NewOp(1101, listop, 1, LISTOP);
4737 OpTYPE_set(listop, type);
4740 listop->op_flags = (U8)flags;
4744 else if (!first && last)
4747 OpMORESIB_set(first, last);
4748 listop->op_first = first;
4749 listop->op_last = last;
4750 if (type == OP_LIST) {
4751 OP* const pushop = newOP(OP_PUSHMARK, 0);
4752 OpMORESIB_set(pushop, first);
4753 listop->op_first = pushop;
4754 listop->op_flags |= OPf_KIDS;
4756 listop->op_last = pushop;
4758 if (listop->op_last)
4759 OpLASTSIB_set(listop->op_last, (OP*)listop);
4761 return CHECKOP(type, listop);
4765 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4767 Constructs, checks, and returns an op of any base type (any type that
4768 has no extra fields). C<type> is the opcode. C<flags> gives the
4769 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4776 Perl_newOP(pTHX_ I32 type, I32 flags)
4781 if (type == -OP_ENTEREVAL) {
4782 type = OP_ENTEREVAL;
4783 flags |= OPpEVAL_BYTES<<8;
4786 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4787 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4788 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4789 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4791 NewOp(1101, o, 1, OP);
4792 OpTYPE_set(o, type);
4793 o->op_flags = (U8)flags;
4796 o->op_private = (U8)(0 | (flags >> 8));
4797 if (PL_opargs[type] & OA_RETSCALAR)
4799 if (PL_opargs[type] & OA_TARGET)
4800 o->op_targ = pad_alloc(type, SVs_PADTMP);
4801 return CHECKOP(type, o);
4805 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4807 Constructs, checks, and returns an op of any unary type. C<type> is
4808 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4809 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4810 bits, the eight bits of C<op_private>, except that the bit with value 1
4811 is automatically set. C<first> supplies an optional op to be the direct
4812 child of the unary op; it is consumed by this function and become part
4813 of the constructed op tree.
4819 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4824 if (type == -OP_ENTEREVAL) {
4825 type = OP_ENTEREVAL;
4826 flags |= OPpEVAL_BYTES<<8;
4829 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4830 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4831 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4832 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4833 || type == OP_SASSIGN
4834 || type == OP_ENTERTRY
4835 || type == OP_CUSTOM
4836 || type == OP_NULL );
4839 first = newOP(OP_STUB, 0);
4840 if (PL_opargs[type] & OA_MARK)
4841 first = force_list(first, 1);
4843 NewOp(1101, unop, 1, UNOP);
4844 OpTYPE_set(unop, type);
4845 unop->op_first = first;
4846 unop->op_flags = (U8)(flags | OPf_KIDS);
4847 unop->op_private = (U8)(1 | (flags >> 8));
4849 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4850 OpLASTSIB_set(first, (OP*)unop);
4852 unop = (UNOP*) CHECKOP(type, unop);
4856 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4860 =for apidoc newUNOP_AUX
4862 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4863 initialised to C<aux>
4869 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4874 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4875 || type == OP_CUSTOM);
4877 NewOp(1101, unop, 1, UNOP_AUX);
4878 unop->op_type = (OPCODE)type;
4879 unop->op_ppaddr = PL_ppaddr[type];
4880 unop->op_first = first;
4881 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4882 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4885 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4886 OpLASTSIB_set(first, (OP*)unop);
4888 unop = (UNOP_AUX*) CHECKOP(type, unop);
4890 return op_std_init((OP *) unop);
4894 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4896 Constructs, checks, and returns an op of method type with a method name
4897 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
4898 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4899 and, shifted up eight bits, the eight bits of C<op_private>, except that
4900 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
4901 op which evaluates method name; it is consumed by this function and
4902 become part of the constructed op tree.
4903 Supported optypes: C<OP_METHOD>.
4909 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4913 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4914 || type == OP_CUSTOM);
4916 NewOp(1101, methop, 1, METHOP);
4918 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4919 methop->op_flags = (U8)(flags | OPf_KIDS);
4920 methop->op_u.op_first = dynamic_meth;
4921 methop->op_private = (U8)(1 | (flags >> 8));
4923 if (!OpHAS_SIBLING(dynamic_meth))
4924 OpLASTSIB_set(dynamic_meth, (OP*)methop);
4928 methop->op_flags = (U8)(flags & ~OPf_KIDS);
4929 methop->op_u.op_meth_sv = const_meth;
4930 methop->op_private = (U8)(0 | (flags >> 8));
4931 methop->op_next = (OP*)methop;
4935 methop->op_rclass_targ = 0;
4937 methop->op_rclass_sv = NULL;
4940 OpTYPE_set(methop, type);
4941 return CHECKOP(type, methop);
4945 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4946 PERL_ARGS_ASSERT_NEWMETHOP;
4947 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4951 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4953 Constructs, checks, and returns an op of method type with a constant
4954 method name. C<type> is the opcode. C<flags> gives the eight bits of
4955 C<op_flags>, and, shifted up eight bits, the eight bits of
4956 C<op_private>. C<const_meth> supplies a constant method name;
4957 it must be a shared COW string.
4958 Supported optypes: C<OP_METHOD_NAMED>.
4964 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4965 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4966 return newMETHOP_internal(type, flags, NULL, const_meth);
4970 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4972 Constructs, checks, and returns an op of any binary type. C<type>
4973 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
4974 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4975 the eight bits of C<op_private>, except that the bit with value 1 or
4976 2 is automatically set as required. C<first> and C<last> supply up to
4977 two ops to be the direct children of the binary op; they are consumed
4978 by this function and become part of the constructed op tree.
4984 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4989 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4990 || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
4992 NewOp(1101, binop, 1, BINOP);
4995 first = newOP(OP_NULL, 0);
4997 OpTYPE_set(binop, type);
4998 binop->op_first = first;
4999 binop->op_flags = (U8)(flags | OPf_KIDS);
5002 binop->op_private = (U8)(1 | (flags >> 8));
5005 binop->op_private = (U8)(2 | (flags >> 8));
5006 OpMORESIB_set(first, last);
5009 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5010 OpLASTSIB_set(last, (OP*)binop);
5012 binop->op_last = OpSIBLING(binop->op_first);
5014 OpLASTSIB_set(binop->op_last, (OP*)binop);
5016 binop = (BINOP*)CHECKOP(type, binop);
5017 if (binop->op_next || binop->op_type != (OPCODE)type)
5020 return fold_constants(op_integerize(op_std_init((OP *)binop)));
5023 static int uvcompare(const void *a, const void *b)
5024 __attribute__nonnull__(1)
5025 __attribute__nonnull__(2)
5026 __attribute__pure__;
5027 static int uvcompare(const void *a, const void *b)
5029 if (*((const UV *)a) < (*(const UV *)b))
5031 if (*((const UV *)a) > (*(const UV *)b))
5033 if (*((const UV *)a+1) < (*(const UV *)b+1))
5035 if (*((const UV *)a+1) > (*(const UV *)b+1))
5041 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5043 SV * const tstr = ((SVOP*)expr)->op_sv;
5045 ((SVOP*)repl)->op_sv;
5048 const U8 *t = (U8*)SvPV_const(tstr, tlen);
5049 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5055 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5056 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5057 I32 del = o->op_private & OPpTRANS_DELETE;
5060 PERL_ARGS_ASSERT_PMTRANS;
5062 PL_hints |= HINT_BLOCK_SCOPE;
5065 o->op_private |= OPpTRANS_FROM_UTF;
5068 o->op_private |= OPpTRANS_TO_UTF;
5070 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5071 SV* const listsv = newSVpvs("# comment\n");
5073 const U8* tend = t + tlen;
5074 const U8* rend = r + rlen;
5090 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5091 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5094 const U32 flags = UTF8_ALLOW_DEFAULT;
5098 t = tsave = bytes_to_utf8(t, &len);
5101 if (!to_utf && rlen) {
5103 r = rsave = bytes_to_utf8(r, &len);
5107 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5108 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5112 U8 tmpbuf[UTF8_MAXBYTES+1];
5115 Newx(cp, 2*tlen, UV);
5117 transv = newSVpvs("");
5119 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5121 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5123 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5127 cp[2*i+1] = cp[2*i];
5131 qsort(cp, i, 2*sizeof(UV), uvcompare);
5132 for (j = 0; j < i; j++) {
5134 diff = val - nextmin;
5136 t = uvchr_to_utf8(tmpbuf,nextmin);
5137 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5139 U8 range_mark = ILLEGAL_UTF8_BYTE;
5140 t = uvchr_to_utf8(tmpbuf, val - 1);
5141 sv_catpvn(transv, (char *)&range_mark, 1);
5142 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5149 t = uvchr_to_utf8(tmpbuf,nextmin);
5150 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5152 U8 range_mark = ILLEGAL_UTF8_BYTE;
5153 sv_catpvn(transv, (char *)&range_mark, 1);
5155 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5156 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5157 t = (const U8*)SvPVX_const(transv);
5158 tlen = SvCUR(transv);
5162 else if (!rlen && !del) {
5163 r = t; rlen = tlen; rend = tend;
5166 if ((!rlen && !del) || t == r ||
5167 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5169 o->op_private |= OPpTRANS_IDENTICAL;
5173 while (t < tend || tfirst <= tlast) {
5174 /* see if we need more "t" chars */
5175 if (tfirst > tlast) {
5176 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5178 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5180 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5187 /* now see if we need more "r" chars */
5188 if (rfirst > rlast) {
5190 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5192 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5194 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5203 rfirst = rlast = 0xffffffff;
5207 /* now see which range will peter out first, if either. */
5208 tdiff = tlast - tfirst;
5209 rdiff = rlast - rfirst;
5210 tcount += tdiff + 1;
5211 rcount += rdiff + 1;
5218 if (rfirst == 0xffffffff) {
5219 diff = tdiff; /* oops, pretend rdiff is infinite */
5221 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5222 (long)tfirst, (long)tlast);
5224 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5228 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5229 (long)tfirst, (long)(tfirst + diff),
5232 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5233 (long)tfirst, (long)rfirst);
5235 if (rfirst + diff > max)
5236 max = rfirst + diff;
5238 grows = (tfirst < rfirst &&
5239 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5251 else if (max > 0xff)
5256 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5258 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5259 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5260 PAD_SETSV(cPADOPo->op_padix, swash);
5262 SvREADONLY_on(swash);
5264 cSVOPo->op_sv = swash;
5266 SvREFCNT_dec(listsv);
5267 SvREFCNT_dec(transv);
5269 if (!del && havefinal && rlen)
5270 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5271 newSVuv((UV)final), 0);
5280 else if (rlast == 0xffffffff)
5286 tbl = (short*)PerlMemShared_calloc(
5287 (o->op_private & OPpTRANS_COMPLEMENT) &&
5288 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5290 cPVOPo->op_pv = (char*)tbl;
5292 for (i = 0; i < (I32)tlen; i++)
5294 for (i = 0, j = 0; i < 256; i++) {
5296 if (j >= (I32)rlen) {
5305 if (i < 128 && r[j] >= 128)
5315 o->op_private |= OPpTRANS_IDENTICAL;
5317 else if (j >= (I32)rlen)
5322 PerlMemShared_realloc(tbl,
5323 (0x101+rlen-j) * sizeof(short));
5324 cPVOPo->op_pv = (char*)tbl;
5326 tbl[0x100] = (short)(rlen - j);
5327 for (i=0; i < (I32)rlen - j; i++)
5328 tbl[0x101+i] = r[j+i];
5332 if (!rlen && !del) {
5335 o->op_private |= OPpTRANS_IDENTICAL;
5337 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5338 o->op_private |= OPpTRANS_IDENTICAL;
5340 for (i = 0; i < 256; i++)
5342 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5343 if (j >= (I32)rlen) {
5345 if (tbl[t[i]] == -1)
5351 if (tbl[t[i]] == -1) {
5352 if (t[i] < 128 && r[j] >= 128)
5360 if(del && rlen == tlen) {
5361 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5362 } else if(rlen > tlen && !complement) {
5363 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5367 o->op_private |= OPpTRANS_GROWS;
5375 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5377 Constructs, checks, and returns an op of any pattern matching type.
5378 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
5379 and, shifted up eight bits, the eight bits of C<op_private>.
5385 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5390 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5391 || type == OP_CUSTOM);
5393 NewOp(1101, pmop, 1, PMOP);
5394 OpTYPE_set(pmop, type);
5395 pmop->op_flags = (U8)flags;
5396 pmop->op_private = (U8)(0 | (flags >> 8));
5397 if (PL_opargs[type] & OA_RETSCALAR)
5400 if (PL_hints & HINT_RE_TAINT)
5401 pmop->op_pmflags |= PMf_RETAINT;
5402 #ifdef USE_LOCALE_CTYPE
5403 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5404 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5409 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5411 if (PL_hints & HINT_RE_FLAGS) {
5412 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5413 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5415 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5416 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5417 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5419 if (reflags && SvOK(reflags)) {
5420 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5426 assert(SvPOK(PL_regex_pad[0]));
5427 if (SvCUR(PL_regex_pad[0])) {
5428 /* Pop off the "packed" IV from the end. */
5429 SV *const repointer_list = PL_regex_pad[0];
5430 const char *p = SvEND(repointer_list) - sizeof(IV);
5431 const IV offset = *((IV*)p);
5433 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5435 SvEND_set(repointer_list, p);
5437 pmop->op_pmoffset = offset;
5438 /* This slot should be free, so assert this: */
5439 assert(PL_regex_pad[offset] == &PL_sv_undef);
5441 SV * const repointer = &PL_sv_undef;
5442 av_push(PL_regex_padav, repointer);
5443 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5444 PL_regex_pad = AvARRAY(PL_regex_padav);
5448 return CHECKOP(type, pmop);
5456 /* Any pad names in scope are potentially lvalues. */
5457 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5458 PADNAME *pn = PAD_COMPNAME_SV(i);
5459 if (!pn || !PadnameLEN(pn))
5461 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5462 S_mark_padname_lvalue(aTHX_ pn);
5466 /* Given some sort of match op o, and an expression expr containing a
5467 * pattern, either compile expr into a regex and attach it to o (if it's
5468 * constant), or convert expr into a runtime regcomp op sequence (if it's
5471 * isreg indicates that the pattern is part of a regex construct, eg
5472 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5473 * split "pattern", which aren't. In the former case, expr will be a list
5474 * if the pattern contains more than one term (eg /a$b/).
5476 * When the pattern has been compiled within a new anon CV (for
5477 * qr/(?{...})/ ), then floor indicates the savestack level just before
5478 * the new sub was created
5482 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5486 I32 repl_has_vars = 0;
5487 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5488 bool is_compiletime;
5491 PERL_ARGS_ASSERT_PMRUNTIME;
5494 return pmtrans(o, expr, repl);
5497 /* find whether we have any runtime or code elements;
5498 * at the same time, temporarily set the op_next of each DO block;
5499 * then when we LINKLIST, this will cause the DO blocks to be excluded
5500 * from the op_next chain (and from having LINKLIST recursively
5501 * applied to them). We fix up the DOs specially later */
5505 if (expr->op_type == OP_LIST) {
5507 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5508 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5510 assert(!o->op_next);
5511 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5512 assert(PL_parser && PL_parser->error_count);
5513 /* This can happen with qr/ (?{(^{})/. Just fake up
5514 the op we were expecting to see, to avoid crashing
5516 op_sibling_splice(expr, o, 0,
5517 newSVOP(OP_CONST, 0, &PL_sv_no));
5519 o->op_next = OpSIBLING(o);
5521 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5525 else if (expr->op_type != OP_CONST)
5530 /* fix up DO blocks; treat each one as a separate little sub;
5531 * also, mark any arrays as LIST/REF */
5533 if (expr->op_type == OP_LIST) {
5535 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5537 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5538 assert( !(o->op_flags & OPf_WANT));
5539 /* push the array rather than its contents. The regex
5540 * engine will retrieve and join the elements later */
5541 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5545 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5547 o->op_next = NULL; /* undo temporary hack from above */
5550 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5551 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5553 assert(leaveop->op_first->op_type == OP_ENTER);
5554 assert(OpHAS_SIBLING(leaveop->op_first));
5555 o->op_next = OpSIBLING(leaveop->op_first);
5557 assert(leaveop->op_flags & OPf_KIDS);
5558 assert(leaveop->op_last->op_next == (OP*)leaveop);
5559 leaveop->op_next = NULL; /* stop on last op */
5560 op_null((OP*)leaveop);
5564 OP *scope = cLISTOPo->op_first;
5565 assert(scope->op_type == OP_SCOPE);
5566 assert(scope->op_flags & OPf_KIDS);
5567 scope->op_next = NULL; /* stop on last op */
5570 /* have to peep the DOs individually as we've removed it from
5571 * the op_next chain */
5573 S_prune_chain_head(&(o->op_next));
5575 /* runtime finalizes as part of finalizing whole tree */
5579 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5580 assert( !(expr->op_flags & OPf_WANT));
5581 /* push the array rather than its contents. The regex
5582 * engine will retrieve and join the elements later */
5583 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5586 PL_hints |= HINT_BLOCK_SCOPE;
5588 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5590 if (is_compiletime) {
5591 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5592 regexp_engine const *eng = current_re_engine();
5594 if (o->op_flags & OPf_SPECIAL)
5595 rx_flags |= RXf_SPLIT;
5597 if (!has_code || !eng->op_comp) {
5598 /* compile-time simple constant pattern */
5600 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5601 /* whoops! we guessed that a qr// had a code block, but we
5602 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5603 * that isn't required now. Note that we have to be pretty
5604 * confident that nothing used that CV's pad while the
5605 * regex was parsed, except maybe op targets for \Q etc.
5606 * If there were any op targets, though, they should have
5607 * been stolen by constant folding.
5611 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5612 while (++i <= AvFILLp(PL_comppad)) {
5613 assert(!PL_curpad[i]);
5616 /* But we know that one op is using this CV's slab. */
5617 cv_forget_slab(PL_compcv);
5619 pm->op_pmflags &= ~PMf_HAS_CV;
5624 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5625 rx_flags, pm->op_pmflags)
5626 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5627 rx_flags, pm->op_pmflags)
5632 /* compile-time pattern that includes literal code blocks */
5633 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5636 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5639 if (pm->op_pmflags & PMf_HAS_CV) {
5641 /* this QR op (and the anon sub we embed it in) is never
5642 * actually executed. It's just a placeholder where we can
5643 * squirrel away expr in op_code_list without the peephole
5644 * optimiser etc processing it for a second time */
5645 OP *qr = newPMOP(OP_QR, 0);
5646 ((PMOP*)qr)->op_code_list = expr;
5648 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5649 SvREFCNT_inc_simple_void(PL_compcv);
5650 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5651 ReANY(re)->qr_anoncv = cv;
5653 /* attach the anon CV to the pad so that
5654 * pad_fixup_inner_anons() can find it */
5655 (void)pad_add_anon(cv, o->op_type);
5656 SvREFCNT_inc_simple_void(cv);
5659 pm->op_code_list = expr;
5664 /* runtime pattern: build chain of regcomp etc ops */
5666 PADOFFSET cv_targ = 0;
5668 reglist = isreg && expr->op_type == OP_LIST;
5673 pm->op_code_list = expr;
5674 /* don't free op_code_list; its ops are embedded elsewhere too */
5675 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5678 if (o->op_flags & OPf_SPECIAL)
5679 pm->op_pmflags |= PMf_SPLIT;
5681 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5682 * to allow its op_next to be pointed past the regcomp and
5683 * preceding stacking ops;
5684 * OP_REGCRESET is there to reset taint before executing the
5686 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5687 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5689 if (pm->op_pmflags & PMf_HAS_CV) {
5690 /* we have a runtime qr with literal code. This means
5691 * that the qr// has been wrapped in a new CV, which
5692 * means that runtime consts, vars etc will have been compiled
5693 * against a new pad. So... we need to execute those ops
5694 * within the environment of the new CV. So wrap them in a call
5695 * to a new anon sub. i.e. for
5699 * we build an anon sub that looks like
5701 * sub { "a", $b, '(?{...})' }
5703 * and call it, passing the returned list to regcomp.
5704 * Or to put it another way, the list of ops that get executed
5708 * ------ -------------------
5709 * pushmark (for regcomp)
5710 * pushmark (for entersub)
5714 * regcreset regcreset
5716 * const("a") const("a")
5718 * const("(?{...})") const("(?{...})")
5723 SvREFCNT_inc_simple_void(PL_compcv);
5724 CvLVALUE_on(PL_compcv);
5725 /* these lines are just an unrolled newANONATTRSUB */
5726 expr = newSVOP(OP_ANONCODE, 0,
5727 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5728 cv_targ = expr->op_targ;
5729 expr = newUNOP(OP_REFGEN, 0, expr);
5731 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5734 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5735 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5736 | (reglist ? OPf_STACKED : 0);
5737 rcop->op_targ = cv_targ;
5739 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5740 if (PL_hints & HINT_RE_EVAL)
5741 S_set_haseval(aTHX);
5743 /* establish postfix order */
5744 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5746 rcop->op_next = expr;
5747 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5750 rcop->op_next = LINKLIST(expr);
5751 expr->op_next = (OP*)rcop;
5754 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5760 /* If we are looking at s//.../e with a single statement, get past
5761 the implicit do{}. */
5762 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5763 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5764 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5767 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5768 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5769 && !OpHAS_SIBLING(sib))
5772 if (curop->op_type == OP_CONST)
5774 else if (( (curop->op_type == OP_RV2SV ||
5775 curop->op_type == OP_RV2AV ||
5776 curop->op_type == OP_RV2HV ||
5777 curop->op_type == OP_RV2GV)
5778 && cUNOPx(curop)->op_first
5779 && cUNOPx(curop)->op_first->op_type == OP_GV )
5780 || curop->op_type == OP_PADSV
5781 || curop->op_type == OP_PADAV
5782 || curop->op_type == OP_PADHV
5783 || curop->op_type == OP_PADANY) {
5791 || !RX_PRELEN(PM_GETRE(pm))
5792 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5794 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5795 op_prepend_elem(o->op_type, scalar(repl), o);
5798 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5799 rcop->op_private = 1;
5801 /* establish postfix order */
5802 rcop->op_next = LINKLIST(repl);
5803 repl->op_next = (OP*)rcop;
5805 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5806 assert(!(pm->op_pmflags & PMf_ONCE));
5807 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5816 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5818 Constructs, checks, and returns an op of any type that involves an
5819 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
5820 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
5821 takes ownership of one reference to it.
5827 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5832 PERL_ARGS_ASSERT_NEWSVOP;
5834 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5835 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5836 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5837 || type == OP_CUSTOM);
5839 NewOp(1101, svop, 1, SVOP);
5840 OpTYPE_set(svop, type);
5842 svop->op_next = (OP*)svop;
5843 svop->op_flags = (U8)flags;
5844 svop->op_private = (U8)(0 | (flags >> 8));
5845 if (PL_opargs[type] & OA_RETSCALAR)
5847 if (PL_opargs[type] & OA_TARGET)
5848 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5849 return CHECKOP(type, svop);
5853 =for apidoc Am|OP *|newDEFSVOP|
5855 Constructs and returns an op to access C<$_>.
5861 Perl_newDEFSVOP(pTHX)
5863 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5869 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5871 Constructs, checks, and returns an op of any type that involves a
5872 reference to a pad element. C<type> is the opcode. C<flags> gives the
5873 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5874 is populated with C<sv>; this function takes ownership of one reference
5877 This function only exists if Perl has been compiled to use ithreads.
5883 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5888 PERL_ARGS_ASSERT_NEWPADOP;
5890 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5891 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5892 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5893 || type == OP_CUSTOM);
5895 NewOp(1101, padop, 1, PADOP);
5896 OpTYPE_set(padop, type);
5898 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5899 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5900 PAD_SETSV(padop->op_padix, sv);
5902 padop->op_next = (OP*)padop;
5903 padop->op_flags = (U8)flags;
5904 if (PL_opargs[type] & OA_RETSCALAR)
5906 if (PL_opargs[type] & OA_TARGET)
5907 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5908 return CHECKOP(type, padop);
5911 #endif /* USE_ITHREADS */
5914 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5916 Constructs, checks, and returns an op of any type that involves an
5917 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
5918 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
5919 reference; calling this function does not transfer ownership of any
5926 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5928 PERL_ARGS_ASSERT_NEWGVOP;
5931 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5933 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5938 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5940 Constructs, checks, and returns an op of any type that involves an
5941 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
5942 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
5943 must have been allocated using C<PerlMemShared_malloc>; the memory will
5944 be freed when the op is destroyed.
5950 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5953 const bool utf8 = cBOOL(flags & SVf_UTF8);
5958 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5959 || type == OP_RUNCV || type == OP_CUSTOM
5960 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5962 NewOp(1101, pvop, 1, PVOP);
5963 OpTYPE_set(pvop, type);
5965 pvop->op_next = (OP*)pvop;
5966 pvop->op_flags = (U8)flags;
5967 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5968 if (PL_opargs[type] & OA_RETSCALAR)
5970 if (PL_opargs[type] & OA_TARGET)
5971 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5972 return CHECKOP(type, pvop);
5976 Perl_package(pTHX_ OP *o)
5978 SV *const sv = cSVOPo->op_sv;
5980 PERL_ARGS_ASSERT_PACKAGE;
5982 SAVEGENERICSV(PL_curstash);
5983 save_item(PL_curstname);
5985 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5987 sv_setsv(PL_curstname, sv);
5989 PL_hints |= HINT_BLOCK_SCOPE;
5990 PL_parser->copline = NOLINE;
5996 Perl_package_version( pTHX_ OP *v )
5998 U32 savehints = PL_hints;
5999 PERL_ARGS_ASSERT_PACKAGE_VERSION;
6000 PL_hints &= ~HINT_STRICT_VARS;
6001 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6002 PL_hints = savehints;
6007 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6012 SV *use_version = NULL;
6014 PERL_ARGS_ASSERT_UTILIZE;
6016 if (idop->op_type != OP_CONST)
6017 Perl_croak(aTHX_ "Module name must be constant");
6022 SV * const vesv = ((SVOP*)version)->op_sv;
6024 if (!arg && !SvNIOKp(vesv)) {
6031 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6032 Perl_croak(aTHX_ "Version number must be a constant number");
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 VERSION */
6038 meth = newSVpvs_share("VERSION");
6039 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6040 op_append_elem(OP_LIST,
6041 op_prepend_elem(OP_LIST, pack, version),
6042 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6046 /* Fake up an import/unimport */
6047 if (arg && arg->op_type == OP_STUB) {
6048 imop = arg; /* no import on explicit () */
6050 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6051 imop = NULL; /* use 5.0; */
6053 use_version = ((SVOP*)idop)->op_sv;
6055 idop->op_private |= OPpCONST_NOVER;
6060 /* Make copy of idop so we don't free it twice */
6061 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6063 /* Fake up a method call to import/unimport */
6065 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6066 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6067 op_append_elem(OP_LIST,
6068 op_prepend_elem(OP_LIST, pack, arg),
6069 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6073 /* Fake up the BEGIN {}, which does its thing immediately. */
6075 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6078 op_append_elem(OP_LINESEQ,
6079 op_append_elem(OP_LINESEQ,
6080 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6081 newSTATEOP(0, NULL, veop)),
6082 newSTATEOP(0, NULL, imop) ));
6086 * feature bundle that corresponds to the required version. */
6087 use_version = sv_2mortal(new_version(use_version));
6088 S_enable_feature_bundle(aTHX_ use_version);
6090 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6091 if (vcmp(use_version,
6092 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6093 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6094 PL_hints |= HINT_STRICT_REFS;
6095 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6096 PL_hints |= HINT_STRICT_SUBS;
6097 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6098 PL_hints |= HINT_STRICT_VARS;
6100 /* otherwise they are off */
6102 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6103 PL_hints &= ~HINT_STRICT_REFS;
6104 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6105 PL_hints &= ~HINT_STRICT_SUBS;
6106 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6107 PL_hints &= ~HINT_STRICT_VARS;
6111 /* The "did you use incorrect case?" warning used to be here.
6112 * The problem is that on case-insensitive filesystems one
6113 * might get false positives for "use" (and "require"):
6114 * "use Strict" or "require CARP" will work. This causes
6115 * portability problems for the script: in case-strict
6116 * filesystems the script will stop working.
6118 * The "incorrect case" warning checked whether "use Foo"
6119 * imported "Foo" to your namespace, but that is wrong, too:
6120 * there is no requirement nor promise in the language that
6121 * a Foo.pm should or would contain anything in package "Foo".
6123 * There is very little Configure-wise that can be done, either:
6124 * the case-sensitivity of the build filesystem of Perl does not
6125 * help in guessing the case-sensitivity of the runtime environment.
6128 PL_hints |= HINT_BLOCK_SCOPE;
6129 PL_parser->copline = NOLINE;
6130 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6134 =head1 Embedding Functions
6136 =for apidoc load_module
6138 Loads the module whose name is pointed to by the string part of name.
6139 Note that the actual module name, not its filename, should be given.
6140 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
6141 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6142 (or 0 for no flags). ver, if specified
6143 and not NULL, provides version semantics
6144 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
6145 arguments can be used to specify arguments to the module's C<import()>
6146 method, similar to C<use Foo::Bar VERSION LIST>. They must be
6147 terminated with a final C<NULL> pointer. Note that this list can only
6148 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6149 Otherwise at least a single C<NULL> pointer to designate the default
6150 import list is required.
6152 The reference count for each specified C<SV*> parameter is decremented.
6157 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6161 PERL_ARGS_ASSERT_LOAD_MODULE;
6163 va_start(args, ver);
6164 vload_module(flags, name, ver, &args);
6168 #ifdef PERL_IMPLICIT_CONTEXT
6170 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6174 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6175 va_start(args, ver);
6176 vload_module(flags, name, ver, &args);
6182 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6185 OP * const modname = newSVOP(OP_CONST, 0, name);
6187 PERL_ARGS_ASSERT_VLOAD_MODULE;
6189 modname->op_private |= OPpCONST_BARE;
6191 veop = newSVOP(OP_CONST, 0, ver);
6195 if (flags & PERL_LOADMOD_NOIMPORT) {
6196 imop = sawparens(newNULLLIST());
6198 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6199 imop = va_arg(*args, OP*);
6204 sv = va_arg(*args, SV*);
6206 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6207 sv = va_arg(*args, SV*);
6211 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6212 * that it has a PL_parser to play with while doing that, and also
6213 * that it doesn't mess with any existing parser, by creating a tmp
6214 * new parser with lex_start(). This won't actually be used for much,
6215 * since pp_require() will create another parser for the real work.
6216 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6219 SAVEVPTR(PL_curcop);
6220 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6221 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6222 veop, modname, imop);
6226 PERL_STATIC_INLINE OP *
6227 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6229 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6230 newLISTOP(OP_LIST, 0, arg,
6231 newUNOP(OP_RV2CV, 0,
6232 newGVOP(OP_GV, 0, gv))));
6236 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6241 PERL_ARGS_ASSERT_DOFILE;
6243 if (!force_builtin && (gv = gv_override("do", 2))) {
6244 doop = S_new_entersubop(aTHX_ gv, term);
6247 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6253 =head1 Optree construction
6255 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6257 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
6258 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6259 be set automatically, and, shifted up eight bits, the eight bits of
6260 C<op_private>, except that the bit with value 1 or 2 is automatically
6261 set as required. C<listval> and C<subscript> supply the parameters of
6262 the slice; they are consumed by this function and become part of the
6263 constructed op tree.
6269 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6271 return newBINOP(OP_LSLICE, flags,
6272 list(force_list(subscript, 1)),
6273 list(force_list(listval, 1)) );
6276 #define ASSIGN_LIST 1
6277 #define ASSIGN_REF 2
6280 S_assignment_type(pTHX_ const OP *o)
6289 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6290 o = cUNOPo->op_first;
6292 flags = o->op_flags;
6294 if (type == OP_COND_EXPR) {
6295 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6296 const I32 t = assignment_type(sib);
6297 const I32 f = assignment_type(OpSIBLING(sib));
6299 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6301 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6302 yyerror("Assignment to both a list and a scalar");
6306 if (type == OP_SREFGEN)
6308 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6309 type = kid->op_type;
6310 flags |= kid->op_flags;
6311 if (!(flags & OPf_PARENS)
6312 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6313 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6319 if (type == OP_LIST &&
6320 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6321 o->op_private & OPpLVAL_INTRO)
6324 if (type == OP_LIST || flags & OPf_PARENS ||
6325 type == OP_RV2AV || type == OP_RV2HV ||
6326 type == OP_ASLICE || type == OP_HSLICE ||
6327 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6330 if (type == OP_PADAV || type == OP_PADHV)
6333 if (type == OP_RV2SV)
6341 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6343 Constructs, checks, and returns an assignment op. C<left> and C<right>
6344 supply the parameters of the assignment; they are consumed by this
6345 function and become part of the constructed op tree.
6347 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6348 a suitable conditional optree is constructed. If C<optype> is the opcode
6349 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6350 performs the binary operation and assigns the result to the left argument.
6351 Either way, if C<optype> is non-zero then C<flags> has no effect.
6353 If C<optype> is zero, then a plain scalar or list assignment is
6354 constructed. Which type of assignment it is is automatically determined.
6355 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6356 will be set automatically, and, shifted up eight bits, the eight bits
6357 of C<op_private>, except that the bit with value 1 or 2 is automatically
6364 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6370 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6371 return newLOGOP(optype, 0,
6372 op_lvalue(scalar(left), optype),
6373 newUNOP(OP_SASSIGN, 0, scalar(right)));
6376 return newBINOP(optype, OPf_STACKED,
6377 op_lvalue(scalar(left), optype), scalar(right));
6381 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6382 static const char no_list_state[] = "Initialization of state variables"
6383 " in list context currently forbidden";
6386 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6387 left->op_private &= ~ OPpSLICEWARNING;
6390 left = op_lvalue(left, OP_AASSIGN);
6391 curop = list(force_list(left, 1));
6392 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6393 o->op_private = (U8)(0 | (flags >> 8));
6395 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6397 OP* lop = ((LISTOP*)left)->op_first;
6399 if ((lop->op_type == OP_PADSV ||
6400 lop->op_type == OP_PADAV ||
6401 lop->op_type == OP_PADHV ||
6402 lop->op_type == OP_PADANY)
6403 && (lop->op_private & OPpPAD_STATE)
6405 yyerror(no_list_state);
6406 lop = OpSIBLING(lop);
6409 else if ( (left->op_private & OPpLVAL_INTRO)
6410 && (left->op_private & OPpPAD_STATE)
6411 && ( left->op_type == OP_PADSV
6412 || left->op_type == OP_PADAV
6413 || left->op_type == OP_PADHV
6414 || left->op_type == OP_PADANY)
6416 /* All single variable list context state assignments, hence
6426 yyerror(no_list_state);
6429 if (right && right->op_type == OP_SPLIT
6430 && !(right->op_flags & OPf_STACKED)) {
6431 OP* tmpop = ((LISTOP*)right)->op_first;
6432 PMOP * const pm = (PMOP*)tmpop;
6433 assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6436 !pm->op_pmreplrootu.op_pmtargetoff
6438 !pm->op_pmreplrootu.op_pmtargetgv
6442 if (!(left->op_private & OPpLVAL_INTRO) &&
6443 ( (left->op_type == OP_RV2AV &&
6444 (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6445 || left->op_type == OP_PADAV )
6447 if (tmpop != (OP *)pm) {
6449 pm->op_pmreplrootu.op_pmtargetoff
6450 = cPADOPx(tmpop)->op_padix;
6451 cPADOPx(tmpop)->op_padix = 0; /* steal it */
6453 pm->op_pmreplrootu.op_pmtargetgv
6454 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6455 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
6457 right->op_private |=
6458 left->op_private & OPpOUR_INTRO;
6461 pm->op_targ = left->op_targ;
6462 left->op_targ = 0; /* filch it */
6465 tmpop = cUNOPo->op_first; /* to list (nulled) */
6466 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6467 /* detach rest of siblings from o subtree,
6468 * and free subtree */
6469 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6470 op_free(o); /* blow off assign */
6471 right->op_flags &= ~OPf_WANT;
6472 /* "I don't know and I don't care." */
6475 else if (left->op_type == OP_RV2AV
6476 || left->op_type == OP_PADAV)
6478 /* Detach the array. */
6482 op_sibling_splice(cBINOPo->op_last,
6483 cUNOPx(cBINOPo->op_last)
6484 ->op_first, 1, NULL);
6485 assert(ary == left);
6486 /* Attach it to the split. */
6487 op_sibling_splice(right, cLISTOPx(right)->op_last,
6489 right->op_flags |= OPf_STACKED;
6490 /* Detach split and expunge aassign as above. */
6493 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6494 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6497 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6498 SV * const sv = *svp;
6499 if (SvIOK(sv) && SvIVX(sv) == 0)
6501 if (right->op_private & OPpSPLIT_IMPLIM) {
6502 /* our own SV, created in ck_split */
6504 sv_setiv(sv, PL_modcount+1);
6507 /* SV may belong to someone else */
6509 *svp = newSViv(PL_modcount+1);
6517 if (assign_type == ASSIGN_REF)
6518 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6520 right = newOP(OP_UNDEF, 0);
6521 if (right->op_type == OP_READLINE) {
6522 right->op_flags |= OPf_STACKED;
6523 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6527 o = newBINOP(OP_SASSIGN, flags,
6528 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6534 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6536 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6537 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6538 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6539 If C<label> is non-null, it supplies the name of a label to attach to
6540 the state op; this function takes ownership of the memory pointed at by
6541 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
6544 If C<o> is null, the state op is returned. Otherwise the state op is
6545 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
6546 is consumed by this function and becomes part of the returned op tree.
6552 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6555 const U32 seq = intro_my();
6556 const U32 utf8 = flags & SVf_UTF8;
6559 PL_parser->parsed_sub = 0;
6563 NewOp(1101, cop, 1, COP);
6564 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6565 OpTYPE_set(cop, OP_DBSTATE);
6568 OpTYPE_set(cop, OP_NEXTSTATE);
6570 cop->op_flags = (U8)flags;
6571 CopHINTS_set(cop, PL_hints);
6573 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6575 cop->op_next = (OP*)cop;
6578 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6579 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6581 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6583 PL_hints |= HINT_BLOCK_SCOPE;
6584 /* It seems that we need to defer freeing this pointer, as other parts
6585 of the grammar end up wanting to copy it after this op has been
6590 if (PL_parser->preambling != NOLINE) {
6591 CopLINE_set(cop, PL_parser->preambling);
6592 PL_parser->copline = NOLINE;
6594 else if (PL_parser->copline == NOLINE)
6595 CopLINE_set(cop, CopLINE(PL_curcop));
6597 CopLINE_set(cop, PL_parser->copline);
6598 PL_parser->copline = NOLINE;
6601 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6603 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6605 CopSTASH_set(cop, PL_curstash);
6607 if (cop->op_type == OP_DBSTATE) {
6608 /* this line can have a breakpoint - store the cop in IV */
6609 AV *av = CopFILEAVx(PL_curcop);
6611 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6612 if (svp && *svp != &PL_sv_undef ) {
6613 (void)SvIOK_on(*svp);
6614 SvIV_set(*svp, PTR2IV(cop));
6619 if (flags & OPf_SPECIAL)
6621 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6625 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6627 Constructs, checks, and returns a logical (flow control) op. C<type>
6628 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6629 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6630 the eight bits of C<op_private>, except that the bit with value 1 is
6631 automatically set. C<first> supplies the expression controlling the
6632 flow, and C<other> supplies the side (alternate) chain of ops; they are
6633 consumed by this function and become part of the constructed op tree.
6639 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6641 PERL_ARGS_ASSERT_NEWLOGOP;
6643 return new_logop(type, flags, &first, &other);
6647 S_search_const(pTHX_ OP *o)
6649 PERL_ARGS_ASSERT_SEARCH_CONST;
6651 switch (o->op_type) {
6655 if (o->op_flags & OPf_KIDS)
6656 return search_const(cUNOPo->op_first);
6663 if (!(o->op_flags & OPf_KIDS))
6665 kid = cLISTOPo->op_first;
6667 switch (kid->op_type) {
6671 kid = OpSIBLING(kid);
6674 if (kid != cLISTOPo->op_last)
6680 kid = cLISTOPo->op_last;
6682 return search_const(kid);
6690 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6698 int prepend_not = 0;
6700 PERL_ARGS_ASSERT_NEW_LOGOP;
6705 /* [perl #59802]: Warn about things like "return $a or $b", which
6706 is parsed as "(return $a) or $b" rather than "return ($a or
6707 $b)". NB: This also applies to xor, which is why we do it
6710 switch (first->op_type) {
6714 /* XXX: Perhaps we should emit a stronger warning for these.
6715 Even with the high-precedence operator they don't seem to do
6718 But until we do, fall through here.
6724 /* XXX: Currently we allow people to "shoot themselves in the
6725 foot" by explicitly writing "(return $a) or $b".
6727 Warn unless we are looking at the result from folding or if
6728 the programmer explicitly grouped the operators like this.
6729 The former can occur with e.g.
6731 use constant FEATURE => ( $] >= ... );
6732 sub { not FEATURE and return or do_stuff(); }
6734 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6735 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6736 "Possible precedence issue with control flow operator");
6737 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6743 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6744 return newBINOP(type, flags, scalar(first), scalar(other));
6746 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6747 || type == OP_CUSTOM);
6749 scalarboolean(first);
6750 /* optimize AND and OR ops that have NOTs as children */
6751 if (first->op_type == OP_NOT
6752 && (first->op_flags & OPf_KIDS)
6753 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6754 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6756 if (type == OP_AND || type == OP_OR) {
6762 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6764 prepend_not = 1; /* prepend a NOT op later */
6768 /* search for a constant op that could let us fold the test */
6769 if ((cstop = search_const(first))) {
6770 if (cstop->op_private & OPpCONST_STRICT)
6771 no_bareword_allowed(cstop);
6772 else if ((cstop->op_private & OPpCONST_BARE))
6773 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6774 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6775 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6776 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6778 if (other->op_type == OP_CONST)
6779 other->op_private |= OPpCONST_SHORTCIRCUIT;
6781 if (other->op_type == OP_LEAVE)
6782 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6783 else if (other->op_type == OP_MATCH
6784 || other->op_type == OP_SUBST
6785 || other->op_type == OP_TRANSR
6786 || other->op_type == OP_TRANS)
6787 /* Mark the op as being unbindable with =~ */
6788 other->op_flags |= OPf_SPECIAL;
6790 other->op_folded = 1;
6794 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6795 const OP *o2 = other;
6796 if ( ! (o2->op_type == OP_LIST
6797 && (( o2 = cUNOPx(o2)->op_first))
6798 && o2->op_type == OP_PUSHMARK
6799 && (( o2 = OpSIBLING(o2))) )
6802 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6803 || o2->op_type == OP_PADHV)
6804 && o2->op_private & OPpLVAL_INTRO
6805 && !(o2->op_private & OPpPAD_STATE))
6807 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6808 "Deprecated use of my() in false conditional");
6812 if (cstop->op_type == OP_CONST)
6813 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6818 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6819 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6821 const OP * const k1 = ((UNOP*)first)->op_first;
6822 const OP * const k2 = OpSIBLING(k1);
6824 switch (first->op_type)
6827 if (k2 && k2->op_type == OP_READLINE
6828 && (k2->op_flags & OPf_STACKED)
6829 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6831 warnop = k2->op_type;
6836 if (k1->op_type == OP_READDIR
6837 || k1->op_type == OP_GLOB
6838 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6839 || k1->op_type == OP_EACH
6840 || k1->op_type == OP_AEACH)
6842 warnop = ((k1->op_type == OP_NULL)
6843 ? (OPCODE)k1->op_targ : k1->op_type);
6848 const line_t oldline = CopLINE(PL_curcop);
6849 /* This ensures that warnings are reported at the first line
6850 of the construction, not the last. */
6851 CopLINE_set(PL_curcop, PL_parser->copline);
6852 Perl_warner(aTHX_ packWARN(WARN_MISC),
6853 "Value of %s%s can be \"0\"; test with defined()",
6855 ((warnop == OP_READLINE || warnop == OP_GLOB)
6856 ? " construct" : "() operator"));
6857 CopLINE_set(PL_curcop, oldline);
6864 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6865 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6867 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6868 logop->op_flags |= (U8)flags;
6869 logop->op_private = (U8)(1 | (flags >> 8));
6871 /* establish postfix order */
6872 logop->op_next = LINKLIST(first);
6873 first->op_next = (OP*)logop;
6874 assert(!OpHAS_SIBLING(first));
6875 op_sibling_splice((OP*)logop, first, 0, other);
6877 CHECKOP(type,logop);
6879 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
6880 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
6888 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6890 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6891 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6892 will be set automatically, and, shifted up eight bits, the eight bits of
6893 C<op_private>, except that the bit with value 1 is automatically set.
6894 C<first> supplies the expression selecting between the two branches,
6895 and C<trueop> and C<falseop> supply the branches; they are consumed by
6896 this function and become part of the constructed op tree.
6902 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6910 PERL_ARGS_ASSERT_NEWCONDOP;
6913 return newLOGOP(OP_AND, 0, first, trueop);
6915 return newLOGOP(OP_OR, 0, first, falseop);
6917 scalarboolean(first);
6918 if ((cstop = search_const(first))) {
6919 /* Left or right arm of the conditional? */
6920 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6921 OP *live = left ? trueop : falseop;
6922 OP *const dead = left ? falseop : trueop;
6923 if (cstop->op_private & OPpCONST_BARE &&
6924 cstop->op_private & OPpCONST_STRICT) {
6925 no_bareword_allowed(cstop);
6929 if (live->op_type == OP_LEAVE)
6930 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6931 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6932 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6933 /* Mark the op as being unbindable with =~ */
6934 live->op_flags |= OPf_SPECIAL;
6935 live->op_folded = 1;
6938 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6939 logop->op_flags |= (U8)flags;
6940 logop->op_private = (U8)(1 | (flags >> 8));
6941 logop->op_next = LINKLIST(falseop);
6943 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6946 /* establish postfix order */
6947 start = LINKLIST(first);
6948 first->op_next = (OP*)logop;
6950 /* make first, trueop, falseop siblings */
6951 op_sibling_splice((OP*)logop, first, 0, trueop);
6952 op_sibling_splice((OP*)logop, trueop, 0, falseop);
6954 o = newUNOP(OP_NULL, 0, (OP*)logop);
6956 trueop->op_next = falseop->op_next = o;
6963 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6965 Constructs and returns a C<range> op, with subordinate C<flip> and
6966 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
6967 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6968 for both the C<flip> and C<range> ops, except that the bit with value
6969 1 is automatically set. C<left> and C<right> supply the expressions
6970 controlling the endpoints of the range; they are consumed by this function
6971 and become part of the constructed op tree.
6977 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6985 PERL_ARGS_ASSERT_NEWRANGE;
6987 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6988 range->op_flags = OPf_KIDS;
6989 leftstart = LINKLIST(left);
6990 range->op_private = (U8)(1 | (flags >> 8));
6992 /* make left and right siblings */
6993 op_sibling_splice((OP*)range, left, 0, right);
6995 range->op_next = (OP*)range;
6996 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6997 flop = newUNOP(OP_FLOP, 0, flip);
6998 o = newUNOP(OP_NULL, 0, flop);
7000 range->op_next = leftstart;
7002 left->op_next = flip;
7003 right->op_next = flop;
7006 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7007 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7009 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7010 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7011 SvPADTMP_on(PAD_SV(flip->op_targ));
7013 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7014 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7016 /* check barewords before they might be optimized aways */
7017 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7018 no_bareword_allowed(left);
7019 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7020 no_bareword_allowed(right);
7023 if (!flip->op_private || !flop->op_private)
7024 LINKLIST(o); /* blow off optimizer unless constant */
7030 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7032 Constructs, checks, and returns an op tree expressing a loop. This is
7033 only a loop in the control flow through the op tree; it does not have
7034 the heavyweight loop structure that allows exiting the loop by C<last>
7035 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
7036 top-level op, except that some bits will be set automatically as required.
7037 C<expr> supplies the expression controlling loop iteration, and C<block>
7038 supplies the body of the loop; they are consumed by this function and
7039 become part of the constructed op tree. C<debuggable> is currently
7040 unused and should always be 1.
7046 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7050 const bool once = block && block->op_flags & OPf_SPECIAL &&
7051 block->op_type == OP_NULL;
7053 PERL_UNUSED_ARG(debuggable);
7057 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7058 || ( expr->op_type == OP_NOT
7059 && cUNOPx(expr)->op_first->op_type == OP_CONST
7060 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7063 /* Return the block now, so that S_new_logop does not try to
7065 return block; /* do {} while 0 does once */
7066 if (expr->op_type == OP_READLINE
7067 || expr->op_type == OP_READDIR
7068 || expr->op_type == OP_GLOB
7069 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7070 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7071 expr = newUNOP(OP_DEFINED, 0,
7072 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7073 } else if (expr->op_flags & OPf_KIDS) {
7074 const OP * const k1 = ((UNOP*)expr)->op_first;
7075 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7076 switch (expr->op_type) {
7078 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7079 && (k2->op_flags & OPf_STACKED)
7080 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7081 expr = newUNOP(OP_DEFINED, 0, expr);
7085 if (k1 && (k1->op_type == OP_READDIR
7086 || k1->op_type == OP_GLOB
7087 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7088 || k1->op_type == OP_EACH
7089 || k1->op_type == OP_AEACH))
7090 expr = newUNOP(OP_DEFINED, 0, expr);
7096 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7097 * op, in listop. This is wrong. [perl #27024] */
7099 block = newOP(OP_NULL, 0);
7100 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7101 o = new_logop(OP_AND, 0, &expr, &listop);
7108 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7110 if (once && o != listop)
7112 assert(cUNOPo->op_first->op_type == OP_AND
7113 || cUNOPo->op_first->op_type == OP_OR);
7114 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7118 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7120 o->op_flags |= flags;
7122 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7127 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7129 Constructs, checks, and returns an op tree expressing a C<while> loop.
7130 This is a heavyweight loop, with structure that allows exiting the loop
7131 by C<last> and suchlike.
7133 C<loop> is an optional preconstructed C<enterloop> op to use in the
7134 loop; if it is null then a suitable op will be constructed automatically.
7135 C<expr> supplies the loop's controlling expression. C<block> supplies the
7136 main body of the loop, and C<cont> optionally supplies a C<continue> block
7137 that operates as a second half of the body. All of these optree inputs
7138 are consumed by this function and become part of the constructed op tree.
7140 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7141 op and, shifted up eight bits, the eight bits of C<op_private> for
7142 the C<leaveloop> op, except that (in both cases) some bits will be set
7143 automatically. C<debuggable> is currently unused and should always be 1.
7144 C<has_my> can be supplied as true to force the
7145 loop body to be enclosed in its own scope.
7151 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7152 OP *expr, OP *block, OP *cont, I32 has_my)
7161 PERL_UNUSED_ARG(debuggable);
7164 if (expr->op_type == OP_READLINE
7165 || expr->op_type == OP_READDIR
7166 || expr->op_type == OP_GLOB
7167 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7168 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7169 expr = newUNOP(OP_DEFINED, 0,
7170 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7171 } else if (expr->op_flags & OPf_KIDS) {
7172 const OP * const k1 = ((UNOP*)expr)->op_first;
7173 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7174 switch (expr->op_type) {
7176 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7177 && (k2->op_flags & OPf_STACKED)
7178 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7179 expr = newUNOP(OP_DEFINED, 0, expr);
7183 if (k1 && (k1->op_type == OP_READDIR
7184 || k1->op_type == OP_GLOB
7185 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7186 || k1->op_type == OP_EACH
7187 || k1->op_type == OP_AEACH))
7188 expr = newUNOP(OP_DEFINED, 0, expr);
7195 block = newOP(OP_NULL, 0);
7196 else if (cont || has_my) {
7197 block = op_scope(block);
7201 next = LINKLIST(cont);
7204 OP * const unstack = newOP(OP_UNSTACK, 0);
7207 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7211 listop = op_append_list(OP_LINESEQ, block, cont);
7213 redo = LINKLIST(listop);
7217 o = new_logop(OP_AND, 0, &expr, &listop);
7218 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7220 return expr; /* listop already freed by new_logop */
7223 ((LISTOP*)listop)->op_last->op_next =
7224 (o == listop ? redo : LINKLIST(o));
7230 NewOp(1101,loop,1,LOOP);
7231 OpTYPE_set(loop, OP_ENTERLOOP);
7232 loop->op_private = 0;
7233 loop->op_next = (OP*)loop;
7236 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7238 loop->op_redoop = redo;
7239 loop->op_lastop = o;
7240 o->op_private |= loopflags;
7243 loop->op_nextop = next;
7245 loop->op_nextop = o;
7247 o->op_flags |= flags;
7248 o->op_private |= (flags >> 8);
7253 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7255 Constructs, checks, and returns an op tree expressing a C<foreach>
7256 loop (iteration through a list of values). This is a heavyweight loop,
7257 with structure that allows exiting the loop by C<last> and suchlike.
7259 C<sv> optionally supplies the variable that will be aliased to each
7260 item in turn; if null, it defaults to C<$_>.
7261 C<expr> supplies the list of values to iterate over. C<block> supplies
7262 the main body of the loop, and C<cont> optionally supplies a C<continue>
7263 block that operates as a second half of the body. All of these optree
7264 inputs are consumed by this function and become part of the constructed
7267 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7268 op and, shifted up eight bits, the eight bits of C<op_private> for
7269 the C<leaveloop> op, except that (in both cases) some bits will be set
7276 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7281 PADOFFSET padoff = 0;
7285 PERL_ARGS_ASSERT_NEWFOROP;
7288 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7289 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7290 OpTYPE_set(sv, OP_RV2GV);
7292 /* The op_type check is needed to prevent a possible segfault
7293 * if the loop variable is undeclared and 'strict vars' is in
7294 * effect. This is illegal but is nonetheless parsed, so we
7295 * may reach this point with an OP_CONST where we're expecting
7298 if (cUNOPx(sv)->op_first->op_type == OP_GV
7299 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7300 iterpflags |= OPpITER_DEF;
7302 else if (sv->op_type == OP_PADSV) { /* private variable */
7303 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7304 padoff = sv->op_targ;
7308 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7310 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7313 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7315 PADNAME * const pn = PAD_COMPNAME(padoff);
7316 const char * const name = PadnamePV(pn);
7318 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7319 iterpflags |= OPpITER_DEF;
7323 sv = newGVOP(OP_GV, 0, PL_defgv);
7324 iterpflags |= OPpITER_DEF;
7327 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7328 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7329 iterflags |= OPf_STACKED;
7331 else if (expr->op_type == OP_NULL &&
7332 (expr->op_flags & OPf_KIDS) &&
7333 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7335 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7336 * set the STACKED flag to indicate that these values are to be
7337 * treated as min/max values by 'pp_enteriter'.
7339 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7340 LOGOP* const range = (LOGOP*) flip->op_first;
7341 OP* const left = range->op_first;
7342 OP* const right = OpSIBLING(left);
7345 range->op_flags &= ~OPf_KIDS;
7346 /* detach range's children */
7347 op_sibling_splice((OP*)range, NULL, -1, NULL);
7349 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7350 listop->op_first->op_next = range->op_next;
7351 left->op_next = range->op_other;
7352 right->op_next = (OP*)listop;
7353 listop->op_next = listop->op_first;
7356 expr = (OP*)(listop);
7358 iterflags |= OPf_STACKED;
7361 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7364 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7365 op_append_elem(OP_LIST, list(expr),
7367 assert(!loop->op_next);
7368 /* for my $x () sets OPpLVAL_INTRO;
7369 * for our $x () sets OPpOUR_INTRO */
7370 loop->op_private = (U8)iterpflags;
7371 if (loop->op_slabbed
7372 && DIFF(loop, OpSLOT(loop)->opslot_next)
7373 < SIZE_TO_PSIZE(sizeof(LOOP)))
7376 NewOp(1234,tmp,1,LOOP);
7377 Copy(loop,tmp,1,LISTOP);
7378 #ifdef PERL_OP_PARENT
7379 assert(loop->op_last->op_sibparent == (OP*)loop);
7380 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7382 S_op_destroy(aTHX_ (OP*)loop);
7385 else if (!loop->op_slabbed)
7387 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7388 #ifdef PERL_OP_PARENT
7389 OpLASTSIB_set(loop->op_last, (OP*)loop);
7392 loop->op_targ = padoff;
7393 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7398 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7400 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7401 or C<last>). C<type> is the opcode. C<label> supplies the parameter
7402 determining the target of the op; it is consumed by this function and
7403 becomes part of the constructed op tree.
7409 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7413 PERL_ARGS_ASSERT_NEWLOOPEX;
7415 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7416 || type == OP_CUSTOM);
7418 if (type != OP_GOTO) {
7419 /* "last()" means "last" */
7420 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7421 o = newOP(type, OPf_SPECIAL);
7425 /* Check whether it's going to be a goto &function */
7426 if (label->op_type == OP_ENTERSUB
7427 && !(label->op_flags & OPf_STACKED))
7428 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7431 /* Check for a constant argument */
7432 if (label->op_type == OP_CONST) {
7433 SV * const sv = ((SVOP *)label)->op_sv;
7435 const char *s = SvPV_const(sv,l);
7436 if (l == strlen(s)) {
7438 SvUTF8(((SVOP*)label)->op_sv),
7440 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7444 /* If we have already created an op, we do not need the label. */
7447 else o = newUNOP(type, OPf_STACKED, label);
7449 PL_hints |= HINT_BLOCK_SCOPE;
7453 /* if the condition is a literal array or hash
7454 (or @{ ... } etc), make a reference to it.
7457 S_ref_array_or_hash(pTHX_ OP *cond)
7460 && (cond->op_type == OP_RV2AV
7461 || cond->op_type == OP_PADAV
7462 || cond->op_type == OP_RV2HV
7463 || cond->op_type == OP_PADHV))
7465 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7468 && (cond->op_type == OP_ASLICE
7469 || cond->op_type == OP_KVASLICE
7470 || cond->op_type == OP_HSLICE
7471 || cond->op_type == OP_KVHSLICE)) {
7473 /* anonlist now needs a list from this op, was previously used in
7475 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7476 cond->op_flags |= OPf_WANT_LIST;
7478 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7485 /* These construct the optree fragments representing given()
7488 entergiven and enterwhen are LOGOPs; the op_other pointer
7489 points up to the associated leave op. We need this so we
7490 can put it in the context and make break/continue work.
7491 (Also, of course, pp_enterwhen will jump straight to
7492 op_other if the match fails.)
7496 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7497 I32 enter_opcode, I32 leave_opcode,
7498 PADOFFSET entertarg)
7504 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7505 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7507 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7508 enterop->op_targ = 0;
7509 enterop->op_private = 0;
7511 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7514 /* prepend cond if we have one */
7515 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7517 o->op_next = LINKLIST(cond);
7518 cond->op_next = (OP *) enterop;
7521 /* This is a default {} block */
7522 enterop->op_flags |= OPf_SPECIAL;
7523 o ->op_flags |= OPf_SPECIAL;
7525 o->op_next = (OP *) enterop;
7528 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7529 entergiven and enterwhen both
7532 enterop->op_next = LINKLIST(block);
7533 block->op_next = enterop->op_other = o;
7538 /* Does this look like a boolean operation? For these purposes
7539 a boolean operation is:
7540 - a subroutine call [*]
7541 - a logical connective
7542 - a comparison operator
7543 - a filetest operator, with the exception of -s -M -A -C
7544 - defined(), exists() or eof()
7545 - /$re/ or $foo =~ /$re/
7547 [*] possibly surprising
7550 S_looks_like_bool(pTHX_ const OP *o)
7552 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7554 switch(o->op_type) {
7557 return looks_like_bool(cLOGOPo->op_first);
7561 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7564 looks_like_bool(cLOGOPo->op_first)
7565 && looks_like_bool(sibl));
7571 o->op_flags & OPf_KIDS
7572 && looks_like_bool(cUNOPo->op_first));
7576 case OP_NOT: case OP_XOR:
7578 case OP_EQ: case OP_NE: case OP_LT:
7579 case OP_GT: case OP_LE: case OP_GE:
7581 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7582 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7584 case OP_SEQ: case OP_SNE: case OP_SLT:
7585 case OP_SGT: case OP_SLE: case OP_SGE:
7589 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7590 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7591 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7592 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7593 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7594 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7595 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7596 case OP_FTTEXT: case OP_FTBINARY:
7598 case OP_DEFINED: case OP_EXISTS:
7599 case OP_MATCH: case OP_EOF:
7606 /* Detect comparisons that have been optimized away */
7607 if (cSVOPo->op_sv == &PL_sv_yes
7608 || cSVOPo->op_sv == &PL_sv_no)
7621 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7623 Constructs, checks, and returns an op tree expressing a C<given> block.
7624 C<cond> supplies the expression that will be locally assigned to a lexical
7625 variable, and C<block> supplies the body of the C<given> construct; they
7626 are consumed by this function and become part of the constructed op tree.
7627 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7633 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7635 PERL_ARGS_ASSERT_NEWGIVENOP;
7636 PERL_UNUSED_ARG(defsv_off);
7639 return newGIVWHENOP(
7640 ref_array_or_hash(cond),
7642 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7647 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7649 Constructs, checks, and returns an op tree expressing a C<when> block.
7650 C<cond> supplies the test expression, and C<block> supplies the block
7651 that will be executed if the test evaluates to true; they are consumed
7652 by this function and become part of the constructed op tree. C<cond>
7653 will be interpreted DWIMically, often as a comparison against C<$_>,
7654 and may be null to generate a C<default> block.
7660 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7662 const bool cond_llb = (!cond || looks_like_bool(cond));
7665 PERL_ARGS_ASSERT_NEWWHENOP;
7670 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7672 scalar(ref_array_or_hash(cond)));
7675 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7678 /* must not conflict with SVf_UTF8 */
7679 #define CV_CKPROTO_CURSTASH 0x1
7682 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7683 const STRLEN len, const U32 flags)
7685 SV *name = NULL, *msg;
7686 const char * cvp = SvROK(cv)
7687 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7688 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7691 STRLEN clen = CvPROTOLEN(cv), plen = len;
7693 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7695 if (p == NULL && cvp == NULL)
7698 if (!ckWARN_d(WARN_PROTOTYPE))
7702 p = S_strip_spaces(aTHX_ p, &plen);
7703 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7704 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7705 if (plen == clen && memEQ(cvp, p, plen))
7708 if (flags & SVf_UTF8) {
7709 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7713 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7719 msg = sv_newmortal();
7724 gv_efullname3(name = sv_newmortal(), gv, NULL);
7725 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7726 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7727 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7728 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7729 sv_catpvs(name, "::");
7731 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7732 assert (CvNAMED(SvRV_const(gv)));
7733 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7735 else sv_catsv(name, (SV *)gv);
7737 else name = (SV *)gv;
7739 sv_setpvs(msg, "Prototype mismatch:");
7741 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7743 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7744 UTF8fARG(SvUTF8(cv),clen,cvp)
7747 sv_catpvs(msg, ": none");
7748 sv_catpvs(msg, " vs ");
7750 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7752 sv_catpvs(msg, "none");
7753 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7756 static void const_sv_xsub(pTHX_ CV* cv);
7757 static void const_av_xsub(pTHX_ CV* cv);
7761 =head1 Optree Manipulation Functions
7763 =for apidoc cv_const_sv
7765 If C<cv> is a constant sub eligible for inlining, returns the constant
7766 value returned by the sub. Otherwise, returns C<NULL>.
7768 Constant subs can be created with C<newCONSTSUB> or as described in
7769 L<perlsub/"Constant Functions">.
7774 Perl_cv_const_sv(const CV *const cv)
7779 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7781 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7782 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7787 Perl_cv_const_sv_or_av(const CV * const cv)
7791 if (SvROK(cv)) return SvRV((SV *)cv);
7792 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7793 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7796 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7797 * Can be called in 2 ways:
7800 * look for a single OP_CONST with attached value: return the value
7802 * allow_lex && !CvCONST(cv);
7804 * examine the clone prototype, and if contains only a single
7805 * OP_CONST, return the value; or if it contains a single PADSV ref-
7806 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7807 * a candidate for "constizing" at clone time, and return NULL.
7811 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7819 for (; o; o = o->op_next) {
7820 const OPCODE type = o->op_type;
7822 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7824 || type == OP_PUSHMARK)
7826 if (type == OP_DBSTATE)
7828 if (type == OP_LEAVESUB)
7832 if (type == OP_CONST && cSVOPo->op_sv)
7834 else if (type == OP_UNDEF && !o->op_private) {
7838 else if (allow_lex && type == OP_PADSV) {
7839 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7841 sv = &PL_sv_undef; /* an arbitrary non-null value */
7859 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7860 PADNAME * const name, SV ** const const_svp)
7867 if (CvFLAGS(PL_compcv)) {
7868 /* might have had built-in attrs applied */
7869 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7870 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7871 && ckWARN(WARN_MISC))
7873 /* protect against fatal warnings leaking compcv */
7874 SAVEFREESV(PL_compcv);
7875 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7876 SvREFCNT_inc_simple_void_NN(PL_compcv);
7879 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7880 & ~(CVf_LVALUE * pureperl));
7885 /* redundant check for speed: */
7886 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7887 const line_t oldline = CopLINE(PL_curcop);
7890 : sv_2mortal(newSVpvn_utf8(
7891 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7893 if (PL_parser && PL_parser->copline != NOLINE)
7894 /* This ensures that warnings are reported at the first
7895 line of a redefinition, not the last. */
7896 CopLINE_set(PL_curcop, PL_parser->copline);
7897 /* protect against fatal warnings leaking compcv */
7898 SAVEFREESV(PL_compcv);
7899 report_redefined_cv(namesv, cv, const_svp);
7900 SvREFCNT_inc_simple_void_NN(PL_compcv);
7901 CopLINE_set(PL_curcop, oldline);
7908 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7913 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7916 CV *compcv = PL_compcv;
7919 PADOFFSET pax = o->op_targ;
7920 CV *outcv = CvOUTSIDE(PL_compcv);
7923 bool reusable = FALSE;
7925 #ifdef PERL_DEBUG_READONLY_OPS
7926 OPSLAB *slab = NULL;
7929 PERL_ARGS_ASSERT_NEWMYSUB;
7931 /* Find the pad slot for storing the new sub.
7932 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7933 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7934 ing sub. And then we need to dig deeper if this is a lexical from
7936 my sub foo; sub { sub foo { } }
7939 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7940 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7941 pax = PARENT_PAD_INDEX(name);
7942 outcv = CvOUTSIDE(outcv);
7947 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7948 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7949 spot = (CV **)svspot;
7951 if (!(PL_parser && PL_parser->error_count))
7952 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
7955 assert(proto->op_type == OP_CONST);
7956 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7957 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7967 if (PL_parser && PL_parser->error_count) {
7969 SvREFCNT_dec(PL_compcv);
7974 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7976 svspot = (SV **)(spot = &clonee);
7978 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7981 assert (SvTYPE(*spot) == SVt_PVCV);
7983 hek = CvNAME_HEK(*spot);
7987 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7988 CvNAME_HEK_set(*spot, hek =
7991 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
7995 CvLEXICAL_on(*spot);
7997 cv = PadnamePROTOCV(name);
7998 svspot = (SV **)(spot = &PadnamePROTOCV(name));
8002 /* This makes sub {}; work as expected. */
8003 if (block->op_type == OP_STUB) {
8004 const line_t l = PL_parser->copline;
8006 block = newSTATEOP(0, NULL, 0);
8007 PL_parser->copline = l;
8009 block = CvLVALUE(compcv)
8010 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8011 ? newUNOP(OP_LEAVESUBLV, 0,
8012 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8013 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8014 start = LINKLIST(block);
8016 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8017 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8025 const bool exists = CvROOT(cv) || CvXSUB(cv);
8027 /* if the subroutine doesn't exist and wasn't pre-declared
8028 * with a prototype, assume it will be AUTOLOADed,
8029 * skipping the prototype check
8031 if (exists || SvPOK(cv))
8032 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8034 /* already defined? */
8036 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8039 if (attrs) goto attrs;
8040 /* just a "sub foo;" when &foo is already defined */
8045 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8051 SvREFCNT_inc_simple_void_NN(const_sv);
8052 SvFLAGS(const_sv) |= SVs_PADTMP;
8054 assert(!CvROOT(cv) && !CvCONST(cv));
8058 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8059 CvFILE_set_from_cop(cv, PL_curcop);
8060 CvSTASH_set(cv, PL_curstash);
8063 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8064 CvXSUBANY(cv).any_ptr = const_sv;
8065 CvXSUB(cv) = const_sv_xsub;
8069 CvFLAGS(cv) |= CvMETHOD(compcv);
8071 SvREFCNT_dec(compcv);
8075 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8076 determine whether this sub definition is in the same scope as its
8077 declaration. If this sub definition is inside an inner named pack-
8078 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8079 the package sub. So check PadnameOUTER(name) too.
8081 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8082 assert(!CvWEAKOUTSIDE(compcv));
8083 SvREFCNT_dec(CvOUTSIDE(compcv));
8084 CvWEAKOUTSIDE_on(compcv);
8086 /* XXX else do we have a circular reference? */
8087 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8088 /* transfer PL_compcv to cv */
8091 cv_flags_t preserved_flags =
8092 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8093 PADLIST *const temp_padl = CvPADLIST(cv);
8094 CV *const temp_cv = CvOUTSIDE(cv);
8095 const cv_flags_t other_flags =
8096 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8097 OP * const cvstart = CvSTART(cv);
8101 CvFLAGS(compcv) | preserved_flags;
8102 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8103 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8104 CvPADLIST_set(cv, CvPADLIST(compcv));
8105 CvOUTSIDE(compcv) = temp_cv;
8106 CvPADLIST_set(compcv, temp_padl);
8107 CvSTART(cv) = CvSTART(compcv);
8108 CvSTART(compcv) = cvstart;
8109 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8110 CvFLAGS(compcv) |= other_flags;
8112 if (CvFILE(cv) && CvDYNFILE(cv)) {
8113 Safefree(CvFILE(cv));
8116 /* inner references to compcv must be fixed up ... */
8117 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8118 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8119 ++PL_sub_generation;
8122 /* Might have had built-in attributes applied -- propagate them. */
8123 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8125 /* ... before we throw it away */
8126 SvREFCNT_dec(compcv);
8127 PL_compcv = compcv = cv;
8135 if (!CvNAME_HEK(cv)) {
8136 if (hek) (void)share_hek_hek(hek);
8140 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8141 hek = share_hek(PadnamePV(name)+1,
8142 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8145 CvNAME_HEK_set(cv, hek);
8147 if (const_sv) goto clone;
8149 CvFILE_set_from_cop(cv, PL_curcop);
8150 CvSTASH_set(cv, PL_curstash);
8153 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8154 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8160 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8161 the debugger could be able to set a breakpoint in, so signal to
8162 pp_entereval that it should not throw away any saved lines at scope
8165 PL_breakable_sub_gen++;
8167 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8168 OpREFCNT_set(CvROOT(cv), 1);
8169 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8170 itself has a refcount. */
8172 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8173 #ifdef PERL_DEBUG_READONLY_OPS
8174 slab = (OPSLAB *)CvSTART(cv);
8176 CvSTART(cv) = start;
8178 finalize_optree(CvROOT(cv));
8179 S_prune_chain_head(&CvSTART(cv));
8181 /* now that optimizer has done its work, adjust pad values */
8183 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8187 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8188 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8192 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8193 SV * const tmpstr = sv_newmortal();
8194 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8195 GV_ADDMULTI, SVt_PVHV);
8197 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8200 (long)CopLINE(PL_curcop));
8201 if (HvNAME_HEK(PL_curstash)) {
8202 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8203 sv_catpvs(tmpstr, "::");
8205 else sv_setpvs(tmpstr, "__ANON__::");
8206 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8207 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8208 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8209 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8210 hv = GvHVn(db_postponed);
8211 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8212 CV * const pcv = GvCV(db_postponed);
8218 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8226 assert(CvDEPTH(outcv));
8228 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8229 if (reusable) cv_clone_into(clonee, *spot);
8230 else *spot = cv_clone(clonee);
8231 SvREFCNT_dec_NN(clonee);
8234 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8235 PADOFFSET depth = CvDEPTH(outcv);
8238 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8240 *svspot = SvREFCNT_inc_simple_NN(cv);
8241 SvREFCNT_dec(oldcv);
8247 PL_parser->copline = NOLINE;
8249 #ifdef PERL_DEBUG_READONLY_OPS
8259 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8260 OP *block, bool o_is_gv)
8264 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8268 const bool ec = PL_parser && PL_parser->error_count;
8269 /* If the subroutine has no body, no attributes, and no builtin attributes
8270 then it's just a sub declaration, and we may be able to get away with
8271 storing with a placeholder scalar in the symbol table, rather than a
8272 full CV. If anything is present then it will take a full CV to
8274 const I32 gv_fetch_flags
8275 = ec ? GV_NOADD_NOINIT :
8276 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8277 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8279 const char * const name =
8280 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8282 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8283 bool evanescent = FALSE;
8285 #ifdef PERL_DEBUG_READONLY_OPS
8286 OPSLAB *slab = NULL;
8294 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8295 hek and CvSTASH pointer together can imply the GV. If the name
8296 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8297 CvSTASH, so forego the optimisation if we find any.
8298 Also, we may be called from load_module at run time, so
8299 PL_curstash (which sets CvSTASH) may not point to the stash the
8300 sub is stored in. */
8302 ec ? GV_NOADD_NOINIT
8303 : PL_curstash != CopSTASH(PL_curcop)
8304 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8306 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8307 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8309 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8310 SV * const sv = sv_newmortal();
8311 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8312 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8313 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8314 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8316 } else if (PL_curstash) {
8317 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8320 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8325 move_proto_attr(&proto, &attrs, gv);
8328 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8333 assert(proto->op_type == OP_CONST);
8334 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8335 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8349 if (name) SvREFCNT_dec(PL_compcv);
8350 else cv = PL_compcv;
8352 if (name && block) {
8353 const char *s = strrchr(name, ':');
8355 if (strEQ(s, "BEGIN")) {
8356 if (PL_in_eval & EVAL_KEEPERR)
8357 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8359 SV * const errsv = ERRSV;
8360 /* force display of errors found but not reported */
8361 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8362 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8369 if (!block && SvTYPE(gv) != SVt_PVGV) {
8370 /* If we are not defining a new sub and the existing one is not a
8372 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8373 /* We are applying attributes to an existing sub, so we need it
8374 upgraded if it is a constant. */
8375 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8376 gv_init_pvn(gv, PL_curstash, name, namlen,
8377 SVf_UTF8 * name_is_utf8);
8379 else { /* Maybe prototype now, and had at maximum
8380 a prototype or const/sub ref before. */
8381 if (SvTYPE(gv) > SVt_NULL) {
8382 cv_ckproto_len_flags((const CV *)gv,
8383 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8388 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8389 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8392 sv_setiv(MUTABLE_SV(gv), -1);
8395 SvREFCNT_dec(PL_compcv);
8396 cv = PL_compcv = NULL;
8401 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8405 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8411 /* This makes sub {}; work as expected. */
8412 if (block->op_type == OP_STUB) {
8413 const line_t l = PL_parser->copline;
8415 block = newSTATEOP(0, NULL, 0);
8416 PL_parser->copline = l;
8418 block = CvLVALUE(PL_compcv)
8419 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8420 && (!isGV(gv) || !GvASSUMECV(gv)))
8421 ? newUNOP(OP_LEAVESUBLV, 0,
8422 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8423 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8424 start = LINKLIST(block);
8426 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8428 S_op_const_sv(aTHX_ start, PL_compcv,
8429 cBOOL(CvCLONE(PL_compcv)));
8436 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8437 cv_ckproto_len_flags((const CV *)gv,
8438 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8439 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8441 /* All the other code for sub redefinition warnings expects the
8442 clobbered sub to be a CV. Instead of making all those code
8443 paths more complex, just inline the RV version here. */
8444 const line_t oldline = CopLINE(PL_curcop);
8445 assert(IN_PERL_COMPILETIME);
8446 if (PL_parser && PL_parser->copline != NOLINE)
8447 /* This ensures that warnings are reported at the first
8448 line of a redefinition, not the last. */
8449 CopLINE_set(PL_curcop, PL_parser->copline);
8450 /* protect against fatal warnings leaking compcv */
8451 SAVEFREESV(PL_compcv);
8453 if (ckWARN(WARN_REDEFINE)
8454 || ( ckWARN_d(WARN_REDEFINE)
8455 && ( !const_sv || SvRV(gv) == const_sv
8456 || sv_cmp(SvRV(gv), const_sv) )))
8457 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8458 "Constant subroutine %"SVf" redefined",
8459 SVfARG(cSVOPo->op_sv));
8461 SvREFCNT_inc_simple_void_NN(PL_compcv);
8462 CopLINE_set(PL_curcop, oldline);
8463 SvREFCNT_dec(SvRV(gv));
8468 const bool exists = CvROOT(cv) || CvXSUB(cv);
8470 /* if the subroutine doesn't exist and wasn't pre-declared
8471 * with a prototype, assume it will be AUTOLOADed,
8472 * skipping the prototype check
8474 if (exists || SvPOK(cv))
8475 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8476 /* already defined (or promised)? */
8477 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8478 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8481 if (attrs) goto attrs;
8482 /* just a "sub foo;" when &foo is already defined */
8483 SAVEFREESV(PL_compcv);
8489 SvREFCNT_inc_simple_void_NN(const_sv);
8490 SvFLAGS(const_sv) |= SVs_PADTMP;
8492 assert(!CvROOT(cv) && !CvCONST(cv));
8494 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8495 CvXSUBANY(cv).any_ptr = const_sv;
8496 CvXSUB(cv) = const_sv_xsub;
8500 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8503 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8504 if (name && isGV(gv))
8506 cv = newCONSTSUB_flags(
8507 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8510 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8514 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8515 prepare_SV_for_RV((SV *)gv);
8519 SvRV_set(gv, const_sv);
8523 SvREFCNT_dec(PL_compcv);
8527 if (cv) { /* must reuse cv if autoloaded */
8528 /* transfer PL_compcv to cv */
8531 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8532 PADLIST *const temp_av = CvPADLIST(cv);
8533 CV *const temp_cv = CvOUTSIDE(cv);
8534 const cv_flags_t other_flags =
8535 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8536 OP * const cvstart = CvSTART(cv);
8540 assert(!CvCVGV_RC(cv));
8541 assert(CvGV(cv) == gv);
8546 PERL_HASH(hash, name, namlen);
8556 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8558 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8559 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8560 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8561 CvOUTSIDE(PL_compcv) = temp_cv;
8562 CvPADLIST_set(PL_compcv, temp_av);
8563 CvSTART(cv) = CvSTART(PL_compcv);
8564 CvSTART(PL_compcv) = cvstart;
8565 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8566 CvFLAGS(PL_compcv) |= other_flags;
8568 if (CvFILE(cv) && CvDYNFILE(cv)) {
8569 Safefree(CvFILE(cv));
8571 CvFILE_set_from_cop(cv, PL_curcop);
8572 CvSTASH_set(cv, PL_curstash);
8574 /* inner references to PL_compcv must be fixed up ... */
8575 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8576 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8577 ++PL_sub_generation;
8580 /* Might have had built-in attributes applied -- propagate them. */
8581 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8583 /* ... before we throw it away */
8584 SvREFCNT_dec(PL_compcv);
8589 if (name && isGV(gv)) {
8592 if (HvENAME_HEK(GvSTASH(gv)))
8593 /* sub Foo::bar { (shift)+1 } */
8594 gv_method_changed(gv);
8598 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8599 prepare_SV_for_RV((SV *)gv);
8603 SvRV_set(gv, (SV *)cv);
8607 if (isGV(gv)) CvGV_set(cv, gv);
8611 PERL_HASH(hash, name, namlen);
8612 CvNAME_HEK_set(cv, share_hek(name,
8618 CvFILE_set_from_cop(cv, PL_curcop);
8619 CvSTASH_set(cv, PL_curstash);
8623 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8624 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8630 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8631 the debugger could be able to set a breakpoint in, so signal to
8632 pp_entereval that it should not throw away any saved lines at scope
8635 PL_breakable_sub_gen++;
8637 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8638 OpREFCNT_set(CvROOT(cv), 1);
8639 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8640 itself has a refcount. */
8642 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8643 #ifdef PERL_DEBUG_READONLY_OPS
8644 slab = (OPSLAB *)CvSTART(cv);
8646 CvSTART(cv) = start;
8648 finalize_optree(CvROOT(cv));
8649 S_prune_chain_head(&CvSTART(cv));
8651 /* now that optimizer has done its work, adjust pad values */
8653 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8657 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8658 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8661 if (!name) SAVEFREESV(cv);
8662 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8663 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8666 if (block && has_name) {
8667 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8668 SV * const tmpstr = cv_name(cv,NULL,0);
8669 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8670 GV_ADDMULTI, SVt_PVHV);
8672 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8675 (long)CopLINE(PL_curcop));
8676 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8677 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8678 hv = GvHVn(db_postponed);
8679 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8680 CV * const pcv = GvCV(db_postponed);
8686 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8692 if (PL_parser && PL_parser->error_count)
8693 clear_special_blocks(name, gv, cv);
8696 process_special_blocks(floor, name, gv, cv);
8702 PL_parser->copline = NOLINE;
8705 #ifdef PERL_DEBUG_READONLY_OPS
8709 if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8710 pad_add_weakref(cv);
8716 S_clear_special_blocks(pTHX_ const char *const fullname,
8717 GV *const gv, CV *const cv) {
8721 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8723 colon = strrchr(fullname,':');
8724 name = colon ? colon + 1 : fullname;
8726 if ((*name == 'B' && strEQ(name, "BEGIN"))
8727 || (*name == 'E' && strEQ(name, "END"))
8728 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8729 || (*name == 'C' && strEQ(name, "CHECK"))
8730 || (*name == 'I' && strEQ(name, "INIT"))) {
8736 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8740 /* Returns true if the sub has been freed. */
8742 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8746 const char *const colon = strrchr(fullname,':');
8747 const char *const name = colon ? colon + 1 : fullname;
8749 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8752 if (strEQ(name, "BEGIN")) {
8753 const I32 oldscope = PL_scopestack_ix;
8756 if (floor) LEAVE_SCOPE(floor);
8758 PUSHSTACKi(PERLSI_REQUIRE);
8759 SAVECOPFILE(&PL_compiling);
8760 SAVECOPLINE(&PL_compiling);
8761 SAVEVPTR(PL_curcop);
8763 DEBUG_x( dump_sub(gv) );
8764 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8765 GvCV_set(gv,0); /* cv has been hijacked */
8766 call_list(oldscope, PL_beginav);
8770 return !PL_savebegin;
8776 if strEQ(name, "END") {
8777 DEBUG_x( dump_sub(gv) );
8778 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8781 } else if (*name == 'U') {
8782 if (strEQ(name, "UNITCHECK")) {
8783 /* It's never too late to run a unitcheck block */
8784 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8788 } else if (*name == 'C') {
8789 if (strEQ(name, "CHECK")) {
8791 /* diag_listed_as: Too late to run %s block */
8792 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8793 "Too late to run CHECK block");
8794 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8798 } else if (*name == 'I') {
8799 if (strEQ(name, "INIT")) {
8801 /* diag_listed_as: Too late to run %s block */
8802 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8803 "Too late to run INIT block");
8804 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8810 DEBUG_x( dump_sub(gv) );
8812 GvCV_set(gv,0); /* cv has been hijacked */
8818 =for apidoc newCONSTSUB
8820 See L</newCONSTSUB_flags>.
8826 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8828 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8832 =for apidoc newCONSTSUB_flags
8834 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
8835 eligible for inlining at compile-time.
8837 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
8839 The newly created subroutine takes ownership of a reference to the passed in
8842 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
8843 which won't be called if used as a destructor, but will suppress the overhead
8844 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8851 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8855 const char *const file = CopFILE(PL_curcop);
8859 if (IN_PERL_RUNTIME) {
8860 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8861 * an op shared between threads. Use a non-shared COP for our
8863 SAVEVPTR(PL_curcop);
8864 SAVECOMPILEWARNINGS();
8865 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8866 PL_curcop = &PL_compiling;
8868 SAVECOPLINE(PL_curcop);
8869 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8872 PL_hints &= ~HINT_BLOCK_SCOPE;
8875 SAVEGENERICSV(PL_curstash);
8876 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8879 /* Protect sv against leakage caused by fatal warnings. */
8880 if (sv) SAVEFREESV(sv);
8882 /* file becomes the CvFILE. For an XS, it's usually static storage,
8883 and so doesn't get free()d. (It's expected to be from the C pre-
8884 processor __FILE__ directive). But we need a dynamically allocated one,
8885 and we need it to get freed. */
8886 cv = newXS_len_flags(name, len,
8887 sv && SvTYPE(sv) == SVt_PVAV
8890 file ? file : "", "",
8891 &sv, XS_DYNAMIC_FILENAME | flags);
8892 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8901 =for apidoc U||newXS
8903 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
8904 static storage, as it is used directly as CvFILE(), without a copy being made.
8910 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8912 PERL_ARGS_ASSERT_NEWXS;
8913 return newXS_len_flags(
8914 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8919 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8920 const char *const filename, const char *const proto,
8923 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8924 return newXS_len_flags(
8925 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8930 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
8932 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
8933 return newXS_len_flags(
8934 name, strlen(name), subaddr, NULL, NULL, NULL, 0
8939 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8940 XSUBADDR_t subaddr, const char *const filename,
8941 const char *const proto, SV **const_svp,
8945 bool interleave = FALSE;
8947 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8950 GV * const gv = gv_fetchpvn(
8951 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8952 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8953 sizeof("__ANON__::__ANON__") - 1,
8954 GV_ADDMULTI | flags, SVt_PVCV);
8956 if ((cv = (name ? GvCV(gv) : NULL))) {
8958 /* just a cached method */
8962 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8963 /* already defined (or promised) */
8964 /* Redundant check that allows us to avoid creating an SV
8965 most of the time: */
8966 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8967 report_redefined_cv(newSVpvn_flags(
8968 name,len,(flags&SVf_UTF8)|SVs_TEMP
8979 if (cv) /* must reuse cv if autoloaded */
8982 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8986 if (HvENAME_HEK(GvSTASH(gv)))
8987 gv_method_changed(gv); /* newXS */
8993 /* XSUBs can't be perl lang/perl5db.pl debugged
8994 if (PERLDB_LINE_OR_SAVESRC)
8995 (void)gv_fetchfile(filename); */
8996 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8997 if (flags & XS_DYNAMIC_FILENAME) {
8999 CvFILE(cv) = savepv(filename);
9001 /* NOTE: not copied, as it is expected to be an external constant string */
9002 CvFILE(cv) = (char *)filename;
9005 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9006 CvFILE(cv) = (char*)PL_xsubfilename;
9009 CvXSUB(cv) = subaddr;
9010 #ifndef PERL_IMPLICIT_CONTEXT
9011 CvHSCXT(cv) = &PL_stack_sp;
9017 process_special_blocks(0, name, gv, cv);
9020 } /* <- not a conditional branch */
9023 sv_setpv(MUTABLE_SV(cv), proto);
9024 if (interleave) LEAVE;
9029 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9031 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9033 PERL_ARGS_ASSERT_NEWSTUB;
9037 if (!fake && HvENAME_HEK(GvSTASH(gv)))
9038 gv_method_changed(gv);
9040 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9045 CvFILE_set_from_cop(cv, PL_curcop);
9046 CvSTASH_set(cv, PL_curstash);
9052 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9058 if (PL_parser && PL_parser->error_count) {
9064 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9065 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9068 if ((cv = GvFORM(gv))) {
9069 if (ckWARN(WARN_REDEFINE)) {
9070 const line_t oldline = CopLINE(PL_curcop);
9071 if (PL_parser && PL_parser->copline != NOLINE)
9072 CopLINE_set(PL_curcop, PL_parser->copline);
9074 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9075 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9077 /* diag_listed_as: Format %s redefined */
9078 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9079 "Format STDOUT redefined");
9081 CopLINE_set(PL_curcop, oldline);
9086 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9088 CvFILE_set_from_cop(cv, PL_curcop);
9091 pad_tidy(padtidy_FORMAT);
9092 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9093 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9094 OpREFCNT_set(CvROOT(cv), 1);
9095 CvSTART(cv) = LINKLIST(CvROOT(cv));
9096 CvROOT(cv)->op_next = 0;
9097 CALL_PEEP(CvSTART(cv));
9098 finalize_optree(CvROOT(cv));
9099 S_prune_chain_head(&CvSTART(cv));
9105 PL_parser->copline = NOLINE;
9107 PL_compiling.cop_seq = 0;
9111 Perl_newANONLIST(pTHX_ OP *o)
9113 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9117 Perl_newANONHASH(pTHX_ OP *o)
9119 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9123 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9125 return newANONATTRSUB(floor, proto, NULL, block);
9129 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9131 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9133 newSVOP(OP_ANONCODE, 0,
9135 if (CvANONCONST(cv))
9136 anoncode = newUNOP(OP_ANONCONST, 0,
9137 op_convert_list(OP_ENTERSUB,
9138 OPf_STACKED|OPf_WANT_SCALAR,
9140 return newUNOP(OP_REFGEN, 0, anoncode);
9144 Perl_oopsAV(pTHX_ OP *o)
9148 PERL_ARGS_ASSERT_OOPSAV;
9150 switch (o->op_type) {
9153 OpTYPE_set(o, OP_PADAV);
9154 return ref(o, OP_RV2AV);
9158 OpTYPE_set(o, OP_RV2AV);
9163 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9170 Perl_oopsHV(pTHX_ OP *o)
9174 PERL_ARGS_ASSERT_OOPSHV;
9176 switch (o->op_type) {
9179 OpTYPE_set(o, OP_PADHV);
9180 return ref(o, OP_RV2HV);
9184 OpTYPE_set(o, OP_RV2HV);
9189 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9196 Perl_newAVREF(pTHX_ OP *o)
9200 PERL_ARGS_ASSERT_NEWAVREF;
9202 if (o->op_type == OP_PADANY) {
9203 OpTYPE_set(o, OP_PADAV);
9206 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9207 Perl_croak(aTHX_ "Can't use an array as a reference");
9209 return newUNOP(OP_RV2AV, 0, scalar(o));
9213 Perl_newGVREF(pTHX_ I32 type, OP *o)
9215 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9216 return newUNOP(OP_NULL, 0, o);
9217 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9221 Perl_newHVREF(pTHX_ OP *o)
9225 PERL_ARGS_ASSERT_NEWHVREF;
9227 if (o->op_type == OP_PADANY) {
9228 OpTYPE_set(o, OP_PADHV);
9231 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9232 Perl_croak(aTHX_ "Can't use a hash as a reference");
9234 return newUNOP(OP_RV2HV, 0, scalar(o));
9238 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9240 if (o->op_type == OP_PADANY) {
9242 OpTYPE_set(o, OP_PADCV);
9244 return newUNOP(OP_RV2CV, flags, scalar(o));
9248 Perl_newSVREF(pTHX_ OP *o)
9252 PERL_ARGS_ASSERT_NEWSVREF;
9254 if (o->op_type == OP_PADANY) {
9255 OpTYPE_set(o, OP_PADSV);
9259 return newUNOP(OP_RV2SV, 0, scalar(o));
9262 /* Check routines. See the comments at the top of this file for details
9263 * on when these are called */
9266 Perl_ck_anoncode(pTHX_ OP *o)
9268 PERL_ARGS_ASSERT_CK_ANONCODE;
9270 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9271 cSVOPo->op_sv = NULL;
9276 S_io_hints(pTHX_ OP *o)
9278 #if O_BINARY != 0 || O_TEXT != 0
9280 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9282 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9285 const char *d = SvPV_const(*svp, len);
9286 const I32 mode = mode_from_discipline(d, len);
9287 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9289 if (mode & O_BINARY)
9290 o->op_private |= OPpOPEN_IN_RAW;
9294 o->op_private |= OPpOPEN_IN_CRLF;
9298 svp = hv_fetchs(table, "open_OUT", FALSE);
9301 const char *d = SvPV_const(*svp, len);
9302 const I32 mode = mode_from_discipline(d, len);
9303 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9305 if (mode & O_BINARY)
9306 o->op_private |= OPpOPEN_OUT_RAW;
9310 o->op_private |= OPpOPEN_OUT_CRLF;
9315 PERL_UNUSED_CONTEXT;
9321 Perl_ck_backtick(pTHX_ OP *o)
9326 PERL_ARGS_ASSERT_CK_BACKTICK;
9327 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9328 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9329 && (gv = gv_override("readpipe",8)))
9331 /* detach rest of siblings from o and its first child */
9332 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9333 newop = S_new_entersubop(aTHX_ gv, sibl);
9335 else if (!(o->op_flags & OPf_KIDS))
9336 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9341 S_io_hints(aTHX_ o);
9346 Perl_ck_bitop(pTHX_ OP *o)
9348 PERL_ARGS_ASSERT_CK_BITOP;
9350 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9352 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9353 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9354 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9355 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9356 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9357 "The bitwise feature is experimental");
9358 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9359 && OP_IS_INFIX_BIT(o->op_type))
9361 const OP * const left = cBINOPo->op_first;
9362 const OP * const right = OpSIBLING(left);
9363 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9364 (left->op_flags & OPf_PARENS) == 0) ||
9365 (OP_IS_NUMCOMPARE(right->op_type) &&
9366 (right->op_flags & OPf_PARENS) == 0))
9367 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9368 "Possible precedence problem on bitwise %s operator",
9369 o->op_type == OP_BIT_OR
9370 ||o->op_type == OP_NBIT_OR ? "|"
9371 : o->op_type == OP_BIT_AND
9372 ||o->op_type == OP_NBIT_AND ? "&"
9373 : o->op_type == OP_BIT_XOR
9374 ||o->op_type == OP_NBIT_XOR ? "^"
9375 : o->op_type == OP_SBIT_OR ? "|."
9376 : o->op_type == OP_SBIT_AND ? "&." : "^."
9382 PERL_STATIC_INLINE bool
9383 is_dollar_bracket(pTHX_ const OP * const o)
9386 PERL_UNUSED_CONTEXT;
9387 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9388 && (kid = cUNOPx(o)->op_first)
9389 && kid->op_type == OP_GV
9390 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9394 Perl_ck_cmp(pTHX_ OP *o)
9396 PERL_ARGS_ASSERT_CK_CMP;
9397 if (ckWARN(WARN_SYNTAX)) {
9398 const OP *kid = cUNOPo->op_first;
9401 ( is_dollar_bracket(aTHX_ kid)
9402 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9404 || ( kid->op_type == OP_CONST
9405 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9409 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9410 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9416 Perl_ck_concat(pTHX_ OP *o)
9418 const OP * const kid = cUNOPo->op_first;
9420 PERL_ARGS_ASSERT_CK_CONCAT;
9421 PERL_UNUSED_CONTEXT;
9423 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9424 !(kUNOP->op_first->op_flags & OPf_MOD))
9425 o->op_flags |= OPf_STACKED;
9430 Perl_ck_spair(pTHX_ OP *o)
9434 PERL_ARGS_ASSERT_CK_SPAIR;
9436 if (o->op_flags & OPf_KIDS) {
9440 const OPCODE type = o->op_type;
9441 o = modkids(ck_fun(o), type);
9442 kid = cUNOPo->op_first;
9443 kidkid = kUNOP->op_first;
9444 newop = OpSIBLING(kidkid);
9446 const OPCODE type = newop->op_type;
9447 if (OpHAS_SIBLING(newop))
9449 if (o->op_type == OP_REFGEN
9450 && ( type == OP_RV2CV
9451 || ( !(newop->op_flags & OPf_PARENS)
9452 && ( type == OP_RV2AV || type == OP_PADAV
9453 || type == OP_RV2HV || type == OP_PADHV))))
9454 NOOP; /* OK (allow srefgen for \@a and \%h) */
9455 else if (OP_GIMME(newop,0) != G_SCALAR)
9458 /* excise first sibling */
9459 op_sibling_splice(kid, NULL, 1, NULL);
9462 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9463 * and OP_CHOMP into OP_SCHOMP */
9464 o->op_ppaddr = PL_ppaddr[++o->op_type];
9469 Perl_ck_delete(pTHX_ OP *o)
9471 PERL_ARGS_ASSERT_CK_DELETE;
9475 if (o->op_flags & OPf_KIDS) {
9476 OP * const kid = cUNOPo->op_first;
9477 switch (kid->op_type) {
9479 o->op_flags |= OPf_SPECIAL;
9482 o->op_private |= OPpSLICE;
9485 o->op_flags |= OPf_SPECIAL;
9490 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9491 " use array slice");
9493 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9496 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9497 "element or slice");
9499 if (kid->op_private & OPpLVAL_INTRO)
9500 o->op_private |= OPpLVAL_INTRO;
9507 Perl_ck_eof(pTHX_ OP *o)
9509 PERL_ARGS_ASSERT_CK_EOF;
9511 if (o->op_flags & OPf_KIDS) {
9513 if (cLISTOPo->op_first->op_type == OP_STUB) {
9515 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9520 kid = cLISTOPo->op_first;
9521 if (kid->op_type == OP_RV2GV)
9522 kid->op_private |= OPpALLOW_FAKE;
9528 Perl_ck_eval(pTHX_ OP *o)
9532 PERL_ARGS_ASSERT_CK_EVAL;
9534 PL_hints |= HINT_BLOCK_SCOPE;
9535 if (o->op_flags & OPf_KIDS) {
9536 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9539 if (o->op_type == OP_ENTERTRY) {
9542 /* cut whole sibling chain free from o */
9543 op_sibling_splice(o, NULL, -1, NULL);
9546 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9548 /* establish postfix order */
9549 enter->op_next = (OP*)enter;
9551 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9552 OpTYPE_set(o, OP_LEAVETRY);
9553 enter->op_other = o;
9558 S_set_haseval(aTHX);
9562 const U8 priv = o->op_private;
9564 /* the newUNOP will recursively call ck_eval(), which will handle
9565 * all the stuff at the end of this function, like adding
9568 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9570 o->op_targ = (PADOFFSET)PL_hints;
9571 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9572 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9573 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9574 /* Store a copy of %^H that pp_entereval can pick up. */
9575 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9576 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9577 /* append hhop to only child */
9578 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9580 o->op_private |= OPpEVAL_HAS_HH;
9582 if (!(o->op_private & OPpEVAL_BYTES)
9583 && FEATURE_UNIEVAL_IS_ENABLED)
9584 o->op_private |= OPpEVAL_UNICODE;
9589 Perl_ck_exec(pTHX_ OP *o)
9591 PERL_ARGS_ASSERT_CK_EXEC;
9593 if (o->op_flags & OPf_STACKED) {
9596 kid = OpSIBLING(cUNOPo->op_first);
9597 if (kid->op_type == OP_RV2GV)
9606 Perl_ck_exists(pTHX_ OP *o)
9608 PERL_ARGS_ASSERT_CK_EXISTS;
9611 if (o->op_flags & OPf_KIDS) {
9612 OP * const kid = cUNOPo->op_first;
9613 if (kid->op_type == OP_ENTERSUB) {
9614 (void) ref(kid, o->op_type);
9615 if (kid->op_type != OP_RV2CV
9616 && !(PL_parser && PL_parser->error_count))
9618 "exists argument is not a subroutine name");
9619 o->op_private |= OPpEXISTS_SUB;
9621 else if (kid->op_type == OP_AELEM)
9622 o->op_flags |= OPf_SPECIAL;
9623 else if (kid->op_type != OP_HELEM)
9624 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9625 "element or a subroutine");
9632 Perl_ck_rvconst(pTHX_ OP *o)
9635 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9637 PERL_ARGS_ASSERT_CK_RVCONST;
9639 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9641 if (kid->op_type == OP_CONST) {
9644 SV * const kidsv = kid->op_sv;
9646 /* Is it a constant from cv_const_sv()? */
9647 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9650 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9651 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9652 const char *badthing;
9653 switch (o->op_type) {
9655 badthing = "a SCALAR";
9658 badthing = "an ARRAY";
9661 badthing = "a HASH";
9669 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9670 SVfARG(kidsv), badthing);
9673 * This is a little tricky. We only want to add the symbol if we
9674 * didn't add it in the lexer. Otherwise we get duplicate strict
9675 * warnings. But if we didn't add it in the lexer, we must at
9676 * least pretend like we wanted to add it even if it existed before,
9677 * or we get possible typo warnings. OPpCONST_ENTERED says
9678 * whether the lexer already added THIS instance of this symbol.
9680 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9681 gv = gv_fetchsv(kidsv,
9682 o->op_type == OP_RV2CV
9683 && o->op_private & OPpMAY_RETURN_CONSTANT
9685 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9688 : o->op_type == OP_RV2SV
9690 : o->op_type == OP_RV2AV
9692 : o->op_type == OP_RV2HV
9699 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9700 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9701 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9703 OpTYPE_set(kid, OP_GV);
9704 SvREFCNT_dec(kid->op_sv);
9706 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9707 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9708 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9709 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9710 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9712 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9714 kid->op_private = 0;
9715 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9723 Perl_ck_ftst(pTHX_ OP *o)
9726 const I32 type = o->op_type;
9728 PERL_ARGS_ASSERT_CK_FTST;
9730 if (o->op_flags & OPf_REF) {
9733 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9734 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9735 const OPCODE kidtype = kid->op_type;
9737 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9738 && !kid->op_folded) {
9739 OP * const newop = newGVOP(type, OPf_REF,
9740 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9745 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
9746 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
9748 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9749 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
9750 array_passed_to_stat, name);
9753 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9754 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
9758 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9759 o->op_private |= OPpFT_ACCESS;
9760 if (type != OP_STAT && type != OP_LSTAT
9761 && PL_check[kidtype] == Perl_ck_ftst
9762 && kidtype != OP_STAT && kidtype != OP_LSTAT
9764 o->op_private |= OPpFT_STACKED;
9765 kid->op_private |= OPpFT_STACKING;
9766 if (kidtype == OP_FTTTY && (
9767 !(kid->op_private & OPpFT_STACKED)
9768 || kid->op_private & OPpFT_AFTER_t
9770 o->op_private |= OPpFT_AFTER_t;
9775 if (type == OP_FTTTY)
9776 o = newGVOP(type, OPf_REF, PL_stdingv);
9778 o = newUNOP(type, 0, newDEFSVOP());
9784 Perl_ck_fun(pTHX_ OP *o)
9786 const int type = o->op_type;
9787 I32 oa = PL_opargs[type] >> OASHIFT;
9789 PERL_ARGS_ASSERT_CK_FUN;
9791 if (o->op_flags & OPf_STACKED) {
9792 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9795 return no_fh_allowed(o);
9798 if (o->op_flags & OPf_KIDS) {
9799 OP *prev_kid = NULL;
9800 OP *kid = cLISTOPo->op_first;
9802 bool seen_optional = FALSE;
9804 if (kid->op_type == OP_PUSHMARK ||
9805 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9808 kid = OpSIBLING(kid);
9810 if (kid && kid->op_type == OP_COREARGS) {
9811 bool optional = FALSE;
9814 if (oa & OA_OPTIONAL) optional = TRUE;
9817 if (optional) o->op_private |= numargs;
9822 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9823 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9825 /* append kid to chain */
9826 op_sibling_splice(o, prev_kid, 0, kid);
9828 seen_optional = TRUE;
9835 /* list seen where single (scalar) arg expected? */
9836 if (numargs == 1 && !(oa >> 4)
9837 && kid->op_type == OP_LIST && type != OP_SCALAR)
9839 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9841 if (type != OP_DELETE) scalar(kid);
9852 if ((type == OP_PUSH || type == OP_UNSHIFT)
9853 && !OpHAS_SIBLING(kid))
9854 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9855 "Useless use of %s with no values",
9858 if (kid->op_type == OP_CONST
9859 && ( !SvROK(cSVOPx_sv(kid))
9860 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9862 bad_type_pv(numargs, "array", o, kid);
9863 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9864 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9865 PL_op_desc[type]), 0);
9868 op_lvalue(kid, type);
9872 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9873 bad_type_pv(numargs, "hash", o, kid);
9874 op_lvalue(kid, type);
9878 /* replace kid with newop in chain */
9880 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9881 newop->op_next = newop;
9886 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9887 if (kid->op_type == OP_CONST &&
9888 (kid->op_private & OPpCONST_BARE))
9890 OP * const newop = newGVOP(OP_GV, 0,
9891 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9892 /* replace kid with newop in chain */
9893 op_sibling_splice(o, prev_kid, 1, newop);
9897 else if (kid->op_type == OP_READLINE) {
9898 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9899 bad_type_pv(numargs, "HANDLE", o, kid);
9902 I32 flags = OPf_SPECIAL;
9906 /* is this op a FH constructor? */
9907 if (is_handle_constructor(o,numargs)) {
9908 const char *name = NULL;
9911 bool want_dollar = TRUE;
9914 /* Set a flag to tell rv2gv to vivify
9915 * need to "prove" flag does not mean something
9916 * else already - NI-S 1999/05/07
9919 if (kid->op_type == OP_PADSV) {
9921 = PAD_COMPNAME_SV(kid->op_targ);
9922 name = PadnamePV (pn);
9923 len = PadnameLEN(pn);
9924 name_utf8 = PadnameUTF8(pn);
9926 else if (kid->op_type == OP_RV2SV
9927 && kUNOP->op_first->op_type == OP_GV)
9929 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9931 len = GvNAMELEN(gv);
9932 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9934 else if (kid->op_type == OP_AELEM
9935 || kid->op_type == OP_HELEM)
9938 OP *op = ((BINOP*)kid)->op_first;
9942 const char * const a =
9943 kid->op_type == OP_AELEM ?
9945 if (((op->op_type == OP_RV2AV) ||
9946 (op->op_type == OP_RV2HV)) &&
9947 (firstop = ((UNOP*)op)->op_first) &&
9948 (firstop->op_type == OP_GV)) {
9949 /* packagevar $a[] or $h{} */
9950 GV * const gv = cGVOPx_gv(firstop);
9958 else if (op->op_type == OP_PADAV
9959 || op->op_type == OP_PADHV) {
9960 /* lexicalvar $a[] or $h{} */
9961 const char * const padname =
9962 PAD_COMPNAME_PV(op->op_targ);
9971 name = SvPV_const(tmpstr, len);
9972 name_utf8 = SvUTF8(tmpstr);
9977 name = "__ANONIO__";
9979 want_dollar = FALSE;
9981 op_lvalue(kid, type);
9985 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9986 namesv = PAD_SVl(targ);
9987 if (want_dollar && *name != '$')
9988 sv_setpvs(namesv, "$");
9990 sv_setpvs(namesv, "");
9991 sv_catpvn(namesv, name, len);
9992 if ( name_utf8 ) SvUTF8_on(namesv);
9996 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9998 kid->op_targ = targ;
9999 kid->op_private |= priv;
10005 if ((type == OP_UNDEF || type == OP_POS)
10006 && numargs == 1 && !(oa >> 4)
10007 && kid->op_type == OP_LIST)
10008 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10009 op_lvalue(scalar(kid), type);
10014 kid = OpSIBLING(kid);
10016 /* FIXME - should the numargs or-ing move after the too many
10017 * arguments check? */
10018 o->op_private |= numargs;
10020 return too_many_arguments_pv(o,OP_DESC(o), 0);
10023 else if (PL_opargs[type] & OA_DEFGV) {
10024 /* Ordering of these two is important to keep f_map.t passing. */
10026 return newUNOP(type, 0, newDEFSVOP());
10030 while (oa & OA_OPTIONAL)
10032 if (oa && oa != OA_LIST)
10033 return too_few_arguments_pv(o,OP_DESC(o), 0);
10039 Perl_ck_glob(pTHX_ OP *o)
10043 PERL_ARGS_ASSERT_CK_GLOB;
10046 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10047 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10049 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10053 * \ null - const(wildcard)
10058 * \ mark - glob - rv2cv
10059 * | \ gv(CORE::GLOBAL::glob)
10061 * \ null - const(wildcard)
10063 o->op_flags |= OPf_SPECIAL;
10064 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10065 o = S_new_entersubop(aTHX_ gv, o);
10066 o = newUNOP(OP_NULL, 0, o);
10067 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10070 else o->op_flags &= ~OPf_SPECIAL;
10071 #if !defined(PERL_EXTERNAL_GLOB)
10072 if (!PL_globhook) {
10074 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10075 newSVpvs("File::Glob"), NULL, NULL, NULL);
10078 #endif /* !PERL_EXTERNAL_GLOB */
10079 gv = (GV *)newSV(0);
10080 gv_init(gv, 0, "", 0, 0);
10082 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10083 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10089 Perl_ck_grep(pTHX_ OP *o)
10093 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10095 PERL_ARGS_ASSERT_CK_GREP;
10097 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10099 if (o->op_flags & OPf_STACKED) {
10100 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10101 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10102 return no_fh_allowed(o);
10103 o->op_flags &= ~OPf_STACKED;
10105 kid = OpSIBLING(cLISTOPo->op_first);
10106 if (type == OP_MAPWHILE)
10111 if (PL_parser && PL_parser->error_count)
10113 kid = OpSIBLING(cLISTOPo->op_first);
10114 if (kid->op_type != OP_NULL)
10115 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10116 kid = kUNOP->op_first;
10118 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10119 kid->op_next = (OP*)gwop;
10120 o->op_private = gwop->op_private = 0;
10121 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10123 kid = OpSIBLING(cLISTOPo->op_first);
10124 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10125 op_lvalue(kid, OP_GREPSTART);
10131 Perl_ck_index(pTHX_ OP *o)
10133 PERL_ARGS_ASSERT_CK_INDEX;
10135 if (o->op_flags & OPf_KIDS) {
10136 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10138 kid = OpSIBLING(kid); /* get past "big" */
10139 if (kid && kid->op_type == OP_CONST) {
10140 const bool save_taint = TAINT_get;
10141 SV *sv = kSVOP->op_sv;
10142 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10144 sv_copypv(sv, kSVOP->op_sv);
10145 SvREFCNT_dec_NN(kSVOP->op_sv);
10148 if (SvOK(sv)) fbm_compile(sv, 0);
10149 TAINT_set(save_taint);
10150 #ifdef NO_TAINT_SUPPORT
10151 PERL_UNUSED_VAR(save_taint);
10159 Perl_ck_lfun(pTHX_ OP *o)
10161 const OPCODE type = o->op_type;
10163 PERL_ARGS_ASSERT_CK_LFUN;
10165 return modkids(ck_fun(o), type);
10169 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10171 PERL_ARGS_ASSERT_CK_DEFINED;
10173 if ((o->op_flags & OPf_KIDS)) {
10174 switch (cUNOPo->op_first->op_type) {
10177 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10178 " (Maybe you should just omit the defined()?)");
10182 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10183 " (Maybe you should just omit the defined()?)");
10194 Perl_ck_readline(pTHX_ OP *o)
10196 PERL_ARGS_ASSERT_CK_READLINE;
10198 if (o->op_flags & OPf_KIDS) {
10199 OP *kid = cLISTOPo->op_first;
10200 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10204 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10212 Perl_ck_rfun(pTHX_ OP *o)
10214 const OPCODE type = o->op_type;
10216 PERL_ARGS_ASSERT_CK_RFUN;
10218 return refkids(ck_fun(o), type);
10222 Perl_ck_listiob(pTHX_ OP *o)
10226 PERL_ARGS_ASSERT_CK_LISTIOB;
10228 kid = cLISTOPo->op_first;
10230 o = force_list(o, 1);
10231 kid = cLISTOPo->op_first;
10233 if (kid->op_type == OP_PUSHMARK)
10234 kid = OpSIBLING(kid);
10235 if (kid && o->op_flags & OPf_STACKED)
10236 kid = OpSIBLING(kid);
10237 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10238 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10239 && !kid->op_folded) {
10240 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10242 /* replace old const op with new OP_RV2GV parent */
10243 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10244 OP_RV2GV, OPf_REF);
10245 kid = OpSIBLING(kid);
10250 op_append_elem(o->op_type, o, newDEFSVOP());
10252 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10253 return listkids(o);
10257 Perl_ck_smartmatch(pTHX_ OP *o)
10260 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10261 if (0 == (o->op_flags & OPf_SPECIAL)) {
10262 OP *first = cBINOPo->op_first;
10263 OP *second = OpSIBLING(first);
10265 /* Implicitly take a reference to an array or hash */
10267 /* remove the original two siblings, then add back the
10268 * (possibly different) first and second sibs.
10270 op_sibling_splice(o, NULL, 1, NULL);
10271 op_sibling_splice(o, NULL, 1, NULL);
10272 first = ref_array_or_hash(first);
10273 second = ref_array_or_hash(second);
10274 op_sibling_splice(o, NULL, 0, second);
10275 op_sibling_splice(o, NULL, 0, first);
10277 /* Implicitly take a reference to a regular expression */
10278 if (first->op_type == OP_MATCH) {
10279 OpTYPE_set(first, OP_QR);
10281 if (second->op_type == OP_MATCH) {
10282 OpTYPE_set(second, OP_QR);
10291 S_maybe_targlex(pTHX_ OP *o)
10293 OP * const kid = cLISTOPo->op_first;
10294 /* has a disposable target? */
10295 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10296 && !(kid->op_flags & OPf_STACKED)
10297 /* Cannot steal the second time! */
10298 && !(kid->op_private & OPpTARGET_MY)
10301 OP * const kkid = OpSIBLING(kid);
10303 /* Can just relocate the target. */
10304 if (kkid && kkid->op_type == OP_PADSV
10305 && (!(kkid->op_private & OPpLVAL_INTRO)
10306 || kkid->op_private & OPpPAD_STATE))
10308 kid->op_targ = kkid->op_targ;
10310 /* Now we do not need PADSV and SASSIGN.
10311 * Detach kid and free the rest. */
10312 op_sibling_splice(o, NULL, 1, NULL);
10314 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10322 Perl_ck_sassign(pTHX_ OP *o)
10325 OP * const kid = cLISTOPo->op_first;
10327 PERL_ARGS_ASSERT_CK_SASSIGN;
10329 if (OpHAS_SIBLING(kid)) {
10330 OP *kkid = OpSIBLING(kid);
10331 /* For state variable assignment with attributes, kkid is a list op
10332 whose op_last is a padsv. */
10333 if ((kkid->op_type == OP_PADSV ||
10334 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10335 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10338 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10339 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10340 const PADOFFSET target = kkid->op_targ;
10341 OP *const other = newOP(OP_PADSV,
10343 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10344 OP *const first = newOP(OP_NULL, 0);
10346 newCONDOP(0, first, o, other);
10347 /* XXX targlex disabled for now; see ticket #124160
10348 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10350 OP *const condop = first->op_next;
10352 OpTYPE_set(condop, OP_ONCE);
10353 other->op_targ = target;
10354 nullop->op_flags |= OPf_WANT_SCALAR;
10356 /* Store the initializedness of state vars in a separate
10359 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10360 /* hijacking PADSTALE for uninitialized state variables */
10361 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10366 return S_maybe_targlex(aTHX_ o);
10370 Perl_ck_match(pTHX_ OP *o)
10372 PERL_UNUSED_CONTEXT;
10373 PERL_ARGS_ASSERT_CK_MATCH;
10375 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10376 o->op_private |= OPpRUNTIME;
10381 Perl_ck_method(pTHX_ OP *o)
10383 SV *sv, *methsv, *rclass;
10384 const char* method;
10387 STRLEN len, nsplit = 0, i;
10389 OP * const kid = cUNOPo->op_first;
10391 PERL_ARGS_ASSERT_CK_METHOD;
10392 if (kid->op_type != OP_CONST) return o;
10396 /* replace ' with :: */
10397 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10399 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10402 method = SvPVX_const(sv);
10404 utf8 = SvUTF8(sv) ? -1 : 1;
10406 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10411 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10413 if (!nsplit) { /* $proto->method() */
10415 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10418 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10420 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10423 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10424 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10425 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10426 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10428 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10429 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10431 #ifdef USE_ITHREADS
10432 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10434 cMETHOPx(new_op)->op_rclass_sv = rclass;
10441 Perl_ck_null(pTHX_ OP *o)
10443 PERL_ARGS_ASSERT_CK_NULL;
10444 PERL_UNUSED_CONTEXT;
10449 Perl_ck_open(pTHX_ OP *o)
10451 PERL_ARGS_ASSERT_CK_OPEN;
10453 S_io_hints(aTHX_ o);
10455 /* In case of three-arg dup open remove strictness
10456 * from the last arg if it is a bareword. */
10457 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10458 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10462 if ((last->op_type == OP_CONST) && /* The bareword. */
10463 (last->op_private & OPpCONST_BARE) &&
10464 (last->op_private & OPpCONST_STRICT) &&
10465 (oa = OpSIBLING(first)) && /* The fh. */
10466 (oa = OpSIBLING(oa)) && /* The mode. */
10467 (oa->op_type == OP_CONST) &&
10468 SvPOK(((SVOP*)oa)->op_sv) &&
10469 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10470 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10471 (last == OpSIBLING(oa))) /* The bareword. */
10472 last->op_private &= ~OPpCONST_STRICT;
10478 Perl_ck_prototype(pTHX_ OP *o)
10480 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10481 if (!(o->op_flags & OPf_KIDS)) {
10483 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10489 Perl_ck_refassign(pTHX_ OP *o)
10491 OP * const right = cLISTOPo->op_first;
10492 OP * const left = OpSIBLING(right);
10493 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10496 PERL_ARGS_ASSERT_CK_REFASSIGN;
10498 assert (left->op_type == OP_SREFGEN);
10501 /* we use OPpPAD_STATE in refassign to mean either of those things,
10502 * and the code assumes the two flags occupy the same bit position
10503 * in the various ops below */
10504 assert(OPpPAD_STATE == OPpOUR_INTRO);
10506 switch (varop->op_type) {
10508 o->op_private |= OPpLVREF_AV;
10511 o->op_private |= OPpLVREF_HV;
10515 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10516 o->op_targ = varop->op_targ;
10517 varop->op_targ = 0;
10518 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10522 o->op_private |= OPpLVREF_AV;
10524 NOT_REACHED; /* NOTREACHED */
10526 o->op_private |= OPpLVREF_HV;
10530 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10531 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10533 /* Point varop to its GV kid, detached. */
10534 varop = op_sibling_splice(varop, NULL, -1, NULL);
10538 OP * const kidparent =
10539 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10540 OP * const kid = cUNOPx(kidparent)->op_first;
10541 o->op_private |= OPpLVREF_CV;
10542 if (kid->op_type == OP_GV) {
10544 goto detach_and_stack;
10546 if (kid->op_type != OP_PADCV) goto bad;
10547 o->op_targ = kid->op_targ;
10553 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10554 o->op_private |= OPpLVREF_ELEM;
10557 /* Detach varop. */
10558 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10562 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10563 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10568 if (!FEATURE_REFALIASING_IS_ENABLED)
10570 "Experimental aliasing via reference not enabled");
10571 Perl_ck_warner_d(aTHX_
10572 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10573 "Aliasing via reference is experimental");
10575 o->op_flags |= OPf_STACKED;
10576 op_sibling_splice(o, right, 1, varop);
10579 o->op_flags &=~ OPf_STACKED;
10580 op_sibling_splice(o, right, 1, NULL);
10587 Perl_ck_repeat(pTHX_ OP *o)
10589 PERL_ARGS_ASSERT_CK_REPEAT;
10591 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10593 o->op_private |= OPpREPEAT_DOLIST;
10594 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10595 kids = force_list(kids, 1); /* promote it to a list */
10596 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10604 Perl_ck_require(pTHX_ OP *o)
10608 PERL_ARGS_ASSERT_CK_REQUIRE;
10610 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10611 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10616 if (kid->op_type == OP_CONST) {
10617 SV * const sv = kid->op_sv;
10618 U32 const was_readonly = SvREADONLY(sv);
10619 if (kid->op_private & OPpCONST_BARE) {
10623 if (was_readonly) {
10624 SvREADONLY_off(sv);
10626 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10631 for (; s < end; s++) {
10632 if (*s == ':' && s[1] == ':') {
10634 Move(s+2, s+1, end - s - 1, char);
10638 SvEND_set(sv, end);
10639 sv_catpvs(sv, ".pm");
10640 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10641 hek = share_hek(SvPVX(sv),
10642 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10644 sv_sethek(sv, hek);
10646 SvFLAGS(sv) |= was_readonly;
10648 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10651 if (SvREFCNT(sv) > 1) {
10652 kid->op_sv = newSVpvn_share(
10653 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10654 SvREFCNT_dec_NN(sv);
10658 if (was_readonly) SvREADONLY_off(sv);
10659 PERL_HASH(hash, s, len);
10661 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10663 sv_sethek(sv, hek);
10665 SvFLAGS(sv) |= was_readonly;
10671 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10672 /* handle override, if any */
10673 && (gv = gv_override("require", 7))) {
10675 if (o->op_flags & OPf_KIDS) {
10676 kid = cUNOPo->op_first;
10677 op_sibling_splice(o, NULL, -1, NULL);
10680 kid = newDEFSVOP();
10683 newop = S_new_entersubop(aTHX_ gv, kid);
10691 Perl_ck_return(pTHX_ OP *o)
10695 PERL_ARGS_ASSERT_CK_RETURN;
10697 kid = OpSIBLING(cLISTOPo->op_first);
10698 if (CvLVALUE(PL_compcv)) {
10699 for (; kid; kid = OpSIBLING(kid))
10700 op_lvalue(kid, OP_LEAVESUBLV);
10707 Perl_ck_select(pTHX_ OP *o)
10712 PERL_ARGS_ASSERT_CK_SELECT;
10714 if (o->op_flags & OPf_KIDS) {
10715 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10716 if (kid && OpHAS_SIBLING(kid)) {
10717 OpTYPE_set(o, OP_SSELECT);
10719 return fold_constants(op_integerize(op_std_init(o)));
10723 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10724 if (kid && kid->op_type == OP_RV2GV)
10725 kid->op_private &= ~HINT_STRICT_REFS;
10730 Perl_ck_shift(pTHX_ OP *o)
10732 const I32 type = o->op_type;
10734 PERL_ARGS_ASSERT_CK_SHIFT;
10736 if (!(o->op_flags & OPf_KIDS)) {
10739 if (!CvUNIQUE(PL_compcv)) {
10740 o->op_flags |= OPf_SPECIAL;
10744 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10746 return newUNOP(type, 0, scalar(argop));
10748 return scalar(ck_fun(o));
10752 Perl_ck_sort(pTHX_ OP *o)
10756 HV * const hinthv =
10757 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10760 PERL_ARGS_ASSERT_CK_SORT;
10763 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10765 const I32 sorthints = (I32)SvIV(*svp);
10766 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10767 o->op_private |= OPpSORT_QSORT;
10768 if ((sorthints & HINT_SORT_STABLE) != 0)
10769 o->op_private |= OPpSORT_STABLE;
10773 if (o->op_flags & OPf_STACKED)
10775 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10777 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10778 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10780 /* if the first arg is a code block, process it and mark sort as
10782 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10784 if (kid->op_type == OP_LEAVE)
10785 op_null(kid); /* wipe out leave */
10786 /* Prevent execution from escaping out of the sort block. */
10789 /* provide scalar context for comparison function/block */
10790 kid = scalar(firstkid);
10791 kid->op_next = kid;
10792 o->op_flags |= OPf_SPECIAL;
10794 else if (kid->op_type == OP_CONST
10795 && kid->op_private & OPpCONST_BARE) {
10799 const char * const name = SvPV(kSVOP_sv, len);
10801 assert (len < 256);
10802 Copy(name, tmpbuf+1, len, char);
10803 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10804 if (off != NOT_IN_PAD) {
10805 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10807 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10808 sv_catpvs(fq, "::");
10809 sv_catsv(fq, kSVOP_sv);
10810 SvREFCNT_dec_NN(kSVOP_sv);
10814 OP * const padop = newOP(OP_PADCV, 0);
10815 padop->op_targ = off;
10816 /* replace the const op with the pad op */
10817 op_sibling_splice(firstkid, NULL, 1, padop);
10823 firstkid = OpSIBLING(firstkid);
10826 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10827 /* provide list context for arguments */
10830 op_lvalue(kid, OP_GREPSTART);
10836 /* for sort { X } ..., where X is one of
10837 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10838 * elide the second child of the sort (the one containing X),
10839 * and set these flags as appropriate
10843 * Also, check and warn on lexical $a, $b.
10847 S_simplify_sort(pTHX_ OP *o)
10849 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10853 const char *gvname;
10856 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10858 kid = kUNOP->op_first; /* get past null */
10859 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10860 && kid->op_type != OP_LEAVE)
10862 kid = kLISTOP->op_last; /* get past scope */
10863 switch(kid->op_type) {
10867 if (!have_scopeop) goto padkids;
10872 k = kid; /* remember this node*/
10873 if (kBINOP->op_first->op_type != OP_RV2SV
10874 || kBINOP->op_last ->op_type != OP_RV2SV)
10877 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10878 then used in a comparison. This catches most, but not
10879 all cases. For instance, it catches
10880 sort { my($a); $a <=> $b }
10882 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10883 (although why you'd do that is anyone's guess).
10887 if (!ckWARN(WARN_SYNTAX)) return;
10888 kid = kBINOP->op_first;
10890 if (kid->op_type == OP_PADSV) {
10891 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
10892 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
10893 && ( PadnamePV(name)[1] == 'a'
10894 || PadnamePV(name)[1] == 'b' ))
10895 /* diag_listed_as: "my %s" used in sort comparison */
10896 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10897 "\"%s %s\" used in sort comparison",
10898 PadnameIsSTATE(name)
10903 } while ((kid = OpSIBLING(kid)));
10906 kid = kBINOP->op_first; /* get past cmp */
10907 if (kUNOP->op_first->op_type != OP_GV)
10909 kid = kUNOP->op_first; /* get past rv2sv */
10911 if (GvSTASH(gv) != PL_curstash)
10913 gvname = GvNAME(gv);
10914 if (*gvname == 'a' && gvname[1] == '\0')
10916 else if (*gvname == 'b' && gvname[1] == '\0')
10921 kid = k; /* back to cmp */
10922 /* already checked above that it is rv2sv */
10923 kid = kBINOP->op_last; /* down to 2nd arg */
10924 if (kUNOP->op_first->op_type != OP_GV)
10926 kid = kUNOP->op_first; /* get past rv2sv */
10928 if (GvSTASH(gv) != PL_curstash)
10930 gvname = GvNAME(gv);
10932 ? !(*gvname == 'a' && gvname[1] == '\0')
10933 : !(*gvname == 'b' && gvname[1] == '\0'))
10935 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10937 o->op_private |= OPpSORT_DESCEND;
10938 if (k->op_type == OP_NCMP)
10939 o->op_private |= OPpSORT_NUMERIC;
10940 if (k->op_type == OP_I_NCMP)
10941 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10942 kid = OpSIBLING(cLISTOPo->op_first);
10943 /* cut out and delete old block (second sibling) */
10944 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10949 Perl_ck_split(pTHX_ OP *o)
10954 PERL_ARGS_ASSERT_CK_SPLIT;
10956 if (o->op_flags & OPf_STACKED)
10957 return no_fh_allowed(o);
10959 kid = cLISTOPo->op_first;
10960 if (kid->op_type != OP_NULL)
10961 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10962 /* delete leading NULL node, then add a CONST if no other nodes */
10963 op_sibling_splice(o, NULL, 1,
10964 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10966 kid = cLISTOPo->op_first;
10968 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10969 /* remove kid, and replace with new optree */
10970 op_sibling_splice(o, NULL, 1, NULL);
10971 /* OPf_SPECIAL is used to trigger split " " behavior */
10972 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
10973 op_sibling_splice(o, NULL, 0, kid);
10975 OpTYPE_set(kid, OP_PUSHRE);
10976 /* target implies @ary=..., so wipe it */
10979 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10980 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10981 "Use of /g modifier is meaningless in split");
10984 if (!OpHAS_SIBLING(kid))
10985 op_append_elem(OP_SPLIT, o, newDEFSVOP());
10987 kid = OpSIBLING(kid);
10991 if (!OpHAS_SIBLING(kid))
10993 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10994 o->op_private |= OPpSPLIT_IMPLIM;
10996 assert(OpHAS_SIBLING(kid));
10998 kid = OpSIBLING(kid);
11001 if (OpHAS_SIBLING(kid))
11002 return too_many_arguments_pv(o,OP_DESC(o), 0);
11008 Perl_ck_stringify(pTHX_ OP *o)
11010 OP * const kid = OpSIBLING(cUNOPo->op_first);
11011 PERL_ARGS_ASSERT_CK_STRINGIFY;
11012 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11013 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
11014 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
11015 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11017 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11025 Perl_ck_join(pTHX_ OP *o)
11027 OP * const kid = OpSIBLING(cLISTOPo->op_first);
11029 PERL_ARGS_ASSERT_CK_JOIN;
11031 if (kid && kid->op_type == OP_MATCH) {
11032 if (ckWARN(WARN_SYNTAX)) {
11033 const REGEXP *re = PM_GETRE(kPMOP);
11035 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11036 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11037 : newSVpvs_flags( "STRING", SVs_TEMP );
11038 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11039 "/%"SVf"/ should probably be written as \"%"SVf"\"",
11040 SVfARG(msg), SVfARG(msg));
11044 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11045 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11046 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11047 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11049 const OP * const bairn = OpSIBLING(kid); /* the list */
11050 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11051 && OP_GIMME(bairn,0) == G_SCALAR)
11053 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11054 op_sibling_splice(o, kid, 1, NULL));
11064 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11066 Examines an op, which is expected to identify a subroutine at runtime,
11067 and attempts to determine at compile time which subroutine it identifies.
11068 This is normally used during Perl compilation to determine whether
11069 a prototype can be applied to a function call. C<cvop> is the op
11070 being considered, normally an C<rv2cv> op. A pointer to the identified
11071 subroutine is returned, if it could be determined statically, and a null
11072 pointer is returned if it was not possible to determine statically.
11074 Currently, the subroutine can be identified statically if the RV that the
11075 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11076 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11077 suitable if the constant value must be an RV pointing to a CV. Details of
11078 this process may change in future versions of Perl. If the C<rv2cv> op
11079 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11080 the subroutine statically: this flag is used to suppress compile-time
11081 magic on a subroutine call, forcing it to use default runtime behaviour.
11083 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11084 of a GV reference is modified. If a GV was examined and its CV slot was
11085 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11086 If the op is not optimised away, and the CV slot is later populated with
11087 a subroutine having a prototype, that flag eventually triggers the warning
11088 "called too early to check prototype".
11090 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11091 of returning a pointer to the subroutine it returns a pointer to the
11092 GV giving the most appropriate name for the subroutine in this context.
11093 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11094 (C<CvANON>) subroutine that is referenced through a GV it will be the
11095 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11096 A null pointer is returned as usual if there is no statically-determinable
11102 /* shared by toke.c:yylex */
11104 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11106 PADNAME *name = PAD_COMPNAME(off);
11107 CV *compcv = PL_compcv;
11108 while (PadnameOUTER(name)) {
11109 assert(PARENT_PAD_INDEX(name));
11110 compcv = CvOUTSIDE(compcv);
11111 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11112 [off = PARENT_PAD_INDEX(name)];
11114 assert(!PadnameIsOUR(name));
11115 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11116 return PadnamePROTOCV(name);
11118 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11122 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11127 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11128 if (flags & ~RV2CVOPCV_FLAG_MASK)
11129 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11130 if (cvop->op_type != OP_RV2CV)
11132 if (cvop->op_private & OPpENTERSUB_AMPER)
11134 if (!(cvop->op_flags & OPf_KIDS))
11136 rvop = cUNOPx(cvop)->op_first;
11137 switch (rvop->op_type) {
11139 gv = cGVOPx_gv(rvop);
11141 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11142 cv = MUTABLE_CV(SvRV(gv));
11146 if (flags & RV2CVOPCV_RETURN_STUB)
11152 if (flags & RV2CVOPCV_MARK_EARLY)
11153 rvop->op_private |= OPpEARLY_CV;
11158 SV *rv = cSVOPx_sv(rvop);
11161 cv = (CV*)SvRV(rv);
11165 cv = find_lexical_cv(rvop->op_targ);
11170 } NOT_REACHED; /* NOTREACHED */
11172 if (SvTYPE((SV*)cv) != SVt_PVCV)
11174 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11175 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11176 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11185 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11187 Performs the default fixup of the arguments part of an C<entersub>
11188 op tree. This consists of applying list context to each of the
11189 argument ops. This is the standard treatment used on a call marked
11190 with C<&>, or a method call, or a call through a subroutine reference,
11191 or any other call where the callee can't be identified at compile time,
11192 or a call where the callee has no prototype.
11198 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11202 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11204 aop = cUNOPx(entersubop)->op_first;
11205 if (!OpHAS_SIBLING(aop))
11206 aop = cUNOPx(aop)->op_first;
11207 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11208 /* skip the extra attributes->import() call implicitly added in
11209 * something like foo(my $x : bar)
11211 if ( aop->op_type == OP_ENTERSUB
11212 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11216 op_lvalue(aop, OP_ENTERSUB);
11222 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11224 Performs the fixup of the arguments part of an C<entersub> op tree
11225 based on a subroutine prototype. This makes various modifications to
11226 the argument ops, from applying context up to inserting C<refgen> ops,
11227 and checking the number and syntactic types of arguments, as directed by
11228 the prototype. This is the standard treatment used on a subroutine call,
11229 not marked with C<&>, where the callee can be identified at compile time
11230 and has a prototype.
11232 C<protosv> supplies the subroutine prototype to be applied to the call.
11233 It may be a normal defined scalar, of which the string value will be used.
11234 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11235 that has been cast to C<SV*>) which has a prototype. The prototype
11236 supplied, in whichever form, does not need to match the actual callee
11237 referenced by the op tree.
11239 If the argument ops disagree with the prototype, for example by having
11240 an unacceptable number of arguments, a valid op tree is returned anyway.
11241 The error is reflected in the parser state, normally resulting in a single
11242 exception at the top level of parsing which covers all the compilation
11243 errors that occurred. In the error message, the callee is referred to
11244 by the name defined by the C<namegv> parameter.
11250 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11253 const char *proto, *proto_end;
11254 OP *aop, *prev, *cvop, *parent;
11257 I32 contextclass = 0;
11258 const char *e = NULL;
11259 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11260 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11261 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11262 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11263 if (SvTYPE(protosv) == SVt_PVCV)
11264 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11265 else proto = SvPV(protosv, proto_len);
11266 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11267 proto_end = proto + proto_len;
11268 parent = entersubop;
11269 aop = cUNOPx(entersubop)->op_first;
11270 if (!OpHAS_SIBLING(aop)) {
11272 aop = cUNOPx(aop)->op_first;
11275 aop = OpSIBLING(aop);
11276 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11277 while (aop != cvop) {
11280 if (proto >= proto_end)
11282 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11283 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11284 SVfARG(namesv)), SvUTF8(namesv));
11294 /* _ must be at the end */
11295 if (proto[1] && !strchr(";@%", proto[1]))
11311 if ( o3->op_type != OP_UNDEF
11312 && (o3->op_type != OP_SREFGEN
11313 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11315 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11317 bad_type_gv(arg, namegv, o3,
11318 arg == 1 ? "block or sub {}" : "sub {}");
11321 /* '*' allows any scalar type, including bareword */
11324 if (o3->op_type == OP_RV2GV)
11325 goto wrapref; /* autoconvert GLOB -> GLOBref */
11326 else if (o3->op_type == OP_CONST)
11327 o3->op_private &= ~OPpCONST_STRICT;
11333 if (o3->op_type == OP_RV2AV ||
11334 o3->op_type == OP_PADAV ||
11335 o3->op_type == OP_RV2HV ||
11336 o3->op_type == OP_PADHV
11342 case '[': case ']':
11349 switch (*proto++) {
11351 if (contextclass++ == 0) {
11352 e = strchr(proto, ']');
11353 if (!e || e == proto)
11361 if (contextclass) {
11362 const char *p = proto;
11363 const char *const end = proto;
11365 while (*--p != '[')
11366 /* \[$] accepts any scalar lvalue */
11368 && Perl_op_lvalue_flags(aTHX_
11370 OP_READ, /* not entersub */
11373 bad_type_gv(arg, namegv, o3,
11374 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11379 if (o3->op_type == OP_RV2GV)
11382 bad_type_gv(arg, namegv, o3, "symbol");
11385 if (o3->op_type == OP_ENTERSUB
11386 && !(o3->op_flags & OPf_STACKED))
11389 bad_type_gv(arg, namegv, o3, "subroutine");
11392 if (o3->op_type == OP_RV2SV ||
11393 o3->op_type == OP_PADSV ||
11394 o3->op_type == OP_HELEM ||
11395 o3->op_type == OP_AELEM)
11397 if (!contextclass) {
11398 /* \$ accepts any scalar lvalue */
11399 if (Perl_op_lvalue_flags(aTHX_
11401 OP_READ, /* not entersub */
11404 bad_type_gv(arg, namegv, o3, "scalar");
11408 if (o3->op_type == OP_RV2AV ||
11409 o3->op_type == OP_PADAV)
11411 o3->op_flags &=~ OPf_PARENS;
11415 bad_type_gv(arg, namegv, o3, "array");
11418 if (o3->op_type == OP_RV2HV ||
11419 o3->op_type == OP_PADHV)
11421 o3->op_flags &=~ OPf_PARENS;
11425 bad_type_gv(arg, namegv, o3, "hash");
11428 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11430 if (contextclass && e) {
11435 default: goto oops;
11445 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11446 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11451 op_lvalue(aop, OP_ENTERSUB);
11453 aop = OpSIBLING(aop);
11455 if (aop == cvop && *proto == '_') {
11456 /* generate an access to $_ */
11457 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11459 if (!optional && proto_end > proto &&
11460 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11462 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11463 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11464 SVfARG(namesv)), SvUTF8(namesv));
11470 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11472 Performs the fixup of the arguments part of an C<entersub> op tree either
11473 based on a subroutine prototype or using default list-context processing.
11474 This is the standard treatment used on a subroutine call, not marked
11475 with C<&>, where the callee can be identified at compile time.
11477 C<protosv> supplies the subroutine prototype to be applied to the call,
11478 or indicates that there is no prototype. It may be a normal scalar,
11479 in which case if it is defined then the string value will be used
11480 as a prototype, and if it is undefined then there is no prototype.
11481 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11482 that has been cast to C<SV*>), of which the prototype will be used if it
11483 has one. The prototype (or lack thereof) supplied, in whichever form,
11484 does not need to match the actual callee referenced by the op tree.
11486 If the argument ops disagree with the prototype, for example by having
11487 an unacceptable number of arguments, a valid op tree is returned anyway.
11488 The error is reflected in the parser state, normally resulting in a single
11489 exception at the top level of parsing which covers all the compilation
11490 errors that occurred. In the error message, the callee is referred to
11491 by the name defined by the C<namegv> parameter.
11497 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11498 GV *namegv, SV *protosv)
11500 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11501 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11502 return ck_entersub_args_proto(entersubop, namegv, protosv);
11504 return ck_entersub_args_list(entersubop);
11508 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11510 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11511 OP *aop = cUNOPx(entersubop)->op_first;
11513 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11517 if (!OpHAS_SIBLING(aop))
11518 aop = cUNOPx(aop)->op_first;
11519 aop = OpSIBLING(aop);
11520 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11522 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11524 op_free(entersubop);
11525 switch(GvNAME(namegv)[2]) {
11526 case 'F': return newSVOP(OP_CONST, 0,
11527 newSVpv(CopFILE(PL_curcop),0));
11528 case 'L': return newSVOP(
11530 Perl_newSVpvf(aTHX_
11531 "%"IVdf, (IV)CopLINE(PL_curcop)
11534 case 'P': return newSVOP(OP_CONST, 0,
11536 ? newSVhek(HvNAME_HEK(PL_curstash))
11541 NOT_REACHED; /* NOTREACHED */
11544 OP *prev, *cvop, *first, *parent;
11547 parent = entersubop;
11548 if (!OpHAS_SIBLING(aop)) {
11550 aop = cUNOPx(aop)->op_first;
11553 first = prev = aop;
11554 aop = OpSIBLING(aop);
11555 /* find last sibling */
11557 OpHAS_SIBLING(cvop);
11558 prev = cvop, cvop = OpSIBLING(cvop))
11560 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11561 /* Usually, OPf_SPECIAL on an op with no args means that it had
11562 * parens, but these have their own meaning for that flag: */
11563 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11564 && opnum != OP_DELETE && opnum != OP_EXISTS)
11565 flags |= OPf_SPECIAL;
11566 /* excise cvop from end of sibling chain */
11567 op_sibling_splice(parent, prev, 1, NULL);
11569 if (aop == cvop) aop = NULL;
11571 /* detach remaining siblings from the first sibling, then
11572 * dispose of original optree */
11575 op_sibling_splice(parent, first, -1, NULL);
11576 op_free(entersubop);
11578 if (opnum == OP_ENTEREVAL
11579 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11580 flags |= OPpEVAL_BYTES <<8;
11582 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11584 case OA_BASEOP_OR_UNOP:
11585 case OA_FILESTATOP:
11586 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11589 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11592 return opnum == OP_RUNCV
11593 ? newPVOP(OP_RUNCV,0,NULL)
11596 return op_convert_list(opnum,0,aop);
11599 NOT_REACHED; /* NOTREACHED */
11604 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11606 Retrieves the function that will be used to fix up a call to C<cv>.
11607 Specifically, the function is applied to an C<entersub> op tree for a
11608 subroutine call, not marked with C<&>, where the callee can be identified
11609 at compile time as C<cv>.
11611 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11612 argument for it is returned in C<*ckobj_p>. The function is intended
11613 to be called in this manner:
11615 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11617 In this call, C<entersubop> is a pointer to the C<entersub> op,
11618 which may be replaced by the check function, and C<namegv> is a GV
11619 supplying the name that should be used by the check function to refer
11620 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11621 It is permitted to apply the check function in non-standard situations,
11622 such as to a call to a different subroutine or to a method call.
11624 By default, the function is
11625 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11626 and the SV parameter is C<cv> itself. This implements standard
11627 prototype processing. It can be changed, for a particular subroutine,
11628 by L</cv_set_call_checker>.
11634 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11638 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11640 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11641 *ckobj_p = callmg->mg_obj;
11642 if (flagsp) *flagsp = callmg->mg_flags;
11644 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11645 *ckobj_p = (SV*)cv;
11646 if (flagsp) *flagsp = 0;
11651 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11653 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11654 PERL_UNUSED_CONTEXT;
11655 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11659 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11661 Sets the function that will be used to fix up a call to C<cv>.
11662 Specifically, the function is applied to an C<entersub> op tree for a
11663 subroutine call, not marked with C<&>, where the callee can be identified
11664 at compile time as C<cv>.
11666 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11667 for it is supplied in C<ckobj>. The function should be defined like this:
11669 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11671 It is intended to be called in this manner:
11673 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11675 In this call, C<entersubop> is a pointer to the C<entersub> op,
11676 which may be replaced by the check function, and C<namegv> supplies
11677 the name that should be used by the check function to refer
11678 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11679 It is permitted to apply the check function in non-standard situations,
11680 such as to a call to a different subroutine or to a method call.
11682 C<namegv> may not actually be a GV. For efficiency, perl may pass a
11683 CV or other SV instead. Whatever is passed can be used as the first
11684 argument to L</cv_name>. You can force perl to pass a GV by including
11685 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11687 The current setting for a particular CV can be retrieved by
11688 L</cv_get_call_checker>.
11690 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11692 The original form of L</cv_set_call_checker_flags>, which passes it the
11693 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11699 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11701 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11702 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11706 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11707 SV *ckobj, U32 flags)
11709 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11710 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11711 if (SvMAGICAL((SV*)cv))
11712 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11715 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11716 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11718 if (callmg->mg_flags & MGf_REFCOUNTED) {
11719 SvREFCNT_dec(callmg->mg_obj);
11720 callmg->mg_flags &= ~MGf_REFCOUNTED;
11722 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11723 callmg->mg_obj = ckobj;
11724 if (ckobj != (SV*)cv) {
11725 SvREFCNT_inc_simple_void_NN(ckobj);
11726 callmg->mg_flags |= MGf_REFCOUNTED;
11728 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11729 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11734 S_entersub_alloc_targ(pTHX_ OP * const o)
11736 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11737 o->op_private |= OPpENTERSUB_HASTARG;
11741 Perl_ck_subr(pTHX_ OP *o)
11746 SV **const_class = NULL;
11748 PERL_ARGS_ASSERT_CK_SUBR;
11750 aop = cUNOPx(o)->op_first;
11751 if (!OpHAS_SIBLING(aop))
11752 aop = cUNOPx(aop)->op_first;
11753 aop = OpSIBLING(aop);
11754 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11755 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11756 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11758 o->op_private &= ~1;
11759 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11760 if (PERLDB_SUB && PL_curstash != PL_debstash)
11761 o->op_private |= OPpENTERSUB_DB;
11762 switch (cvop->op_type) {
11764 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11768 case OP_METHOD_NAMED:
11769 case OP_METHOD_SUPER:
11770 case OP_METHOD_REDIR:
11771 case OP_METHOD_REDIR_SUPER:
11772 if (aop->op_type == OP_CONST) {
11773 aop->op_private &= ~OPpCONST_STRICT;
11774 const_class = &cSVOPx(aop)->op_sv;
11776 else if (aop->op_type == OP_LIST) {
11777 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11778 if (sib && sib->op_type == OP_CONST) {
11779 sib->op_private &= ~OPpCONST_STRICT;
11780 const_class = &cSVOPx(sib)->op_sv;
11783 /* make class name a shared cow string to speedup method calls */
11784 /* constant string might be replaced with object, f.e. bigint */
11785 if (const_class && SvPOK(*const_class)) {
11787 const char* str = SvPV(*const_class, len);
11789 SV* const shared = newSVpvn_share(
11790 str, SvUTF8(*const_class)
11791 ? -(SSize_t)len : (SSize_t)len,
11794 if (SvREADONLY(*const_class))
11795 SvREADONLY_on(shared);
11796 SvREFCNT_dec(*const_class);
11797 *const_class = shared;
11804 S_entersub_alloc_targ(aTHX_ o);
11805 return ck_entersub_args_list(o);
11807 Perl_call_checker ckfun;
11810 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11811 if (CvISXSUB(cv) || !CvROOT(cv))
11812 S_entersub_alloc_targ(aTHX_ o);
11814 /* The original call checker API guarantees that a GV will be
11815 be provided with the right name. So, if the old API was
11816 used (or the REQUIRE_GV flag was passed), we have to reify
11817 the CV’s GV, unless this is an anonymous sub. This is not
11818 ideal for lexical subs, as its stringification will include
11819 the package. But it is the best we can do. */
11820 if (flags & MGf_REQUIRE_GV) {
11821 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11824 else namegv = MUTABLE_GV(cv);
11825 /* After a syntax error in a lexical sub, the cv that
11826 rv2cv_op_cv returns may be a nameless stub. */
11827 if (!namegv) return ck_entersub_args_list(o);
11830 return ckfun(aTHX_ o, namegv, ckobj);
11835 Perl_ck_svconst(pTHX_ OP *o)
11837 SV * const sv = cSVOPo->op_sv;
11838 PERL_ARGS_ASSERT_CK_SVCONST;
11839 PERL_UNUSED_CONTEXT;
11840 #ifdef PERL_COPY_ON_WRITE
11841 /* Since the read-only flag may be used to protect a string buffer, we
11842 cannot do copy-on-write with existing read-only scalars that are not
11843 already copy-on-write scalars. To allow $_ = "hello" to do COW with
11844 that constant, mark the constant as COWable here, if it is not
11845 already read-only. */
11846 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11849 # ifdef PERL_DEBUG_READONLY_COW
11859 Perl_ck_trunc(pTHX_ OP *o)
11861 PERL_ARGS_ASSERT_CK_TRUNC;
11863 if (o->op_flags & OPf_KIDS) {
11864 SVOP *kid = (SVOP*)cUNOPo->op_first;
11866 if (kid->op_type == OP_NULL)
11867 kid = (SVOP*)OpSIBLING(kid);
11868 if (kid && kid->op_type == OP_CONST &&
11869 (kid->op_private & OPpCONST_BARE) &&
11872 o->op_flags |= OPf_SPECIAL;
11873 kid->op_private &= ~OPpCONST_STRICT;
11880 Perl_ck_substr(pTHX_ OP *o)
11882 PERL_ARGS_ASSERT_CK_SUBSTR;
11885 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11886 OP *kid = cLISTOPo->op_first;
11888 if (kid->op_type == OP_NULL)
11889 kid = OpSIBLING(kid);
11891 kid->op_flags |= OPf_MOD;
11898 Perl_ck_tell(pTHX_ OP *o)
11900 PERL_ARGS_ASSERT_CK_TELL;
11902 if (o->op_flags & OPf_KIDS) {
11903 OP *kid = cLISTOPo->op_first;
11904 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
11905 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11911 Perl_ck_each(pTHX_ OP *o)
11914 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11915 const unsigned orig_type = o->op_type;
11917 PERL_ARGS_ASSERT_CK_EACH;
11920 switch (kid->op_type) {
11926 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
11927 : orig_type == OP_KEYS ? OP_AKEYS
11931 if (kid->op_private == OPpCONST_BARE
11932 || !SvROK(cSVOPx_sv(kid))
11933 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11934 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
11936 /* we let ck_fun handle it */
11939 Perl_croak_nocontext(
11940 "Experimental %s on scalar is now forbidden",
11941 PL_op_desc[orig_type]);
11949 Perl_ck_length(pTHX_ OP *o)
11951 PERL_ARGS_ASSERT_CK_LENGTH;
11955 if (ckWARN(WARN_SYNTAX)) {
11956 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11960 const bool hash = kid->op_type == OP_PADHV
11961 || kid->op_type == OP_RV2HV;
11962 switch (kid->op_type) {
11967 name = S_op_varname(aTHX_ kid);
11973 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11974 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11976 SVfARG(name), hash ? "keys " : "", SVfARG(name)
11979 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11980 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11981 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11983 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11984 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11985 "length() used on @array (did you mean \"scalar(@array)\"?)");
11995 ---------------------------------------------------------
11997 Common vars in list assignment
11999 There now follows some enums and static functions for detecting
12000 common variables in list assignments. Here is a little essay I wrote
12001 for myself when trying to get my head around this. DAPM.
12005 First some random observations:
12007 * If a lexical var is an alias of something else, e.g.
12008 for my $x ($lex, $pkg, $a[0]) {...}
12009 then the act of aliasing will increase the reference count of the SV
12011 * If a package var is an alias of something else, it may still have a
12012 reference count of 1, depending on how the alias was created, e.g.
12013 in *a = *b, $a may have a refcount of 1 since the GP is shared
12014 with a single GvSV pointer to the SV. So If it's an alias of another
12015 package var, then RC may be 1; if it's an alias of another scalar, e.g.
12016 a lexical var or an array element, then it will have RC > 1.
12018 * There are many ways to create a package alias; ultimately, XS code
12019 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12020 run-time tracing mechanisms are unlikely to be able to catch all cases.
12022 * When the LHS is all my declarations, the same vars can't appear directly
12023 on the RHS, but they can indirectly via closures, aliasing and lvalue
12024 subs. But those techniques all involve an increase in the lexical
12025 scalar's ref count.
12027 * When the LHS is all lexical vars (but not necessarily my declarations),
12028 it is possible for the same lexicals to appear directly on the RHS, and
12029 without an increased ref count, since the stack isn't refcounted.
12030 This case can be detected at compile time by scanning for common lex
12031 vars with PL_generation.
12033 * lvalue subs defeat common var detection, but they do at least
12034 return vars with a temporary ref count increment. Also, you can't
12035 tell at compile time whether a sub call is lvalue.
12040 A: There are a few circumstances where there definitely can't be any
12043 LHS empty: () = (...);
12044 RHS empty: (....) = ();
12045 RHS contains only constants or other 'can't possibly be shared'
12046 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
12047 i.e. they only contain ops not marked as dangerous, whose children
12048 are also not dangerous;
12050 LHS contains a single scalar element: e.g. ($x) = (....); because
12051 after $x has been modified, it won't be used again on the RHS;
12052 RHS contains a single element with no aggregate on LHS: e.g.
12053 ($a,$b,$c) = ($x); again, once $a has been modified, its value
12054 won't be used again.
12056 B: If LHS are all 'my' lexical var declarations (or safe ops, which
12059 my ($a, $b, @c) = ...;
12061 Due to closure and goto tricks, these vars may already have content.
12062 For the same reason, an element on the RHS may be a lexical or package
12063 alias of one of the vars on the left, or share common elements, for
12066 my ($x,$y) = f(); # $x and $y on both sides
12067 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12072 my @a = @$ra; # elements of @a on both sides
12073 sub f { @a = 1..4; \@a }
12076 First, just consider scalar vars on LHS:
12078 RHS is safe only if (A), or in addition,
12079 * contains only lexical *scalar* vars, where neither side's
12080 lexicals have been flagged as aliases
12082 If RHS is not safe, then it's always legal to check LHS vars for
12083 RC==1, since the only RHS aliases will always be associated
12086 Note that in particular, RHS is not safe if:
12088 * it contains package scalar vars; e.g.:
12091 my ($x, $y) = (2, $x_alias);
12092 sub f { $x = 1; *x_alias = \$x; }
12094 * It contains other general elements, such as flattened or
12095 * spliced or single array or hash elements, e.g.
12098 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12102 use feature 'refaliasing';
12103 \($a[0], $a[1]) = \($y,$x);
12106 It doesn't matter if the array/hash is lexical or package.
12108 * it contains a function call that happens to be an lvalue
12109 sub which returns one or more of the above, e.g.
12120 (so a sub call on the RHS should be treated the same
12121 as having a package var on the RHS).
12123 * any other "dangerous" thing, such an op or built-in that
12124 returns one of the above, e.g. pp_preinc
12127 If RHS is not safe, what we can do however is at compile time flag
12128 that the LHS are all my declarations, and at run time check whether
12129 all the LHS have RC == 1, and if so skip the full scan.
12131 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12133 Here the issue is whether there can be elements of @a on the RHS
12134 which will get prematurely freed when @a is cleared prior to
12135 assignment. This is only a problem if the aliasing mechanism
12136 is one which doesn't increase the refcount - only if RC == 1
12137 will the RHS element be prematurely freed.
12139 Because the array/hash is being INTROed, it or its elements
12140 can't directly appear on the RHS:
12142 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12144 but can indirectly, e.g.:
12148 sub f { @a = 1..3; \@a }
12150 So if the RHS isn't safe as defined by (A), we must always
12151 mortalise and bump the ref count of any remaining RHS elements
12152 when assigning to a non-empty LHS aggregate.
12154 Lexical scalars on the RHS aren't safe if they've been involved in
12157 use feature 'refaliasing';
12160 \(my $lex) = \$pkg;
12161 my @a = ($lex,3); # equivalent to ($a[0],3)
12168 Similarly with lexical arrays and hashes on the RHS:
12182 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12183 my $a; ($a, my $b) = (....);
12185 The difference between (B) and (C) is that it is now physically
12186 possible for the LHS vars to appear on the RHS too, where they
12187 are not reference counted; but in this case, the compile-time
12188 PL_generation sweep will detect such common vars.
12190 So the rules for (C) differ from (B) in that if common vars are
12191 detected, the runtime "test RC==1" optimisation can no longer be used,
12192 and a full mark and sweep is required
12194 D: As (C), but in addition the LHS may contain package vars.
12196 Since package vars can be aliased without a corresponding refcount
12197 increase, all bets are off. It's only safe if (A). E.g.
12199 my ($x, $y) = (1,2);
12201 for $x_alias ($x) {
12202 ($x_alias, $y) = (3, $x); # whoops
12205 Ditto for LHS aggregate package vars.
12207 E: Any other dangerous ops on LHS, e.g.
12208 (f(), $a[0], @$r) = (...);
12210 this is similar to (E) in that all bets are off. In addition, it's
12211 impossible to determine at compile time whether the LHS
12212 contains a scalar or an aggregate, e.g.
12214 sub f : lvalue { @a }
12217 * ---------------------------------------------------------
12221 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12222 * that at least one of the things flagged was seen.
12226 AAS_MY_SCALAR = 0x001, /* my $scalar */
12227 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
12228 AAS_LEX_SCALAR = 0x004, /* $lexical */
12229 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
12230 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12231 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
12232 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
12233 AAS_DANGEROUS = 0x080, /* an op (other than the above)
12234 that's flagged OA_DANGEROUS */
12235 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
12236 not in any of the categories above */
12237 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
12242 /* helper function for S_aassign_scan().
12243 * check a PAD-related op for commonality and/or set its generation number.
12244 * Returns a boolean indicating whether its shared */
12247 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12249 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12250 /* lexical used in aliasing */
12254 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12256 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12263 Helper function for OPpASSIGN_COMMON* detection in rpeep().
12264 It scans the left or right hand subtree of the aassign op, and returns a
12265 set of flags indicating what sorts of things it found there.
12266 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12267 set PL_generation on lexical vars; if the latter, we see if
12268 PL_generation matches.
12269 'top' indicates whether we're recursing or at the top level.
12270 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12271 This fn will increment it by the number seen. It's not intended to
12272 be an accurate count (especially as many ops can push a variable
12273 number of SVs onto the stack); rather it's used as to test whether there
12274 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12278 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12281 bool kid_top = FALSE;
12283 /* first, look for a solitary @_ on the RHS */
12286 && (o->op_flags & OPf_KIDS)
12287 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12289 OP *kid = cUNOPo->op_first;
12290 if ( ( kid->op_type == OP_PUSHMARK
12291 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12292 && ((kid = OpSIBLING(kid)))
12293 && !OpHAS_SIBLING(kid)
12294 && kid->op_type == OP_RV2AV
12295 && !(kid->op_flags & OPf_REF)
12296 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12297 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12298 && ((kid = cUNOPx(kid)->op_first))
12299 && kid->op_type == OP_GV
12300 && cGVOPx_gv(kid) == PL_defgv
12302 flags |= AAS_DEFAV;
12305 switch (o->op_type) {
12308 return AAS_PKG_SCALAR;
12313 if (top && (o->op_flags & OPf_REF))
12314 return (o->op_private & OPpLVAL_INTRO)
12315 ? AAS_MY_AGG : AAS_LEX_AGG;
12316 return AAS_DANGEROUS;
12320 int comm = S_aassign_padcheck(aTHX_ o, rhs)
12321 ? AAS_LEX_SCALAR_COMM : 0;
12323 return (o->op_private & OPpLVAL_INTRO)
12324 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12330 if (cUNOPx(o)->op_first->op_type != OP_GV)
12331 return AAS_DANGEROUS; /* @{expr}, %{expr} */
12333 if (top && (o->op_flags & OPf_REF))
12334 return AAS_PKG_AGG;
12335 return AAS_DANGEROUS;
12339 if (cUNOPx(o)->op_first->op_type != OP_GV) {
12341 return AAS_DANGEROUS; /* ${expr} */
12343 return AAS_PKG_SCALAR; /* $pkg */
12346 if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
12347 /* "@foo = split... " optimises away the aassign and stores its
12348 * destination array in the OP_PUSHRE that precedes it.
12349 * A flattened array is always dangerous.
12352 return AAS_DANGEROUS;
12357 /* undef counts as a scalar on the RHS:
12358 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
12359 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
12363 flags = AAS_SAFE_SCALAR;
12368 /* these are all no-ops; they don't push a potentially common SV
12369 * onto the stack, so they are neither AAS_DANGEROUS nor
12370 * AAS_SAFE_SCALAR */
12373 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12378 /* these do nothing but may have children; but their children
12379 * should also be treated as top-level */
12384 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12386 flags = AAS_DANGEROUS;
12390 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
12391 && (o->op_private & OPpTARGET_MY))
12394 return S_aassign_padcheck(aTHX_ o, rhs)
12395 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12398 /* if its an unrecognised, non-dangerous op, assume that it
12399 * it the cause of at least one safe scalar */
12401 flags = AAS_SAFE_SCALAR;
12405 if (o->op_flags & OPf_KIDS) {
12407 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12408 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12414 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12415 and modify the optree to make them work inplace */
12418 S_inplace_aassign(pTHX_ OP *o) {
12420 OP *modop, *modop_pushmark;
12422 OP *oleft, *oleft_pushmark;
12424 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12426 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12428 assert(cUNOPo->op_first->op_type == OP_NULL);
12429 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12430 assert(modop_pushmark->op_type == OP_PUSHMARK);
12431 modop = OpSIBLING(modop_pushmark);
12433 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12436 /* no other operation except sort/reverse */
12437 if (OpHAS_SIBLING(modop))
12440 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12441 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12443 if (modop->op_flags & OPf_STACKED) {
12444 /* skip sort subroutine/block */
12445 assert(oright->op_type == OP_NULL);
12446 oright = OpSIBLING(oright);
12449 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12450 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12451 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12452 oleft = OpSIBLING(oleft_pushmark);
12454 /* Check the lhs is an array */
12456 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12457 || OpHAS_SIBLING(oleft)
12458 || (oleft->op_private & OPpLVAL_INTRO)
12462 /* Only one thing on the rhs */
12463 if (OpHAS_SIBLING(oright))
12466 /* check the array is the same on both sides */
12467 if (oleft->op_type == OP_RV2AV) {
12468 if (oright->op_type != OP_RV2AV
12469 || !cUNOPx(oright)->op_first
12470 || cUNOPx(oright)->op_first->op_type != OP_GV
12471 || cUNOPx(oleft )->op_first->op_type != OP_GV
12472 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12473 cGVOPx_gv(cUNOPx(oright)->op_first)
12477 else if (oright->op_type != OP_PADAV
12478 || oright->op_targ != oleft->op_targ
12482 /* This actually is an inplace assignment */
12484 modop->op_private |= OPpSORT_INPLACE;
12486 /* transfer MODishness etc from LHS arg to RHS arg */
12487 oright->op_flags = oleft->op_flags;
12489 /* remove the aassign op and the lhs */
12491 op_null(oleft_pushmark);
12492 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12493 op_null(cUNOPx(oleft)->op_first);
12499 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12500 * that potentially represent a series of one or more aggregate derefs
12501 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12502 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12503 * additional ops left in too).
12505 * The caller will have already verified that the first few ops in the
12506 * chain following 'start' indicate a multideref candidate, and will have
12507 * set 'orig_o' to the point further on in the chain where the first index
12508 * expression (if any) begins. 'orig_action' specifies what type of
12509 * beginning has already been determined by the ops between start..orig_o
12510 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12512 * 'hints' contains any hints flags that need adding (currently just
12513 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12517 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12521 UNOP_AUX_item *arg_buf = NULL;
12522 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12523 int index_skip = -1; /* don't output index arg on this action */
12525 /* similar to regex compiling, do two passes; the first pass
12526 * determines whether the op chain is convertible and calculates the
12527 * buffer size; the second pass populates the buffer and makes any
12528 * changes necessary to ops (such as moving consts to the pad on
12529 * threaded builds).
12531 * NB: for things like Coverity, note that both passes take the same
12532 * path through the logic tree (except for 'if (pass)' bits), since
12533 * both passes are following the same op_next chain; and in
12534 * particular, if it would return early on the second pass, it would
12535 * already have returned early on the first pass.
12537 for (pass = 0; pass < 2; pass++) {
12539 UV action = orig_action;
12540 OP *first_elem_op = NULL; /* first seen aelem/helem */
12541 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12542 int action_count = 0; /* number of actions seen so far */
12543 int action_ix = 0; /* action_count % (actions per IV) */
12544 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12545 bool is_last = FALSE; /* no more derefs to follow */
12546 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12547 UNOP_AUX_item *arg = arg_buf;
12548 UNOP_AUX_item *action_ptr = arg_buf;
12551 action_ptr->uv = 0;
12555 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12556 case MDEREF_HV_gvhv_helem:
12557 next_is_hash = TRUE;
12559 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12560 case MDEREF_AV_gvav_aelem:
12562 #ifdef USE_ITHREADS
12563 arg->pad_offset = cPADOPx(start)->op_padix;
12564 /* stop it being swiped when nulled */
12565 cPADOPx(start)->op_padix = 0;
12567 arg->sv = cSVOPx(start)->op_sv;
12568 cSVOPx(start)->op_sv = NULL;
12574 case MDEREF_HV_padhv_helem:
12575 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12576 next_is_hash = TRUE;
12578 case MDEREF_AV_padav_aelem:
12579 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12581 arg->pad_offset = start->op_targ;
12582 /* we skip setting op_targ = 0 for now, since the intact
12583 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12584 reset_start_targ = TRUE;
12589 case MDEREF_HV_pop_rv2hv_helem:
12590 next_is_hash = TRUE;
12592 case MDEREF_AV_pop_rv2av_aelem:
12596 NOT_REACHED; /* NOTREACHED */
12601 /* look for another (rv2av/hv; get index;
12602 * aelem/helem/exists/delele) sequence */
12607 UV index_type = MDEREF_INDEX_none;
12609 if (action_count) {
12610 /* if this is not the first lookup, consume the rv2av/hv */
12612 /* for N levels of aggregate lookup, we normally expect
12613 * that the first N-1 [ah]elem ops will be flagged as
12614 * /DEREF (so they autovivifiy if necessary), and the last
12615 * lookup op not to be.
12616 * For other things (like @{$h{k1}{k2}}) extra scope or
12617 * leave ops can appear, so abandon the effort in that
12619 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12622 /* rv2av or rv2hv sKR/1 */
12624 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12625 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12626 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12629 /* at this point, we wouldn't expect any of these
12630 * possible private flags:
12631 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12632 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12634 ASSUME(!(o->op_private &
12635 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12637 hints = (o->op_private & OPpHINT_STRICT_REFS);
12639 /* make sure the type of the previous /DEREF matches the
12640 * type of the next lookup */
12641 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12644 action = next_is_hash
12645 ? MDEREF_HV_vivify_rv2hv_helem
12646 : MDEREF_AV_vivify_rv2av_aelem;
12650 /* if this is the second pass, and we're at the depth where
12651 * previously we encountered a non-simple index expression,
12652 * stop processing the index at this point */
12653 if (action_count != index_skip) {
12655 /* look for one or more simple ops that return an array
12656 * index or hash key */
12658 switch (o->op_type) {
12660 /* it may be a lexical var index */
12661 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12662 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12663 ASSUME(!(o->op_private &
12664 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12666 if ( OP_GIMME(o,0) == G_SCALAR
12667 && !(o->op_flags & (OPf_REF|OPf_MOD))
12668 && o->op_private == 0)
12671 arg->pad_offset = o->op_targ;
12673 index_type = MDEREF_INDEX_padsv;
12679 if (next_is_hash) {
12680 /* it's a constant hash index */
12681 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12682 /* "use constant foo => FOO; $h{+foo}" for
12683 * some weird FOO, can leave you with constants
12684 * that aren't simple strings. It's not worth
12685 * the extra hassle for those edge cases */
12690 OP * helem_op = o->op_next;
12692 ASSUME( helem_op->op_type == OP_HELEM
12693 || helem_op->op_type == OP_NULL);
12694 if (helem_op->op_type == OP_HELEM) {
12695 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12696 if ( helem_op->op_private & OPpLVAL_INTRO
12697 || rop->op_type != OP_RV2HV
12701 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12703 #ifdef USE_ITHREADS
12704 /* Relocate sv to the pad for thread safety */
12705 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12706 arg->pad_offset = o->op_targ;
12709 arg->sv = cSVOPx_sv(o);
12714 /* it's a constant array index */
12716 SV *ix_sv = cSVOPo->op_sv;
12721 if ( action_count == 0
12724 && ( action == MDEREF_AV_padav_aelem
12725 || action == MDEREF_AV_gvav_aelem)
12727 maybe_aelemfast = TRUE;
12731 SvREFCNT_dec_NN(cSVOPo->op_sv);
12735 /* we've taken ownership of the SV */
12736 cSVOPo->op_sv = NULL;
12738 index_type = MDEREF_INDEX_const;
12743 /* it may be a package var index */
12745 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12746 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12747 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12748 || o->op_private != 0
12753 if (kid->op_type != OP_RV2SV)
12756 ASSUME(!(kid->op_flags &
12757 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12758 |OPf_SPECIAL|OPf_PARENS)));
12759 ASSUME(!(kid->op_private &
12761 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12762 |OPpDEREF|OPpLVAL_INTRO)));
12763 if( (kid->op_flags &~ OPf_PARENS)
12764 != (OPf_WANT_SCALAR|OPf_KIDS)
12765 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12770 #ifdef USE_ITHREADS
12771 arg->pad_offset = cPADOPx(o)->op_padix;
12772 /* stop it being swiped when nulled */
12773 cPADOPx(o)->op_padix = 0;
12775 arg->sv = cSVOPx(o)->op_sv;
12776 cSVOPo->op_sv = NULL;
12780 index_type = MDEREF_INDEX_gvsv;
12785 } /* action_count != index_skip */
12787 action |= index_type;
12790 /* at this point we have either:
12791 * * detected what looks like a simple index expression,
12792 * and expect the next op to be an [ah]elem, or
12793 * an nulled [ah]elem followed by a delete or exists;
12794 * * found a more complex expression, so something other
12795 * than the above follows.
12798 /* possibly an optimised away [ah]elem (where op_next is
12799 * exists or delete) */
12800 if (o->op_type == OP_NULL)
12803 /* at this point we're looking for an OP_AELEM, OP_HELEM,
12804 * OP_EXISTS or OP_DELETE */
12806 /* if something like arybase (a.k.a $[ ) is in scope,
12807 * abandon optimisation attempt */
12808 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12809 && PL_check[o->op_type] != Perl_ck_null)
12812 if ( o->op_type != OP_AELEM
12813 || (o->op_private &
12814 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12816 maybe_aelemfast = FALSE;
12818 /* look for aelem/helem/exists/delete. If it's not the last elem
12819 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12820 * flags; if it's the last, then it mustn't have
12821 * OPpDEREF_AV/HV, but may have lots of other flags, like
12822 * OPpLVAL_INTRO etc
12825 if ( index_type == MDEREF_INDEX_none
12826 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
12827 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12831 /* we have aelem/helem/exists/delete with valid simple index */
12833 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12834 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
12835 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12838 ASSUME(!(o->op_flags &
12839 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12840 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12842 ok = (o->op_flags &~ OPf_PARENS)
12843 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12844 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12846 else if (o->op_type == OP_EXISTS) {
12847 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12848 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12849 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12850 ok = !(o->op_private & ~OPpARG1_MASK);
12852 else if (o->op_type == OP_DELETE) {
12853 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12854 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12855 ASSUME(!(o->op_private &
12856 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12857 /* don't handle slices or 'local delete'; the latter
12858 * is fairly rare, and has a complex runtime */
12859 ok = !(o->op_private & ~OPpARG1_MASK);
12860 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12861 /* skip handling run-tome error */
12862 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12865 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12866 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12867 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12868 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12869 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12870 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12875 if (!first_elem_op)
12879 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12884 action |= MDEREF_FLAG_last;
12888 /* at this point we have something that started
12889 * promisingly enough (with rv2av or whatever), but failed
12890 * to find a simple index followed by an
12891 * aelem/helem/exists/delete. If this is the first action,
12892 * give up; but if we've already seen at least one
12893 * aelem/helem, then keep them and add a new action with
12894 * MDEREF_INDEX_none, which causes it to do the vivify
12895 * from the end of the previous lookup, and do the deref,
12896 * but stop at that point. So $a[0][expr] will do one
12897 * av_fetch, vivify and deref, then continue executing at
12902 index_skip = action_count;
12903 action |= MDEREF_FLAG_last;
12907 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12910 /* if there's no space for the next action, create a new slot
12911 * for it *before* we start adding args for that action */
12912 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12919 } /* while !is_last */
12927 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12928 if (index_skip == -1) {
12929 mderef->op_flags = o->op_flags
12930 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12931 if (o->op_type == OP_EXISTS)
12932 mderef->op_private = OPpMULTIDEREF_EXISTS;
12933 else if (o->op_type == OP_DELETE)
12934 mderef->op_private = OPpMULTIDEREF_DELETE;
12936 mderef->op_private = o->op_private
12937 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12939 /* accumulate strictness from every level (although I don't think
12940 * they can actually vary) */
12941 mderef->op_private |= hints;
12943 /* integrate the new multideref op into the optree and the
12946 * In general an op like aelem or helem has two child
12947 * sub-trees: the aggregate expression (a_expr) and the
12948 * index expression (i_expr):
12954 * The a_expr returns an AV or HV, while the i-expr returns an
12955 * index. In general a multideref replaces most or all of a
12956 * multi-level tree, e.g.
12972 * With multideref, all the i_exprs will be simple vars or
12973 * constants, except that i_expr1 may be arbitrary in the case
12974 * of MDEREF_INDEX_none.
12976 * The bottom-most a_expr will be either:
12977 * 1) a simple var (so padXv or gv+rv2Xv);
12978 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
12979 * so a simple var with an extra rv2Xv;
12980 * 3) or an arbitrary expression.
12982 * 'start', the first op in the execution chain, will point to
12983 * 1),2): the padXv or gv op;
12984 * 3): the rv2Xv which forms the last op in the a_expr
12985 * execution chain, and the top-most op in the a_expr
12988 * For all cases, the 'start' node is no longer required,
12989 * but we can't free it since one or more external nodes
12990 * may point to it. E.g. consider
12991 * $h{foo} = $a ? $b : $c
12992 * Here, both the op_next and op_other branches of the
12993 * cond_expr point to the gv[*h] of the hash expression, so
12994 * we can't free the 'start' op.
12996 * For expr->[...], we need to save the subtree containing the
12997 * expression; for the other cases, we just need to save the
12999 * So in all cases, we null the start op and keep it around by
13000 * making it the child of the multideref op; for the expr->
13001 * case, the expr will be a subtree of the start node.
13003 * So in the simple 1,2 case the optree above changes to
13009 * ex-gv (or ex-padxv)
13011 * with the op_next chain being
13013 * -> ex-gv -> multideref -> op-following-ex-exists ->
13015 * In the 3 case, we have
13028 * -> rest-of-a_expr subtree ->
13029 * ex-rv2xv -> multideref -> op-following-ex-exists ->
13032 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13033 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13034 * multideref attached as the child, e.g.
13040 * ex-rv2av - i_expr1
13048 /* if we free this op, don't free the pad entry */
13049 if (reset_start_targ)
13050 start->op_targ = 0;
13053 /* Cut the bit we need to save out of the tree and attach to
13054 * the multideref op, then free the rest of the tree */
13056 /* find parent of node to be detached (for use by splice) */
13058 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
13059 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13061 /* there is an arbitrary expression preceding us, e.g.
13062 * expr->[..]? so we need to save the 'expr' subtree */
13063 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13064 p = cUNOPx(p)->op_first;
13065 ASSUME( start->op_type == OP_RV2AV
13066 || start->op_type == OP_RV2HV);
13069 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13070 * above for exists/delete. */
13071 while ( (p->op_flags & OPf_KIDS)
13072 && cUNOPx(p)->op_first != start
13074 p = cUNOPx(p)->op_first;
13076 ASSUME(cUNOPx(p)->op_first == start);
13078 /* detach from main tree, and re-attach under the multideref */
13079 op_sibling_splice(mderef, NULL, 0,
13080 op_sibling_splice(p, NULL, 1, NULL));
13083 start->op_next = mderef;
13085 mderef->op_next = index_skip == -1 ? o->op_next : o;
13087 /* excise and free the original tree, and replace with
13088 * the multideref op */
13089 p = op_sibling_splice(top_op, NULL, -1, mderef);
13098 Size_t size = arg - arg_buf;
13100 if (maybe_aelemfast && action_count == 1)
13103 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13104 sizeof(UNOP_AUX_item) * (size + 1));
13105 /* for dumping etc: store the length in a hidden first slot;
13106 * we set the op_aux pointer to the second slot */
13107 arg_buf->uv = size;
13110 } /* for (pass = ...) */
13115 /* mechanism for deferring recursion in rpeep() */
13117 #define MAX_DEFERRED 4
13121 if (defer_ix == (MAX_DEFERRED-1)) { \
13122 OP **defer = defer_queue[defer_base]; \
13123 CALL_RPEEP(*defer); \
13124 S_prune_chain_head(defer); \
13125 defer_base = (defer_base + 1) % MAX_DEFERRED; \
13128 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13131 #define IS_AND_OP(o) (o->op_type == OP_AND)
13132 #define IS_OR_OP(o) (o->op_type == OP_OR)
13135 /* A peephole optimizer. We visit the ops in the order they're to execute.
13136 * See the comments at the top of this file for more details about when
13137 * peep() is called */
13140 Perl_rpeep(pTHX_ OP *o)
13144 OP* oldoldop = NULL;
13145 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13146 int defer_base = 0;
13151 if (!o || o->op_opt)
13155 SAVEVPTR(PL_curcop);
13156 for (;; o = o->op_next) {
13157 if (o && o->op_opt)
13160 while (defer_ix >= 0) {
13162 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13163 CALL_RPEEP(*defer);
13164 S_prune_chain_head(defer);
13171 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13172 assert(!oldoldop || oldoldop->op_next == oldop);
13173 assert(!oldop || oldop->op_next == o);
13175 /* By default, this op has now been optimised. A couple of cases below
13176 clear this again. */
13180 /* look for a series of 1 or more aggregate derefs, e.g.
13181 * $a[1]{foo}[$i]{$k}
13182 * and replace with a single OP_MULTIDEREF op.
13183 * Each index must be either a const, or a simple variable,
13185 * First, look for likely combinations of starting ops,
13186 * corresponding to (global and lexical variants of)
13188 * $r->[...] $r->{...}
13189 * (preceding expression)->[...]
13190 * (preceding expression)->{...}
13191 * and if so, call maybe_multideref() to do a full inspection
13192 * of the op chain and if appropriate, replace with an
13200 switch (o2->op_type) {
13202 /* $pkg[..] : gv[*pkg]
13203 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
13205 /* Fail if there are new op flag combinations that we're
13206 * not aware of, rather than:
13207 * * silently failing to optimise, or
13208 * * silently optimising the flag away.
13209 * If this ASSUME starts failing, examine what new flag
13210 * has been added to the op, and decide whether the
13211 * optimisation should still occur with that flag, then
13212 * update the code accordingly. This applies to all the
13213 * other ASSUMEs in the block of code too.
13215 ASSUME(!(o2->op_flags &
13216 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13217 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13221 if (o2->op_type == OP_RV2AV) {
13222 action = MDEREF_AV_gvav_aelem;
13226 if (o2->op_type == OP_RV2HV) {
13227 action = MDEREF_HV_gvhv_helem;
13231 if (o2->op_type != OP_RV2SV)
13234 /* at this point we've seen gv,rv2sv, so the only valid
13235 * construct left is $pkg->[] or $pkg->{} */
13237 ASSUME(!(o2->op_flags & OPf_STACKED));
13238 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13239 != (OPf_WANT_SCALAR|OPf_MOD))
13242 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13243 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13244 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13246 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
13247 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13251 if (o2->op_type == OP_RV2AV) {
13252 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13255 if (o2->op_type == OP_RV2HV) {
13256 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13262 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13264 ASSUME(!(o2->op_flags &
13265 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13266 if ((o2->op_flags &
13267 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13268 != (OPf_WANT_SCALAR|OPf_MOD))
13271 ASSUME(!(o2->op_private &
13272 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13273 /* skip if state or intro, or not a deref */
13274 if ( o2->op_private != OPpDEREF_AV
13275 && o2->op_private != OPpDEREF_HV)
13279 if (o2->op_type == OP_RV2AV) {
13280 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13283 if (o2->op_type == OP_RV2HV) {
13284 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13291 /* $lex[..]: padav[@lex:1,2] sR *
13292 * or $lex{..}: padhv[%lex:1,2] sR */
13293 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13294 OPf_REF|OPf_SPECIAL)));
13295 if ((o2->op_flags &
13296 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13297 != (OPf_WANT_SCALAR|OPf_REF))
13299 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13301 /* OPf_PARENS isn't currently used in this case;
13302 * if that changes, let us know! */
13303 ASSUME(!(o2->op_flags & OPf_PARENS));
13305 /* at this point, we wouldn't expect any of the remaining
13306 * possible private flags:
13307 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13308 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13310 * OPpSLICEWARNING shouldn't affect runtime
13312 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13314 action = o2->op_type == OP_PADAV
13315 ? MDEREF_AV_padav_aelem
13316 : MDEREF_HV_padhv_helem;
13318 S_maybe_multideref(aTHX_ o, o2, action, 0);
13324 action = o2->op_type == OP_RV2AV
13325 ? MDEREF_AV_pop_rv2av_aelem
13326 : MDEREF_HV_pop_rv2hv_helem;
13329 /* (expr)->[...]: rv2av sKR/1;
13330 * (expr)->{...}: rv2hv sKR/1; */
13332 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13334 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13335 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13336 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13339 /* at this point, we wouldn't expect any of these
13340 * possible private flags:
13341 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13342 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13344 ASSUME(!(o2->op_private &
13345 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13347 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13351 S_maybe_multideref(aTHX_ o, o2, action, hints);
13360 switch (o->op_type) {
13362 PL_curcop = ((COP*)o); /* for warnings */
13365 PL_curcop = ((COP*)o); /* for warnings */
13367 /* Optimise a "return ..." at the end of a sub to just be "...".
13368 * This saves 2 ops. Before:
13369 * 1 <;> nextstate(main 1 -e:1) v ->2
13370 * 4 <@> return K ->5
13371 * 2 <0> pushmark s ->3
13372 * - <1> ex-rv2sv sK/1 ->4
13373 * 3 <#> gvsv[*cat] s ->4
13376 * - <@> return K ->-
13377 * - <0> pushmark s ->2
13378 * - <1> ex-rv2sv sK/1 ->-
13379 * 2 <$> gvsv(*cat) s ->3
13382 OP *next = o->op_next;
13383 OP *sibling = OpSIBLING(o);
13384 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13385 && OP_TYPE_IS(sibling, OP_RETURN)
13386 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13387 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13388 ||OP_TYPE_IS(sibling->op_next->op_next,
13390 && cUNOPx(sibling)->op_first == next
13391 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13394 /* Look through the PUSHMARK's siblings for one that
13395 * points to the RETURN */
13396 OP *top = OpSIBLING(next);
13397 while (top && top->op_next) {
13398 if (top->op_next == sibling) {
13399 top->op_next = sibling->op_next;
13400 o->op_next = next->op_next;
13403 top = OpSIBLING(top);
13408 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13410 * This latter form is then suitable for conversion into padrange
13411 * later on. Convert:
13413 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13417 * nextstate1 -> listop -> nextstate3
13419 * pushmark -> padop1 -> padop2
13421 if (o->op_next && (
13422 o->op_next->op_type == OP_PADSV
13423 || o->op_next->op_type == OP_PADAV
13424 || o->op_next->op_type == OP_PADHV
13426 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13427 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13428 && o->op_next->op_next->op_next && (
13429 o->op_next->op_next->op_next->op_type == OP_PADSV
13430 || o->op_next->op_next->op_next->op_type == OP_PADAV
13431 || o->op_next->op_next->op_next->op_type == OP_PADHV
13433 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13434 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13435 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13436 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13438 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13441 ns2 = pad1->op_next;
13442 pad2 = ns2->op_next;
13443 ns3 = pad2->op_next;
13445 /* we assume here that the op_next chain is the same as
13446 * the op_sibling chain */
13447 assert(OpSIBLING(o) == pad1);
13448 assert(OpSIBLING(pad1) == ns2);
13449 assert(OpSIBLING(ns2) == pad2);
13450 assert(OpSIBLING(pad2) == ns3);
13452 /* excise and delete ns2 */
13453 op_sibling_splice(NULL, pad1, 1, NULL);
13456 /* excise pad1 and pad2 */
13457 op_sibling_splice(NULL, o, 2, NULL);
13459 /* create new listop, with children consisting of:
13460 * a new pushmark, pad1, pad2. */
13461 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13462 newop->op_flags |= OPf_PARENS;
13463 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13465 /* insert newop between o and ns3 */
13466 op_sibling_splice(NULL, o, 0, newop);
13468 /*fixup op_next chain */
13469 newpm = cUNOPx(newop)->op_first; /* pushmark */
13470 o ->op_next = newpm;
13471 newpm->op_next = pad1;
13472 pad1 ->op_next = pad2;
13473 pad2 ->op_next = newop; /* listop */
13474 newop->op_next = ns3;
13476 /* Ensure pushmark has this flag if padops do */
13477 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13478 newpm->op_flags |= OPf_MOD;
13484 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13485 to carry two labels. For now, take the easier option, and skip
13486 this optimisation if the first NEXTSTATE has a label. */
13487 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13488 OP *nextop = o->op_next;
13489 while (nextop && nextop->op_type == OP_NULL)
13490 nextop = nextop->op_next;
13492 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13495 oldop->op_next = nextop;
13497 /* Skip (old)oldop assignment since the current oldop's
13498 op_next already points to the next op. */
13505 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13506 if (o->op_next->op_private & OPpTARGET_MY) {
13507 if (o->op_flags & OPf_STACKED) /* chained concats */
13508 break; /* ignore_optimization */
13510 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13511 o->op_targ = o->op_next->op_targ;
13512 o->op_next->op_targ = 0;
13513 o->op_private |= OPpTARGET_MY;
13516 op_null(o->op_next);
13520 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13521 break; /* Scalar stub must produce undef. List stub is noop */
13525 if (o->op_targ == OP_NEXTSTATE
13526 || o->op_targ == OP_DBSTATE)
13528 PL_curcop = ((COP*)o);
13530 /* XXX: We avoid setting op_seq here to prevent later calls
13531 to rpeep() from mistakenly concluding that optimisation
13532 has already occurred. This doesn't fix the real problem,
13533 though (See 20010220.007). AMS 20010719 */
13534 /* op_seq functionality is now replaced by op_opt */
13542 oldop->op_next = o->op_next;
13556 convert repeat into a stub with no kids.
13558 if (o->op_next->op_type == OP_CONST
13559 || ( o->op_next->op_type == OP_PADSV
13560 && !(o->op_next->op_private & OPpLVAL_INTRO))
13561 || ( o->op_next->op_type == OP_GV
13562 && o->op_next->op_next->op_type == OP_RV2SV
13563 && !(o->op_next->op_next->op_private
13564 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13566 const OP *kid = o->op_next->op_next;
13567 if (o->op_next->op_type == OP_GV)
13568 kid = kid->op_next;
13569 /* kid is now the ex-list. */
13570 if (kid->op_type == OP_NULL
13571 && (kid = kid->op_next)->op_type == OP_CONST
13572 /* kid is now the repeat count. */
13573 && kid->op_next->op_type == OP_REPEAT
13574 && kid->op_next->op_private & OPpREPEAT_DOLIST
13575 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13576 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13578 o = kid->op_next; /* repeat */
13580 oldop->op_next = o;
13581 op_free(cBINOPo->op_first);
13582 op_free(cBINOPo->op_last );
13583 o->op_flags &=~ OPf_KIDS;
13584 /* stub is a baseop; repeat is a binop */
13585 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13586 OpTYPE_set(o, OP_STUB);
13592 /* Convert a series of PAD ops for my vars plus support into a
13593 * single padrange op. Basically
13595 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13597 * becomes, depending on circumstances, one of
13599 * padrange ----------------------------------> (list) -> rest
13600 * padrange --------------------------------------------> rest
13602 * where all the pad indexes are sequential and of the same type
13604 * We convert the pushmark into a padrange op, then skip
13605 * any other pad ops, and possibly some trailing ops.
13606 * Note that we don't null() the skipped ops, to make it
13607 * easier for Deparse to undo this optimisation (and none of
13608 * the skipped ops are holding any resourses). It also makes
13609 * it easier for find_uninit_var(), as it can just ignore
13610 * padrange, and examine the original pad ops.
13614 OP *followop = NULL; /* the op that will follow the padrange op */
13617 PADOFFSET base = 0; /* init only to stop compiler whining */
13618 bool gvoid = 0; /* init only to stop compiler whining */
13619 bool defav = 0; /* seen (...) = @_ */
13620 bool reuse = 0; /* reuse an existing padrange op */
13622 /* look for a pushmark -> gv[_] -> rv2av */
13627 if ( p->op_type == OP_GV
13628 && cGVOPx_gv(p) == PL_defgv
13629 && (rv2av = p->op_next)
13630 && rv2av->op_type == OP_RV2AV
13631 && !(rv2av->op_flags & OPf_REF)
13632 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13633 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13635 q = rv2av->op_next;
13636 if (q->op_type == OP_NULL)
13638 if (q->op_type == OP_PUSHMARK) {
13648 /* scan for PAD ops */
13650 for (p = p->op_next; p; p = p->op_next) {
13651 if (p->op_type == OP_NULL)
13654 if (( p->op_type != OP_PADSV
13655 && p->op_type != OP_PADAV
13656 && p->op_type != OP_PADHV
13658 /* any private flag other than INTRO? e.g. STATE */
13659 || (p->op_private & ~OPpLVAL_INTRO)
13663 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13665 if ( p->op_type == OP_PADAV
13667 && p->op_next->op_type == OP_CONST
13668 && p->op_next->op_next
13669 && p->op_next->op_next->op_type == OP_AELEM
13673 /* for 1st padop, note what type it is and the range
13674 * start; for the others, check that it's the same type
13675 * and that the targs are contiguous */
13677 intro = (p->op_private & OPpLVAL_INTRO);
13679 gvoid = OP_GIMME(p,0) == G_VOID;
13682 if ((p->op_private & OPpLVAL_INTRO) != intro)
13684 /* Note that you'd normally expect targs to be
13685 * contiguous in my($a,$b,$c), but that's not the case
13686 * when external modules start doing things, e.g.
13687 * Function::Parameters */
13688 if (p->op_targ != base + count)
13690 assert(p->op_targ == base + count);
13691 /* Either all the padops or none of the padops should
13692 be in void context. Since we only do the optimisa-
13693 tion for av/hv when the aggregate itself is pushed
13694 on to the stack (one item), there is no need to dis-
13695 tinguish list from scalar context. */
13696 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13700 /* for AV, HV, only when we're not flattening */
13701 if ( p->op_type != OP_PADSV
13703 && !(p->op_flags & OPf_REF)
13707 if (count >= OPpPADRANGE_COUNTMASK)
13710 /* there's a biggest base we can fit into a
13711 * SAVEt_CLEARPADRANGE in pp_padrange.
13712 * (The sizeof() stuff will be constant-folded, and is
13713 * intended to avoid getting "comparison is always false"
13714 * compiler warnings. See the comments above
13715 * MEM_WRAP_CHECK for more explanation on why we do this
13716 * in a weird way to avoid compiler warnings.)
13719 && (8*sizeof(base) >
13720 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13722 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13724 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13728 /* Success! We've got another valid pad op to optimise away */
13730 followop = p->op_next;
13733 if (count < 1 || (count == 1 && !defav))
13736 /* pp_padrange in specifically compile-time void context
13737 * skips pushing a mark and lexicals; in all other contexts
13738 * (including unknown till runtime) it pushes a mark and the
13739 * lexicals. We must be very careful then, that the ops we
13740 * optimise away would have exactly the same effect as the
13742 * In particular in void context, we can only optimise to
13743 * a padrange if we see the complete sequence
13744 * pushmark, pad*v, ...., list
13745 * which has the net effect of leaving the markstack as it
13746 * was. Not pushing onto the stack (whereas padsv does touch
13747 * the stack) makes no difference in void context.
13751 if (followop->op_type == OP_LIST
13752 && OP_GIMME(followop,0) == G_VOID
13755 followop = followop->op_next; /* skip OP_LIST */
13757 /* consolidate two successive my(...);'s */
13760 && oldoldop->op_type == OP_PADRANGE
13761 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13762 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13763 && !(oldoldop->op_flags & OPf_SPECIAL)
13766 assert(oldoldop->op_next == oldop);
13767 assert( oldop->op_type == OP_NEXTSTATE
13768 || oldop->op_type == OP_DBSTATE);
13769 assert(oldop->op_next == o);
13772 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13774 /* Do not assume pad offsets for $c and $d are con-
13779 if ( oldoldop->op_targ + old_count == base
13780 && old_count < OPpPADRANGE_COUNTMASK - count) {
13781 base = oldoldop->op_targ;
13782 count += old_count;
13787 /* if there's any immediately following singleton
13788 * my var's; then swallow them and the associated
13790 * my ($a,$b); my $c; my $d;
13792 * my ($a,$b,$c,$d);
13795 while ( ((p = followop->op_next))
13796 && ( p->op_type == OP_PADSV
13797 || p->op_type == OP_PADAV
13798 || p->op_type == OP_PADHV)
13799 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13800 && (p->op_private & OPpLVAL_INTRO) == intro
13801 && !(p->op_private & ~OPpLVAL_INTRO)
13803 && ( p->op_next->op_type == OP_NEXTSTATE
13804 || p->op_next->op_type == OP_DBSTATE)
13805 && count < OPpPADRANGE_COUNTMASK
13806 && base + count == p->op_targ
13809 followop = p->op_next;
13817 assert(oldoldop->op_type == OP_PADRANGE);
13818 oldoldop->op_next = followop;
13819 oldoldop->op_private = (intro | count);
13825 /* Convert the pushmark into a padrange.
13826 * To make Deparse easier, we guarantee that a padrange was
13827 * *always* formerly a pushmark */
13828 assert(o->op_type == OP_PUSHMARK);
13829 o->op_next = followop;
13830 OpTYPE_set(o, OP_PADRANGE);
13832 /* bit 7: INTRO; bit 6..0: count */
13833 o->op_private = (intro | count);
13834 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13835 | gvoid * OPf_WANT_VOID
13836 | (defav ? OPf_SPECIAL : 0));
13844 /* Skip over state($x) in void context. */
13845 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13846 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13848 oldop->op_next = o->op_next;
13849 goto redo_nextstate;
13851 if (o->op_type != OP_PADAV)
13855 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13856 OP* const pop = (o->op_type == OP_PADAV) ?
13857 o->op_next : o->op_next->op_next;
13859 if (pop && pop->op_type == OP_CONST &&
13860 ((PL_op = pop->op_next)) &&
13861 pop->op_next->op_type == OP_AELEM &&
13862 !(pop->op_next->op_private &
13863 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13864 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13867 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13868 no_bareword_allowed(pop);
13869 if (o->op_type == OP_GV)
13870 op_null(o->op_next);
13871 op_null(pop->op_next);
13873 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13874 o->op_next = pop->op_next->op_next;
13875 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13876 o->op_private = (U8)i;
13877 if (o->op_type == OP_GV) {
13880 o->op_type = OP_AELEMFAST;
13883 o->op_type = OP_AELEMFAST_LEX;
13885 if (o->op_type != OP_GV)
13889 /* Remove $foo from the op_next chain in void context. */
13891 && ( o->op_next->op_type == OP_RV2SV
13892 || o->op_next->op_type == OP_RV2AV
13893 || o->op_next->op_type == OP_RV2HV )
13894 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13895 && !(o->op_next->op_private & OPpLVAL_INTRO))
13897 oldop->op_next = o->op_next->op_next;
13898 /* Reprocess the previous op if it is a nextstate, to
13899 allow double-nextstate optimisation. */
13901 if (oldop->op_type == OP_NEXTSTATE) {
13908 o = oldop->op_next;
13911 else if (o->op_next->op_type == OP_RV2SV) {
13912 if (!(o->op_next->op_private & OPpDEREF)) {
13913 op_null(o->op_next);
13914 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13916 o->op_next = o->op_next->op_next;
13917 OpTYPE_set(o, OP_GVSV);
13920 else if (o->op_next->op_type == OP_READLINE
13921 && o->op_next->op_next->op_type == OP_CONCAT
13922 && (o->op_next->op_next->op_flags & OPf_STACKED))
13924 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13925 OpTYPE_set(o, OP_RCATLINE);
13926 o->op_flags |= OPf_STACKED;
13927 op_null(o->op_next->op_next);
13928 op_null(o->op_next);
13933 #define HV_OR_SCALARHV(op) \
13934 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13936 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13937 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
13938 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
13939 ? cUNOPx(op)->op_first \
13943 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13944 fop->op_private |= OPpTRUEBOOL;
13950 fop = cLOGOP->op_first;
13951 sop = OpSIBLING(fop);
13952 while (cLOGOP->op_other->op_type == OP_NULL)
13953 cLOGOP->op_other = cLOGOP->op_other->op_next;
13954 while (o->op_next && ( o->op_type == o->op_next->op_type
13955 || o->op_next->op_type == OP_NULL))
13956 o->op_next = o->op_next->op_next;
13958 /* If we're an OR and our next is an AND in void context, we'll
13959 follow its op_other on short circuit, same for reverse.
13960 We can't do this with OP_DOR since if it's true, its return
13961 value is the underlying value which must be evaluated
13965 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13966 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13968 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13970 o->op_next = ((LOGOP*)o->op_next)->op_other;
13972 DEFER(cLOGOP->op_other);
13975 fop = HV_OR_SCALARHV(fop);
13976 if (sop) sop = HV_OR_SCALARHV(sop);
13981 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
13982 while (nop && nop->op_next) {
13983 switch (nop->op_next->op_type) {
13988 lop = nop = nop->op_next;
13991 nop = nop->op_next;
14000 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14001 || o->op_type == OP_AND )
14002 fop->op_private |= OPpTRUEBOOL;
14003 else if (!(lop->op_flags & OPf_WANT))
14004 fop->op_private |= OPpMAYBE_TRUEBOOL;
14006 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14008 sop->op_private |= OPpTRUEBOOL;
14015 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
14016 fop->op_private |= OPpTRUEBOOL;
14017 #undef HV_OR_SCALARHV
14018 /* GERONIMO! */ /* FALLTHROUGH */
14027 while (cLOGOP->op_other->op_type == OP_NULL)
14028 cLOGOP->op_other = cLOGOP->op_other->op_next;
14029 DEFER(cLOGOP->op_other);
14034 while (cLOOP->op_redoop->op_type == OP_NULL)
14035 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14036 while (cLOOP->op_nextop->op_type == OP_NULL)
14037 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14038 while (cLOOP->op_lastop->op_type == OP_NULL)
14039 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14040 /* a while(1) loop doesn't have an op_next that escapes the
14041 * loop, so we have to explicitly follow the op_lastop to
14042 * process the rest of the code */
14043 DEFER(cLOOP->op_lastop);
14047 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14048 DEFER(cLOGOPo->op_other);
14052 assert(!(cPMOP->op_pmflags & PMf_ONCE));
14053 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14054 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14055 cPMOP->op_pmstashstartu.op_pmreplstart
14056 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14057 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14063 if (o->op_flags & OPf_SPECIAL) {
14064 /* first arg is a code block */
14065 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14066 OP * kid = cUNOPx(nullop)->op_first;
14068 assert(nullop->op_type == OP_NULL);
14069 assert(kid->op_type == OP_SCOPE
14070 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14071 /* since OP_SORT doesn't have a handy op_other-style
14072 * field that can point directly to the start of the code
14073 * block, store it in the otherwise-unused op_next field
14074 * of the top-level OP_NULL. This will be quicker at
14075 * run-time, and it will also allow us to remove leading
14076 * OP_NULLs by just messing with op_nexts without
14077 * altering the basic op_first/op_sibling layout. */
14078 kid = kLISTOP->op_first;
14080 (kid->op_type == OP_NULL
14081 && ( kid->op_targ == OP_NEXTSTATE
14082 || kid->op_targ == OP_DBSTATE ))
14083 || kid->op_type == OP_STUB
14084 || kid->op_type == OP_ENTER);
14085 nullop->op_next = kLISTOP->op_next;
14086 DEFER(nullop->op_next);
14089 /* check that RHS of sort is a single plain array */
14090 oright = cUNOPo->op_first;
14091 if (!oright || oright->op_type != OP_PUSHMARK)
14094 if (o->op_private & OPpSORT_INPLACE)
14097 /* reverse sort ... can be optimised. */
14098 if (!OpHAS_SIBLING(cUNOPo)) {
14099 /* Nothing follows us on the list. */
14100 OP * const reverse = o->op_next;
14102 if (reverse->op_type == OP_REVERSE &&
14103 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14104 OP * const pushmark = cUNOPx(reverse)->op_first;
14105 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14106 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14107 /* reverse -> pushmark -> sort */
14108 o->op_private |= OPpSORT_REVERSE;
14110 pushmark->op_next = oright->op_next;
14120 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14122 LISTOP *enter, *exlist;
14124 if (o->op_private & OPpSORT_INPLACE)
14127 enter = (LISTOP *) o->op_next;
14130 if (enter->op_type == OP_NULL) {
14131 enter = (LISTOP *) enter->op_next;
14135 /* for $a (...) will have OP_GV then OP_RV2GV here.
14136 for (...) just has an OP_GV. */
14137 if (enter->op_type == OP_GV) {
14138 gvop = (OP *) enter;
14139 enter = (LISTOP *) enter->op_next;
14142 if (enter->op_type == OP_RV2GV) {
14143 enter = (LISTOP *) enter->op_next;
14149 if (enter->op_type != OP_ENTERITER)
14152 iter = enter->op_next;
14153 if (!iter || iter->op_type != OP_ITER)
14156 expushmark = enter->op_first;
14157 if (!expushmark || expushmark->op_type != OP_NULL
14158 || expushmark->op_targ != OP_PUSHMARK)
14161 exlist = (LISTOP *) OpSIBLING(expushmark);
14162 if (!exlist || exlist->op_type != OP_NULL
14163 || exlist->op_targ != OP_LIST)
14166 if (exlist->op_last != o) {
14167 /* Mmm. Was expecting to point back to this op. */
14170 theirmark = exlist->op_first;
14171 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14174 if (OpSIBLING(theirmark) != o) {
14175 /* There's something between the mark and the reverse, eg
14176 for (1, reverse (...))
14181 ourmark = ((LISTOP *)o)->op_first;
14182 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14185 ourlast = ((LISTOP *)o)->op_last;
14186 if (!ourlast || ourlast->op_next != o)
14189 rv2av = OpSIBLING(ourmark);
14190 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14191 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14192 /* We're just reversing a single array. */
14193 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14194 enter->op_flags |= OPf_STACKED;
14197 /* We don't have control over who points to theirmark, so sacrifice
14199 theirmark->op_next = ourmark->op_next;
14200 theirmark->op_flags = ourmark->op_flags;
14201 ourlast->op_next = gvop ? gvop : (OP *) enter;
14204 enter->op_private |= OPpITER_REVERSED;
14205 iter->op_private |= OPpITER_REVERSED;
14209 o = oldop->op_next;
14217 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14218 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14223 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14224 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14227 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14229 sv = newRV((SV *)PL_compcv);
14233 OpTYPE_set(o, OP_CONST);
14234 o->op_flags |= OPf_SPECIAL;
14235 cSVOPo->op_sv = sv;
14240 if (OP_GIMME(o,0) == G_VOID
14241 || ( o->op_next->op_type == OP_LINESEQ
14242 && ( o->op_next->op_next->op_type == OP_LEAVESUB
14243 || ( o->op_next->op_next->op_type == OP_RETURN
14244 && !CvLVALUE(PL_compcv)))))
14246 OP *right = cBINOP->op_first;
14265 OP *left = OpSIBLING(right);
14266 if (left->op_type == OP_SUBSTR
14267 && (left->op_private & 7) < 4) {
14269 /* cut out right */
14270 op_sibling_splice(o, NULL, 1, NULL);
14271 /* and insert it as second child of OP_SUBSTR */
14272 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14274 left->op_private |= OPpSUBSTR_REPL_FIRST;
14276 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14283 int l, r, lr, lscalars, rscalars;
14285 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14286 Note that we do this now rather than in newASSIGNOP(),
14287 since only by now are aliased lexicals flagged as such
14289 See the essay "Common vars in list assignment" above for
14290 the full details of the rationale behind all the conditions
14293 PL_generation sorcery:
14294 To detect whether there are common vars, the global var
14295 PL_generation is incremented for each assign op we scan.
14296 Then we run through all the lexical variables on the LHS,
14297 of the assignment, setting a spare slot in each of them to
14298 PL_generation. Then we scan the RHS, and if any lexicals
14299 already have that value, we know we've got commonality.
14300 Also, if the generation number is already set to
14301 PERL_INT_MAX, then the variable is involved in aliasing, so
14302 we also have potential commonality in that case.
14308 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
14311 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14315 /* After looking for things which are *always* safe, this main
14316 * if/else chain selects primarily based on the type of the
14317 * LHS, gradually working its way down from the more dangerous
14318 * to the more restrictive and thus safer cases */
14320 if ( !l /* () = ....; */
14321 || !r /* .... = (); */
14322 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14323 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14324 || (lscalars < 2) /* ($x, undef) = ... */
14326 NOOP; /* always safe */
14328 else if (l & AAS_DANGEROUS) {
14329 /* always dangerous */
14330 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14331 o->op_private |= OPpASSIGN_COMMON_AGG;
14333 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14334 /* package vars are always dangerous - too many
14335 * aliasing possibilities */
14336 if (l & AAS_PKG_SCALAR)
14337 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14338 if (l & AAS_PKG_AGG)
14339 o->op_private |= OPpASSIGN_COMMON_AGG;
14341 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14342 |AAS_LEX_SCALAR|AAS_LEX_AGG))
14344 /* LHS contains only lexicals and safe ops */
14346 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14347 o->op_private |= OPpASSIGN_COMMON_AGG;
14349 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14350 if (lr & AAS_LEX_SCALAR_COMM)
14351 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14352 else if ( !(l & AAS_LEX_SCALAR)
14353 && (r & AAS_DEFAV))
14357 * as scalar-safe for performance reasons.
14358 * (it will still have been marked _AGG if necessary */
14361 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14362 o->op_private |= OPpASSIGN_COMMON_RC1;
14367 * may have to handle aggregate on LHS, but we can't
14368 * have common scalars. */
14371 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14377 Perl_cpeep_t cpeep =
14378 XopENTRYCUSTOM(o, xop_peep);
14380 cpeep(aTHX_ o, oldop);
14385 /* did we just null the current op? If so, re-process it to handle
14386 * eliding "empty" ops from the chain */
14387 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14400 Perl_peep(pTHX_ OP *o)
14406 =head1 Custom Operators
14408 =for apidoc Ao||custom_op_xop
14409 Return the XOP structure for a given custom op. This macro should be
14410 considered internal to C<OP_NAME> and the other access macros: use them instead.
14411 This macro does call a function. Prior
14412 to 5.19.6, this was implemented as a
14419 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14425 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14427 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14428 assert(o->op_type == OP_CUSTOM);
14430 /* This is wrong. It assumes a function pointer can be cast to IV,
14431 * which isn't guaranteed, but this is what the old custom OP code
14432 * did. In principle it should be safer to Copy the bytes of the
14433 * pointer into a PV: since the new interface is hidden behind
14434 * functions, this can be changed later if necessary. */
14435 /* Change custom_op_xop if this ever happens */
14436 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14439 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14441 /* assume noone will have just registered a desc */
14442 if (!he && PL_custom_op_names &&
14443 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14448 /* XXX does all this need to be shared mem? */
14449 Newxz(xop, 1, XOP);
14450 pv = SvPV(HeVAL(he), l);
14451 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14452 if (PL_custom_op_descs &&
14453 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14455 pv = SvPV(HeVAL(he), l);
14456 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14458 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14462 xop = (XOP *)&xop_null;
14464 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14468 if(field == XOPe_xop_ptr) {
14471 const U32 flags = XopFLAGS(xop);
14472 if(flags & field) {
14474 case XOPe_xop_name:
14475 any.xop_name = xop->xop_name;
14477 case XOPe_xop_desc:
14478 any.xop_desc = xop->xop_desc;
14480 case XOPe_xop_class:
14481 any.xop_class = xop->xop_class;
14483 case XOPe_xop_peep:
14484 any.xop_peep = xop->xop_peep;
14487 NOT_REACHED; /* NOTREACHED */
14492 case XOPe_xop_name:
14493 any.xop_name = XOPd_xop_name;
14495 case XOPe_xop_desc:
14496 any.xop_desc = XOPd_xop_desc;
14498 case XOPe_xop_class:
14499 any.xop_class = XOPd_xop_class;
14501 case XOPe_xop_peep:
14502 any.xop_peep = XOPd_xop_peep;
14505 NOT_REACHED; /* NOTREACHED */
14510 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14511 * op.c: In function 'Perl_custom_op_get_field':
14512 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14513 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14514 * expands to assert(0), which expands to ((0) ? (void)0 :
14515 * __assert(...)), and gcc doesn't know that __assert can never return. */
14521 =for apidoc Ao||custom_op_register
14522 Register a custom op. See L<perlguts/"Custom Operators">.
14528 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14532 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14534 /* see the comment in custom_op_xop */
14535 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14537 if (!PL_custom_ops)
14538 PL_custom_ops = newHV();
14540 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14541 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14546 =for apidoc core_prototype
14548 This function assigns the prototype of the named core function to C<sv>, or
14549 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
14550 C<NULL> if the core function has no prototype. C<code> is a code as returned
14551 by C<keyword()>. It must not be equal to 0.
14557 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14560 int i = 0, n = 0, seen_question = 0, defgv = 0;
14562 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14563 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14564 bool nullret = FALSE;
14566 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14570 if (!sv) sv = sv_newmortal();
14572 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14574 switch (code < 0 ? -code : code) {
14575 case KEY_and : case KEY_chop: case KEY_chomp:
14576 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14577 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14578 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14579 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14580 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14581 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14582 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14583 case KEY_x : case KEY_xor :
14584 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14585 case KEY_glob: retsetpvs("_;", OP_GLOB);
14586 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
14587 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
14588 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
14589 case KEY_push: retsetpvs("\\@@", OP_PUSH);
14590 case KEY_unshift: retsetpvs("\\@@", OP_UNSHIFT);
14591 case KEY_pop: retsetpvs(";\\@", OP_POP);
14592 case KEY_shift: retsetpvs(";\\@", OP_SHIFT);
14593 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14595 retsetpvs("\\@;$$@", OP_SPLICE);
14596 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14598 case KEY_evalbytes:
14599 name = "entereval"; break;
14607 while (i < MAXO) { /* The slow way. */
14608 if (strEQ(name, PL_op_name[i])
14609 || strEQ(name, PL_op_desc[i]))
14611 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14618 defgv = PL_opargs[i] & OA_DEFGV;
14619 oa = PL_opargs[i] >> OASHIFT;
14621 if (oa & OA_OPTIONAL && !seen_question && (
14622 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14627 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14628 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14629 /* But globs are already references (kinda) */
14630 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14634 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14635 && !scalar_mod_type(NULL, i)) {
14640 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14644 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14645 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14646 str[n-1] = '_'; defgv = 0;
14650 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14652 sv_setpvn(sv, str, n - 1);
14653 if (opnum) *opnum = i;
14658 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14661 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14664 PERL_ARGS_ASSERT_CORESUB_OP;
14668 return op_append_elem(OP_LINESEQ,
14671 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14675 case OP_SELECT: /* which represents OP_SSELECT as well */
14680 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14681 newSVOP(OP_CONST, 0, newSVuv(1))
14683 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14685 coresub_op(coreargssv, 0, OP_SELECT)
14689 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14691 return op_append_elem(
14694 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14695 ? OPpOFFBYONE << 8 : 0)
14697 case OA_BASEOP_OR_UNOP:
14698 if (opnum == OP_ENTEREVAL) {
14699 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14700 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14702 else o = newUNOP(opnum,0,argop);
14703 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14706 if (is_handle_constructor(o, 1))
14707 argop->op_private |= OPpCOREARGS_DEREF1;
14708 if (scalar_mod_type(NULL, opnum))
14709 argop->op_private |= OPpCOREARGS_SCALARMOD;
14713 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14714 if (is_handle_constructor(o, 2))
14715 argop->op_private |= OPpCOREARGS_DEREF2;
14716 if (opnum == OP_SUBSTR) {
14717 o->op_private |= OPpMAYBE_LVSUB;
14726 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14727 SV * const *new_const_svp)
14729 const char *hvname;
14730 bool is_const = !!CvCONST(old_cv);
14731 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14733 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14735 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14737 /* They are 2 constant subroutines generated from
14738 the same constant. This probably means that
14739 they are really the "same" proxy subroutine
14740 instantiated in 2 places. Most likely this is
14741 when a constant is exported twice. Don't warn.
14744 (ckWARN(WARN_REDEFINE)
14746 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14747 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14748 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14749 strEQ(hvname, "autouse"))
14753 && ckWARN_d(WARN_REDEFINE)
14754 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14757 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14759 ? "Constant subroutine %"SVf" redefined"
14760 : "Subroutine %"SVf" redefined",
14765 =head1 Hook manipulation
14767 These functions provide convenient and thread-safe means of manipulating
14774 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14776 Puts a C function into the chain of check functions for a specified op
14777 type. This is the preferred way to manipulate the L</PL_check> array.
14778 C<opcode> specifies which type of op is to be affected. C<new_checker>
14779 is a pointer to the C function that is to be added to that opcode's
14780 check chain, and C<old_checker_p> points to the storage location where a
14781 pointer to the next function in the chain will be stored. The value of
14782 C<new_pointer> is written into the L</PL_check> array, while the value
14783 previously stored there is written to C<*old_checker_p>.
14785 The function should be defined like this:
14787 static OP *new_checker(pTHX_ OP *op) { ... }
14789 It is intended to be called in this manner:
14791 new_checker(aTHX_ op)
14793 C<old_checker_p> should be defined like this:
14795 static Perl_check_t old_checker_p;
14797 L</PL_check> is global to an entire process, and a module wishing to
14798 hook op checking may find itself invoked more than once per process,
14799 typically in different threads. To handle that situation, this function
14800 is idempotent. The location C<*old_checker_p> must initially (once
14801 per process) contain a null pointer. A C variable of static duration
14802 (declared at file scope, typically also marked C<static> to give
14803 it internal linkage) will be implicitly initialised appropriately,
14804 if it does not have an explicit initialiser. This function will only
14805 actually modify the check chain if it finds C<*old_checker_p> to be null.
14806 This function is also thread safe on the small scale. It uses appropriate
14807 locking to avoid race conditions in accessing L</PL_check>.
14809 When this function is called, the function referenced by C<new_checker>
14810 must be ready to be called, except for C<*old_checker_p> being unfilled.
14811 In a threading situation, C<new_checker> may be called immediately,
14812 even before this function has returned. C<*old_checker_p> will always
14813 be appropriately set before C<new_checker> is called. If C<new_checker>
14814 decides not to do anything special with an op that it is given (which
14815 is the usual case for most uses of op check hooking), it must chain the
14816 check function referenced by C<*old_checker_p>.
14818 If you want to influence compilation of calls to a specific subroutine,
14819 then use L</cv_set_call_checker> rather than hooking checking of all
14826 Perl_wrap_op_checker(pTHX_ Optype opcode,
14827 Perl_check_t new_checker, Perl_check_t *old_checker_p)
14831 PERL_UNUSED_CONTEXT;
14832 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14833 if (*old_checker_p) return;
14834 OP_CHECK_MUTEX_LOCK;
14835 if (!*old_checker_p) {
14836 *old_checker_p = PL_check[opcode];
14837 PL_check[opcode] = new_checker;
14839 OP_CHECK_MUTEX_UNLOCK;
14844 /* Efficient sub that returns a constant scalar value. */
14846 const_sv_xsub(pTHX_ CV* cv)
14849 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14850 PERL_UNUSED_ARG(items);
14860 const_av_xsub(pTHX_ CV* cv)
14863 AV * const av = MUTABLE_AV(XSANY.any_ptr);
14871 if (SvRMAGICAL(av))
14872 Perl_croak(aTHX_ "Magical list constants are not supported");
14873 if (GIMME_V != G_ARRAY) {
14875 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14878 EXTEND(SP, AvFILLp(av)+1);
14879 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14880 XSRETURN(AvFILLp(av)+1);
14884 * ex: set ts=8 sts=4 sw=4 et: