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;
2981 if (type == OP_LEAVESUBLV)
2982 o->op_private |= OPpMAYBE_LVSUB;
2985 PL_hints |= HINT_BLOCK_SCOPE;
2986 if (type == OP_LEAVESUBLV)
2987 o->op_private |= OPpMAYBE_LVSUB;
2991 ref(cUNOPo->op_first, o->op_type);
2995 PL_hints |= HINT_BLOCK_SCOPE;
3005 case OP_AELEMFAST_LEX:
3012 PL_modcount = RETURN_UNLIMITED_NUMBER;
3013 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3014 return o; /* Treat \(@foo) like ordinary list. */
3015 if (scalar_mod_type(o, type))
3017 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3018 && type == OP_LEAVESUBLV)
3019 o->op_private |= OPpMAYBE_LVSUB;
3023 if (!type) /* local() */
3024 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3025 PNfARG(PAD_COMPNAME(o->op_targ)));
3026 if (!(o->op_private & OPpLVAL_INTRO)
3027 || ( type != OP_SASSIGN && type != OP_AASSIGN
3028 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3029 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3037 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
3041 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3047 if (type == OP_LEAVESUBLV)
3048 o->op_private |= OPpMAYBE_LVSUB;
3049 if (o->op_flags & OPf_KIDS)
3050 op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3055 ref(cBINOPo->op_first, o->op_type);
3056 if (type == OP_ENTERSUB &&
3057 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3058 o->op_private |= OPpLVAL_DEFER;
3059 if (type == OP_LEAVESUBLV)
3060 o->op_private |= OPpMAYBE_LVSUB;
3067 o->op_private |= OPpLVALUE;
3073 if (o->op_flags & OPf_KIDS)
3074 op_lvalue(cLISTOPo->op_last, type);
3079 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3081 else if (!(o->op_flags & OPf_KIDS))
3083 if (o->op_targ != OP_LIST) {
3084 op_lvalue(cBINOPo->op_first, type);
3090 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3091 /* elements might be in void context because the list is
3092 in scalar context or because they are attribute sub calls */
3093 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3094 op_lvalue(kid, type);
3102 if (type == OP_LEAVESUBLV
3103 || !S_vivifies(cLOGOPo->op_first->op_type))
3104 op_lvalue(cLOGOPo->op_first, type);
3105 if (type == OP_LEAVESUBLV
3106 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3107 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3111 if (type != OP_AASSIGN && type != OP_SASSIGN
3112 && type != OP_ENTERLOOP)
3114 /* Don’t bother applying lvalue context to the ex-list. */
3115 kid = cUNOPx(cUNOPo->op_first)->op_first;
3116 assert (!OpHAS_SIBLING(kid));
3119 if (type != OP_AASSIGN) goto nomod;
3120 kid = cUNOPo->op_first;
3123 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3124 S_lvref(aTHX_ kid, type);
3125 if (!PL_parser || PL_parser->error_count == ec) {
3126 if (!FEATURE_REFALIASING_IS_ENABLED)
3128 "Experimental aliasing via reference not enabled");
3129 Perl_ck_warner_d(aTHX_
3130 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3131 "Aliasing via reference is experimental");
3134 if (o->op_type == OP_REFGEN)
3135 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3140 kid = cLISTOPo->op_first;
3141 if (kid && kid->op_type == OP_PUSHRE &&
3143 || o->op_flags & OPf_STACKED
3145 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3147 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3150 /* This is actually @array = split. */
3151 PL_modcount = RETURN_UNLIMITED_NUMBER;
3157 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3161 /* [20011101.069] File test operators interpret OPf_REF to mean that
3162 their argument is a filehandle; thus \stat(".") should not set
3164 if (type == OP_REFGEN &&
3165 PL_check[o->op_type] == Perl_ck_ftst)
3168 if (type != OP_LEAVESUBLV)
3169 o->op_flags |= OPf_MOD;
3171 if (type == OP_AASSIGN || type == OP_SASSIGN)
3172 o->op_flags |= OPf_SPECIAL|OPf_REF;
3173 else if (!type) { /* local() */
3176 o->op_private |= OPpLVAL_INTRO;
3177 o->op_flags &= ~OPf_SPECIAL;
3178 PL_hints |= HINT_BLOCK_SCOPE;
3183 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3184 "Useless localization of %s", OP_DESC(o));
3187 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3188 && type != OP_LEAVESUBLV)
3189 o->op_flags |= OPf_REF;
3194 S_scalar_mod_type(const OP *o, I32 type)
3199 if (o && o->op_type == OP_RV2GV)
3223 case OP_RIGHT_SHIFT:
3244 S_is_handle_constructor(const OP *o, I32 numargs)
3246 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3248 switch (o->op_type) {
3256 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3269 S_refkids(pTHX_ OP *o, I32 type)
3271 if (o && o->op_flags & OPf_KIDS) {
3273 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3280 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3285 PERL_ARGS_ASSERT_DOREF;
3287 if (PL_parser && PL_parser->error_count)
3290 switch (o->op_type) {
3292 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3293 !(o->op_flags & OPf_STACKED)) {
3294 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3295 assert(cUNOPo->op_first->op_type == OP_NULL);
3296 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3297 o->op_flags |= OPf_SPECIAL;
3299 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3300 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3301 : type == OP_RV2HV ? OPpDEREF_HV
3303 o->op_flags |= OPf_MOD;
3309 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3310 doref(kid, type, set_op_ref);
3313 if (type == OP_DEFINED)
3314 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3315 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3318 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3319 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3320 : type == OP_RV2HV ? OPpDEREF_HV
3322 o->op_flags |= OPf_MOD;
3329 o->op_flags |= OPf_REF;
3332 if (type == OP_DEFINED)
3333 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3334 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3340 o->op_flags |= OPf_REF;
3345 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3347 doref(cBINOPo->op_first, type, set_op_ref);
3351 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3352 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3353 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3354 : type == OP_RV2HV ? OPpDEREF_HV
3356 o->op_flags |= OPf_MOD;
3366 if (!(o->op_flags & OPf_KIDS))
3368 doref(cLISTOPo->op_last, type, set_op_ref);
3378 S_dup_attrlist(pTHX_ OP *o)
3382 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3384 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3385 * where the first kid is OP_PUSHMARK and the remaining ones
3386 * are OP_CONST. We need to push the OP_CONST values.
3388 if (o->op_type == OP_CONST)
3389 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3391 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3393 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3394 if (o->op_type == OP_CONST)
3395 rop = op_append_elem(OP_LIST, rop,
3396 newSVOP(OP_CONST, o->op_flags,
3397 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3404 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3406 PERL_ARGS_ASSERT_APPLY_ATTRS;
3408 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3410 /* fake up C<use attributes $pkg,$rv,@attrs> */
3412 #define ATTRSMODULE "attributes"
3413 #define ATTRSMODULE_PM "attributes.pm"
3416 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3417 newSVpvs(ATTRSMODULE),
3419 op_prepend_elem(OP_LIST,
3420 newSVOP(OP_CONST, 0, stashsv),
3421 op_prepend_elem(OP_LIST,
3422 newSVOP(OP_CONST, 0,
3424 dup_attrlist(attrs))));
3429 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3431 OP *pack, *imop, *arg;
3432 SV *meth, *stashsv, **svp;
3434 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3439 assert(target->op_type == OP_PADSV ||
3440 target->op_type == OP_PADHV ||
3441 target->op_type == OP_PADAV);
3443 /* Ensure that attributes.pm is loaded. */
3444 /* Don't force the C<use> if we don't need it. */
3445 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3446 if (svp && *svp != &PL_sv_undef)
3447 NOOP; /* already in %INC */
3449 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3450 newSVpvs(ATTRSMODULE), NULL);
3452 /* Need package name for method call. */
3453 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3455 /* Build up the real arg-list. */
3456 stashsv = newSVhek(HvNAME_HEK(stash));
3458 arg = newOP(OP_PADSV, 0);
3459 arg->op_targ = target->op_targ;
3460 arg = op_prepend_elem(OP_LIST,
3461 newSVOP(OP_CONST, 0, stashsv),
3462 op_prepend_elem(OP_LIST,
3463 newUNOP(OP_REFGEN, 0,
3465 dup_attrlist(attrs)));
3467 /* Fake up a method call to import */
3468 meth = newSVpvs_share("import");
3469 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3470 op_append_elem(OP_LIST,
3471 op_prepend_elem(OP_LIST, pack, arg),
3472 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3474 /* Combine the ops. */
3475 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3479 =notfor apidoc apply_attrs_string
3481 Attempts to apply a list of attributes specified by the C<attrstr> and
3482 C<len> arguments to the subroutine identified by the C<cv> argument which
3483 is expected to be associated with the package identified by the C<stashpv>
3484 argument (see L<attributes>). It gets this wrong, though, in that it
3485 does not correctly identify the boundaries of the individual attribute
3486 specifications within C<attrstr>. This is not really intended for the
3487 public API, but has to be listed here for systems such as AIX which
3488 need an explicit export list for symbols. (It's called from XS code
3489 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3490 to respect attribute syntax properly would be welcome.
3496 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3497 const char *attrstr, STRLEN len)
3501 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3504 len = strlen(attrstr);
3508 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3510 const char * const sstr = attrstr;
3511 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3512 attrs = op_append_elem(OP_LIST, attrs,
3513 newSVOP(OP_CONST, 0,
3514 newSVpvn(sstr, attrstr-sstr)));
3518 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3519 newSVpvs(ATTRSMODULE),
3520 NULL, op_prepend_elem(OP_LIST,
3521 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3522 op_prepend_elem(OP_LIST,
3523 newSVOP(OP_CONST, 0,
3524 newRV(MUTABLE_SV(cv))),
3529 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3531 OP *new_proto = NULL;
3536 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3542 if (o->op_type == OP_CONST) {
3543 pv = SvPV(cSVOPo_sv, pvlen);
3544 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3545 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3546 SV ** const tmpo = cSVOPx_svp(o);
3547 SvREFCNT_dec(cSVOPo_sv);
3552 } else if (o->op_type == OP_LIST) {
3554 assert(o->op_flags & OPf_KIDS);
3555 lasto = cLISTOPo->op_first;
3556 assert(lasto->op_type == OP_PUSHMARK);
3557 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3558 if (o->op_type == OP_CONST) {
3559 pv = SvPV(cSVOPo_sv, pvlen);
3560 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3561 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3562 SV ** const tmpo = cSVOPx_svp(o);
3563 SvREFCNT_dec(cSVOPo_sv);
3565 if (new_proto && ckWARN(WARN_MISC)) {
3567 const char * newp = SvPV(cSVOPo_sv, new_len);
3568 Perl_warner(aTHX_ packWARN(WARN_MISC),
3569 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3570 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3576 /* excise new_proto from the list */
3577 op_sibling_splice(*attrs, lasto, 1, NULL);
3584 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3585 would get pulled in with no real need */
3586 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3595 svname = sv_newmortal();
3596 gv_efullname3(svname, name, NULL);
3598 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3599 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3601 svname = (SV *)name;
3602 if (ckWARN(WARN_ILLEGALPROTO))
3603 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3604 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3605 STRLEN old_len, new_len;
3606 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3607 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3609 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3610 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3612 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3613 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3623 S_cant_declare(pTHX_ OP *o)
3625 if (o->op_type == OP_NULL
3626 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3627 o = cUNOPo->op_first;
3628 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3629 o->op_type == OP_NULL
3630 && o->op_flags & OPf_SPECIAL
3633 PL_parser->in_my == KEY_our ? "our" :
3634 PL_parser->in_my == KEY_state ? "state" :
3639 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3642 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3644 PERL_ARGS_ASSERT_MY_KID;
3646 if (!o || (PL_parser && PL_parser->error_count))
3651 if (type == OP_LIST) {
3653 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3654 my_kid(kid, attrs, imopsp);
3656 } else if (type == OP_UNDEF || type == OP_STUB) {
3658 } else if (type == OP_RV2SV || /* "our" declaration */
3660 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3661 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3662 S_cant_declare(aTHX_ o);
3664 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3666 PL_parser->in_my = FALSE;
3667 PL_parser->in_my_stash = NULL;
3668 apply_attrs(GvSTASH(gv),
3669 (type == OP_RV2SV ? GvSV(gv) :
3670 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3671 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3674 o->op_private |= OPpOUR_INTRO;
3677 else if (type != OP_PADSV &&
3680 type != OP_PUSHMARK)
3682 S_cant_declare(aTHX_ o);
3685 else if (attrs && type != OP_PUSHMARK) {
3689 PL_parser->in_my = FALSE;
3690 PL_parser->in_my_stash = NULL;
3692 /* check for C<my Dog $spot> when deciding package */
3693 stash = PAD_COMPNAME_TYPE(o->op_targ);
3695 stash = PL_curstash;
3696 apply_attrs_my(stash, o, attrs, imopsp);
3698 o->op_flags |= OPf_MOD;
3699 o->op_private |= OPpLVAL_INTRO;
3701 o->op_private |= OPpPAD_STATE;
3706 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3709 int maybe_scalar = 0;
3711 PERL_ARGS_ASSERT_MY_ATTRS;
3713 /* [perl #17376]: this appears to be premature, and results in code such as
3714 C< our(%x); > executing in list mode rather than void mode */
3716 if (o->op_flags & OPf_PARENS)
3726 o = my_kid(o, attrs, &rops);
3728 if (maybe_scalar && o->op_type == OP_PADSV) {
3729 o = scalar(op_append_list(OP_LIST, rops, o));
3730 o->op_private |= OPpLVAL_INTRO;
3733 /* The listop in rops might have a pushmark at the beginning,
3734 which will mess up list assignment. */
3735 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3736 if (rops->op_type == OP_LIST &&
3737 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3739 OP * const pushmark = lrops->op_first;
3740 /* excise pushmark */
3741 op_sibling_splice(rops, NULL, 1, NULL);
3744 o = op_append_list(OP_LIST, o, rops);
3747 PL_parser->in_my = FALSE;
3748 PL_parser->in_my_stash = NULL;
3753 Perl_sawparens(pTHX_ OP *o)
3755 PERL_UNUSED_CONTEXT;
3757 o->op_flags |= OPf_PARENS;
3762 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3766 const OPCODE ltype = left->op_type;
3767 const OPCODE rtype = right->op_type;
3769 PERL_ARGS_ASSERT_BIND_MATCH;
3771 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3772 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3774 const char * const desc
3776 rtype == OP_SUBST || rtype == OP_TRANS
3777 || rtype == OP_TRANSR
3779 ? (int)rtype : OP_MATCH];
3780 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3782 S_op_varname(aTHX_ left);
3784 Perl_warner(aTHX_ packWARN(WARN_MISC),
3785 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3786 desc, SVfARG(name), SVfARG(name));
3788 const char * const sample = (isary
3789 ? "@array" : "%hash");
3790 Perl_warner(aTHX_ packWARN(WARN_MISC),
3791 "Applying %s to %s will act on scalar(%s)",
3792 desc, sample, sample);
3796 if (rtype == OP_CONST &&
3797 cSVOPx(right)->op_private & OPpCONST_BARE &&
3798 cSVOPx(right)->op_private & OPpCONST_STRICT)
3800 no_bareword_allowed(right);
3803 /* !~ doesn't make sense with /r, so error on it for now */
3804 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3806 /* diag_listed_as: Using !~ with %s doesn't make sense */
3807 yyerror("Using !~ with s///r doesn't make sense");
3808 if (rtype == OP_TRANSR && type == OP_NOT)
3809 /* diag_listed_as: Using !~ with %s doesn't make sense */
3810 yyerror("Using !~ with tr///r doesn't make sense");
3812 ismatchop = (rtype == OP_MATCH ||
3813 rtype == OP_SUBST ||
3814 rtype == OP_TRANS || rtype == OP_TRANSR)
3815 && !(right->op_flags & OPf_SPECIAL);
3816 if (ismatchop && right->op_private & OPpTARGET_MY) {
3818 right->op_private &= ~OPpTARGET_MY;
3820 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3821 if (left->op_type == OP_PADSV
3822 && !(left->op_private & OPpLVAL_INTRO))
3824 right->op_targ = left->op_targ;
3829 right->op_flags |= OPf_STACKED;
3830 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3831 ! (rtype == OP_TRANS &&
3832 right->op_private & OPpTRANS_IDENTICAL) &&
3833 ! (rtype == OP_SUBST &&
3834 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3835 left = op_lvalue(left, rtype);
3836 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3837 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3839 o = op_prepend_elem(rtype, scalar(left), right);
3842 return newUNOP(OP_NOT, 0, scalar(o));
3846 return bind_match(type, left,
3847 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3851 Perl_invert(pTHX_ OP *o)
3855 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3859 =for apidoc Amx|OP *|op_scope|OP *o
3861 Wraps up an op tree with some additional ops so that at runtime a dynamic
3862 scope will be created. The original ops run in the new dynamic scope,
3863 and then, provided that they exit normally, the scope will be unwound.
3864 The additional ops used to create and unwind the dynamic scope will
3865 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3866 instead if the ops are simple enough to not need the full dynamic scope
3873 Perl_op_scope(pTHX_ OP *o)
3877 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3878 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3879 OpTYPE_set(o, OP_LEAVE);
3881 else if (o->op_type == OP_LINESEQ) {
3883 OpTYPE_set(o, OP_SCOPE);
3884 kid = ((LISTOP*)o)->op_first;
3885 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3888 /* The following deals with things like 'do {1 for 1}' */
3889 kid = OpSIBLING(kid);
3891 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3896 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3902 Perl_op_unscope(pTHX_ OP *o)
3904 if (o && o->op_type == OP_LINESEQ) {
3905 OP *kid = cLISTOPo->op_first;
3906 for(; kid; kid = OpSIBLING(kid))
3907 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3914 =for apidoc Am|int|block_start|int full
3916 Handles compile-time scope entry.
3917 Arranges for hints to be restored on block
3918 exit and also handles pad sequence numbers to make lexical variables scope
3919 right. Returns a savestack index for use with C<block_end>.
3925 Perl_block_start(pTHX_ int full)
3927 const int retval = PL_savestack_ix;
3929 PL_compiling.cop_seq = PL_cop_seqmax;
3931 pad_block_start(full);
3933 PL_hints &= ~HINT_BLOCK_SCOPE;
3934 SAVECOMPILEWARNINGS();
3935 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3936 SAVEI32(PL_compiling.cop_seq);
3937 PL_compiling.cop_seq = 0;
3939 CALL_BLOCK_HOOKS(bhk_start, full);
3945 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3947 Handles compile-time scope exit. C<floor>
3948 is the savestack index returned by
3949 C<block_start>, and C<seq> is the body of the block. Returns the block,
3956 Perl_block_end(pTHX_ I32 floor, OP *seq)
3958 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3959 OP* retval = scalarseq(seq);
3962 /* XXX Is the null PL_parser check necessary here? */
3963 assert(PL_parser); /* Let’s find out under debugging builds. */
3964 if (PL_parser && PL_parser->parsed_sub) {
3965 o = newSTATEOP(0, NULL, NULL);
3967 retval = op_append_elem(OP_LINESEQ, retval, o);
3970 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3974 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3978 /* pad_leavemy has created a sequence of introcv ops for all my
3979 subs declared in the block. We have to replicate that list with
3980 clonecv ops, to deal with this situation:
3985 sub s1 { state sub foo { \&s2 } }
3988 Originally, I was going to have introcv clone the CV and turn
3989 off the stale flag. Since &s1 is declared before &s2, the
3990 introcv op for &s1 is executed (on sub entry) before the one for
3991 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3992 cloned, since it is a state sub) closes over &s2 and expects
3993 to see it in its outer CV’s pad. If the introcv op clones &s1,
3994 then &s2 is still marked stale. Since &s1 is not active, and
3995 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3996 ble will not stay shared’ warning. Because it is the same stub
3997 that will be used when the introcv op for &s2 is executed, clos-
3998 ing over it is safe. Hence, we have to turn off the stale flag
3999 on all lexical subs in the block before we clone any of them.
4000 Hence, having introcv clone the sub cannot work. So we create a
4001 list of ops like this:
4025 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4026 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4027 for (;; kid = OpSIBLING(kid)) {
4028 OP *newkid = newOP(OP_CLONECV, 0);
4029 newkid->op_targ = kid->op_targ;
4030 o = op_append_elem(OP_LINESEQ, o, newkid);
4031 if (kid == last) break;
4033 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4036 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4042 =head1 Compile-time scope hooks
4044 =for apidoc Aox||blockhook_register
4046 Register a set of hooks to be called when the Perl lexical scope changes
4047 at compile time. See L<perlguts/"Compile-time scope hooks">.
4053 Perl_blockhook_register(pTHX_ BHK *hk)
4055 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4057 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4061 Perl_newPROG(pTHX_ OP *o)
4063 PERL_ARGS_ASSERT_NEWPROG;
4070 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4071 ((PL_in_eval & EVAL_KEEPERR)
4072 ? OPf_SPECIAL : 0), o);
4075 assert(CxTYPE(cx) == CXt_EVAL);
4077 if ((cx->blk_gimme & G_WANT) == G_VOID)
4078 scalarvoid(PL_eval_root);
4079 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4082 scalar(PL_eval_root);
4084 PL_eval_start = op_linklist(PL_eval_root);
4085 PL_eval_root->op_private |= OPpREFCOUNTED;
4086 OpREFCNT_set(PL_eval_root, 1);
4087 PL_eval_root->op_next = 0;
4088 i = PL_savestack_ix;
4091 CALL_PEEP(PL_eval_start);
4092 finalize_optree(PL_eval_root);
4093 S_prune_chain_head(&PL_eval_start);
4095 PL_savestack_ix = i;
4098 if (o->op_type == OP_STUB) {
4099 /* This block is entered if nothing is compiled for the main
4100 program. This will be the case for an genuinely empty main
4101 program, or one which only has BEGIN blocks etc, so already
4104 Historically (5.000) the guard above was !o. However, commit
4105 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4106 c71fccf11fde0068, changed perly.y so that newPROG() is now
4107 called with the output of block_end(), which returns a new
4108 OP_STUB for the case of an empty optree. ByteLoader (and
4109 maybe other things) also take this path, because they set up
4110 PL_main_start and PL_main_root directly, without generating an
4113 If the parsing the main program aborts (due to parse errors,
4114 or due to BEGIN or similar calling exit), then newPROG()
4115 isn't even called, and hence this code path and its cleanups
4116 are skipped. This shouldn't make a make a difference:
4117 * a non-zero return from perl_parse is a failure, and
4118 perl_destruct() should be called immediately.
4119 * however, if exit(0) is called during the parse, then
4120 perl_parse() returns 0, and perl_run() is called. As
4121 PL_main_start will be NULL, perl_run() will return
4122 promptly, and the exit code will remain 0.
4125 PL_comppad_name = 0;
4127 S_op_destroy(aTHX_ o);
4130 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4131 PL_curcop = &PL_compiling;
4132 PL_main_start = LINKLIST(PL_main_root);
4133 PL_main_root->op_private |= OPpREFCOUNTED;
4134 OpREFCNT_set(PL_main_root, 1);
4135 PL_main_root->op_next = 0;
4136 CALL_PEEP(PL_main_start);
4137 finalize_optree(PL_main_root);
4138 S_prune_chain_head(&PL_main_start);
4139 cv_forget_slab(PL_compcv);
4142 /* Register with debugger */
4144 CV * const cv = get_cvs("DB::postponed", 0);
4148 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4150 call_sv(MUTABLE_SV(cv), G_DISCARD);
4157 Perl_localize(pTHX_ OP *o, I32 lex)
4159 PERL_ARGS_ASSERT_LOCALIZE;
4161 if (o->op_flags & OPf_PARENS)
4162 /* [perl #17376]: this appears to be premature, and results in code such as
4163 C< our(%x); > executing in list mode rather than void mode */
4170 if ( PL_parser->bufptr > PL_parser->oldbufptr
4171 && PL_parser->bufptr[-1] == ','
4172 && ckWARN(WARN_PARENTHESIS))
4174 char *s = PL_parser->bufptr;
4177 /* some heuristics to detect a potential error */
4178 while (*s && (strchr(", \t\n", *s)))
4182 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4184 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4187 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4189 while (*s && (strchr(", \t\n", *s)))
4195 if (sigil && (*s == ';' || *s == '=')) {
4196 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4197 "Parentheses missing around \"%s\" list",
4199 ? (PL_parser->in_my == KEY_our
4201 : PL_parser->in_my == KEY_state
4211 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4212 PL_parser->in_my = FALSE;
4213 PL_parser->in_my_stash = NULL;
4218 Perl_jmaybe(pTHX_ OP *o)
4220 PERL_ARGS_ASSERT_JMAYBE;
4222 if (o->op_type == OP_LIST) {
4224 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4225 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4230 PERL_STATIC_INLINE OP *
4231 S_op_std_init(pTHX_ OP *o)
4233 I32 type = o->op_type;
4235 PERL_ARGS_ASSERT_OP_STD_INIT;
4237 if (PL_opargs[type] & OA_RETSCALAR)
4239 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4240 o->op_targ = pad_alloc(type, SVs_PADTMP);
4245 PERL_STATIC_INLINE OP *
4246 S_op_integerize(pTHX_ OP *o)
4248 I32 type = o->op_type;
4250 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4252 /* integerize op. */
4253 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4256 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4259 if (type == OP_NEGATE)
4260 /* XXX might want a ck_negate() for this */
4261 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4267 S_fold_constants(pTHX_ OP *o)
4272 VOL I32 type = o->op_type;
4277 SV * const oldwarnhook = PL_warnhook;
4278 SV * const olddiehook = PL_diehook;
4280 U8 oldwarn = PL_dowarn;
4284 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4286 if (!(PL_opargs[type] & OA_FOLDCONST))
4295 #ifdef USE_LOCALE_CTYPE
4296 if (IN_LC_COMPILETIME(LC_CTYPE))
4305 #ifdef USE_LOCALE_COLLATE
4306 if (IN_LC_COMPILETIME(LC_COLLATE))
4311 /* XXX what about the numeric ops? */
4312 #ifdef USE_LOCALE_NUMERIC
4313 if (IN_LC_COMPILETIME(LC_NUMERIC))
4318 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4319 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4322 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4323 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4325 const char *s = SvPVX_const(sv);
4326 while (s < SvEND(sv)) {
4327 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4334 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4337 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4338 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4342 if (PL_parser && PL_parser->error_count)
4343 goto nope; /* Don't try to run w/ errors */
4345 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4346 switch (curop->op_type) {
4348 if ( (curop->op_private & OPpCONST_BARE)
4349 && (curop->op_private & OPpCONST_STRICT)) {
4350 no_bareword_allowed(curop);
4358 /* Foldable; move to next op in list */
4362 /* No other op types are considered foldable */
4367 curop = LINKLIST(o);
4368 old_next = o->op_next;
4372 old_cxix = cxstack_ix;
4373 create_eval_scope(NULL, G_FAKINGEVAL);
4375 /* Verify that we don't need to save it: */
4376 assert(PL_curcop == &PL_compiling);
4377 StructCopy(&PL_compiling, ¬_compiling, COP);
4378 PL_curcop = ¬_compiling;
4379 /* The above ensures that we run with all the correct hints of the
4380 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4381 assert(IN_PERL_RUNTIME);
4382 PL_warnhook = PERL_WARNHOOK_FATAL;
4386 /* Effective $^W=1. */
4387 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4388 PL_dowarn |= G_WARN_ON;
4393 sv = *(PL_stack_sp--);
4394 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4395 pad_swipe(o->op_targ, FALSE);
4397 else if (SvTEMP(sv)) { /* grab mortal temp? */
4398 SvREFCNT_inc_simple_void(sv);
4401 else { assert(SvIMMORTAL(sv)); }
4404 /* Something tried to die. Abandon constant folding. */
4405 /* Pretend the error never happened. */
4407 o->op_next = old_next;
4411 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4412 PL_warnhook = oldwarnhook;
4413 PL_diehook = olddiehook;
4414 /* XXX note that this croak may fail as we've already blown away
4415 * the stack - eg any nested evals */
4416 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4419 PL_dowarn = oldwarn;
4420 PL_warnhook = oldwarnhook;
4421 PL_diehook = olddiehook;
4422 PL_curcop = &PL_compiling;
4424 /* if we croaked, depending on how we croaked the eval scope
4425 * may or may not have already been popped */
4426 if (cxstack_ix > old_cxix) {
4427 assert(cxstack_ix == old_cxix + 1);
4428 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4429 delete_eval_scope();
4434 /* OP_STRINGIFY and constant folding are used to implement qq.
4435 Here the constant folding is an implementation detail that we
4436 want to hide. If the stringify op is itself already marked
4437 folded, however, then it is actually a folded join. */
4438 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4443 else if (!SvIMMORTAL(sv)) {
4447 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4448 if (!is_stringify) newop->op_folded = 1;
4456 S_gen_constant_list(pTHX_ OP *o)
4460 const SSize_t oldtmps_floor = PL_tmps_floor;
4465 if (PL_parser && PL_parser->error_count)
4466 return o; /* Don't attempt to run with errors */
4468 curop = LINKLIST(o);
4471 S_prune_chain_head(&curop);
4473 Perl_pp_pushmark(aTHX);
4476 assert (!(curop->op_flags & OPf_SPECIAL));
4477 assert(curop->op_type == OP_RANGE);
4478 Perl_pp_anonlist(aTHX);
4479 PL_tmps_floor = oldtmps_floor;
4481 OpTYPE_set(o, OP_RV2AV);
4482 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4483 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4484 o->op_opt = 0; /* needs to be revisited in rpeep() */
4485 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4487 /* replace subtree with an OP_CONST */
4488 curop = ((UNOP*)o)->op_first;
4489 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4492 if (AvFILLp(av) != -1)
4493 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4496 SvREADONLY_on(*svp);
4503 =head1 Optree Manipulation Functions
4506 /* List constructors */
4509 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4511 Append an item to the list of ops contained directly within a list-type
4512 op, returning the lengthened list. C<first> is the list-type op,
4513 and C<last> is the op to append to the list. C<optype> specifies the
4514 intended opcode for the list. If C<first> is not already a list of the
4515 right type, it will be upgraded into one. If either C<first> or C<last>
4516 is null, the other is returned unchanged.
4522 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4530 if (first->op_type != (unsigned)type
4531 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4533 return newLISTOP(type, 0, first, last);
4536 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4537 first->op_flags |= OPf_KIDS;
4542 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4544 Concatenate the lists of ops contained directly within two list-type ops,
4545 returning the combined list. C<first> and C<last> are the list-type ops
4546 to concatenate. C<optype> specifies the intended opcode for the list.
4547 If either C<first> or C<last> is not already a list of the right type,
4548 it will be upgraded into one. If either C<first> or C<last> is null,
4549 the other is returned unchanged.
4555 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4563 if (first->op_type != (unsigned)type)
4564 return op_prepend_elem(type, first, last);
4566 if (last->op_type != (unsigned)type)
4567 return op_append_elem(type, first, last);
4569 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4570 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4571 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4572 first->op_flags |= (last->op_flags & OPf_KIDS);
4574 S_op_destroy(aTHX_ last);
4580 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4582 Prepend an item to the list of ops contained directly within a list-type
4583 op, returning the lengthened list. C<first> is the op to prepend to the
4584 list, and C<last> is the list-type op. C<optype> specifies the intended
4585 opcode for the list. If C<last> is not already a list of the right type,
4586 it will be upgraded into one. If either C<first> or C<last> is null,
4587 the other is returned unchanged.
4593 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4601 if (last->op_type == (unsigned)type) {
4602 if (type == OP_LIST) { /* already a PUSHMARK there */
4603 /* insert 'first' after pushmark */
4604 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4605 if (!(first->op_flags & OPf_PARENS))
4606 last->op_flags &= ~OPf_PARENS;
4609 op_sibling_splice(last, NULL, 0, first);
4610 last->op_flags |= OPf_KIDS;
4614 return newLISTOP(type, 0, first, last);
4618 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4620 Converts C<o> into a list op if it is not one already, and then converts it
4621 into the specified C<type>, calling its check function, allocating a target if
4622 it needs one, and folding constants.
4624 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4625 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4626 C<op_convert_list> to make it the right type.
4632 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4635 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4636 if (!o || o->op_type != OP_LIST)
4637 o = force_list(o, 0);
4640 o->op_flags &= ~OPf_WANT;
4641 o->op_private &= ~OPpLVAL_INTRO;
4644 if (!(PL_opargs[type] & OA_MARK))
4645 op_null(cLISTOPo->op_first);
4647 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4648 if (kid2 && kid2->op_type == OP_COREARGS) {
4649 op_null(cLISTOPo->op_first);
4650 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4654 OpTYPE_set(o, type);
4655 o->op_flags |= flags;
4656 if (flags & OPf_FOLDED)
4659 o = CHECKOP(type, o);
4660 if (o->op_type != (unsigned)type)
4663 return fold_constants(op_integerize(op_std_init(o)));
4670 =head1 Optree construction
4672 =for apidoc Am|OP *|newNULLLIST
4674 Constructs, checks, and returns a new C<stub> op, which represents an
4675 empty list expression.
4681 Perl_newNULLLIST(pTHX)
4683 return newOP(OP_STUB, 0);
4686 /* promote o and any siblings to be a list if its not already; i.e.
4694 * pushmark - o - A - B
4696 * If nullit it true, the list op is nulled.
4700 S_force_list(pTHX_ OP *o, bool nullit)
4702 if (!o || o->op_type != OP_LIST) {
4705 /* manually detach any siblings then add them back later */
4706 rest = OpSIBLING(o);
4707 OpLASTSIB_set(o, NULL);
4709 o = newLISTOP(OP_LIST, 0, o, NULL);
4711 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4719 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4721 Constructs, checks, and returns an op of any list type. C<type> is
4722 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4723 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
4724 supply up to two ops to be direct children of the list op; they are
4725 consumed by this function and become part of the constructed op tree.
4727 For most list operators, the check function expects all the kid ops to be
4728 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4729 appropriate. What you want to do in that case is create an op of type
4730 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4731 See L</op_convert_list> for more information.
4738 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4743 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4744 || type == OP_CUSTOM);
4746 NewOp(1101, listop, 1, LISTOP);
4748 OpTYPE_set(listop, type);
4751 listop->op_flags = (U8)flags;
4755 else if (!first && last)
4758 OpMORESIB_set(first, last);
4759 listop->op_first = first;
4760 listop->op_last = last;
4761 if (type == OP_LIST) {
4762 OP* const pushop = newOP(OP_PUSHMARK, 0);
4763 OpMORESIB_set(pushop, first);
4764 listop->op_first = pushop;
4765 listop->op_flags |= OPf_KIDS;
4767 listop->op_last = pushop;
4769 if (listop->op_last)
4770 OpLASTSIB_set(listop->op_last, (OP*)listop);
4772 return CHECKOP(type, listop);
4776 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4778 Constructs, checks, and returns an op of any base type (any type that
4779 has no extra fields). C<type> is the opcode. C<flags> gives the
4780 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4787 Perl_newOP(pTHX_ I32 type, I32 flags)
4792 if (type == -OP_ENTEREVAL) {
4793 type = OP_ENTEREVAL;
4794 flags |= OPpEVAL_BYTES<<8;
4797 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4798 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4799 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4800 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4802 NewOp(1101, o, 1, OP);
4803 OpTYPE_set(o, type);
4804 o->op_flags = (U8)flags;
4807 o->op_private = (U8)(0 | (flags >> 8));
4808 if (PL_opargs[type] & OA_RETSCALAR)
4810 if (PL_opargs[type] & OA_TARGET)
4811 o->op_targ = pad_alloc(type, SVs_PADTMP);
4812 return CHECKOP(type, o);
4816 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4818 Constructs, checks, and returns an op of any unary type. C<type> is
4819 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4820 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4821 bits, the eight bits of C<op_private>, except that the bit with value 1
4822 is automatically set. C<first> supplies an optional op to be the direct
4823 child of the unary op; it is consumed by this function and become part
4824 of the constructed op tree.
4830 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4835 if (type == -OP_ENTEREVAL) {
4836 type = OP_ENTEREVAL;
4837 flags |= OPpEVAL_BYTES<<8;
4840 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4841 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4842 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4843 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4844 || type == OP_SASSIGN
4845 || type == OP_ENTERTRY
4846 || type == OP_CUSTOM
4847 || type == OP_NULL );
4850 first = newOP(OP_STUB, 0);
4851 if (PL_opargs[type] & OA_MARK)
4852 first = force_list(first, 1);
4854 NewOp(1101, unop, 1, UNOP);
4855 OpTYPE_set(unop, type);
4856 unop->op_first = first;
4857 unop->op_flags = (U8)(flags | OPf_KIDS);
4858 unop->op_private = (U8)(1 | (flags >> 8));
4860 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4861 OpLASTSIB_set(first, (OP*)unop);
4863 unop = (UNOP*) CHECKOP(type, unop);
4867 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4871 =for apidoc newUNOP_AUX
4873 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4874 initialised to C<aux>
4880 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4885 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4886 || type == OP_CUSTOM);
4888 NewOp(1101, unop, 1, UNOP_AUX);
4889 unop->op_type = (OPCODE)type;
4890 unop->op_ppaddr = PL_ppaddr[type];
4891 unop->op_first = first;
4892 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4893 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4896 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4897 OpLASTSIB_set(first, (OP*)unop);
4899 unop = (UNOP_AUX*) CHECKOP(type, unop);
4901 return op_std_init((OP *) unop);
4905 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4907 Constructs, checks, and returns an op of method type with a method name
4908 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
4909 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4910 and, shifted up eight bits, the eight bits of C<op_private>, except that
4911 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
4912 op which evaluates method name; it is consumed by this function and
4913 become part of the constructed op tree.
4914 Supported optypes: C<OP_METHOD>.
4920 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4924 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4925 || type == OP_CUSTOM);
4927 NewOp(1101, methop, 1, METHOP);
4929 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4930 methop->op_flags = (U8)(flags | OPf_KIDS);
4931 methop->op_u.op_first = dynamic_meth;
4932 methop->op_private = (U8)(1 | (flags >> 8));
4934 if (!OpHAS_SIBLING(dynamic_meth))
4935 OpLASTSIB_set(dynamic_meth, (OP*)methop);
4939 methop->op_flags = (U8)(flags & ~OPf_KIDS);
4940 methop->op_u.op_meth_sv = const_meth;
4941 methop->op_private = (U8)(0 | (flags >> 8));
4942 methop->op_next = (OP*)methop;
4946 methop->op_rclass_targ = 0;
4948 methop->op_rclass_sv = NULL;
4951 OpTYPE_set(methop, type);
4952 return CHECKOP(type, methop);
4956 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4957 PERL_ARGS_ASSERT_NEWMETHOP;
4958 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4962 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4964 Constructs, checks, and returns an op of method type with a constant
4965 method name. C<type> is the opcode. C<flags> gives the eight bits of
4966 C<op_flags>, and, shifted up eight bits, the eight bits of
4967 C<op_private>. C<const_meth> supplies a constant method name;
4968 it must be a shared COW string.
4969 Supported optypes: C<OP_METHOD_NAMED>.
4975 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4976 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4977 return newMETHOP_internal(type, flags, NULL, const_meth);
4981 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4983 Constructs, checks, and returns an op of any binary type. C<type>
4984 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
4985 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4986 the eight bits of C<op_private>, except that the bit with value 1 or
4987 2 is automatically set as required. C<first> and C<last> supply up to
4988 two ops to be the direct children of the binary op; they are consumed
4989 by this function and become part of the constructed op tree.
4995 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5000 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5001 || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
5003 NewOp(1101, binop, 1, BINOP);
5006 first = newOP(OP_NULL, 0);
5008 OpTYPE_set(binop, type);
5009 binop->op_first = first;
5010 binop->op_flags = (U8)(flags | OPf_KIDS);
5013 binop->op_private = (U8)(1 | (flags >> 8));
5016 binop->op_private = (U8)(2 | (flags >> 8));
5017 OpMORESIB_set(first, last);
5020 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5021 OpLASTSIB_set(last, (OP*)binop);
5023 binop->op_last = OpSIBLING(binop->op_first);
5025 OpLASTSIB_set(binop->op_last, (OP*)binop);
5027 binop = (BINOP*)CHECKOP(type, binop);
5028 if (binop->op_next || binop->op_type != (OPCODE)type)
5031 return fold_constants(op_integerize(op_std_init((OP *)binop)));
5034 static int uvcompare(const void *a, const void *b)
5035 __attribute__nonnull__(1)
5036 __attribute__nonnull__(2)
5037 __attribute__pure__;
5038 static int uvcompare(const void *a, const void *b)
5040 if (*((const UV *)a) < (*(const UV *)b))
5042 if (*((const UV *)a) > (*(const UV *)b))
5044 if (*((const UV *)a+1) < (*(const UV *)b+1))
5046 if (*((const UV *)a+1) > (*(const UV *)b+1))
5052 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5054 SV * const tstr = ((SVOP*)expr)->op_sv;
5056 ((SVOP*)repl)->op_sv;
5059 const U8 *t = (U8*)SvPV_const(tstr, tlen);
5060 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5066 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5067 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5068 I32 del = o->op_private & OPpTRANS_DELETE;
5071 PERL_ARGS_ASSERT_PMTRANS;
5073 PL_hints |= HINT_BLOCK_SCOPE;
5076 o->op_private |= OPpTRANS_FROM_UTF;
5079 o->op_private |= OPpTRANS_TO_UTF;
5081 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5082 SV* const listsv = newSVpvs("# comment\n");
5084 const U8* tend = t + tlen;
5085 const U8* rend = r + rlen;
5101 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5102 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5105 const U32 flags = UTF8_ALLOW_DEFAULT;
5109 t = tsave = bytes_to_utf8(t, &len);
5112 if (!to_utf && rlen) {
5114 r = rsave = bytes_to_utf8(r, &len);
5118 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5119 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5123 U8 tmpbuf[UTF8_MAXBYTES+1];
5126 Newx(cp, 2*tlen, UV);
5128 transv = newSVpvs("");
5130 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5132 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5134 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5138 cp[2*i+1] = cp[2*i];
5142 qsort(cp, i, 2*sizeof(UV), uvcompare);
5143 for (j = 0; j < i; j++) {
5145 diff = val - nextmin;
5147 t = uvchr_to_utf8(tmpbuf,nextmin);
5148 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5150 U8 range_mark = ILLEGAL_UTF8_BYTE;
5151 t = uvchr_to_utf8(tmpbuf, val - 1);
5152 sv_catpvn(transv, (char *)&range_mark, 1);
5153 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5160 t = uvchr_to_utf8(tmpbuf,nextmin);
5161 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5163 U8 range_mark = ILLEGAL_UTF8_BYTE;
5164 sv_catpvn(transv, (char *)&range_mark, 1);
5166 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5167 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5168 t = (const U8*)SvPVX_const(transv);
5169 tlen = SvCUR(transv);
5173 else if (!rlen && !del) {
5174 r = t; rlen = tlen; rend = tend;
5177 if ((!rlen && !del) || t == r ||
5178 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5180 o->op_private |= OPpTRANS_IDENTICAL;
5184 while (t < tend || tfirst <= tlast) {
5185 /* see if we need more "t" chars */
5186 if (tfirst > tlast) {
5187 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5189 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5191 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5198 /* now see if we need more "r" chars */
5199 if (rfirst > rlast) {
5201 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5203 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5205 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5214 rfirst = rlast = 0xffffffff;
5218 /* now see which range will peter out first, if either. */
5219 tdiff = tlast - tfirst;
5220 rdiff = rlast - rfirst;
5221 tcount += tdiff + 1;
5222 rcount += rdiff + 1;
5229 if (rfirst == 0xffffffff) {
5230 diff = tdiff; /* oops, pretend rdiff is infinite */
5232 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5233 (long)tfirst, (long)tlast);
5235 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5239 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5240 (long)tfirst, (long)(tfirst + diff),
5243 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5244 (long)tfirst, (long)rfirst);
5246 if (rfirst + diff > max)
5247 max = rfirst + diff;
5249 grows = (tfirst < rfirst &&
5250 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5262 else if (max > 0xff)
5267 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5269 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5270 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5271 PAD_SETSV(cPADOPo->op_padix, swash);
5273 SvREADONLY_on(swash);
5275 cSVOPo->op_sv = swash;
5277 SvREFCNT_dec(listsv);
5278 SvREFCNT_dec(transv);
5280 if (!del && havefinal && rlen)
5281 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5282 newSVuv((UV)final), 0);
5291 else if (rlast == 0xffffffff)
5297 tbl = (short*)PerlMemShared_calloc(
5298 (o->op_private & OPpTRANS_COMPLEMENT) &&
5299 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5301 cPVOPo->op_pv = (char*)tbl;
5303 for (i = 0; i < (I32)tlen; i++)
5305 for (i = 0, j = 0; i < 256; i++) {
5307 if (j >= (I32)rlen) {
5316 if (i < 128 && r[j] >= 128)
5326 o->op_private |= OPpTRANS_IDENTICAL;
5328 else if (j >= (I32)rlen)
5333 PerlMemShared_realloc(tbl,
5334 (0x101+rlen-j) * sizeof(short));
5335 cPVOPo->op_pv = (char*)tbl;
5337 tbl[0x100] = (short)(rlen - j);
5338 for (i=0; i < (I32)rlen - j; i++)
5339 tbl[0x101+i] = r[j+i];
5343 if (!rlen && !del) {
5346 o->op_private |= OPpTRANS_IDENTICAL;
5348 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5349 o->op_private |= OPpTRANS_IDENTICAL;
5351 for (i = 0; i < 256; i++)
5353 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5354 if (j >= (I32)rlen) {
5356 if (tbl[t[i]] == -1)
5362 if (tbl[t[i]] == -1) {
5363 if (t[i] < 128 && r[j] >= 128)
5371 if(del && rlen == tlen) {
5372 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5373 } else if(rlen > tlen && !complement) {
5374 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5378 o->op_private |= OPpTRANS_GROWS;
5386 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5388 Constructs, checks, and returns an op of any pattern matching type.
5389 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
5390 and, shifted up eight bits, the eight bits of C<op_private>.
5396 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5401 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5402 || type == OP_CUSTOM);
5404 NewOp(1101, pmop, 1, PMOP);
5405 OpTYPE_set(pmop, type);
5406 pmop->op_flags = (U8)flags;
5407 pmop->op_private = (U8)(0 | (flags >> 8));
5408 if (PL_opargs[type] & OA_RETSCALAR)
5411 if (PL_hints & HINT_RE_TAINT)
5412 pmop->op_pmflags |= PMf_RETAINT;
5413 #ifdef USE_LOCALE_CTYPE
5414 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5415 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5420 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5422 if (PL_hints & HINT_RE_FLAGS) {
5423 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5424 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5426 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5427 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5428 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5430 if (reflags && SvOK(reflags)) {
5431 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5437 assert(SvPOK(PL_regex_pad[0]));
5438 if (SvCUR(PL_regex_pad[0])) {
5439 /* Pop off the "packed" IV from the end. */
5440 SV *const repointer_list = PL_regex_pad[0];
5441 const char *p = SvEND(repointer_list) - sizeof(IV);
5442 const IV offset = *((IV*)p);
5444 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5446 SvEND_set(repointer_list, p);
5448 pmop->op_pmoffset = offset;
5449 /* This slot should be free, so assert this: */
5450 assert(PL_regex_pad[offset] == &PL_sv_undef);
5452 SV * const repointer = &PL_sv_undef;
5453 av_push(PL_regex_padav, repointer);
5454 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5455 PL_regex_pad = AvARRAY(PL_regex_padav);
5459 return CHECKOP(type, pmop);
5467 /* Any pad names in scope are potentially lvalues. */
5468 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5469 PADNAME *pn = PAD_COMPNAME_SV(i);
5470 if (!pn || !PadnameLEN(pn))
5472 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5473 S_mark_padname_lvalue(aTHX_ pn);
5477 /* Given some sort of match op o, and an expression expr containing a
5478 * pattern, either compile expr into a regex and attach it to o (if it's
5479 * constant), or convert expr into a runtime regcomp op sequence (if it's
5482 * isreg indicates that the pattern is part of a regex construct, eg
5483 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5484 * split "pattern", which aren't. In the former case, expr will be a list
5485 * if the pattern contains more than one term (eg /a$b/).
5487 * When the pattern has been compiled within a new anon CV (for
5488 * qr/(?{...})/ ), then floor indicates the savestack level just before
5489 * the new sub was created
5493 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5497 I32 repl_has_vars = 0;
5498 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5499 bool is_compiletime;
5502 PERL_ARGS_ASSERT_PMRUNTIME;
5505 return pmtrans(o, expr, repl);
5508 /* find whether we have any runtime or code elements;
5509 * at the same time, temporarily set the op_next of each DO block;
5510 * then when we LINKLIST, this will cause the DO blocks to be excluded
5511 * from the op_next chain (and from having LINKLIST recursively
5512 * applied to them). We fix up the DOs specially later */
5516 if (expr->op_type == OP_LIST) {
5518 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5519 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5521 assert(!o->op_next);
5522 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5523 assert(PL_parser && PL_parser->error_count);
5524 /* This can happen with qr/ (?{(^{})/. Just fake up
5525 the op we were expecting to see, to avoid crashing
5527 op_sibling_splice(expr, o, 0,
5528 newSVOP(OP_CONST, 0, &PL_sv_no));
5530 o->op_next = OpSIBLING(o);
5532 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5536 else if (expr->op_type != OP_CONST)
5541 /* fix up DO blocks; treat each one as a separate little sub;
5542 * also, mark any arrays as LIST/REF */
5544 if (expr->op_type == OP_LIST) {
5546 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5548 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5549 assert( !(o->op_flags & OPf_WANT));
5550 /* push the array rather than its contents. The regex
5551 * engine will retrieve and join the elements later */
5552 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5556 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5558 o->op_next = NULL; /* undo temporary hack from above */
5561 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5562 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5564 assert(leaveop->op_first->op_type == OP_ENTER);
5565 assert(OpHAS_SIBLING(leaveop->op_first));
5566 o->op_next = OpSIBLING(leaveop->op_first);
5568 assert(leaveop->op_flags & OPf_KIDS);
5569 assert(leaveop->op_last->op_next == (OP*)leaveop);
5570 leaveop->op_next = NULL; /* stop on last op */
5571 op_null((OP*)leaveop);
5575 OP *scope = cLISTOPo->op_first;
5576 assert(scope->op_type == OP_SCOPE);
5577 assert(scope->op_flags & OPf_KIDS);
5578 scope->op_next = NULL; /* stop on last op */
5581 /* have to peep the DOs individually as we've removed it from
5582 * the op_next chain */
5584 S_prune_chain_head(&(o->op_next));
5586 /* runtime finalizes as part of finalizing whole tree */
5590 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5591 assert( !(expr->op_flags & OPf_WANT));
5592 /* push the array rather than its contents. The regex
5593 * engine will retrieve and join the elements later */
5594 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5597 PL_hints |= HINT_BLOCK_SCOPE;
5599 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5601 if (is_compiletime) {
5602 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5603 regexp_engine const *eng = current_re_engine();
5605 if (o->op_flags & OPf_SPECIAL)
5606 rx_flags |= RXf_SPLIT;
5608 if (!has_code || !eng->op_comp) {
5609 /* compile-time simple constant pattern */
5611 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5612 /* whoops! we guessed that a qr// had a code block, but we
5613 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5614 * that isn't required now. Note that we have to be pretty
5615 * confident that nothing used that CV's pad while the
5616 * regex was parsed, except maybe op targets for \Q etc.
5617 * If there were any op targets, though, they should have
5618 * been stolen by constant folding.
5622 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5623 while (++i <= AvFILLp(PL_comppad)) {
5624 assert(!PL_curpad[i]);
5627 /* But we know that one op is using this CV's slab. */
5628 cv_forget_slab(PL_compcv);
5630 pm->op_pmflags &= ~PMf_HAS_CV;
5635 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5636 rx_flags, pm->op_pmflags)
5637 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5638 rx_flags, pm->op_pmflags)
5643 /* compile-time pattern that includes literal code blocks */
5644 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5647 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5650 if (pm->op_pmflags & PMf_HAS_CV) {
5652 /* this QR op (and the anon sub we embed it in) is never
5653 * actually executed. It's just a placeholder where we can
5654 * squirrel away expr in op_code_list without the peephole
5655 * optimiser etc processing it for a second time */
5656 OP *qr = newPMOP(OP_QR, 0);
5657 ((PMOP*)qr)->op_code_list = expr;
5659 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5660 SvREFCNT_inc_simple_void(PL_compcv);
5661 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5662 ReANY(re)->qr_anoncv = cv;
5664 /* attach the anon CV to the pad so that
5665 * pad_fixup_inner_anons() can find it */
5666 (void)pad_add_anon(cv, o->op_type);
5667 SvREFCNT_inc_simple_void(cv);
5670 pm->op_code_list = expr;
5675 /* runtime pattern: build chain of regcomp etc ops */
5677 PADOFFSET cv_targ = 0;
5679 reglist = isreg && expr->op_type == OP_LIST;
5684 pm->op_code_list = expr;
5685 /* don't free op_code_list; its ops are embedded elsewhere too */
5686 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5689 if (o->op_flags & OPf_SPECIAL)
5690 pm->op_pmflags |= PMf_SPLIT;
5692 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5693 * to allow its op_next to be pointed past the regcomp and
5694 * preceding stacking ops;
5695 * OP_REGCRESET is there to reset taint before executing the
5697 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5698 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5700 if (pm->op_pmflags & PMf_HAS_CV) {
5701 /* we have a runtime qr with literal code. This means
5702 * that the qr// has been wrapped in a new CV, which
5703 * means that runtime consts, vars etc will have been compiled
5704 * against a new pad. So... we need to execute those ops
5705 * within the environment of the new CV. So wrap them in a call
5706 * to a new anon sub. i.e. for
5710 * we build an anon sub that looks like
5712 * sub { "a", $b, '(?{...})' }
5714 * and call it, passing the returned list to regcomp.
5715 * Or to put it another way, the list of ops that get executed
5719 * ------ -------------------
5720 * pushmark (for regcomp)
5721 * pushmark (for entersub)
5725 * regcreset regcreset
5727 * const("a") const("a")
5729 * const("(?{...})") const("(?{...})")
5734 SvREFCNT_inc_simple_void(PL_compcv);
5735 CvLVALUE_on(PL_compcv);
5736 /* these lines are just an unrolled newANONATTRSUB */
5737 expr = newSVOP(OP_ANONCODE, 0,
5738 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5739 cv_targ = expr->op_targ;
5740 expr = newUNOP(OP_REFGEN, 0, expr);
5742 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5745 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5746 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5747 | (reglist ? OPf_STACKED : 0);
5748 rcop->op_targ = cv_targ;
5750 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5751 if (PL_hints & HINT_RE_EVAL)
5752 S_set_haseval(aTHX);
5754 /* establish postfix order */
5755 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5757 rcop->op_next = expr;
5758 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5761 rcop->op_next = LINKLIST(expr);
5762 expr->op_next = (OP*)rcop;
5765 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5771 /* If we are looking at s//.../e with a single statement, get past
5772 the implicit do{}. */
5773 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5774 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5775 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5778 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5779 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5780 && !OpHAS_SIBLING(sib))
5783 if (curop->op_type == OP_CONST)
5785 else if (( (curop->op_type == OP_RV2SV ||
5786 curop->op_type == OP_RV2AV ||
5787 curop->op_type == OP_RV2HV ||
5788 curop->op_type == OP_RV2GV)
5789 && cUNOPx(curop)->op_first
5790 && cUNOPx(curop)->op_first->op_type == OP_GV )
5791 || curop->op_type == OP_PADSV
5792 || curop->op_type == OP_PADAV
5793 || curop->op_type == OP_PADHV
5794 || curop->op_type == OP_PADANY) {
5802 || !RX_PRELEN(PM_GETRE(pm))
5803 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5805 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5806 op_prepend_elem(o->op_type, scalar(repl), o);
5809 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5810 rcop->op_private = 1;
5812 /* establish postfix order */
5813 rcop->op_next = LINKLIST(repl);
5814 repl->op_next = (OP*)rcop;
5816 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5817 assert(!(pm->op_pmflags & PMf_ONCE));
5818 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5827 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5829 Constructs, checks, and returns an op of any type that involves an
5830 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
5831 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
5832 takes ownership of one reference to it.
5838 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5843 PERL_ARGS_ASSERT_NEWSVOP;
5845 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5846 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5847 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5848 || type == OP_CUSTOM);
5850 NewOp(1101, svop, 1, SVOP);
5851 OpTYPE_set(svop, type);
5853 svop->op_next = (OP*)svop;
5854 svop->op_flags = (U8)flags;
5855 svop->op_private = (U8)(0 | (flags >> 8));
5856 if (PL_opargs[type] & OA_RETSCALAR)
5858 if (PL_opargs[type] & OA_TARGET)
5859 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5860 return CHECKOP(type, svop);
5864 =for apidoc Am|OP *|newDEFSVOP|
5866 Constructs and returns an op to access C<$_>.
5872 Perl_newDEFSVOP(pTHX)
5874 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5880 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5882 Constructs, checks, and returns an op of any type that involves a
5883 reference to a pad element. C<type> is the opcode. C<flags> gives the
5884 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5885 is populated with C<sv>; this function takes ownership of one reference
5888 This function only exists if Perl has been compiled to use ithreads.
5894 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5899 PERL_ARGS_ASSERT_NEWPADOP;
5901 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5902 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5903 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5904 || type == OP_CUSTOM);
5906 NewOp(1101, padop, 1, PADOP);
5907 OpTYPE_set(padop, type);
5909 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5910 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5911 PAD_SETSV(padop->op_padix, sv);
5913 padop->op_next = (OP*)padop;
5914 padop->op_flags = (U8)flags;
5915 if (PL_opargs[type] & OA_RETSCALAR)
5917 if (PL_opargs[type] & OA_TARGET)
5918 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5919 return CHECKOP(type, padop);
5922 #endif /* USE_ITHREADS */
5925 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5927 Constructs, checks, and returns an op of any type that involves an
5928 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
5929 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
5930 reference; calling this function does not transfer ownership of any
5937 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5939 PERL_ARGS_ASSERT_NEWGVOP;
5942 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5944 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5949 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5951 Constructs, checks, and returns an op of any type that involves an
5952 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
5953 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
5954 must have been allocated using C<PerlMemShared_malloc>; the memory will
5955 be freed when the op is destroyed.
5961 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5964 const bool utf8 = cBOOL(flags & SVf_UTF8);
5969 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5970 || type == OP_RUNCV || type == OP_CUSTOM
5971 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5973 NewOp(1101, pvop, 1, PVOP);
5974 OpTYPE_set(pvop, type);
5976 pvop->op_next = (OP*)pvop;
5977 pvop->op_flags = (U8)flags;
5978 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5979 if (PL_opargs[type] & OA_RETSCALAR)
5981 if (PL_opargs[type] & OA_TARGET)
5982 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5983 return CHECKOP(type, pvop);
5987 Perl_package(pTHX_ OP *o)
5989 SV *const sv = cSVOPo->op_sv;
5991 PERL_ARGS_ASSERT_PACKAGE;
5993 SAVEGENERICSV(PL_curstash);
5994 save_item(PL_curstname);
5996 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5998 sv_setsv(PL_curstname, sv);
6000 PL_hints |= HINT_BLOCK_SCOPE;
6001 PL_parser->copline = NOLINE;
6007 Perl_package_version( pTHX_ OP *v )
6009 U32 savehints = PL_hints;
6010 PERL_ARGS_ASSERT_PACKAGE_VERSION;
6011 PL_hints &= ~HINT_STRICT_VARS;
6012 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6013 PL_hints = savehints;
6018 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6023 SV *use_version = NULL;
6025 PERL_ARGS_ASSERT_UTILIZE;
6027 if (idop->op_type != OP_CONST)
6028 Perl_croak(aTHX_ "Module name must be constant");
6033 SV * const vesv = ((SVOP*)version)->op_sv;
6035 if (!arg && !SvNIOKp(vesv)) {
6042 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6043 Perl_croak(aTHX_ "Version number must be a constant number");
6045 /* Make copy of idop so we don't free it twice */
6046 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6048 /* Fake up a method call to VERSION */
6049 meth = newSVpvs_share("VERSION");
6050 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6051 op_append_elem(OP_LIST,
6052 op_prepend_elem(OP_LIST, pack, version),
6053 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6057 /* Fake up an import/unimport */
6058 if (arg && arg->op_type == OP_STUB) {
6059 imop = arg; /* no import on explicit () */
6061 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6062 imop = NULL; /* use 5.0; */
6064 use_version = ((SVOP*)idop)->op_sv;
6066 idop->op_private |= OPpCONST_NOVER;
6071 /* Make copy of idop so we don't free it twice */
6072 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6074 /* Fake up a method call to import/unimport */
6076 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6077 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6078 op_append_elem(OP_LIST,
6079 op_prepend_elem(OP_LIST, pack, arg),
6080 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6084 /* Fake up the BEGIN {}, which does its thing immediately. */
6086 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6089 op_append_elem(OP_LINESEQ,
6090 op_append_elem(OP_LINESEQ,
6091 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6092 newSTATEOP(0, NULL, veop)),
6093 newSTATEOP(0, NULL, imop) ));
6097 * feature bundle that corresponds to the required version. */
6098 use_version = sv_2mortal(new_version(use_version));
6099 S_enable_feature_bundle(aTHX_ use_version);
6101 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6102 if (vcmp(use_version,
6103 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6104 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6105 PL_hints |= HINT_STRICT_REFS;
6106 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6107 PL_hints |= HINT_STRICT_SUBS;
6108 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6109 PL_hints |= HINT_STRICT_VARS;
6111 /* otherwise they are off */
6113 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6114 PL_hints &= ~HINT_STRICT_REFS;
6115 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6116 PL_hints &= ~HINT_STRICT_SUBS;
6117 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6118 PL_hints &= ~HINT_STRICT_VARS;
6122 /* The "did you use incorrect case?" warning used to be here.
6123 * The problem is that on case-insensitive filesystems one
6124 * might get false positives for "use" (and "require"):
6125 * "use Strict" or "require CARP" will work. This causes
6126 * portability problems for the script: in case-strict
6127 * filesystems the script will stop working.
6129 * The "incorrect case" warning checked whether "use Foo"
6130 * imported "Foo" to your namespace, but that is wrong, too:
6131 * there is no requirement nor promise in the language that
6132 * a Foo.pm should or would contain anything in package "Foo".
6134 * There is very little Configure-wise that can be done, either:
6135 * the case-sensitivity of the build filesystem of Perl does not
6136 * help in guessing the case-sensitivity of the runtime environment.
6139 PL_hints |= HINT_BLOCK_SCOPE;
6140 PL_parser->copline = NOLINE;
6141 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6145 =head1 Embedding Functions
6147 =for apidoc load_module
6149 Loads the module whose name is pointed to by the string part of name.
6150 Note that the actual module name, not its filename, should be given.
6151 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
6152 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6153 (or 0 for no flags). ver, if specified
6154 and not NULL, provides version semantics
6155 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
6156 arguments can be used to specify arguments to the module's C<import()>
6157 method, similar to C<use Foo::Bar VERSION LIST>. They must be
6158 terminated with a final C<NULL> pointer. Note that this list can only
6159 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6160 Otherwise at least a single C<NULL> pointer to designate the default
6161 import list is required.
6163 The reference count for each specified C<SV*> parameter is decremented.
6168 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6172 PERL_ARGS_ASSERT_LOAD_MODULE;
6174 va_start(args, ver);
6175 vload_module(flags, name, ver, &args);
6179 #ifdef PERL_IMPLICIT_CONTEXT
6181 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6185 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6186 va_start(args, ver);
6187 vload_module(flags, name, ver, &args);
6193 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6196 OP * const modname = newSVOP(OP_CONST, 0, name);
6198 PERL_ARGS_ASSERT_VLOAD_MODULE;
6200 modname->op_private |= OPpCONST_BARE;
6202 veop = newSVOP(OP_CONST, 0, ver);
6206 if (flags & PERL_LOADMOD_NOIMPORT) {
6207 imop = sawparens(newNULLLIST());
6209 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6210 imop = va_arg(*args, OP*);
6215 sv = va_arg(*args, SV*);
6217 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6218 sv = va_arg(*args, SV*);
6222 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6223 * that it has a PL_parser to play with while doing that, and also
6224 * that it doesn't mess with any existing parser, by creating a tmp
6225 * new parser with lex_start(). This won't actually be used for much,
6226 * since pp_require() will create another parser for the real work.
6227 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6230 SAVEVPTR(PL_curcop);
6231 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6232 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6233 veop, modname, imop);
6237 PERL_STATIC_INLINE OP *
6238 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6240 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6241 newLISTOP(OP_LIST, 0, arg,
6242 newUNOP(OP_RV2CV, 0,
6243 newGVOP(OP_GV, 0, gv))));
6247 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6252 PERL_ARGS_ASSERT_DOFILE;
6254 if (!force_builtin && (gv = gv_override("do", 2))) {
6255 doop = S_new_entersubop(aTHX_ gv, term);
6258 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6264 =head1 Optree construction
6266 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6268 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
6269 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6270 be set automatically, and, shifted up eight bits, the eight bits of
6271 C<op_private>, except that the bit with value 1 or 2 is automatically
6272 set as required. C<listval> and C<subscript> supply the parameters of
6273 the slice; they are consumed by this function and become part of the
6274 constructed op tree.
6280 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6282 return newBINOP(OP_LSLICE, flags,
6283 list(force_list(subscript, 1)),
6284 list(force_list(listval, 1)) );
6287 #define ASSIGN_LIST 1
6288 #define ASSIGN_REF 2
6291 S_assignment_type(pTHX_ const OP *o)
6300 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6301 o = cUNOPo->op_first;
6303 flags = o->op_flags;
6305 if (type == OP_COND_EXPR) {
6306 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6307 const I32 t = assignment_type(sib);
6308 const I32 f = assignment_type(OpSIBLING(sib));
6310 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6312 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6313 yyerror("Assignment to both a list and a scalar");
6317 if (type == OP_SREFGEN)
6319 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6320 type = kid->op_type;
6321 flags |= kid->op_flags;
6322 if (!(flags & OPf_PARENS)
6323 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6324 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6330 if (type == OP_LIST &&
6331 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6332 o->op_private & OPpLVAL_INTRO)
6335 if (type == OP_LIST || flags & OPf_PARENS ||
6336 type == OP_RV2AV || type == OP_RV2HV ||
6337 type == OP_ASLICE || type == OP_HSLICE ||
6338 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6341 if (type == OP_PADAV || type == OP_PADHV)
6344 if (type == OP_RV2SV)
6352 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6354 Constructs, checks, and returns an assignment op. C<left> and C<right>
6355 supply the parameters of the assignment; they are consumed by this
6356 function and become part of the constructed op tree.
6358 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6359 a suitable conditional optree is constructed. If C<optype> is the opcode
6360 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6361 performs the binary operation and assigns the result to the left argument.
6362 Either way, if C<optype> is non-zero then C<flags> has no effect.
6364 If C<optype> is zero, then a plain scalar or list assignment is
6365 constructed. Which type of assignment it is is automatically determined.
6366 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6367 will be set automatically, and, shifted up eight bits, the eight bits
6368 of C<op_private>, except that the bit with value 1 or 2 is automatically
6375 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6381 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6382 return newLOGOP(optype, 0,
6383 op_lvalue(scalar(left), optype),
6384 newUNOP(OP_SASSIGN, 0, scalar(right)));
6387 return newBINOP(optype, OPf_STACKED,
6388 op_lvalue(scalar(left), optype), scalar(right));
6392 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6393 static const char no_list_state[] = "Initialization of state variables"
6394 " in list context currently forbidden";
6397 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6398 left->op_private &= ~ OPpSLICEWARNING;
6401 left = op_lvalue(left, OP_AASSIGN);
6402 curop = list(force_list(left, 1));
6403 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6404 o->op_private = (U8)(0 | (flags >> 8));
6406 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6408 OP* lop = ((LISTOP*)left)->op_first;
6410 if ((lop->op_type == OP_PADSV ||
6411 lop->op_type == OP_PADAV ||
6412 lop->op_type == OP_PADHV ||
6413 lop->op_type == OP_PADANY)
6414 && (lop->op_private & OPpPAD_STATE)
6416 yyerror(no_list_state);
6417 lop = OpSIBLING(lop);
6420 else if ( (left->op_private & OPpLVAL_INTRO)
6421 && (left->op_private & OPpPAD_STATE)
6422 && ( left->op_type == OP_PADSV
6423 || left->op_type == OP_PADAV
6424 || left->op_type == OP_PADHV
6425 || left->op_type == OP_PADANY)
6427 /* All single variable list context state assignments, hence
6437 yyerror(no_list_state);
6440 if (right && right->op_type == OP_SPLIT
6441 && !(right->op_flags & OPf_STACKED)) {
6442 OP* tmpop = ((LISTOP*)right)->op_first;
6443 PMOP * const pm = (PMOP*)tmpop;
6444 assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6447 !pm->op_pmreplrootu.op_pmtargetoff
6449 !pm->op_pmreplrootu.op_pmtargetgv
6453 if (!(left->op_private & OPpLVAL_INTRO) &&
6454 ( (left->op_type == OP_RV2AV &&
6455 (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6456 || left->op_type == OP_PADAV )
6458 if (tmpop != (OP *)pm) {
6460 pm->op_pmreplrootu.op_pmtargetoff
6461 = cPADOPx(tmpop)->op_padix;
6462 cPADOPx(tmpop)->op_padix = 0; /* steal it */
6464 pm->op_pmreplrootu.op_pmtargetgv
6465 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6466 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
6468 right->op_private |=
6469 left->op_private & OPpOUR_INTRO;
6472 pm->op_targ = left->op_targ;
6473 left->op_targ = 0; /* filch it */
6476 tmpop = cUNOPo->op_first; /* to list (nulled) */
6477 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6478 /* detach rest of siblings from o subtree,
6479 * and free subtree */
6480 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6481 op_free(o); /* blow off assign */
6482 right->op_flags &= ~OPf_WANT;
6483 /* "I don't know and I don't care." */
6486 else if (left->op_type == OP_RV2AV
6487 || left->op_type == OP_PADAV)
6489 /* Detach the array. */
6493 op_sibling_splice(cBINOPo->op_last,
6494 cUNOPx(cBINOPo->op_last)
6495 ->op_first, 1, NULL);
6496 assert(ary == left);
6497 /* Attach it to the split. */
6498 op_sibling_splice(right, cLISTOPx(right)->op_last,
6500 right->op_flags |= OPf_STACKED;
6501 /* Detach split and expunge aassign as above. */
6504 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6505 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6508 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6509 SV * const sv = *svp;
6510 if (SvIOK(sv) && SvIVX(sv) == 0)
6512 if (right->op_private & OPpSPLIT_IMPLIM) {
6513 /* our own SV, created in ck_split */
6515 sv_setiv(sv, PL_modcount+1);
6518 /* SV may belong to someone else */
6520 *svp = newSViv(PL_modcount+1);
6528 if (assign_type == ASSIGN_REF)
6529 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6531 right = newOP(OP_UNDEF, 0);
6532 if (right->op_type == OP_READLINE) {
6533 right->op_flags |= OPf_STACKED;
6534 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6538 o = newBINOP(OP_SASSIGN, flags,
6539 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6545 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6547 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6548 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6549 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6550 If C<label> is non-null, it supplies the name of a label to attach to
6551 the state op; this function takes ownership of the memory pointed at by
6552 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
6555 If C<o> is null, the state op is returned. Otherwise the state op is
6556 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
6557 is consumed by this function and becomes part of the returned op tree.
6563 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6566 const U32 seq = intro_my();
6567 const U32 utf8 = flags & SVf_UTF8;
6570 PL_parser->parsed_sub = 0;
6574 NewOp(1101, cop, 1, COP);
6575 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6576 OpTYPE_set(cop, OP_DBSTATE);
6579 OpTYPE_set(cop, OP_NEXTSTATE);
6581 cop->op_flags = (U8)flags;
6582 CopHINTS_set(cop, PL_hints);
6584 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6586 cop->op_next = (OP*)cop;
6589 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6590 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6592 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6594 PL_hints |= HINT_BLOCK_SCOPE;
6595 /* It seems that we need to defer freeing this pointer, as other parts
6596 of the grammar end up wanting to copy it after this op has been
6601 if (PL_parser->preambling != NOLINE) {
6602 CopLINE_set(cop, PL_parser->preambling);
6603 PL_parser->copline = NOLINE;
6605 else if (PL_parser->copline == NOLINE)
6606 CopLINE_set(cop, CopLINE(PL_curcop));
6608 CopLINE_set(cop, PL_parser->copline);
6609 PL_parser->copline = NOLINE;
6612 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6614 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6616 CopSTASH_set(cop, PL_curstash);
6618 if (cop->op_type == OP_DBSTATE) {
6619 /* this line can have a breakpoint - store the cop in IV */
6620 AV *av = CopFILEAVx(PL_curcop);
6622 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6623 if (svp && *svp != &PL_sv_undef ) {
6624 (void)SvIOK_on(*svp);
6625 SvIV_set(*svp, PTR2IV(cop));
6630 if (flags & OPf_SPECIAL)
6632 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6636 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6638 Constructs, checks, and returns a logical (flow control) op. C<type>
6639 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6640 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6641 the eight bits of C<op_private>, except that the bit with value 1 is
6642 automatically set. C<first> supplies the expression controlling the
6643 flow, and C<other> supplies the side (alternate) chain of ops; they are
6644 consumed by this function and become part of the constructed op tree.
6650 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6652 PERL_ARGS_ASSERT_NEWLOGOP;
6654 return new_logop(type, flags, &first, &other);
6658 S_search_const(pTHX_ OP *o)
6660 PERL_ARGS_ASSERT_SEARCH_CONST;
6662 switch (o->op_type) {
6666 if (o->op_flags & OPf_KIDS)
6667 return search_const(cUNOPo->op_first);
6674 if (!(o->op_flags & OPf_KIDS))
6676 kid = cLISTOPo->op_first;
6678 switch (kid->op_type) {
6682 kid = OpSIBLING(kid);
6685 if (kid != cLISTOPo->op_last)
6691 kid = cLISTOPo->op_last;
6693 return search_const(kid);
6701 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6709 int prepend_not = 0;
6711 PERL_ARGS_ASSERT_NEW_LOGOP;
6716 /* [perl #59802]: Warn about things like "return $a or $b", which
6717 is parsed as "(return $a) or $b" rather than "return ($a or
6718 $b)". NB: This also applies to xor, which is why we do it
6721 switch (first->op_type) {
6725 /* XXX: Perhaps we should emit a stronger warning for these.
6726 Even with the high-precedence operator they don't seem to do
6729 But until we do, fall through here.
6735 /* XXX: Currently we allow people to "shoot themselves in the
6736 foot" by explicitly writing "(return $a) or $b".
6738 Warn unless we are looking at the result from folding or if
6739 the programmer explicitly grouped the operators like this.
6740 The former can occur with e.g.
6742 use constant FEATURE => ( $] >= ... );
6743 sub { not FEATURE and return or do_stuff(); }
6745 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6746 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6747 "Possible precedence issue with control flow operator");
6748 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6754 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6755 return newBINOP(type, flags, scalar(first), scalar(other));
6757 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6758 || type == OP_CUSTOM);
6760 scalarboolean(first);
6762 /* search for a constant op that could let us fold the test */
6763 if ((cstop = search_const(first))) {
6764 if (cstop->op_private & OPpCONST_STRICT)
6765 no_bareword_allowed(cstop);
6766 else if ((cstop->op_private & OPpCONST_BARE))
6767 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6768 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6769 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6770 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6771 /* Elide the (constant) lhs, since it can't affect the outcome */
6773 if (other->op_type == OP_CONST)
6774 other->op_private |= OPpCONST_SHORTCIRCUIT;
6776 if (other->op_type == OP_LEAVE)
6777 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6778 else if (other->op_type == OP_MATCH
6779 || other->op_type == OP_SUBST
6780 || other->op_type == OP_TRANSR
6781 || other->op_type == OP_TRANS)
6782 /* Mark the op as being unbindable with =~ */
6783 other->op_flags |= OPf_SPECIAL;
6785 other->op_folded = 1;
6789 /* Elide the rhs, since the outcome is entirely determined by
6790 * the (constant) lhs */
6792 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6793 const OP *o2 = other;
6794 if ( ! (o2->op_type == OP_LIST
6795 && (( o2 = cUNOPx(o2)->op_first))
6796 && o2->op_type == OP_PUSHMARK
6797 && (( o2 = OpSIBLING(o2))) )
6800 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6801 || o2->op_type == OP_PADHV)
6802 && o2->op_private & OPpLVAL_INTRO
6803 && !(o2->op_private & OPpPAD_STATE))
6805 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6806 "Deprecated use of my() in false conditional");
6810 if (cstop->op_type == OP_CONST)
6811 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6816 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6817 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6819 const OP * const k1 = ((UNOP*)first)->op_first;
6820 const OP * const k2 = OpSIBLING(k1);
6822 switch (first->op_type)
6825 if (k2 && k2->op_type == OP_READLINE
6826 && (k2->op_flags & OPf_STACKED)
6827 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6829 warnop = k2->op_type;
6834 if (k1->op_type == OP_READDIR
6835 || k1->op_type == OP_GLOB
6836 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6837 || k1->op_type == OP_EACH
6838 || k1->op_type == OP_AEACH)
6840 warnop = ((k1->op_type == OP_NULL)
6841 ? (OPCODE)k1->op_targ : k1->op_type);
6846 const line_t oldline = CopLINE(PL_curcop);
6847 /* This ensures that warnings are reported at the first line
6848 of the construction, not the last. */
6849 CopLINE_set(PL_curcop, PL_parser->copline);
6850 Perl_warner(aTHX_ packWARN(WARN_MISC),
6851 "Value of %s%s can be \"0\"; test with defined()",
6853 ((warnop == OP_READLINE || warnop == OP_GLOB)
6854 ? " construct" : "() operator"));
6855 CopLINE_set(PL_curcop, oldline);
6859 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6860 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6862 /* optimize AND and OR ops that have NOTs as children */
6863 if (first->op_type == OP_NOT
6864 && (first->op_flags & OPf_KIDS)
6865 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6866 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6868 if (type == OP_AND || type == OP_OR) {
6874 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6876 prepend_not = 1; /* prepend a NOT op later */
6881 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6882 logop->op_flags |= (U8)flags;
6883 logop->op_private = (U8)(1 | (flags >> 8));
6885 /* establish postfix order */
6886 logop->op_next = LINKLIST(first);
6887 first->op_next = (OP*)logop;
6888 assert(!OpHAS_SIBLING(first));
6889 op_sibling_splice((OP*)logop, first, 0, other);
6891 CHECKOP(type,logop);
6893 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
6894 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
6902 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6904 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6905 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6906 will be set automatically, and, shifted up eight bits, the eight bits of
6907 C<op_private>, except that the bit with value 1 is automatically set.
6908 C<first> supplies the expression selecting between the two branches,
6909 and C<trueop> and C<falseop> supply the branches; they are consumed by
6910 this function and become part of the constructed op tree.
6916 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6924 PERL_ARGS_ASSERT_NEWCONDOP;
6927 return newLOGOP(OP_AND, 0, first, trueop);
6929 return newLOGOP(OP_OR, 0, first, falseop);
6931 scalarboolean(first);
6932 if ((cstop = search_const(first))) {
6933 /* Left or right arm of the conditional? */
6934 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6935 OP *live = left ? trueop : falseop;
6936 OP *const dead = left ? falseop : trueop;
6937 if (cstop->op_private & OPpCONST_BARE &&
6938 cstop->op_private & OPpCONST_STRICT) {
6939 no_bareword_allowed(cstop);
6943 if (live->op_type == OP_LEAVE)
6944 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6945 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6946 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6947 /* Mark the op as being unbindable with =~ */
6948 live->op_flags |= OPf_SPECIAL;
6949 live->op_folded = 1;
6952 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6953 logop->op_flags |= (U8)flags;
6954 logop->op_private = (U8)(1 | (flags >> 8));
6955 logop->op_next = LINKLIST(falseop);
6957 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6960 /* establish postfix order */
6961 start = LINKLIST(first);
6962 first->op_next = (OP*)logop;
6964 /* make first, trueop, falseop siblings */
6965 op_sibling_splice((OP*)logop, first, 0, trueop);
6966 op_sibling_splice((OP*)logop, trueop, 0, falseop);
6968 o = newUNOP(OP_NULL, 0, (OP*)logop);
6970 trueop->op_next = falseop->op_next = o;
6977 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6979 Constructs and returns a C<range> op, with subordinate C<flip> and
6980 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
6981 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6982 for both the C<flip> and C<range> ops, except that the bit with value
6983 1 is automatically set. C<left> and C<right> supply the expressions
6984 controlling the endpoints of the range; they are consumed by this function
6985 and become part of the constructed op tree.
6991 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6999 PERL_ARGS_ASSERT_NEWRANGE;
7001 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
7002 range->op_flags = OPf_KIDS;
7003 leftstart = LINKLIST(left);
7004 range->op_private = (U8)(1 | (flags >> 8));
7006 /* make left and right siblings */
7007 op_sibling_splice((OP*)range, left, 0, right);
7009 range->op_next = (OP*)range;
7010 flip = newUNOP(OP_FLIP, flags, (OP*)range);
7011 flop = newUNOP(OP_FLOP, 0, flip);
7012 o = newUNOP(OP_NULL, 0, flop);
7014 range->op_next = leftstart;
7016 left->op_next = flip;
7017 right->op_next = flop;
7020 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7021 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7023 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7024 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7025 SvPADTMP_on(PAD_SV(flip->op_targ));
7027 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7028 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7030 /* check barewords before they might be optimized aways */
7031 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7032 no_bareword_allowed(left);
7033 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7034 no_bareword_allowed(right);
7037 if (!flip->op_private || !flop->op_private)
7038 LINKLIST(o); /* blow off optimizer unless constant */
7044 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7046 Constructs, checks, and returns an op tree expressing a loop. This is
7047 only a loop in the control flow through the op tree; it does not have
7048 the heavyweight loop structure that allows exiting the loop by C<last>
7049 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
7050 top-level op, except that some bits will be set automatically as required.
7051 C<expr> supplies the expression controlling loop iteration, and C<block>
7052 supplies the body of the loop; they are consumed by this function and
7053 become part of the constructed op tree. C<debuggable> is currently
7054 unused and should always be 1.
7060 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7064 const bool once = block && block->op_flags & OPf_SPECIAL &&
7065 block->op_type == OP_NULL;
7067 PERL_UNUSED_ARG(debuggable);
7071 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7072 || ( expr->op_type == OP_NOT
7073 && cUNOPx(expr)->op_first->op_type == OP_CONST
7074 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7077 /* Return the block now, so that S_new_logop does not try to
7079 return block; /* do {} while 0 does once */
7080 if (expr->op_type == OP_READLINE
7081 || expr->op_type == OP_READDIR
7082 || expr->op_type == OP_GLOB
7083 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7084 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7085 expr = newUNOP(OP_DEFINED, 0,
7086 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7087 } else if (expr->op_flags & OPf_KIDS) {
7088 const OP * const k1 = ((UNOP*)expr)->op_first;
7089 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7090 switch (expr->op_type) {
7092 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7093 && (k2->op_flags & OPf_STACKED)
7094 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7095 expr = newUNOP(OP_DEFINED, 0, expr);
7099 if (k1 && (k1->op_type == OP_READDIR
7100 || k1->op_type == OP_GLOB
7101 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7102 || k1->op_type == OP_EACH
7103 || k1->op_type == OP_AEACH))
7104 expr = newUNOP(OP_DEFINED, 0, expr);
7110 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7111 * op, in listop. This is wrong. [perl #27024] */
7113 block = newOP(OP_NULL, 0);
7114 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7115 o = new_logop(OP_AND, 0, &expr, &listop);
7122 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7124 if (once && o != listop)
7126 assert(cUNOPo->op_first->op_type == OP_AND
7127 || cUNOPo->op_first->op_type == OP_OR);
7128 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7132 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7134 o->op_flags |= flags;
7136 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7141 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7143 Constructs, checks, and returns an op tree expressing a C<while> loop.
7144 This is a heavyweight loop, with structure that allows exiting the loop
7145 by C<last> and suchlike.
7147 C<loop> is an optional preconstructed C<enterloop> op to use in the
7148 loop; if it is null then a suitable op will be constructed automatically.
7149 C<expr> supplies the loop's controlling expression. C<block> supplies the
7150 main body of the loop, and C<cont> optionally supplies a C<continue> block
7151 that operates as a second half of the body. All of these optree inputs
7152 are consumed by this function and become part of the constructed op tree.
7154 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7155 op and, shifted up eight bits, the eight bits of C<op_private> for
7156 the C<leaveloop> op, except that (in both cases) some bits will be set
7157 automatically. C<debuggable> is currently unused and should always be 1.
7158 C<has_my> can be supplied as true to force the
7159 loop body to be enclosed in its own scope.
7165 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7166 OP *expr, OP *block, OP *cont, I32 has_my)
7175 PERL_UNUSED_ARG(debuggable);
7178 if (expr->op_type == OP_READLINE
7179 || expr->op_type == OP_READDIR
7180 || expr->op_type == OP_GLOB
7181 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7182 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7183 expr = newUNOP(OP_DEFINED, 0,
7184 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7185 } else if (expr->op_flags & OPf_KIDS) {
7186 const OP * const k1 = ((UNOP*)expr)->op_first;
7187 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7188 switch (expr->op_type) {
7190 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7191 && (k2->op_flags & OPf_STACKED)
7192 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7193 expr = newUNOP(OP_DEFINED, 0, expr);
7197 if (k1 && (k1->op_type == OP_READDIR
7198 || k1->op_type == OP_GLOB
7199 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7200 || k1->op_type == OP_EACH
7201 || k1->op_type == OP_AEACH))
7202 expr = newUNOP(OP_DEFINED, 0, expr);
7209 block = newOP(OP_NULL, 0);
7210 else if (cont || has_my) {
7211 block = op_scope(block);
7215 next = LINKLIST(cont);
7218 OP * const unstack = newOP(OP_UNSTACK, 0);
7221 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7225 listop = op_append_list(OP_LINESEQ, block, cont);
7227 redo = LINKLIST(listop);
7231 o = new_logop(OP_AND, 0, &expr, &listop);
7232 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7234 return expr; /* listop already freed by new_logop */
7237 ((LISTOP*)listop)->op_last->op_next =
7238 (o == listop ? redo : LINKLIST(o));
7244 NewOp(1101,loop,1,LOOP);
7245 OpTYPE_set(loop, OP_ENTERLOOP);
7246 loop->op_private = 0;
7247 loop->op_next = (OP*)loop;
7250 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7252 loop->op_redoop = redo;
7253 loop->op_lastop = o;
7254 o->op_private |= loopflags;
7257 loop->op_nextop = next;
7259 loop->op_nextop = o;
7261 o->op_flags |= flags;
7262 o->op_private |= (flags >> 8);
7267 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7269 Constructs, checks, and returns an op tree expressing a C<foreach>
7270 loop (iteration through a list of values). This is a heavyweight loop,
7271 with structure that allows exiting the loop by C<last> and suchlike.
7273 C<sv> optionally supplies the variable that will be aliased to each
7274 item in turn; if null, it defaults to C<$_>.
7275 C<expr> supplies the list of values to iterate over. C<block> supplies
7276 the main body of the loop, and C<cont> optionally supplies a C<continue>
7277 block that operates as a second half of the body. All of these optree
7278 inputs are consumed by this function and become part of the constructed
7281 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7282 op and, shifted up eight bits, the eight bits of C<op_private> for
7283 the C<leaveloop> op, except that (in both cases) some bits will be set
7290 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7295 PADOFFSET padoff = 0;
7299 PERL_ARGS_ASSERT_NEWFOROP;
7302 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7303 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7304 OpTYPE_set(sv, OP_RV2GV);
7306 /* The op_type check is needed to prevent a possible segfault
7307 * if the loop variable is undeclared and 'strict vars' is in
7308 * effect. This is illegal but is nonetheless parsed, so we
7309 * may reach this point with an OP_CONST where we're expecting
7312 if (cUNOPx(sv)->op_first->op_type == OP_GV
7313 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7314 iterpflags |= OPpITER_DEF;
7316 else if (sv->op_type == OP_PADSV) { /* private variable */
7317 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7318 padoff = sv->op_targ;
7322 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7324 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7327 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7329 PADNAME * const pn = PAD_COMPNAME(padoff);
7330 const char * const name = PadnamePV(pn);
7332 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7333 iterpflags |= OPpITER_DEF;
7337 sv = newGVOP(OP_GV, 0, PL_defgv);
7338 iterpflags |= OPpITER_DEF;
7341 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7342 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7343 iterflags |= OPf_STACKED;
7345 else if (expr->op_type == OP_NULL &&
7346 (expr->op_flags & OPf_KIDS) &&
7347 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7349 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7350 * set the STACKED flag to indicate that these values are to be
7351 * treated as min/max values by 'pp_enteriter'.
7353 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7354 LOGOP* const range = (LOGOP*) flip->op_first;
7355 OP* const left = range->op_first;
7356 OP* const right = OpSIBLING(left);
7359 range->op_flags &= ~OPf_KIDS;
7360 /* detach range's children */
7361 op_sibling_splice((OP*)range, NULL, -1, NULL);
7363 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7364 listop->op_first->op_next = range->op_next;
7365 left->op_next = range->op_other;
7366 right->op_next = (OP*)listop;
7367 listop->op_next = listop->op_first;
7370 expr = (OP*)(listop);
7372 iterflags |= OPf_STACKED;
7375 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7378 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7379 op_append_elem(OP_LIST, list(expr),
7381 assert(!loop->op_next);
7382 /* for my $x () sets OPpLVAL_INTRO;
7383 * for our $x () sets OPpOUR_INTRO */
7384 loop->op_private = (U8)iterpflags;
7385 if (loop->op_slabbed
7386 && DIFF(loop, OpSLOT(loop)->opslot_next)
7387 < SIZE_TO_PSIZE(sizeof(LOOP)))
7390 NewOp(1234,tmp,1,LOOP);
7391 Copy(loop,tmp,1,LISTOP);
7392 #ifdef PERL_OP_PARENT
7393 assert(loop->op_last->op_sibparent == (OP*)loop);
7394 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7396 S_op_destroy(aTHX_ (OP*)loop);
7399 else if (!loop->op_slabbed)
7401 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7402 #ifdef PERL_OP_PARENT
7403 OpLASTSIB_set(loop->op_last, (OP*)loop);
7406 loop->op_targ = padoff;
7407 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7412 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7414 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7415 or C<last>). C<type> is the opcode. C<label> supplies the parameter
7416 determining the target of the op; it is consumed by this function and
7417 becomes part of the constructed op tree.
7423 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7427 PERL_ARGS_ASSERT_NEWLOOPEX;
7429 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7430 || type == OP_CUSTOM);
7432 if (type != OP_GOTO) {
7433 /* "last()" means "last" */
7434 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7435 o = newOP(type, OPf_SPECIAL);
7439 /* Check whether it's going to be a goto &function */
7440 if (label->op_type == OP_ENTERSUB
7441 && !(label->op_flags & OPf_STACKED))
7442 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7445 /* Check for a constant argument */
7446 if (label->op_type == OP_CONST) {
7447 SV * const sv = ((SVOP *)label)->op_sv;
7449 const char *s = SvPV_const(sv,l);
7450 if (l == strlen(s)) {
7452 SvUTF8(((SVOP*)label)->op_sv),
7454 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7458 /* If we have already created an op, we do not need the label. */
7461 else o = newUNOP(type, OPf_STACKED, label);
7463 PL_hints |= HINT_BLOCK_SCOPE;
7467 /* if the condition is a literal array or hash
7468 (or @{ ... } etc), make a reference to it.
7471 S_ref_array_or_hash(pTHX_ OP *cond)
7474 && (cond->op_type == OP_RV2AV
7475 || cond->op_type == OP_PADAV
7476 || cond->op_type == OP_RV2HV
7477 || cond->op_type == OP_PADHV))
7479 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7482 && (cond->op_type == OP_ASLICE
7483 || cond->op_type == OP_KVASLICE
7484 || cond->op_type == OP_HSLICE
7485 || cond->op_type == OP_KVHSLICE)) {
7487 /* anonlist now needs a list from this op, was previously used in
7489 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7490 cond->op_flags |= OPf_WANT_LIST;
7492 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7499 /* These construct the optree fragments representing given()
7502 entergiven and enterwhen are LOGOPs; the op_other pointer
7503 points up to the associated leave op. We need this so we
7504 can put it in the context and make break/continue work.
7505 (Also, of course, pp_enterwhen will jump straight to
7506 op_other if the match fails.)
7510 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7511 I32 enter_opcode, I32 leave_opcode,
7512 PADOFFSET entertarg)
7518 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7519 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7521 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7522 enterop->op_targ = 0;
7523 enterop->op_private = 0;
7525 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7528 /* prepend cond if we have one */
7529 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7531 o->op_next = LINKLIST(cond);
7532 cond->op_next = (OP *) enterop;
7535 /* This is a default {} block */
7536 enterop->op_flags |= OPf_SPECIAL;
7537 o ->op_flags |= OPf_SPECIAL;
7539 o->op_next = (OP *) enterop;
7542 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7543 entergiven and enterwhen both
7546 enterop->op_next = LINKLIST(block);
7547 block->op_next = enterop->op_other = o;
7552 /* Does this look like a boolean operation? For these purposes
7553 a boolean operation is:
7554 - a subroutine call [*]
7555 - a logical connective
7556 - a comparison operator
7557 - a filetest operator, with the exception of -s -M -A -C
7558 - defined(), exists() or eof()
7559 - /$re/ or $foo =~ /$re/
7561 [*] possibly surprising
7564 S_looks_like_bool(pTHX_ const OP *o)
7566 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7568 switch(o->op_type) {
7571 return looks_like_bool(cLOGOPo->op_first);
7575 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7578 looks_like_bool(cLOGOPo->op_first)
7579 && looks_like_bool(sibl));
7585 o->op_flags & OPf_KIDS
7586 && looks_like_bool(cUNOPo->op_first));
7590 case OP_NOT: case OP_XOR:
7592 case OP_EQ: case OP_NE: case OP_LT:
7593 case OP_GT: case OP_LE: case OP_GE:
7595 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7596 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7598 case OP_SEQ: case OP_SNE: case OP_SLT:
7599 case OP_SGT: case OP_SLE: case OP_SGE:
7603 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7604 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7605 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7606 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7607 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7608 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7609 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7610 case OP_FTTEXT: case OP_FTBINARY:
7612 case OP_DEFINED: case OP_EXISTS:
7613 case OP_MATCH: case OP_EOF:
7620 /* Detect comparisons that have been optimized away */
7621 if (cSVOPo->op_sv == &PL_sv_yes
7622 || cSVOPo->op_sv == &PL_sv_no)
7635 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7637 Constructs, checks, and returns an op tree expressing a C<given> block.
7638 C<cond> supplies the expression that will be locally assigned to a lexical
7639 variable, and C<block> supplies the body of the C<given> construct; they
7640 are consumed by this function and become part of the constructed op tree.
7641 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7647 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7649 PERL_ARGS_ASSERT_NEWGIVENOP;
7650 PERL_UNUSED_ARG(defsv_off);
7653 return newGIVWHENOP(
7654 ref_array_or_hash(cond),
7656 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7661 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7663 Constructs, checks, and returns an op tree expressing a C<when> block.
7664 C<cond> supplies the test expression, and C<block> supplies the block
7665 that will be executed if the test evaluates to true; they are consumed
7666 by this function and become part of the constructed op tree. C<cond>
7667 will be interpreted DWIMically, often as a comparison against C<$_>,
7668 and may be null to generate a C<default> block.
7674 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7676 const bool cond_llb = (!cond || looks_like_bool(cond));
7679 PERL_ARGS_ASSERT_NEWWHENOP;
7684 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7686 scalar(ref_array_or_hash(cond)));
7689 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7692 /* must not conflict with SVf_UTF8 */
7693 #define CV_CKPROTO_CURSTASH 0x1
7696 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7697 const STRLEN len, const U32 flags)
7699 SV *name = NULL, *msg;
7700 const char * cvp = SvROK(cv)
7701 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7702 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7705 STRLEN clen = CvPROTOLEN(cv), plen = len;
7707 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7709 if (p == NULL && cvp == NULL)
7712 if (!ckWARN_d(WARN_PROTOTYPE))
7716 p = S_strip_spaces(aTHX_ p, &plen);
7717 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7718 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7719 if (plen == clen && memEQ(cvp, p, plen))
7722 if (flags & SVf_UTF8) {
7723 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7727 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7733 msg = sv_newmortal();
7738 gv_efullname3(name = sv_newmortal(), gv, NULL);
7739 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7740 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7741 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7742 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7743 sv_catpvs(name, "::");
7745 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7746 assert (CvNAMED(SvRV_const(gv)));
7747 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7749 else sv_catsv(name, (SV *)gv);
7751 else name = (SV *)gv;
7753 sv_setpvs(msg, "Prototype mismatch:");
7755 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7757 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7758 UTF8fARG(SvUTF8(cv),clen,cvp)
7761 sv_catpvs(msg, ": none");
7762 sv_catpvs(msg, " vs ");
7764 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7766 sv_catpvs(msg, "none");
7767 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7770 static void const_sv_xsub(pTHX_ CV* cv);
7771 static void const_av_xsub(pTHX_ CV* cv);
7775 =head1 Optree Manipulation Functions
7777 =for apidoc cv_const_sv
7779 If C<cv> is a constant sub eligible for inlining, returns the constant
7780 value returned by the sub. Otherwise, returns C<NULL>.
7782 Constant subs can be created with C<newCONSTSUB> or as described in
7783 L<perlsub/"Constant Functions">.
7788 Perl_cv_const_sv(const CV *const cv)
7793 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7795 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7796 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7801 Perl_cv_const_sv_or_av(const CV * const cv)
7805 if (SvROK(cv)) return SvRV((SV *)cv);
7806 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7807 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7810 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7811 * Can be called in 2 ways:
7814 * look for a single OP_CONST with attached value: return the value
7816 * allow_lex && !CvCONST(cv);
7818 * examine the clone prototype, and if contains only a single
7819 * OP_CONST, return the value; or if it contains a single PADSV ref-
7820 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7821 * a candidate for "constizing" at clone time, and return NULL.
7825 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7833 for (; o; o = o->op_next) {
7834 const OPCODE type = o->op_type;
7836 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7838 || type == OP_PUSHMARK)
7840 if (type == OP_DBSTATE)
7842 if (type == OP_LEAVESUB)
7846 if (type == OP_CONST && cSVOPo->op_sv)
7848 else if (type == OP_UNDEF && !o->op_private) {
7852 else if (allow_lex && type == OP_PADSV) {
7853 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7855 sv = &PL_sv_undef; /* an arbitrary non-null value */
7873 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7874 PADNAME * const name, SV ** const const_svp)
7881 if (CvFLAGS(PL_compcv)) {
7882 /* might have had built-in attrs applied */
7883 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7884 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7885 && ckWARN(WARN_MISC))
7887 /* protect against fatal warnings leaking compcv */
7888 SAVEFREESV(PL_compcv);
7889 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7890 SvREFCNT_inc_simple_void_NN(PL_compcv);
7893 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7894 & ~(CVf_LVALUE * pureperl));
7899 /* redundant check for speed: */
7900 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7901 const line_t oldline = CopLINE(PL_curcop);
7904 : sv_2mortal(newSVpvn_utf8(
7905 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7907 if (PL_parser && PL_parser->copline != NOLINE)
7908 /* This ensures that warnings are reported at the first
7909 line of a redefinition, not the last. */
7910 CopLINE_set(PL_curcop, PL_parser->copline);
7911 /* protect against fatal warnings leaking compcv */
7912 SAVEFREESV(PL_compcv);
7913 report_redefined_cv(namesv, cv, const_svp);
7914 SvREFCNT_inc_simple_void_NN(PL_compcv);
7915 CopLINE_set(PL_curcop, oldline);
7922 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7927 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7930 CV *compcv = PL_compcv;
7933 PADOFFSET pax = o->op_targ;
7934 CV *outcv = CvOUTSIDE(PL_compcv);
7937 bool reusable = FALSE;
7939 #ifdef PERL_DEBUG_READONLY_OPS
7940 OPSLAB *slab = NULL;
7943 PERL_ARGS_ASSERT_NEWMYSUB;
7945 /* Find the pad slot for storing the new sub.
7946 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7947 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7948 ing sub. And then we need to dig deeper if this is a lexical from
7950 my sub foo; sub { sub foo { } }
7953 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7954 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7955 pax = PARENT_PAD_INDEX(name);
7956 outcv = CvOUTSIDE(outcv);
7961 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7962 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7963 spot = (CV **)svspot;
7965 if (!(PL_parser && PL_parser->error_count))
7966 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
7969 assert(proto->op_type == OP_CONST);
7970 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7971 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7981 if (PL_parser && PL_parser->error_count) {
7983 SvREFCNT_dec(PL_compcv);
7988 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7990 svspot = (SV **)(spot = &clonee);
7992 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7995 assert (SvTYPE(*spot) == SVt_PVCV);
7997 hek = CvNAME_HEK(*spot);
8001 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8002 CvNAME_HEK_set(*spot, hek =
8005 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8009 CvLEXICAL_on(*spot);
8011 cv = PadnamePROTOCV(name);
8012 svspot = (SV **)(spot = &PadnamePROTOCV(name));
8016 /* This makes sub {}; work as expected. */
8017 if (block->op_type == OP_STUB) {
8018 const line_t l = PL_parser->copline;
8020 block = newSTATEOP(0, NULL, 0);
8021 PL_parser->copline = l;
8023 block = CvLVALUE(compcv)
8024 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8025 ? newUNOP(OP_LEAVESUBLV, 0,
8026 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8027 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8028 start = LINKLIST(block);
8030 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8031 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8039 const bool exists = CvROOT(cv) || CvXSUB(cv);
8041 /* if the subroutine doesn't exist and wasn't pre-declared
8042 * with a prototype, assume it will be AUTOLOADed,
8043 * skipping the prototype check
8045 if (exists || SvPOK(cv))
8046 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8048 /* already defined? */
8050 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8053 if (attrs) goto attrs;
8054 /* just a "sub foo;" when &foo is already defined */
8059 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8065 SvREFCNT_inc_simple_void_NN(const_sv);
8066 SvFLAGS(const_sv) |= SVs_PADTMP;
8068 assert(!CvROOT(cv) && !CvCONST(cv));
8072 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8073 CvFILE_set_from_cop(cv, PL_curcop);
8074 CvSTASH_set(cv, PL_curstash);
8077 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8078 CvXSUBANY(cv).any_ptr = const_sv;
8079 CvXSUB(cv) = const_sv_xsub;
8083 CvFLAGS(cv) |= CvMETHOD(compcv);
8085 SvREFCNT_dec(compcv);
8089 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8090 determine whether this sub definition is in the same scope as its
8091 declaration. If this sub definition is inside an inner named pack-
8092 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8093 the package sub. So check PadnameOUTER(name) too.
8095 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8096 assert(!CvWEAKOUTSIDE(compcv));
8097 SvREFCNT_dec(CvOUTSIDE(compcv));
8098 CvWEAKOUTSIDE_on(compcv);
8100 /* XXX else do we have a circular reference? */
8101 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8102 /* transfer PL_compcv to cv */
8105 cv_flags_t preserved_flags =
8106 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8107 PADLIST *const temp_padl = CvPADLIST(cv);
8108 CV *const temp_cv = CvOUTSIDE(cv);
8109 const cv_flags_t other_flags =
8110 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8111 OP * const cvstart = CvSTART(cv);
8115 CvFLAGS(compcv) | preserved_flags;
8116 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8117 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8118 CvPADLIST_set(cv, CvPADLIST(compcv));
8119 CvOUTSIDE(compcv) = temp_cv;
8120 CvPADLIST_set(compcv, temp_padl);
8121 CvSTART(cv) = CvSTART(compcv);
8122 CvSTART(compcv) = cvstart;
8123 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8124 CvFLAGS(compcv) |= other_flags;
8126 if (CvFILE(cv) && CvDYNFILE(cv)) {
8127 Safefree(CvFILE(cv));
8130 /* inner references to compcv must be fixed up ... */
8131 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8132 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8133 ++PL_sub_generation;
8136 /* Might have had built-in attributes applied -- propagate them. */
8137 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8139 /* ... before we throw it away */
8140 SvREFCNT_dec(compcv);
8141 PL_compcv = compcv = cv;
8149 if (!CvNAME_HEK(cv)) {
8150 if (hek) (void)share_hek_hek(hek);
8154 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8155 hek = share_hek(PadnamePV(name)+1,
8156 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8159 CvNAME_HEK_set(cv, hek);
8161 if (const_sv) goto clone;
8163 CvFILE_set_from_cop(cv, PL_curcop);
8164 CvSTASH_set(cv, PL_curstash);
8167 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8168 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8174 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8175 the debugger could be able to set a breakpoint in, so signal to
8176 pp_entereval that it should not throw away any saved lines at scope
8179 PL_breakable_sub_gen++;
8181 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8182 OpREFCNT_set(CvROOT(cv), 1);
8183 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8184 itself has a refcount. */
8186 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8187 #ifdef PERL_DEBUG_READONLY_OPS
8188 slab = (OPSLAB *)CvSTART(cv);
8190 CvSTART(cv) = start;
8192 finalize_optree(CvROOT(cv));
8193 S_prune_chain_head(&CvSTART(cv));
8195 /* now that optimizer has done its work, adjust pad values */
8197 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8201 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8202 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8206 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8207 SV * const tmpstr = sv_newmortal();
8208 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8209 GV_ADDMULTI, SVt_PVHV);
8211 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8214 (long)CopLINE(PL_curcop));
8215 if (HvNAME_HEK(PL_curstash)) {
8216 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8217 sv_catpvs(tmpstr, "::");
8219 else sv_setpvs(tmpstr, "__ANON__::");
8220 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8221 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8222 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8223 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8224 hv = GvHVn(db_postponed);
8225 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8226 CV * const pcv = GvCV(db_postponed);
8232 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8240 assert(CvDEPTH(outcv));
8242 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8243 if (reusable) cv_clone_into(clonee, *spot);
8244 else *spot = cv_clone(clonee);
8245 SvREFCNT_dec_NN(clonee);
8248 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8249 PADOFFSET depth = CvDEPTH(outcv);
8252 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8254 *svspot = SvREFCNT_inc_simple_NN(cv);
8255 SvREFCNT_dec(oldcv);
8261 PL_parser->copline = NOLINE;
8263 #ifdef PERL_DEBUG_READONLY_OPS
8273 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8274 OP *block, bool o_is_gv)
8278 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8282 const bool ec = PL_parser && PL_parser->error_count;
8283 /* If the subroutine has no body, no attributes, and no builtin attributes
8284 then it's just a sub declaration, and we may be able to get away with
8285 storing with a placeholder scalar in the symbol table, rather than a
8286 full CV. If anything is present then it will take a full CV to
8288 const I32 gv_fetch_flags
8289 = ec ? GV_NOADD_NOINIT :
8290 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8291 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8293 const char * const name =
8294 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8296 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8297 bool evanescent = FALSE;
8299 #ifdef PERL_DEBUG_READONLY_OPS
8300 OPSLAB *slab = NULL;
8308 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8309 hek and CvSTASH pointer together can imply the GV. If the name
8310 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8311 CvSTASH, so forego the optimisation if we find any.
8312 Also, we may be called from load_module at run time, so
8313 PL_curstash (which sets CvSTASH) may not point to the stash the
8314 sub is stored in. */
8316 ec ? GV_NOADD_NOINIT
8317 : PL_curstash != CopSTASH(PL_curcop)
8318 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8320 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8321 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8323 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8324 SV * const sv = sv_newmortal();
8325 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8326 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8327 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8328 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8330 } else if (PL_curstash) {
8331 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8334 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8339 move_proto_attr(&proto, &attrs, gv);
8342 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8347 assert(proto->op_type == OP_CONST);
8348 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8349 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8363 if (name) SvREFCNT_dec(PL_compcv);
8364 else cv = PL_compcv;
8366 if (name && block) {
8367 const char *s = strrchr(name, ':');
8369 if (strEQ(s, "BEGIN")) {
8370 if (PL_in_eval & EVAL_KEEPERR)
8371 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8373 SV * const errsv = ERRSV;
8374 /* force display of errors found but not reported */
8375 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8376 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8383 if (!block && SvTYPE(gv) != SVt_PVGV) {
8384 /* If we are not defining a new sub and the existing one is not a
8386 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8387 /* We are applying attributes to an existing sub, so we need it
8388 upgraded if it is a constant. */
8389 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8390 gv_init_pvn(gv, PL_curstash, name, namlen,
8391 SVf_UTF8 * name_is_utf8);
8393 else { /* Maybe prototype now, and had at maximum
8394 a prototype or const/sub ref before. */
8395 if (SvTYPE(gv) > SVt_NULL) {
8396 cv_ckproto_len_flags((const CV *)gv,
8397 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8402 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8403 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8406 sv_setiv(MUTABLE_SV(gv), -1);
8409 SvREFCNT_dec(PL_compcv);
8410 cv = PL_compcv = NULL;
8415 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8419 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8425 /* This makes sub {}; work as expected. */
8426 if (block->op_type == OP_STUB) {
8427 const line_t l = PL_parser->copline;
8429 block = newSTATEOP(0, NULL, 0);
8430 PL_parser->copline = l;
8432 block = CvLVALUE(PL_compcv)
8433 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8434 && (!isGV(gv) || !GvASSUMECV(gv)))
8435 ? newUNOP(OP_LEAVESUBLV, 0,
8436 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8437 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8438 start = LINKLIST(block);
8440 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8442 S_op_const_sv(aTHX_ start, PL_compcv,
8443 cBOOL(CvCLONE(PL_compcv)));
8450 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8451 cv_ckproto_len_flags((const CV *)gv,
8452 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8453 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8455 /* All the other code for sub redefinition warnings expects the
8456 clobbered sub to be a CV. Instead of making all those code
8457 paths more complex, just inline the RV version here. */
8458 const line_t oldline = CopLINE(PL_curcop);
8459 assert(IN_PERL_COMPILETIME);
8460 if (PL_parser && PL_parser->copline != NOLINE)
8461 /* This ensures that warnings are reported at the first
8462 line of a redefinition, not the last. */
8463 CopLINE_set(PL_curcop, PL_parser->copline);
8464 /* protect against fatal warnings leaking compcv */
8465 SAVEFREESV(PL_compcv);
8467 if (ckWARN(WARN_REDEFINE)
8468 || ( ckWARN_d(WARN_REDEFINE)
8469 && ( !const_sv || SvRV(gv) == const_sv
8470 || sv_cmp(SvRV(gv), const_sv) ))) {
8472 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8473 "Constant subroutine %"SVf" redefined",
8474 SVfARG(cSVOPo->op_sv));
8477 SvREFCNT_inc_simple_void_NN(PL_compcv);
8478 CopLINE_set(PL_curcop, oldline);
8479 SvREFCNT_dec(SvRV(gv));
8484 const bool exists = CvROOT(cv) || CvXSUB(cv);
8486 /* if the subroutine doesn't exist and wasn't pre-declared
8487 * with a prototype, assume it will be AUTOLOADed,
8488 * skipping the prototype check
8490 if (exists || SvPOK(cv))
8491 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8492 /* already defined (or promised)? */
8493 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8494 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8497 if (attrs) goto attrs;
8498 /* just a "sub foo;" when &foo is already defined */
8499 SAVEFREESV(PL_compcv);
8505 SvREFCNT_inc_simple_void_NN(const_sv);
8506 SvFLAGS(const_sv) |= SVs_PADTMP;
8508 assert(!CvROOT(cv) && !CvCONST(cv));
8510 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8511 CvXSUBANY(cv).any_ptr = const_sv;
8512 CvXSUB(cv) = const_sv_xsub;
8516 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8519 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8520 if (name && isGV(gv))
8522 cv = newCONSTSUB_flags(
8523 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8526 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8530 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8531 prepare_SV_for_RV((SV *)gv);
8535 SvRV_set(gv, const_sv);
8539 SvREFCNT_dec(PL_compcv);
8543 if (cv) { /* must reuse cv if autoloaded */
8544 /* transfer PL_compcv to cv */
8547 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8548 PADLIST *const temp_av = CvPADLIST(cv);
8549 CV *const temp_cv = CvOUTSIDE(cv);
8550 const cv_flags_t other_flags =
8551 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8552 OP * const cvstart = CvSTART(cv);
8556 assert(!CvCVGV_RC(cv));
8557 assert(CvGV(cv) == gv);
8562 PERL_HASH(hash, name, namlen);
8572 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8574 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8575 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8576 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8577 CvOUTSIDE(PL_compcv) = temp_cv;
8578 CvPADLIST_set(PL_compcv, temp_av);
8579 CvSTART(cv) = CvSTART(PL_compcv);
8580 CvSTART(PL_compcv) = cvstart;
8581 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8582 CvFLAGS(PL_compcv) |= other_flags;
8584 if (CvFILE(cv) && CvDYNFILE(cv)) {
8585 Safefree(CvFILE(cv));
8587 CvFILE_set_from_cop(cv, PL_curcop);
8588 CvSTASH_set(cv, PL_curstash);
8590 /* inner references to PL_compcv must be fixed up ... */
8591 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8592 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8593 ++PL_sub_generation;
8596 /* Might have had built-in attributes applied -- propagate them. */
8597 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8599 /* ... before we throw it away */
8600 SvREFCNT_dec(PL_compcv);
8605 if (name && isGV(gv)) {
8608 if (HvENAME_HEK(GvSTASH(gv)))
8609 /* sub Foo::bar { (shift)+1 } */
8610 gv_method_changed(gv);
8614 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8615 prepare_SV_for_RV((SV *)gv);
8619 SvRV_set(gv, (SV *)cv);
8623 if (isGV(gv)) CvGV_set(cv, gv);
8627 PERL_HASH(hash, name, namlen);
8628 CvNAME_HEK_set(cv, share_hek(name,
8634 CvFILE_set_from_cop(cv, PL_curcop);
8635 CvSTASH_set(cv, PL_curstash);
8639 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8640 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8646 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8647 the debugger could be able to set a breakpoint in, so signal to
8648 pp_entereval that it should not throw away any saved lines at scope
8651 PL_breakable_sub_gen++;
8653 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8654 OpREFCNT_set(CvROOT(cv), 1);
8655 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8656 itself has a refcount. */
8658 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8659 #ifdef PERL_DEBUG_READONLY_OPS
8660 slab = (OPSLAB *)CvSTART(cv);
8662 CvSTART(cv) = start;
8664 finalize_optree(CvROOT(cv));
8665 S_prune_chain_head(&CvSTART(cv));
8667 /* now that optimizer has done its work, adjust pad values */
8669 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8673 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8674 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8677 if (!name) SAVEFREESV(cv);
8678 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8679 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8682 if (block && has_name) {
8683 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8684 SV * const tmpstr = cv_name(cv,NULL,0);
8685 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8686 GV_ADDMULTI, SVt_PVHV);
8688 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8691 (long)CopLINE(PL_curcop));
8692 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8693 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8694 hv = GvHVn(db_postponed);
8695 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8696 CV * const pcv = GvCV(db_postponed);
8702 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8708 if (PL_parser && PL_parser->error_count)
8709 clear_special_blocks(name, gv, cv);
8712 process_special_blocks(floor, name, gv, cv);
8718 PL_parser->copline = NOLINE;
8721 #ifdef PERL_DEBUG_READONLY_OPS
8725 if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8726 pad_add_weakref(cv);
8732 S_clear_special_blocks(pTHX_ const char *const fullname,
8733 GV *const gv, CV *const cv) {
8737 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8739 colon = strrchr(fullname,':');
8740 name = colon ? colon + 1 : fullname;
8742 if ((*name == 'B' && strEQ(name, "BEGIN"))
8743 || (*name == 'E' && strEQ(name, "END"))
8744 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8745 || (*name == 'C' && strEQ(name, "CHECK"))
8746 || (*name == 'I' && strEQ(name, "INIT"))) {
8752 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8756 /* Returns true if the sub has been freed. */
8758 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8762 const char *const colon = strrchr(fullname,':');
8763 const char *const name = colon ? colon + 1 : fullname;
8765 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8768 if (strEQ(name, "BEGIN")) {
8769 const I32 oldscope = PL_scopestack_ix;
8772 if (floor) LEAVE_SCOPE(floor);
8774 PUSHSTACKi(PERLSI_REQUIRE);
8775 SAVECOPFILE(&PL_compiling);
8776 SAVECOPLINE(&PL_compiling);
8777 SAVEVPTR(PL_curcop);
8779 DEBUG_x( dump_sub(gv) );
8780 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8781 GvCV_set(gv,0); /* cv has been hijacked */
8782 call_list(oldscope, PL_beginav);
8786 return !PL_savebegin;
8792 if strEQ(name, "END") {
8793 DEBUG_x( dump_sub(gv) );
8794 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8797 } else if (*name == 'U') {
8798 if (strEQ(name, "UNITCHECK")) {
8799 /* It's never too late to run a unitcheck block */
8800 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8804 } else if (*name == 'C') {
8805 if (strEQ(name, "CHECK")) {
8807 /* diag_listed_as: Too late to run %s block */
8808 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8809 "Too late to run CHECK block");
8810 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8814 } else if (*name == 'I') {
8815 if (strEQ(name, "INIT")) {
8817 /* diag_listed_as: Too late to run %s block */
8818 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8819 "Too late to run INIT block");
8820 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8826 DEBUG_x( dump_sub(gv) );
8828 GvCV_set(gv,0); /* cv has been hijacked */
8834 =for apidoc newCONSTSUB
8836 See L</newCONSTSUB_flags>.
8842 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8844 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8848 =for apidoc newCONSTSUB_flags
8850 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
8851 eligible for inlining at compile-time.
8853 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
8855 The newly created subroutine takes ownership of a reference to the passed in
8858 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
8859 which won't be called if used as a destructor, but will suppress the overhead
8860 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8867 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8871 const char *const file = CopFILE(PL_curcop);
8875 if (IN_PERL_RUNTIME) {
8876 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8877 * an op shared between threads. Use a non-shared COP for our
8879 SAVEVPTR(PL_curcop);
8880 SAVECOMPILEWARNINGS();
8881 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8882 PL_curcop = &PL_compiling;
8884 SAVECOPLINE(PL_curcop);
8885 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8888 PL_hints &= ~HINT_BLOCK_SCOPE;
8891 SAVEGENERICSV(PL_curstash);
8892 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8895 /* Protect sv against leakage caused by fatal warnings. */
8896 if (sv) SAVEFREESV(sv);
8898 /* file becomes the CvFILE. For an XS, it's usually static storage,
8899 and so doesn't get free()d. (It's expected to be from the C pre-
8900 processor __FILE__ directive). But we need a dynamically allocated one,
8901 and we need it to get freed. */
8902 cv = newXS_len_flags(name, len,
8903 sv && SvTYPE(sv) == SVt_PVAV
8906 file ? file : "", "",
8907 &sv, XS_DYNAMIC_FILENAME | flags);
8908 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8917 =for apidoc U||newXS
8919 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
8920 static storage, as it is used directly as CvFILE(), without a copy being made.
8926 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8928 PERL_ARGS_ASSERT_NEWXS;
8929 return newXS_len_flags(
8930 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8935 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8936 const char *const filename, const char *const proto,
8939 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8940 return newXS_len_flags(
8941 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8946 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
8948 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
8949 return newXS_len_flags(
8950 name, strlen(name), subaddr, NULL, NULL, NULL, 0
8955 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8956 XSUBADDR_t subaddr, const char *const filename,
8957 const char *const proto, SV **const_svp,
8961 bool interleave = FALSE;
8963 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8966 GV * const gv = gv_fetchpvn(
8967 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8968 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8969 sizeof("__ANON__::__ANON__") - 1,
8970 GV_ADDMULTI | flags, SVt_PVCV);
8972 if ((cv = (name ? GvCV(gv) : NULL))) {
8974 /* just a cached method */
8978 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8979 /* already defined (or promised) */
8980 /* Redundant check that allows us to avoid creating an SV
8981 most of the time: */
8982 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8983 report_redefined_cv(newSVpvn_flags(
8984 name,len,(flags&SVf_UTF8)|SVs_TEMP
8995 if (cv) /* must reuse cv if autoloaded */
8998 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9002 if (HvENAME_HEK(GvSTASH(gv)))
9003 gv_method_changed(gv); /* newXS */
9009 /* XSUBs can't be perl lang/perl5db.pl debugged
9010 if (PERLDB_LINE_OR_SAVESRC)
9011 (void)gv_fetchfile(filename); */
9012 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9013 if (flags & XS_DYNAMIC_FILENAME) {
9015 CvFILE(cv) = savepv(filename);
9017 /* NOTE: not copied, as it is expected to be an external constant string */
9018 CvFILE(cv) = (char *)filename;
9021 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9022 CvFILE(cv) = (char*)PL_xsubfilename;
9025 CvXSUB(cv) = subaddr;
9026 #ifndef PERL_IMPLICIT_CONTEXT
9027 CvHSCXT(cv) = &PL_stack_sp;
9033 process_special_blocks(0, name, gv, cv);
9036 } /* <- not a conditional branch */
9039 sv_setpv(MUTABLE_SV(cv), proto);
9040 if (interleave) LEAVE;
9045 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9047 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9049 PERL_ARGS_ASSERT_NEWSTUB;
9053 if (!fake && HvENAME_HEK(GvSTASH(gv)))
9054 gv_method_changed(gv);
9056 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9061 CvFILE_set_from_cop(cv, PL_curcop);
9062 CvSTASH_set(cv, PL_curstash);
9068 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9074 if (PL_parser && PL_parser->error_count) {
9080 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9081 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9084 if ((cv = GvFORM(gv))) {
9085 if (ckWARN(WARN_REDEFINE)) {
9086 const line_t oldline = CopLINE(PL_curcop);
9087 if (PL_parser && PL_parser->copline != NOLINE)
9088 CopLINE_set(PL_curcop, PL_parser->copline);
9090 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9091 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9093 /* diag_listed_as: Format %s redefined */
9094 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9095 "Format STDOUT redefined");
9097 CopLINE_set(PL_curcop, oldline);
9102 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9104 CvFILE_set_from_cop(cv, PL_curcop);
9107 pad_tidy(padtidy_FORMAT);
9108 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9109 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9110 OpREFCNT_set(CvROOT(cv), 1);
9111 CvSTART(cv) = LINKLIST(CvROOT(cv));
9112 CvROOT(cv)->op_next = 0;
9113 CALL_PEEP(CvSTART(cv));
9114 finalize_optree(CvROOT(cv));
9115 S_prune_chain_head(&CvSTART(cv));
9121 PL_parser->copline = NOLINE;
9123 PL_compiling.cop_seq = 0;
9127 Perl_newANONLIST(pTHX_ OP *o)
9129 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9133 Perl_newANONHASH(pTHX_ OP *o)
9135 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9139 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9141 return newANONATTRSUB(floor, proto, NULL, block);
9145 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9147 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9149 newSVOP(OP_ANONCODE, 0,
9151 if (CvANONCONST(cv))
9152 anoncode = newUNOP(OP_ANONCONST, 0,
9153 op_convert_list(OP_ENTERSUB,
9154 OPf_STACKED|OPf_WANT_SCALAR,
9156 return newUNOP(OP_REFGEN, 0, anoncode);
9160 Perl_oopsAV(pTHX_ OP *o)
9164 PERL_ARGS_ASSERT_OOPSAV;
9166 switch (o->op_type) {
9169 OpTYPE_set(o, OP_PADAV);
9170 return ref(o, OP_RV2AV);
9174 OpTYPE_set(o, OP_RV2AV);
9179 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9186 Perl_oopsHV(pTHX_ OP *o)
9190 PERL_ARGS_ASSERT_OOPSHV;
9192 switch (o->op_type) {
9195 OpTYPE_set(o, OP_PADHV);
9196 return ref(o, OP_RV2HV);
9200 OpTYPE_set(o, OP_RV2HV);
9205 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9212 Perl_newAVREF(pTHX_ OP *o)
9216 PERL_ARGS_ASSERT_NEWAVREF;
9218 if (o->op_type == OP_PADANY) {
9219 OpTYPE_set(o, OP_PADAV);
9222 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9223 Perl_croak(aTHX_ "Can't use an array as a reference");
9225 return newUNOP(OP_RV2AV, 0, scalar(o));
9229 Perl_newGVREF(pTHX_ I32 type, OP *o)
9231 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9232 return newUNOP(OP_NULL, 0, o);
9233 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9237 Perl_newHVREF(pTHX_ OP *o)
9241 PERL_ARGS_ASSERT_NEWHVREF;
9243 if (o->op_type == OP_PADANY) {
9244 OpTYPE_set(o, OP_PADHV);
9247 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9248 Perl_croak(aTHX_ "Can't use a hash as a reference");
9250 return newUNOP(OP_RV2HV, 0, scalar(o));
9254 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9256 if (o->op_type == OP_PADANY) {
9258 OpTYPE_set(o, OP_PADCV);
9260 return newUNOP(OP_RV2CV, flags, scalar(o));
9264 Perl_newSVREF(pTHX_ OP *o)
9268 PERL_ARGS_ASSERT_NEWSVREF;
9270 if (o->op_type == OP_PADANY) {
9271 OpTYPE_set(o, OP_PADSV);
9275 return newUNOP(OP_RV2SV, 0, scalar(o));
9278 /* Check routines. See the comments at the top of this file for details
9279 * on when these are called */
9282 Perl_ck_anoncode(pTHX_ OP *o)
9284 PERL_ARGS_ASSERT_CK_ANONCODE;
9286 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9287 cSVOPo->op_sv = NULL;
9292 S_io_hints(pTHX_ OP *o)
9294 #if O_BINARY != 0 || O_TEXT != 0
9296 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9298 SV **svp = hv_fetchs(table, "open_IN", 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_IN_RAW;
9310 o->op_private |= OPpOPEN_IN_CRLF;
9314 svp = hv_fetchs(table, "open_OUT", FALSE);
9317 const char *d = SvPV_const(*svp, len);
9318 const I32 mode = mode_from_discipline(d, len);
9319 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9321 if (mode & O_BINARY)
9322 o->op_private |= OPpOPEN_OUT_RAW;
9326 o->op_private |= OPpOPEN_OUT_CRLF;
9331 PERL_UNUSED_CONTEXT;
9337 Perl_ck_backtick(pTHX_ OP *o)
9342 PERL_ARGS_ASSERT_CK_BACKTICK;
9343 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9344 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9345 && (gv = gv_override("readpipe",8)))
9347 /* detach rest of siblings from o and its first child */
9348 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9349 newop = S_new_entersubop(aTHX_ gv, sibl);
9351 else if (!(o->op_flags & OPf_KIDS))
9352 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9357 S_io_hints(aTHX_ o);
9362 Perl_ck_bitop(pTHX_ OP *o)
9364 PERL_ARGS_ASSERT_CK_BITOP;
9366 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9368 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9369 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9370 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9371 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9372 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9373 "The bitwise feature is experimental");
9374 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9375 && OP_IS_INFIX_BIT(o->op_type))
9377 const OP * const left = cBINOPo->op_first;
9378 const OP * const right = OpSIBLING(left);
9379 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9380 (left->op_flags & OPf_PARENS) == 0) ||
9381 (OP_IS_NUMCOMPARE(right->op_type) &&
9382 (right->op_flags & OPf_PARENS) == 0))
9383 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9384 "Possible precedence problem on bitwise %s operator",
9385 o->op_type == OP_BIT_OR
9386 ||o->op_type == OP_NBIT_OR ? "|"
9387 : o->op_type == OP_BIT_AND
9388 ||o->op_type == OP_NBIT_AND ? "&"
9389 : o->op_type == OP_BIT_XOR
9390 ||o->op_type == OP_NBIT_XOR ? "^"
9391 : o->op_type == OP_SBIT_OR ? "|."
9392 : o->op_type == OP_SBIT_AND ? "&." : "^."
9398 PERL_STATIC_INLINE bool
9399 is_dollar_bracket(pTHX_ const OP * const o)
9402 PERL_UNUSED_CONTEXT;
9403 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9404 && (kid = cUNOPx(o)->op_first)
9405 && kid->op_type == OP_GV
9406 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9410 Perl_ck_cmp(pTHX_ OP *o)
9412 PERL_ARGS_ASSERT_CK_CMP;
9413 if (ckWARN(WARN_SYNTAX)) {
9414 const OP *kid = cUNOPo->op_first;
9417 ( is_dollar_bracket(aTHX_ kid)
9418 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9420 || ( kid->op_type == OP_CONST
9421 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9425 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9426 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9432 Perl_ck_concat(pTHX_ OP *o)
9434 const OP * const kid = cUNOPo->op_first;
9436 PERL_ARGS_ASSERT_CK_CONCAT;
9437 PERL_UNUSED_CONTEXT;
9439 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9440 !(kUNOP->op_first->op_flags & OPf_MOD))
9441 o->op_flags |= OPf_STACKED;
9446 Perl_ck_spair(pTHX_ OP *o)
9450 PERL_ARGS_ASSERT_CK_SPAIR;
9452 if (o->op_flags & OPf_KIDS) {
9456 const OPCODE type = o->op_type;
9457 o = modkids(ck_fun(o), type);
9458 kid = cUNOPo->op_first;
9459 kidkid = kUNOP->op_first;
9460 newop = OpSIBLING(kidkid);
9462 const OPCODE type = newop->op_type;
9463 if (OpHAS_SIBLING(newop))
9465 if (o->op_type == OP_REFGEN
9466 && ( type == OP_RV2CV
9467 || ( !(newop->op_flags & OPf_PARENS)
9468 && ( type == OP_RV2AV || type == OP_PADAV
9469 || type == OP_RV2HV || type == OP_PADHV))))
9470 NOOP; /* OK (allow srefgen for \@a and \%h) */
9471 else if (OP_GIMME(newop,0) != G_SCALAR)
9474 /* excise first sibling */
9475 op_sibling_splice(kid, NULL, 1, NULL);
9478 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9479 * and OP_CHOMP into OP_SCHOMP */
9480 o->op_ppaddr = PL_ppaddr[++o->op_type];
9485 Perl_ck_delete(pTHX_ OP *o)
9487 PERL_ARGS_ASSERT_CK_DELETE;
9491 if (o->op_flags & OPf_KIDS) {
9492 OP * const kid = cUNOPo->op_first;
9493 switch (kid->op_type) {
9495 o->op_flags |= OPf_SPECIAL;
9498 o->op_private |= OPpSLICE;
9501 o->op_flags |= OPf_SPECIAL;
9506 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9507 " use array slice");
9509 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9512 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9513 "element or slice");
9515 if (kid->op_private & OPpLVAL_INTRO)
9516 o->op_private |= OPpLVAL_INTRO;
9523 Perl_ck_eof(pTHX_ OP *o)
9525 PERL_ARGS_ASSERT_CK_EOF;
9527 if (o->op_flags & OPf_KIDS) {
9529 if (cLISTOPo->op_first->op_type == OP_STUB) {
9531 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9536 kid = cLISTOPo->op_first;
9537 if (kid->op_type == OP_RV2GV)
9538 kid->op_private |= OPpALLOW_FAKE;
9544 Perl_ck_eval(pTHX_ OP *o)
9548 PERL_ARGS_ASSERT_CK_EVAL;
9550 PL_hints |= HINT_BLOCK_SCOPE;
9551 if (o->op_flags & OPf_KIDS) {
9552 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9555 if (o->op_type == OP_ENTERTRY) {
9558 /* cut whole sibling chain free from o */
9559 op_sibling_splice(o, NULL, -1, NULL);
9562 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9564 /* establish postfix order */
9565 enter->op_next = (OP*)enter;
9567 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9568 OpTYPE_set(o, OP_LEAVETRY);
9569 enter->op_other = o;
9574 S_set_haseval(aTHX);
9578 const U8 priv = o->op_private;
9580 /* the newUNOP will recursively call ck_eval(), which will handle
9581 * all the stuff at the end of this function, like adding
9584 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9586 o->op_targ = (PADOFFSET)PL_hints;
9587 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9588 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9589 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9590 /* Store a copy of %^H that pp_entereval can pick up. */
9591 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9592 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9593 /* append hhop to only child */
9594 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9596 o->op_private |= OPpEVAL_HAS_HH;
9598 if (!(o->op_private & OPpEVAL_BYTES)
9599 && FEATURE_UNIEVAL_IS_ENABLED)
9600 o->op_private |= OPpEVAL_UNICODE;
9605 Perl_ck_exec(pTHX_ OP *o)
9607 PERL_ARGS_ASSERT_CK_EXEC;
9609 if (o->op_flags & OPf_STACKED) {
9612 kid = OpSIBLING(cUNOPo->op_first);
9613 if (kid->op_type == OP_RV2GV)
9622 Perl_ck_exists(pTHX_ OP *o)
9624 PERL_ARGS_ASSERT_CK_EXISTS;
9627 if (o->op_flags & OPf_KIDS) {
9628 OP * const kid = cUNOPo->op_first;
9629 if (kid->op_type == OP_ENTERSUB) {
9630 (void) ref(kid, o->op_type);
9631 if (kid->op_type != OP_RV2CV
9632 && !(PL_parser && PL_parser->error_count))
9634 "exists argument is not a subroutine name");
9635 o->op_private |= OPpEXISTS_SUB;
9637 else if (kid->op_type == OP_AELEM)
9638 o->op_flags |= OPf_SPECIAL;
9639 else if (kid->op_type != OP_HELEM)
9640 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9641 "element or a subroutine");
9648 Perl_ck_rvconst(pTHX_ OP *o)
9651 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9653 PERL_ARGS_ASSERT_CK_RVCONST;
9655 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9657 if (kid->op_type == OP_CONST) {
9660 SV * const kidsv = kid->op_sv;
9662 /* Is it a constant from cv_const_sv()? */
9663 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9666 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9667 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9668 const char *badthing;
9669 switch (o->op_type) {
9671 badthing = "a SCALAR";
9674 badthing = "an ARRAY";
9677 badthing = "a HASH";
9685 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9686 SVfARG(kidsv), badthing);
9689 * This is a little tricky. We only want to add the symbol if we
9690 * didn't add it in the lexer. Otherwise we get duplicate strict
9691 * warnings. But if we didn't add it in the lexer, we must at
9692 * least pretend like we wanted to add it even if it existed before,
9693 * or we get possible typo warnings. OPpCONST_ENTERED says
9694 * whether the lexer already added THIS instance of this symbol.
9696 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9697 gv = gv_fetchsv(kidsv,
9698 o->op_type == OP_RV2CV
9699 && o->op_private & OPpMAY_RETURN_CONSTANT
9701 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9704 : o->op_type == OP_RV2SV
9706 : o->op_type == OP_RV2AV
9708 : o->op_type == OP_RV2HV
9715 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9716 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9717 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9719 OpTYPE_set(kid, OP_GV);
9720 SvREFCNT_dec(kid->op_sv);
9722 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9723 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9724 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9725 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9726 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9728 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9730 kid->op_private = 0;
9731 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9739 Perl_ck_ftst(pTHX_ OP *o)
9742 const I32 type = o->op_type;
9744 PERL_ARGS_ASSERT_CK_FTST;
9746 if (o->op_flags & OPf_REF) {
9749 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9750 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9751 const OPCODE kidtype = kid->op_type;
9753 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9754 && !kid->op_folded) {
9755 OP * const newop = newGVOP(type, OPf_REF,
9756 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9761 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
9762 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
9764 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9765 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
9766 array_passed_to_stat, name);
9769 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9770 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
9774 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9775 o->op_private |= OPpFT_ACCESS;
9776 if (type != OP_STAT && type != OP_LSTAT
9777 && PL_check[kidtype] == Perl_ck_ftst
9778 && kidtype != OP_STAT && kidtype != OP_LSTAT
9780 o->op_private |= OPpFT_STACKED;
9781 kid->op_private |= OPpFT_STACKING;
9782 if (kidtype == OP_FTTTY && (
9783 !(kid->op_private & OPpFT_STACKED)
9784 || kid->op_private & OPpFT_AFTER_t
9786 o->op_private |= OPpFT_AFTER_t;
9791 if (type == OP_FTTTY)
9792 o = newGVOP(type, OPf_REF, PL_stdingv);
9794 o = newUNOP(type, 0, newDEFSVOP());
9800 Perl_ck_fun(pTHX_ OP *o)
9802 const int type = o->op_type;
9803 I32 oa = PL_opargs[type] >> OASHIFT;
9805 PERL_ARGS_ASSERT_CK_FUN;
9807 if (o->op_flags & OPf_STACKED) {
9808 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9811 return no_fh_allowed(o);
9814 if (o->op_flags & OPf_KIDS) {
9815 OP *prev_kid = NULL;
9816 OP *kid = cLISTOPo->op_first;
9818 bool seen_optional = FALSE;
9820 if (kid->op_type == OP_PUSHMARK ||
9821 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9824 kid = OpSIBLING(kid);
9826 if (kid && kid->op_type == OP_COREARGS) {
9827 bool optional = FALSE;
9830 if (oa & OA_OPTIONAL) optional = TRUE;
9833 if (optional) o->op_private |= numargs;
9838 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9839 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9841 /* append kid to chain */
9842 op_sibling_splice(o, prev_kid, 0, kid);
9844 seen_optional = TRUE;
9851 /* list seen where single (scalar) arg expected? */
9852 if (numargs == 1 && !(oa >> 4)
9853 && kid->op_type == OP_LIST && type != OP_SCALAR)
9855 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9857 if (type != OP_DELETE) scalar(kid);
9868 if ((type == OP_PUSH || type == OP_UNSHIFT)
9869 && !OpHAS_SIBLING(kid))
9870 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9871 "Useless use of %s with no values",
9874 if (kid->op_type == OP_CONST
9875 && ( !SvROK(cSVOPx_sv(kid))
9876 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9878 bad_type_pv(numargs, "array", o, kid);
9879 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9880 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9881 PL_op_desc[type]), 0);
9884 op_lvalue(kid, type);
9888 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9889 bad_type_pv(numargs, "hash", o, kid);
9890 op_lvalue(kid, type);
9894 /* replace kid with newop in chain */
9896 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9897 newop->op_next = newop;
9902 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9903 if (kid->op_type == OP_CONST &&
9904 (kid->op_private & OPpCONST_BARE))
9906 OP * const newop = newGVOP(OP_GV, 0,
9907 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9908 /* replace kid with newop in chain */
9909 op_sibling_splice(o, prev_kid, 1, newop);
9913 else if (kid->op_type == OP_READLINE) {
9914 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9915 bad_type_pv(numargs, "HANDLE", o, kid);
9918 I32 flags = OPf_SPECIAL;
9922 /* is this op a FH constructor? */
9923 if (is_handle_constructor(o,numargs)) {
9924 const char *name = NULL;
9927 bool want_dollar = TRUE;
9930 /* Set a flag to tell rv2gv to vivify
9931 * need to "prove" flag does not mean something
9932 * else already - NI-S 1999/05/07
9935 if (kid->op_type == OP_PADSV) {
9937 = PAD_COMPNAME_SV(kid->op_targ);
9938 name = PadnamePV (pn);
9939 len = PadnameLEN(pn);
9940 name_utf8 = PadnameUTF8(pn);
9942 else if (kid->op_type == OP_RV2SV
9943 && kUNOP->op_first->op_type == OP_GV)
9945 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9947 len = GvNAMELEN(gv);
9948 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9950 else if (kid->op_type == OP_AELEM
9951 || kid->op_type == OP_HELEM)
9954 OP *op = ((BINOP*)kid)->op_first;
9958 const char * const a =
9959 kid->op_type == OP_AELEM ?
9961 if (((op->op_type == OP_RV2AV) ||
9962 (op->op_type == OP_RV2HV)) &&
9963 (firstop = ((UNOP*)op)->op_first) &&
9964 (firstop->op_type == OP_GV)) {
9965 /* packagevar $a[] or $h{} */
9966 GV * const gv = cGVOPx_gv(firstop);
9974 else if (op->op_type == OP_PADAV
9975 || op->op_type == OP_PADHV) {
9976 /* lexicalvar $a[] or $h{} */
9977 const char * const padname =
9978 PAD_COMPNAME_PV(op->op_targ);
9987 name = SvPV_const(tmpstr, len);
9988 name_utf8 = SvUTF8(tmpstr);
9993 name = "__ANONIO__";
9995 want_dollar = FALSE;
9997 op_lvalue(kid, type);
10001 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10002 namesv = PAD_SVl(targ);
10003 if (want_dollar && *name != '$')
10004 sv_setpvs(namesv, "$");
10006 sv_setpvs(namesv, "");
10007 sv_catpvn(namesv, name, len);
10008 if ( name_utf8 ) SvUTF8_on(namesv);
10012 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10014 kid->op_targ = targ;
10015 kid->op_private |= priv;
10021 if ((type == OP_UNDEF || type == OP_POS)
10022 && numargs == 1 && !(oa >> 4)
10023 && kid->op_type == OP_LIST)
10024 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10025 op_lvalue(scalar(kid), type);
10030 kid = OpSIBLING(kid);
10032 /* FIXME - should the numargs or-ing move after the too many
10033 * arguments check? */
10034 o->op_private |= numargs;
10036 return too_many_arguments_pv(o,OP_DESC(o), 0);
10039 else if (PL_opargs[type] & OA_DEFGV) {
10040 /* Ordering of these two is important to keep f_map.t passing. */
10042 return newUNOP(type, 0, newDEFSVOP());
10046 while (oa & OA_OPTIONAL)
10048 if (oa && oa != OA_LIST)
10049 return too_few_arguments_pv(o,OP_DESC(o), 0);
10055 Perl_ck_glob(pTHX_ OP *o)
10059 PERL_ARGS_ASSERT_CK_GLOB;
10062 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10063 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10065 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10069 * \ null - const(wildcard)
10074 * \ mark - glob - rv2cv
10075 * | \ gv(CORE::GLOBAL::glob)
10077 * \ null - const(wildcard)
10079 o->op_flags |= OPf_SPECIAL;
10080 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10081 o = S_new_entersubop(aTHX_ gv, o);
10082 o = newUNOP(OP_NULL, 0, o);
10083 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10086 else o->op_flags &= ~OPf_SPECIAL;
10087 #if !defined(PERL_EXTERNAL_GLOB)
10088 if (!PL_globhook) {
10090 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10091 newSVpvs("File::Glob"), NULL, NULL, NULL);
10094 #endif /* !PERL_EXTERNAL_GLOB */
10095 gv = (GV *)newSV(0);
10096 gv_init(gv, 0, "", 0, 0);
10098 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10099 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10105 Perl_ck_grep(pTHX_ OP *o)
10109 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10111 PERL_ARGS_ASSERT_CK_GREP;
10113 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10115 if (o->op_flags & OPf_STACKED) {
10116 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10117 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10118 return no_fh_allowed(o);
10119 o->op_flags &= ~OPf_STACKED;
10121 kid = OpSIBLING(cLISTOPo->op_first);
10122 if (type == OP_MAPWHILE)
10127 if (PL_parser && PL_parser->error_count)
10129 kid = OpSIBLING(cLISTOPo->op_first);
10130 if (kid->op_type != OP_NULL)
10131 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10132 kid = kUNOP->op_first;
10134 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10135 kid->op_next = (OP*)gwop;
10136 o->op_private = gwop->op_private = 0;
10137 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10139 kid = OpSIBLING(cLISTOPo->op_first);
10140 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10141 op_lvalue(kid, OP_GREPSTART);
10147 Perl_ck_index(pTHX_ OP *o)
10149 PERL_ARGS_ASSERT_CK_INDEX;
10151 if (o->op_flags & OPf_KIDS) {
10152 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10154 kid = OpSIBLING(kid); /* get past "big" */
10155 if (kid && kid->op_type == OP_CONST) {
10156 const bool save_taint = TAINT_get;
10157 SV *sv = kSVOP->op_sv;
10158 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10160 sv_copypv(sv, kSVOP->op_sv);
10161 SvREFCNT_dec_NN(kSVOP->op_sv);
10164 if (SvOK(sv)) fbm_compile(sv, 0);
10165 TAINT_set(save_taint);
10166 #ifdef NO_TAINT_SUPPORT
10167 PERL_UNUSED_VAR(save_taint);
10175 Perl_ck_lfun(pTHX_ OP *o)
10177 const OPCODE type = o->op_type;
10179 PERL_ARGS_ASSERT_CK_LFUN;
10181 return modkids(ck_fun(o), type);
10185 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10187 PERL_ARGS_ASSERT_CK_DEFINED;
10189 if ((o->op_flags & OPf_KIDS)) {
10190 switch (cUNOPo->op_first->op_type) {
10193 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10194 " (Maybe you should just omit the defined()?)");
10198 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10199 " (Maybe you should just omit the defined()?)");
10210 Perl_ck_readline(pTHX_ OP *o)
10212 PERL_ARGS_ASSERT_CK_READLINE;
10214 if (o->op_flags & OPf_KIDS) {
10215 OP *kid = cLISTOPo->op_first;
10216 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10220 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10228 Perl_ck_rfun(pTHX_ OP *o)
10230 const OPCODE type = o->op_type;
10232 PERL_ARGS_ASSERT_CK_RFUN;
10234 return refkids(ck_fun(o), type);
10238 Perl_ck_listiob(pTHX_ OP *o)
10242 PERL_ARGS_ASSERT_CK_LISTIOB;
10244 kid = cLISTOPo->op_first;
10246 o = force_list(o, 1);
10247 kid = cLISTOPo->op_first;
10249 if (kid->op_type == OP_PUSHMARK)
10250 kid = OpSIBLING(kid);
10251 if (kid && o->op_flags & OPf_STACKED)
10252 kid = OpSIBLING(kid);
10253 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10254 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10255 && !kid->op_folded) {
10256 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10258 /* replace old const op with new OP_RV2GV parent */
10259 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10260 OP_RV2GV, OPf_REF);
10261 kid = OpSIBLING(kid);
10266 op_append_elem(o->op_type, o, newDEFSVOP());
10268 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10269 return listkids(o);
10273 Perl_ck_smartmatch(pTHX_ OP *o)
10276 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10277 if (0 == (o->op_flags & OPf_SPECIAL)) {
10278 OP *first = cBINOPo->op_first;
10279 OP *second = OpSIBLING(first);
10281 /* Implicitly take a reference to an array or hash */
10283 /* remove the original two siblings, then add back the
10284 * (possibly different) first and second sibs.
10286 op_sibling_splice(o, NULL, 1, NULL);
10287 op_sibling_splice(o, NULL, 1, NULL);
10288 first = ref_array_or_hash(first);
10289 second = ref_array_or_hash(second);
10290 op_sibling_splice(o, NULL, 0, second);
10291 op_sibling_splice(o, NULL, 0, first);
10293 /* Implicitly take a reference to a regular expression */
10294 if (first->op_type == OP_MATCH) {
10295 OpTYPE_set(first, OP_QR);
10297 if (second->op_type == OP_MATCH) {
10298 OpTYPE_set(second, OP_QR);
10307 S_maybe_targlex(pTHX_ OP *o)
10309 OP * const kid = cLISTOPo->op_first;
10310 /* has a disposable target? */
10311 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10312 && !(kid->op_flags & OPf_STACKED)
10313 /* Cannot steal the second time! */
10314 && !(kid->op_private & OPpTARGET_MY)
10317 OP * const kkid = OpSIBLING(kid);
10319 /* Can just relocate the target. */
10320 if (kkid && kkid->op_type == OP_PADSV
10321 && (!(kkid->op_private & OPpLVAL_INTRO)
10322 || kkid->op_private & OPpPAD_STATE))
10324 kid->op_targ = kkid->op_targ;
10326 /* Now we do not need PADSV and SASSIGN.
10327 * Detach kid and free the rest. */
10328 op_sibling_splice(o, NULL, 1, NULL);
10330 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10338 Perl_ck_sassign(pTHX_ OP *o)
10341 OP * const kid = cLISTOPo->op_first;
10343 PERL_ARGS_ASSERT_CK_SASSIGN;
10345 if (OpHAS_SIBLING(kid)) {
10346 OP *kkid = OpSIBLING(kid);
10347 /* For state variable assignment with attributes, kkid is a list op
10348 whose op_last is a padsv. */
10349 if ((kkid->op_type == OP_PADSV ||
10350 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10351 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10354 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10355 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10356 const PADOFFSET target = kkid->op_targ;
10357 OP *const other = newOP(OP_PADSV,
10359 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10360 OP *const first = newOP(OP_NULL, 0);
10362 newCONDOP(0, first, o, other);
10363 /* XXX targlex disabled for now; see ticket #124160
10364 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10366 OP *const condop = first->op_next;
10368 OpTYPE_set(condop, OP_ONCE);
10369 other->op_targ = target;
10370 nullop->op_flags |= OPf_WANT_SCALAR;
10372 /* Store the initializedness of state vars in a separate
10375 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10376 /* hijacking PADSTALE for uninitialized state variables */
10377 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10382 return S_maybe_targlex(aTHX_ o);
10386 Perl_ck_match(pTHX_ OP *o)
10388 PERL_UNUSED_CONTEXT;
10389 PERL_ARGS_ASSERT_CK_MATCH;
10391 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10392 o->op_private |= OPpRUNTIME;
10397 Perl_ck_method(pTHX_ OP *o)
10399 SV *sv, *methsv, *rclass;
10400 const char* method;
10403 STRLEN len, nsplit = 0, i;
10405 OP * const kid = cUNOPo->op_first;
10407 PERL_ARGS_ASSERT_CK_METHOD;
10408 if (kid->op_type != OP_CONST) return o;
10412 /* replace ' with :: */
10413 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10415 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10418 method = SvPVX_const(sv);
10420 utf8 = SvUTF8(sv) ? -1 : 1;
10422 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10427 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10429 if (!nsplit) { /* $proto->method() */
10431 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10434 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10436 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10439 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10440 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10441 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10442 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10444 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10445 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10447 #ifdef USE_ITHREADS
10448 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10450 cMETHOPx(new_op)->op_rclass_sv = rclass;
10457 Perl_ck_null(pTHX_ OP *o)
10459 PERL_ARGS_ASSERT_CK_NULL;
10460 PERL_UNUSED_CONTEXT;
10465 Perl_ck_open(pTHX_ OP *o)
10467 PERL_ARGS_ASSERT_CK_OPEN;
10469 S_io_hints(aTHX_ o);
10471 /* In case of three-arg dup open remove strictness
10472 * from the last arg if it is a bareword. */
10473 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10474 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10478 if ((last->op_type == OP_CONST) && /* The bareword. */
10479 (last->op_private & OPpCONST_BARE) &&
10480 (last->op_private & OPpCONST_STRICT) &&
10481 (oa = OpSIBLING(first)) && /* The fh. */
10482 (oa = OpSIBLING(oa)) && /* The mode. */
10483 (oa->op_type == OP_CONST) &&
10484 SvPOK(((SVOP*)oa)->op_sv) &&
10485 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10486 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10487 (last == OpSIBLING(oa))) /* The bareword. */
10488 last->op_private &= ~OPpCONST_STRICT;
10494 Perl_ck_prototype(pTHX_ OP *o)
10496 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10497 if (!(o->op_flags & OPf_KIDS)) {
10499 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10505 Perl_ck_refassign(pTHX_ OP *o)
10507 OP * const right = cLISTOPo->op_first;
10508 OP * const left = OpSIBLING(right);
10509 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10512 PERL_ARGS_ASSERT_CK_REFASSIGN;
10514 assert (left->op_type == OP_SREFGEN);
10517 /* we use OPpPAD_STATE in refassign to mean either of those things,
10518 * and the code assumes the two flags occupy the same bit position
10519 * in the various ops below */
10520 assert(OPpPAD_STATE == OPpOUR_INTRO);
10522 switch (varop->op_type) {
10524 o->op_private |= OPpLVREF_AV;
10527 o->op_private |= OPpLVREF_HV;
10531 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10532 o->op_targ = varop->op_targ;
10533 varop->op_targ = 0;
10534 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10538 o->op_private |= OPpLVREF_AV;
10540 NOT_REACHED; /* NOTREACHED */
10542 o->op_private |= OPpLVREF_HV;
10546 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10547 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10549 /* Point varop to its GV kid, detached. */
10550 varop = op_sibling_splice(varop, NULL, -1, NULL);
10554 OP * const kidparent =
10555 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10556 OP * const kid = cUNOPx(kidparent)->op_first;
10557 o->op_private |= OPpLVREF_CV;
10558 if (kid->op_type == OP_GV) {
10560 goto detach_and_stack;
10562 if (kid->op_type != OP_PADCV) goto bad;
10563 o->op_targ = kid->op_targ;
10569 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10570 o->op_private |= OPpLVREF_ELEM;
10573 /* Detach varop. */
10574 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10578 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10579 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10584 if (!FEATURE_REFALIASING_IS_ENABLED)
10586 "Experimental aliasing via reference not enabled");
10587 Perl_ck_warner_d(aTHX_
10588 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10589 "Aliasing via reference is experimental");
10591 o->op_flags |= OPf_STACKED;
10592 op_sibling_splice(o, right, 1, varop);
10595 o->op_flags &=~ OPf_STACKED;
10596 op_sibling_splice(o, right, 1, NULL);
10603 Perl_ck_repeat(pTHX_ OP *o)
10605 PERL_ARGS_ASSERT_CK_REPEAT;
10607 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10609 o->op_private |= OPpREPEAT_DOLIST;
10610 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10611 kids = force_list(kids, 1); /* promote it to a list */
10612 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10620 Perl_ck_require(pTHX_ OP *o)
10624 PERL_ARGS_ASSERT_CK_REQUIRE;
10626 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10627 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10632 if (kid->op_type == OP_CONST) {
10633 SV * const sv = kid->op_sv;
10634 U32 const was_readonly = SvREADONLY(sv);
10635 if (kid->op_private & OPpCONST_BARE) {
10639 if (was_readonly) {
10640 SvREADONLY_off(sv);
10642 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10647 /* treat ::foo::bar as foo::bar */
10648 if (len >= 2 && s[0] == ':' && s[1] == ':')
10649 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
10651 DIE(aTHX_ "Bareword in require maps to empty filename");
10653 for (; s < end; s++) {
10654 if (*s == ':' && s[1] == ':') {
10656 Move(s+2, s+1, end - s - 1, char);
10660 SvEND_set(sv, end);
10661 sv_catpvs(sv, ".pm");
10662 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10663 hek = share_hek(SvPVX(sv),
10664 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10666 sv_sethek(sv, hek);
10668 SvFLAGS(sv) |= was_readonly;
10670 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10673 if (SvREFCNT(sv) > 1) {
10674 kid->op_sv = newSVpvn_share(
10675 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10676 SvREFCNT_dec_NN(sv);
10680 if (was_readonly) SvREADONLY_off(sv);
10681 PERL_HASH(hash, s, len);
10683 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10685 sv_sethek(sv, hek);
10687 SvFLAGS(sv) |= was_readonly;
10693 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10694 /* handle override, if any */
10695 && (gv = gv_override("require", 7))) {
10697 if (o->op_flags & OPf_KIDS) {
10698 kid = cUNOPo->op_first;
10699 op_sibling_splice(o, NULL, -1, NULL);
10702 kid = newDEFSVOP();
10705 newop = S_new_entersubop(aTHX_ gv, kid);
10713 Perl_ck_return(pTHX_ OP *o)
10717 PERL_ARGS_ASSERT_CK_RETURN;
10719 kid = OpSIBLING(cLISTOPo->op_first);
10720 if (CvLVALUE(PL_compcv)) {
10721 for (; kid; kid = OpSIBLING(kid))
10722 op_lvalue(kid, OP_LEAVESUBLV);
10729 Perl_ck_select(pTHX_ OP *o)
10734 PERL_ARGS_ASSERT_CK_SELECT;
10736 if (o->op_flags & OPf_KIDS) {
10737 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10738 if (kid && OpHAS_SIBLING(kid)) {
10739 OpTYPE_set(o, OP_SSELECT);
10741 return fold_constants(op_integerize(op_std_init(o)));
10745 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10746 if (kid && kid->op_type == OP_RV2GV)
10747 kid->op_private &= ~HINT_STRICT_REFS;
10752 Perl_ck_shift(pTHX_ OP *o)
10754 const I32 type = o->op_type;
10756 PERL_ARGS_ASSERT_CK_SHIFT;
10758 if (!(o->op_flags & OPf_KIDS)) {
10761 if (!CvUNIQUE(PL_compcv)) {
10762 o->op_flags |= OPf_SPECIAL;
10766 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10768 return newUNOP(type, 0, scalar(argop));
10770 return scalar(ck_fun(o));
10774 Perl_ck_sort(pTHX_ OP *o)
10778 HV * const hinthv =
10779 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10782 PERL_ARGS_ASSERT_CK_SORT;
10785 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10787 const I32 sorthints = (I32)SvIV(*svp);
10788 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10789 o->op_private |= OPpSORT_QSORT;
10790 if ((sorthints & HINT_SORT_STABLE) != 0)
10791 o->op_private |= OPpSORT_STABLE;
10795 if (o->op_flags & OPf_STACKED)
10797 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10799 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10800 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10802 /* if the first arg is a code block, process it and mark sort as
10804 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10806 if (kid->op_type == OP_LEAVE)
10807 op_null(kid); /* wipe out leave */
10808 /* Prevent execution from escaping out of the sort block. */
10811 /* provide scalar context for comparison function/block */
10812 kid = scalar(firstkid);
10813 kid->op_next = kid;
10814 o->op_flags |= OPf_SPECIAL;
10816 else if (kid->op_type == OP_CONST
10817 && kid->op_private & OPpCONST_BARE) {
10821 const char * const name = SvPV(kSVOP_sv, len);
10823 assert (len < 256);
10824 Copy(name, tmpbuf+1, len, char);
10825 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10826 if (off != NOT_IN_PAD) {
10827 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10829 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10830 sv_catpvs(fq, "::");
10831 sv_catsv(fq, kSVOP_sv);
10832 SvREFCNT_dec_NN(kSVOP_sv);
10836 OP * const padop = newOP(OP_PADCV, 0);
10837 padop->op_targ = off;
10838 /* replace the const op with the pad op */
10839 op_sibling_splice(firstkid, NULL, 1, padop);
10845 firstkid = OpSIBLING(firstkid);
10848 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10849 /* provide list context for arguments */
10852 op_lvalue(kid, OP_GREPSTART);
10858 /* for sort { X } ..., where X is one of
10859 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10860 * elide the second child of the sort (the one containing X),
10861 * and set these flags as appropriate
10865 * Also, check and warn on lexical $a, $b.
10869 S_simplify_sort(pTHX_ OP *o)
10871 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10875 const char *gvname;
10878 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10880 kid = kUNOP->op_first; /* get past null */
10881 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10882 && kid->op_type != OP_LEAVE)
10884 kid = kLISTOP->op_last; /* get past scope */
10885 switch(kid->op_type) {
10889 if (!have_scopeop) goto padkids;
10894 k = kid; /* remember this node*/
10895 if (kBINOP->op_first->op_type != OP_RV2SV
10896 || kBINOP->op_last ->op_type != OP_RV2SV)
10899 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10900 then used in a comparison. This catches most, but not
10901 all cases. For instance, it catches
10902 sort { my($a); $a <=> $b }
10904 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10905 (although why you'd do that is anyone's guess).
10909 if (!ckWARN(WARN_SYNTAX)) return;
10910 kid = kBINOP->op_first;
10912 if (kid->op_type == OP_PADSV) {
10913 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
10914 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
10915 && ( PadnamePV(name)[1] == 'a'
10916 || PadnamePV(name)[1] == 'b' ))
10917 /* diag_listed_as: "my %s" used in sort comparison */
10918 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10919 "\"%s %s\" used in sort comparison",
10920 PadnameIsSTATE(name)
10925 } while ((kid = OpSIBLING(kid)));
10928 kid = kBINOP->op_first; /* get past cmp */
10929 if (kUNOP->op_first->op_type != OP_GV)
10931 kid = kUNOP->op_first; /* get past rv2sv */
10933 if (GvSTASH(gv) != PL_curstash)
10935 gvname = GvNAME(gv);
10936 if (*gvname == 'a' && gvname[1] == '\0')
10938 else if (*gvname == 'b' && gvname[1] == '\0')
10943 kid = k; /* back to cmp */
10944 /* already checked above that it is rv2sv */
10945 kid = kBINOP->op_last; /* down to 2nd arg */
10946 if (kUNOP->op_first->op_type != OP_GV)
10948 kid = kUNOP->op_first; /* get past rv2sv */
10950 if (GvSTASH(gv) != PL_curstash)
10952 gvname = GvNAME(gv);
10954 ? !(*gvname == 'a' && gvname[1] == '\0')
10955 : !(*gvname == 'b' && gvname[1] == '\0'))
10957 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10959 o->op_private |= OPpSORT_DESCEND;
10960 if (k->op_type == OP_NCMP)
10961 o->op_private |= OPpSORT_NUMERIC;
10962 if (k->op_type == OP_I_NCMP)
10963 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10964 kid = OpSIBLING(cLISTOPo->op_first);
10965 /* cut out and delete old block (second sibling) */
10966 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10971 Perl_ck_split(pTHX_ OP *o)
10976 PERL_ARGS_ASSERT_CK_SPLIT;
10978 if (o->op_flags & OPf_STACKED)
10979 return no_fh_allowed(o);
10981 kid = cLISTOPo->op_first;
10982 if (kid->op_type != OP_NULL)
10983 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10984 /* delete leading NULL node, then add a CONST if no other nodes */
10985 op_sibling_splice(o, NULL, 1,
10986 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10988 kid = cLISTOPo->op_first;
10990 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10991 /* remove kid, and replace with new optree */
10992 op_sibling_splice(o, NULL, 1, NULL);
10993 /* OPf_SPECIAL is used to trigger split " " behavior */
10994 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
10995 op_sibling_splice(o, NULL, 0, kid);
10997 OpTYPE_set(kid, OP_PUSHRE);
10998 /* target implies @ary=..., so wipe it */
11001 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11002 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11003 "Use of /g modifier is meaningless in split");
11006 if (!OpHAS_SIBLING(kid))
11007 op_append_elem(OP_SPLIT, o, newDEFSVOP());
11009 kid = OpSIBLING(kid);
11013 if (!OpHAS_SIBLING(kid))
11015 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
11016 o->op_private |= OPpSPLIT_IMPLIM;
11018 assert(OpHAS_SIBLING(kid));
11020 kid = OpSIBLING(kid);
11023 if (OpHAS_SIBLING(kid))
11024 return too_many_arguments_pv(o,OP_DESC(o), 0);
11030 Perl_ck_stringify(pTHX_ OP *o)
11032 OP * const kid = OpSIBLING(cUNOPo->op_first);
11033 PERL_ARGS_ASSERT_CK_STRINGIFY;
11034 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11035 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
11036 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
11037 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11039 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11047 Perl_ck_join(pTHX_ OP *o)
11049 OP * const kid = OpSIBLING(cLISTOPo->op_first);
11051 PERL_ARGS_ASSERT_CK_JOIN;
11053 if (kid && kid->op_type == OP_MATCH) {
11054 if (ckWARN(WARN_SYNTAX)) {
11055 const REGEXP *re = PM_GETRE(kPMOP);
11057 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11058 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11059 : newSVpvs_flags( "STRING", SVs_TEMP );
11060 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11061 "/%"SVf"/ should probably be written as \"%"SVf"\"",
11062 SVfARG(msg), SVfARG(msg));
11066 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11067 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11068 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11069 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11071 const OP * const bairn = OpSIBLING(kid); /* the list */
11072 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11073 && OP_GIMME(bairn,0) == G_SCALAR)
11075 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11076 op_sibling_splice(o, kid, 1, NULL));
11086 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11088 Examines an op, which is expected to identify a subroutine at runtime,
11089 and attempts to determine at compile time which subroutine it identifies.
11090 This is normally used during Perl compilation to determine whether
11091 a prototype can be applied to a function call. C<cvop> is the op
11092 being considered, normally an C<rv2cv> op. A pointer to the identified
11093 subroutine is returned, if it could be determined statically, and a null
11094 pointer is returned if it was not possible to determine statically.
11096 Currently, the subroutine can be identified statically if the RV that the
11097 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11098 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11099 suitable if the constant value must be an RV pointing to a CV. Details of
11100 this process may change in future versions of Perl. If the C<rv2cv> op
11101 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11102 the subroutine statically: this flag is used to suppress compile-time
11103 magic on a subroutine call, forcing it to use default runtime behaviour.
11105 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11106 of a GV reference is modified. If a GV was examined and its CV slot was
11107 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11108 If the op is not optimised away, and the CV slot is later populated with
11109 a subroutine having a prototype, that flag eventually triggers the warning
11110 "called too early to check prototype".
11112 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11113 of returning a pointer to the subroutine it returns a pointer to the
11114 GV giving the most appropriate name for the subroutine in this context.
11115 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11116 (C<CvANON>) subroutine that is referenced through a GV it will be the
11117 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11118 A null pointer is returned as usual if there is no statically-determinable
11124 /* shared by toke.c:yylex */
11126 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11128 PADNAME *name = PAD_COMPNAME(off);
11129 CV *compcv = PL_compcv;
11130 while (PadnameOUTER(name)) {
11131 assert(PARENT_PAD_INDEX(name));
11132 compcv = CvOUTSIDE(compcv);
11133 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11134 [off = PARENT_PAD_INDEX(name)];
11136 assert(!PadnameIsOUR(name));
11137 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11138 return PadnamePROTOCV(name);
11140 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11144 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11149 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11150 if (flags & ~RV2CVOPCV_FLAG_MASK)
11151 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11152 if (cvop->op_type != OP_RV2CV)
11154 if (cvop->op_private & OPpENTERSUB_AMPER)
11156 if (!(cvop->op_flags & OPf_KIDS))
11158 rvop = cUNOPx(cvop)->op_first;
11159 switch (rvop->op_type) {
11161 gv = cGVOPx_gv(rvop);
11163 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11164 cv = MUTABLE_CV(SvRV(gv));
11168 if (flags & RV2CVOPCV_RETURN_STUB)
11174 if (flags & RV2CVOPCV_MARK_EARLY)
11175 rvop->op_private |= OPpEARLY_CV;
11180 SV *rv = cSVOPx_sv(rvop);
11183 cv = (CV*)SvRV(rv);
11187 cv = find_lexical_cv(rvop->op_targ);
11192 } NOT_REACHED; /* NOTREACHED */
11194 if (SvTYPE((SV*)cv) != SVt_PVCV)
11196 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11197 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11198 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11207 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11209 Performs the default fixup of the arguments part of an C<entersub>
11210 op tree. This consists of applying list context to each of the
11211 argument ops. This is the standard treatment used on a call marked
11212 with C<&>, or a method call, or a call through a subroutine reference,
11213 or any other call where the callee can't be identified at compile time,
11214 or a call where the callee has no prototype.
11220 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11224 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11226 aop = cUNOPx(entersubop)->op_first;
11227 if (!OpHAS_SIBLING(aop))
11228 aop = cUNOPx(aop)->op_first;
11229 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11230 /* skip the extra attributes->import() call implicitly added in
11231 * something like foo(my $x : bar)
11233 if ( aop->op_type == OP_ENTERSUB
11234 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11238 op_lvalue(aop, OP_ENTERSUB);
11244 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11246 Performs the fixup of the arguments part of an C<entersub> op tree
11247 based on a subroutine prototype. This makes various modifications to
11248 the argument ops, from applying context up to inserting C<refgen> ops,
11249 and checking the number and syntactic types of arguments, as directed by
11250 the prototype. This is the standard treatment used on a subroutine call,
11251 not marked with C<&>, where the callee can be identified at compile time
11252 and has a prototype.
11254 C<protosv> supplies the subroutine prototype to be applied to the call.
11255 It may be a normal defined scalar, of which the string value will be used.
11256 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11257 that has been cast to C<SV*>) which has a prototype. The prototype
11258 supplied, in whichever form, does not need to match the actual callee
11259 referenced by the op tree.
11261 If the argument ops disagree with the prototype, for example by having
11262 an unacceptable number of arguments, a valid op tree is returned anyway.
11263 The error is reflected in the parser state, normally resulting in a single
11264 exception at the top level of parsing which covers all the compilation
11265 errors that occurred. In the error message, the callee is referred to
11266 by the name defined by the C<namegv> parameter.
11272 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11275 const char *proto, *proto_end;
11276 OP *aop, *prev, *cvop, *parent;
11279 I32 contextclass = 0;
11280 const char *e = NULL;
11281 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11282 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11283 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11284 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11285 if (SvTYPE(protosv) == SVt_PVCV)
11286 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11287 else proto = SvPV(protosv, proto_len);
11288 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11289 proto_end = proto + proto_len;
11290 parent = entersubop;
11291 aop = cUNOPx(entersubop)->op_first;
11292 if (!OpHAS_SIBLING(aop)) {
11294 aop = cUNOPx(aop)->op_first;
11297 aop = OpSIBLING(aop);
11298 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11299 while (aop != cvop) {
11302 if (proto >= proto_end)
11304 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11305 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11306 SVfARG(namesv)), SvUTF8(namesv));
11316 /* _ must be at the end */
11317 if (proto[1] && !strchr(";@%", proto[1]))
11333 if ( o3->op_type != OP_UNDEF
11334 && (o3->op_type != OP_SREFGEN
11335 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11337 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11339 bad_type_gv(arg, namegv, o3,
11340 arg == 1 ? "block or sub {}" : "sub {}");
11343 /* '*' allows any scalar type, including bareword */
11346 if (o3->op_type == OP_RV2GV)
11347 goto wrapref; /* autoconvert GLOB -> GLOBref */
11348 else if (o3->op_type == OP_CONST)
11349 o3->op_private &= ~OPpCONST_STRICT;
11355 if (o3->op_type == OP_RV2AV ||
11356 o3->op_type == OP_PADAV ||
11357 o3->op_type == OP_RV2HV ||
11358 o3->op_type == OP_PADHV
11364 case '[': case ']':
11371 switch (*proto++) {
11373 if (contextclass++ == 0) {
11374 e = strchr(proto, ']');
11375 if (!e || e == proto)
11383 if (contextclass) {
11384 const char *p = proto;
11385 const char *const end = proto;
11387 while (*--p != '[')
11388 /* \[$] accepts any scalar lvalue */
11390 && Perl_op_lvalue_flags(aTHX_
11392 OP_READ, /* not entersub */
11395 bad_type_gv(arg, namegv, o3,
11396 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11401 if (o3->op_type == OP_RV2GV)
11404 bad_type_gv(arg, namegv, o3, "symbol");
11407 if (o3->op_type == OP_ENTERSUB
11408 && !(o3->op_flags & OPf_STACKED))
11411 bad_type_gv(arg, namegv, o3, "subroutine");
11414 if (o3->op_type == OP_RV2SV ||
11415 o3->op_type == OP_PADSV ||
11416 o3->op_type == OP_HELEM ||
11417 o3->op_type == OP_AELEM)
11419 if (!contextclass) {
11420 /* \$ accepts any scalar lvalue */
11421 if (Perl_op_lvalue_flags(aTHX_
11423 OP_READ, /* not entersub */
11426 bad_type_gv(arg, namegv, o3, "scalar");
11430 if (o3->op_type == OP_RV2AV ||
11431 o3->op_type == OP_PADAV)
11433 o3->op_flags &=~ OPf_PARENS;
11437 bad_type_gv(arg, namegv, o3, "array");
11440 if (o3->op_type == OP_RV2HV ||
11441 o3->op_type == OP_PADHV)
11443 o3->op_flags &=~ OPf_PARENS;
11447 bad_type_gv(arg, namegv, o3, "hash");
11450 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11452 if (contextclass && e) {
11457 default: goto oops;
11467 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11468 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11473 op_lvalue(aop, OP_ENTERSUB);
11475 aop = OpSIBLING(aop);
11477 if (aop == cvop && *proto == '_') {
11478 /* generate an access to $_ */
11479 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11481 if (!optional && proto_end > proto &&
11482 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11484 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11485 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11486 SVfARG(namesv)), SvUTF8(namesv));
11492 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11494 Performs the fixup of the arguments part of an C<entersub> op tree either
11495 based on a subroutine prototype or using default list-context processing.
11496 This is the standard treatment used on a subroutine call, not marked
11497 with C<&>, where the callee can be identified at compile time.
11499 C<protosv> supplies the subroutine prototype to be applied to the call,
11500 or indicates that there is no prototype. It may be a normal scalar,
11501 in which case if it is defined then the string value will be used
11502 as a prototype, and if it is undefined then there is no prototype.
11503 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11504 that has been cast to C<SV*>), of which the prototype will be used if it
11505 has one. The prototype (or lack thereof) supplied, in whichever form,
11506 does not need to match the actual callee referenced by the op tree.
11508 If the argument ops disagree with the prototype, for example by having
11509 an unacceptable number of arguments, a valid op tree is returned anyway.
11510 The error is reflected in the parser state, normally resulting in a single
11511 exception at the top level of parsing which covers all the compilation
11512 errors that occurred. In the error message, the callee is referred to
11513 by the name defined by the C<namegv> parameter.
11519 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11520 GV *namegv, SV *protosv)
11522 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11523 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11524 return ck_entersub_args_proto(entersubop, namegv, protosv);
11526 return ck_entersub_args_list(entersubop);
11530 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11532 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11533 OP *aop = cUNOPx(entersubop)->op_first;
11535 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11539 if (!OpHAS_SIBLING(aop))
11540 aop = cUNOPx(aop)->op_first;
11541 aop = OpSIBLING(aop);
11542 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11544 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11546 op_free(entersubop);
11547 switch(GvNAME(namegv)[2]) {
11548 case 'F': return newSVOP(OP_CONST, 0,
11549 newSVpv(CopFILE(PL_curcop),0));
11550 case 'L': return newSVOP(
11552 Perl_newSVpvf(aTHX_
11553 "%"IVdf, (IV)CopLINE(PL_curcop)
11556 case 'P': return newSVOP(OP_CONST, 0,
11558 ? newSVhek(HvNAME_HEK(PL_curstash))
11563 NOT_REACHED; /* NOTREACHED */
11566 OP *prev, *cvop, *first, *parent;
11569 parent = entersubop;
11570 if (!OpHAS_SIBLING(aop)) {
11572 aop = cUNOPx(aop)->op_first;
11575 first = prev = aop;
11576 aop = OpSIBLING(aop);
11577 /* find last sibling */
11579 OpHAS_SIBLING(cvop);
11580 prev = cvop, cvop = OpSIBLING(cvop))
11582 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11583 /* Usually, OPf_SPECIAL on an op with no args means that it had
11584 * parens, but these have their own meaning for that flag: */
11585 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11586 && opnum != OP_DELETE && opnum != OP_EXISTS)
11587 flags |= OPf_SPECIAL;
11588 /* excise cvop from end of sibling chain */
11589 op_sibling_splice(parent, prev, 1, NULL);
11591 if (aop == cvop) aop = NULL;
11593 /* detach remaining siblings from the first sibling, then
11594 * dispose of original optree */
11597 op_sibling_splice(parent, first, -1, NULL);
11598 op_free(entersubop);
11600 if (opnum == OP_ENTEREVAL
11601 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11602 flags |= OPpEVAL_BYTES <<8;
11604 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11606 case OA_BASEOP_OR_UNOP:
11607 case OA_FILESTATOP:
11608 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11611 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11614 return opnum == OP_RUNCV
11615 ? newPVOP(OP_RUNCV,0,NULL)
11618 return op_convert_list(opnum,0,aop);
11621 NOT_REACHED; /* NOTREACHED */
11626 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11628 Retrieves the function that will be used to fix up a call to C<cv>.
11629 Specifically, the function is applied to an C<entersub> op tree for a
11630 subroutine call, not marked with C<&>, where the callee can be identified
11631 at compile time as C<cv>.
11633 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11634 argument for it is returned in C<*ckobj_p>. The function is intended
11635 to be called in this manner:
11637 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11639 In this call, C<entersubop> is a pointer to the C<entersub> op,
11640 which may be replaced by the check function, and C<namegv> is a GV
11641 supplying the name that should be used by the check function to refer
11642 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11643 It is permitted to apply the check function in non-standard situations,
11644 such as to a call to a different subroutine or to a method call.
11646 By default, the function is
11647 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11648 and the SV parameter is C<cv> itself. This implements standard
11649 prototype processing. It can be changed, for a particular subroutine,
11650 by L</cv_set_call_checker>.
11656 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11660 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11662 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11663 *ckobj_p = callmg->mg_obj;
11664 if (flagsp) *flagsp = callmg->mg_flags;
11666 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11667 *ckobj_p = (SV*)cv;
11668 if (flagsp) *flagsp = 0;
11673 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11675 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11676 PERL_UNUSED_CONTEXT;
11677 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11681 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11683 Sets the function that will be used to fix up a call to C<cv>.
11684 Specifically, the function is applied to an C<entersub> op tree for a
11685 subroutine call, not marked with C<&>, where the callee can be identified
11686 at compile time as C<cv>.
11688 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11689 for it is supplied in C<ckobj>. The function should be defined like this:
11691 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11693 It is intended to be called in this manner:
11695 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11697 In this call, C<entersubop> is a pointer to the C<entersub> op,
11698 which may be replaced by the check function, and C<namegv> supplies
11699 the name that should be used by the check function to refer
11700 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11701 It is permitted to apply the check function in non-standard situations,
11702 such as to a call to a different subroutine or to a method call.
11704 C<namegv> may not actually be a GV. For efficiency, perl may pass a
11705 CV or other SV instead. Whatever is passed can be used as the first
11706 argument to L</cv_name>. You can force perl to pass a GV by including
11707 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11709 The current setting for a particular CV can be retrieved by
11710 L</cv_get_call_checker>.
11712 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11714 The original form of L</cv_set_call_checker_flags>, which passes it the
11715 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11721 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11723 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11724 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11728 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11729 SV *ckobj, U32 flags)
11731 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11732 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11733 if (SvMAGICAL((SV*)cv))
11734 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11737 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11738 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11740 if (callmg->mg_flags & MGf_REFCOUNTED) {
11741 SvREFCNT_dec(callmg->mg_obj);
11742 callmg->mg_flags &= ~MGf_REFCOUNTED;
11744 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11745 callmg->mg_obj = ckobj;
11746 if (ckobj != (SV*)cv) {
11747 SvREFCNT_inc_simple_void_NN(ckobj);
11748 callmg->mg_flags |= MGf_REFCOUNTED;
11750 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11751 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11756 S_entersub_alloc_targ(pTHX_ OP * const o)
11758 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11759 o->op_private |= OPpENTERSUB_HASTARG;
11763 Perl_ck_subr(pTHX_ OP *o)
11768 SV **const_class = NULL;
11770 PERL_ARGS_ASSERT_CK_SUBR;
11772 aop = cUNOPx(o)->op_first;
11773 if (!OpHAS_SIBLING(aop))
11774 aop = cUNOPx(aop)->op_first;
11775 aop = OpSIBLING(aop);
11776 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11777 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11778 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11780 o->op_private &= ~1;
11781 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11782 if (PERLDB_SUB && PL_curstash != PL_debstash)
11783 o->op_private |= OPpENTERSUB_DB;
11784 switch (cvop->op_type) {
11786 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11790 case OP_METHOD_NAMED:
11791 case OP_METHOD_SUPER:
11792 case OP_METHOD_REDIR:
11793 case OP_METHOD_REDIR_SUPER:
11794 if (aop->op_type == OP_CONST) {
11795 aop->op_private &= ~OPpCONST_STRICT;
11796 const_class = &cSVOPx(aop)->op_sv;
11798 else if (aop->op_type == OP_LIST) {
11799 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11800 if (sib && sib->op_type == OP_CONST) {
11801 sib->op_private &= ~OPpCONST_STRICT;
11802 const_class = &cSVOPx(sib)->op_sv;
11805 /* make class name a shared cow string to speedup method calls */
11806 /* constant string might be replaced with object, f.e. bigint */
11807 if (const_class && SvPOK(*const_class)) {
11809 const char* str = SvPV(*const_class, len);
11811 SV* const shared = newSVpvn_share(
11812 str, SvUTF8(*const_class)
11813 ? -(SSize_t)len : (SSize_t)len,
11816 if (SvREADONLY(*const_class))
11817 SvREADONLY_on(shared);
11818 SvREFCNT_dec(*const_class);
11819 *const_class = shared;
11826 S_entersub_alloc_targ(aTHX_ o);
11827 return ck_entersub_args_list(o);
11829 Perl_call_checker ckfun;
11832 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11833 if (CvISXSUB(cv) || !CvROOT(cv))
11834 S_entersub_alloc_targ(aTHX_ o);
11836 /* The original call checker API guarantees that a GV will be
11837 be provided with the right name. So, if the old API was
11838 used (or the REQUIRE_GV flag was passed), we have to reify
11839 the CV’s GV, unless this is an anonymous sub. This is not
11840 ideal for lexical subs, as its stringification will include
11841 the package. But it is the best we can do. */
11842 if (flags & MGf_REQUIRE_GV) {
11843 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11846 else namegv = MUTABLE_GV(cv);
11847 /* After a syntax error in a lexical sub, the cv that
11848 rv2cv_op_cv returns may be a nameless stub. */
11849 if (!namegv) return ck_entersub_args_list(o);
11852 return ckfun(aTHX_ o, namegv, ckobj);
11857 Perl_ck_svconst(pTHX_ OP *o)
11859 SV * const sv = cSVOPo->op_sv;
11860 PERL_ARGS_ASSERT_CK_SVCONST;
11861 PERL_UNUSED_CONTEXT;
11862 #ifdef PERL_COPY_ON_WRITE
11863 /* Since the read-only flag may be used to protect a string buffer, we
11864 cannot do copy-on-write with existing read-only scalars that are not
11865 already copy-on-write scalars. To allow $_ = "hello" to do COW with
11866 that constant, mark the constant as COWable here, if it is not
11867 already read-only. */
11868 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11871 # ifdef PERL_DEBUG_READONLY_COW
11881 Perl_ck_trunc(pTHX_ OP *o)
11883 PERL_ARGS_ASSERT_CK_TRUNC;
11885 if (o->op_flags & OPf_KIDS) {
11886 SVOP *kid = (SVOP*)cUNOPo->op_first;
11888 if (kid->op_type == OP_NULL)
11889 kid = (SVOP*)OpSIBLING(kid);
11890 if (kid && kid->op_type == OP_CONST &&
11891 (kid->op_private & OPpCONST_BARE) &&
11894 o->op_flags |= OPf_SPECIAL;
11895 kid->op_private &= ~OPpCONST_STRICT;
11902 Perl_ck_substr(pTHX_ OP *o)
11904 PERL_ARGS_ASSERT_CK_SUBSTR;
11907 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11908 OP *kid = cLISTOPo->op_first;
11910 if (kid->op_type == OP_NULL)
11911 kid = OpSIBLING(kid);
11913 kid->op_flags |= OPf_MOD;
11920 Perl_ck_tell(pTHX_ OP *o)
11922 PERL_ARGS_ASSERT_CK_TELL;
11924 if (o->op_flags & OPf_KIDS) {
11925 OP *kid = cLISTOPo->op_first;
11926 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
11927 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11933 Perl_ck_each(pTHX_ OP *o)
11936 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11937 const unsigned orig_type = o->op_type;
11939 PERL_ARGS_ASSERT_CK_EACH;
11942 switch (kid->op_type) {
11948 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
11949 : orig_type == OP_KEYS ? OP_AKEYS
11953 if (kid->op_private == OPpCONST_BARE
11954 || !SvROK(cSVOPx_sv(kid))
11955 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11956 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
11960 yyerror_pv(Perl_form(aTHX_
11961 "Experimental %s on scalar is now forbidden",
11962 PL_op_desc[orig_type]), 0);
11964 bad_type_pv(1, "hash or array", o, kid);
11972 Perl_ck_length(pTHX_ OP *o)
11974 PERL_ARGS_ASSERT_CK_LENGTH;
11978 if (ckWARN(WARN_SYNTAX)) {
11979 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11983 const bool hash = kid->op_type == OP_PADHV
11984 || kid->op_type == OP_RV2HV;
11985 switch (kid->op_type) {
11990 name = S_op_varname(aTHX_ kid);
11996 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11997 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11999 SVfARG(name), hash ? "keys " : "", SVfARG(name)
12002 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12003 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12004 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12006 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12007 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12008 "length() used on @array (did you mean \"scalar(@array)\"?)");
12018 ---------------------------------------------------------
12020 Common vars in list assignment
12022 There now follows some enums and static functions for detecting
12023 common variables in list assignments. Here is a little essay I wrote
12024 for myself when trying to get my head around this. DAPM.
12028 First some random observations:
12030 * If a lexical var is an alias of something else, e.g.
12031 for my $x ($lex, $pkg, $a[0]) {...}
12032 then the act of aliasing will increase the reference count of the SV
12034 * If a package var is an alias of something else, it may still have a
12035 reference count of 1, depending on how the alias was created, e.g.
12036 in *a = *b, $a may have a refcount of 1 since the GP is shared
12037 with a single GvSV pointer to the SV. So If it's an alias of another
12038 package var, then RC may be 1; if it's an alias of another scalar, e.g.
12039 a lexical var or an array element, then it will have RC > 1.
12041 * There are many ways to create a package alias; ultimately, XS code
12042 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12043 run-time tracing mechanisms are unlikely to be able to catch all cases.
12045 * When the LHS is all my declarations, the same vars can't appear directly
12046 on the RHS, but they can indirectly via closures, aliasing and lvalue
12047 subs. But those techniques all involve an increase in the lexical
12048 scalar's ref count.
12050 * When the LHS is all lexical vars (but not necessarily my declarations),
12051 it is possible for the same lexicals to appear directly on the RHS, and
12052 without an increased ref count, since the stack isn't refcounted.
12053 This case can be detected at compile time by scanning for common lex
12054 vars with PL_generation.
12056 * lvalue subs defeat common var detection, but they do at least
12057 return vars with a temporary ref count increment. Also, you can't
12058 tell at compile time whether a sub call is lvalue.
12063 A: There are a few circumstances where there definitely can't be any
12066 LHS empty: () = (...);
12067 RHS empty: (....) = ();
12068 RHS contains only constants or other 'can't possibly be shared'
12069 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
12070 i.e. they only contain ops not marked as dangerous, whose children
12071 are also not dangerous;
12073 LHS contains a single scalar element: e.g. ($x) = (....); because
12074 after $x has been modified, it won't be used again on the RHS;
12075 RHS contains a single element with no aggregate on LHS: e.g.
12076 ($a,$b,$c) = ($x); again, once $a has been modified, its value
12077 won't be used again.
12079 B: If LHS are all 'my' lexical var declarations (or safe ops, which
12082 my ($a, $b, @c) = ...;
12084 Due to closure and goto tricks, these vars may already have content.
12085 For the same reason, an element on the RHS may be a lexical or package
12086 alias of one of the vars on the left, or share common elements, for
12089 my ($x,$y) = f(); # $x and $y on both sides
12090 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12095 my @a = @$ra; # elements of @a on both sides
12096 sub f { @a = 1..4; \@a }
12099 First, just consider scalar vars on LHS:
12101 RHS is safe only if (A), or in addition,
12102 * contains only lexical *scalar* vars, where neither side's
12103 lexicals have been flagged as aliases
12105 If RHS is not safe, then it's always legal to check LHS vars for
12106 RC==1, since the only RHS aliases will always be associated
12109 Note that in particular, RHS is not safe if:
12111 * it contains package scalar vars; e.g.:
12114 my ($x, $y) = (2, $x_alias);
12115 sub f { $x = 1; *x_alias = \$x; }
12117 * It contains other general elements, such as flattened or
12118 * spliced or single array or hash elements, e.g.
12121 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12125 use feature 'refaliasing';
12126 \($a[0], $a[1]) = \($y,$x);
12129 It doesn't matter if the array/hash is lexical or package.
12131 * it contains a function call that happens to be an lvalue
12132 sub which returns one or more of the above, e.g.
12143 (so a sub call on the RHS should be treated the same
12144 as having a package var on the RHS).
12146 * any other "dangerous" thing, such an op or built-in that
12147 returns one of the above, e.g. pp_preinc
12150 If RHS is not safe, what we can do however is at compile time flag
12151 that the LHS are all my declarations, and at run time check whether
12152 all the LHS have RC == 1, and if so skip the full scan.
12154 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12156 Here the issue is whether there can be elements of @a on the RHS
12157 which will get prematurely freed when @a is cleared prior to
12158 assignment. This is only a problem if the aliasing mechanism
12159 is one which doesn't increase the refcount - only if RC == 1
12160 will the RHS element be prematurely freed.
12162 Because the array/hash is being INTROed, it or its elements
12163 can't directly appear on the RHS:
12165 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12167 but can indirectly, e.g.:
12171 sub f { @a = 1..3; \@a }
12173 So if the RHS isn't safe as defined by (A), we must always
12174 mortalise and bump the ref count of any remaining RHS elements
12175 when assigning to a non-empty LHS aggregate.
12177 Lexical scalars on the RHS aren't safe if they've been involved in
12180 use feature 'refaliasing';
12183 \(my $lex) = \$pkg;
12184 my @a = ($lex,3); # equivalent to ($a[0],3)
12191 Similarly with lexical arrays and hashes on the RHS:
12205 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12206 my $a; ($a, my $b) = (....);
12208 The difference between (B) and (C) is that it is now physically
12209 possible for the LHS vars to appear on the RHS too, where they
12210 are not reference counted; but in this case, the compile-time
12211 PL_generation sweep will detect such common vars.
12213 So the rules for (C) differ from (B) in that if common vars are
12214 detected, the runtime "test RC==1" optimisation can no longer be used,
12215 and a full mark and sweep is required
12217 D: As (C), but in addition the LHS may contain package vars.
12219 Since package vars can be aliased without a corresponding refcount
12220 increase, all bets are off. It's only safe if (A). E.g.
12222 my ($x, $y) = (1,2);
12224 for $x_alias ($x) {
12225 ($x_alias, $y) = (3, $x); # whoops
12228 Ditto for LHS aggregate package vars.
12230 E: Any other dangerous ops on LHS, e.g.
12231 (f(), $a[0], @$r) = (...);
12233 this is similar to (E) in that all bets are off. In addition, it's
12234 impossible to determine at compile time whether the LHS
12235 contains a scalar or an aggregate, e.g.
12237 sub f : lvalue { @a }
12240 * ---------------------------------------------------------
12244 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12245 * that at least one of the things flagged was seen.
12249 AAS_MY_SCALAR = 0x001, /* my $scalar */
12250 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
12251 AAS_LEX_SCALAR = 0x004, /* $lexical */
12252 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
12253 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12254 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
12255 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
12256 AAS_DANGEROUS = 0x080, /* an op (other than the above)
12257 that's flagged OA_DANGEROUS */
12258 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
12259 not in any of the categories above */
12260 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
12265 /* helper function for S_aassign_scan().
12266 * check a PAD-related op for commonality and/or set its generation number.
12267 * Returns a boolean indicating whether its shared */
12270 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12272 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12273 /* lexical used in aliasing */
12277 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12279 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12286 Helper function for OPpASSIGN_COMMON* detection in rpeep().
12287 It scans the left or right hand subtree of the aassign op, and returns a
12288 set of flags indicating what sorts of things it found there.
12289 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12290 set PL_generation on lexical vars; if the latter, we see if
12291 PL_generation matches.
12292 'top' indicates whether we're recursing or at the top level.
12293 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12294 This fn will increment it by the number seen. It's not intended to
12295 be an accurate count (especially as many ops can push a variable
12296 number of SVs onto the stack); rather it's used as to test whether there
12297 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12301 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12304 bool kid_top = FALSE;
12306 /* first, look for a solitary @_ on the RHS */
12309 && (o->op_flags & OPf_KIDS)
12310 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12312 OP *kid = cUNOPo->op_first;
12313 if ( ( kid->op_type == OP_PUSHMARK
12314 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12315 && ((kid = OpSIBLING(kid)))
12316 && !OpHAS_SIBLING(kid)
12317 && kid->op_type == OP_RV2AV
12318 && !(kid->op_flags & OPf_REF)
12319 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12320 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12321 && ((kid = cUNOPx(kid)->op_first))
12322 && kid->op_type == OP_GV
12323 && cGVOPx_gv(kid) == PL_defgv
12325 flags |= AAS_DEFAV;
12328 switch (o->op_type) {
12331 return AAS_PKG_SCALAR;
12336 if (top && (o->op_flags & OPf_REF))
12337 return (o->op_private & OPpLVAL_INTRO)
12338 ? AAS_MY_AGG : AAS_LEX_AGG;
12339 return AAS_DANGEROUS;
12343 int comm = S_aassign_padcheck(aTHX_ o, rhs)
12344 ? AAS_LEX_SCALAR_COMM : 0;
12346 return (o->op_private & OPpLVAL_INTRO)
12347 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12353 if (cUNOPx(o)->op_first->op_type != OP_GV)
12354 return AAS_DANGEROUS; /* @{expr}, %{expr} */
12356 if (top && (o->op_flags & OPf_REF))
12357 return AAS_PKG_AGG;
12358 return AAS_DANGEROUS;
12362 if (cUNOPx(o)->op_first->op_type != OP_GV) {
12364 return AAS_DANGEROUS; /* ${expr} */
12366 return AAS_PKG_SCALAR; /* $pkg */
12369 if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
12370 /* "@foo = split... " optimises away the aassign and stores its
12371 * destination array in the OP_PUSHRE that precedes it.
12372 * A flattened array is always dangerous.
12375 return AAS_DANGEROUS;
12380 /* undef counts as a scalar on the RHS:
12381 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
12382 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
12386 flags = AAS_SAFE_SCALAR;
12391 /* these are all no-ops; they don't push a potentially common SV
12392 * onto the stack, so they are neither AAS_DANGEROUS nor
12393 * AAS_SAFE_SCALAR */
12396 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12401 /* these do nothing but may have children; but their children
12402 * should also be treated as top-level */
12407 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12409 flags = AAS_DANGEROUS;
12413 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
12414 && (o->op_private & OPpTARGET_MY))
12417 return S_aassign_padcheck(aTHX_ o, rhs)
12418 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12421 /* if its an unrecognised, non-dangerous op, assume that it
12422 * it the cause of at least one safe scalar */
12424 flags = AAS_SAFE_SCALAR;
12428 if (o->op_flags & OPf_KIDS) {
12430 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12431 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12437 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12438 and modify the optree to make them work inplace */
12441 S_inplace_aassign(pTHX_ OP *o) {
12443 OP *modop, *modop_pushmark;
12445 OP *oleft, *oleft_pushmark;
12447 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12449 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12451 assert(cUNOPo->op_first->op_type == OP_NULL);
12452 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12453 assert(modop_pushmark->op_type == OP_PUSHMARK);
12454 modop = OpSIBLING(modop_pushmark);
12456 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12459 /* no other operation except sort/reverse */
12460 if (OpHAS_SIBLING(modop))
12463 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12464 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12466 if (modop->op_flags & OPf_STACKED) {
12467 /* skip sort subroutine/block */
12468 assert(oright->op_type == OP_NULL);
12469 oright = OpSIBLING(oright);
12472 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12473 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12474 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12475 oleft = OpSIBLING(oleft_pushmark);
12477 /* Check the lhs is an array */
12479 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12480 || OpHAS_SIBLING(oleft)
12481 || (oleft->op_private & OPpLVAL_INTRO)
12485 /* Only one thing on the rhs */
12486 if (OpHAS_SIBLING(oright))
12489 /* check the array is the same on both sides */
12490 if (oleft->op_type == OP_RV2AV) {
12491 if (oright->op_type != OP_RV2AV
12492 || !cUNOPx(oright)->op_first
12493 || cUNOPx(oright)->op_first->op_type != OP_GV
12494 || cUNOPx(oleft )->op_first->op_type != OP_GV
12495 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12496 cGVOPx_gv(cUNOPx(oright)->op_first)
12500 else if (oright->op_type != OP_PADAV
12501 || oright->op_targ != oleft->op_targ
12505 /* This actually is an inplace assignment */
12507 modop->op_private |= OPpSORT_INPLACE;
12509 /* transfer MODishness etc from LHS arg to RHS arg */
12510 oright->op_flags = oleft->op_flags;
12512 /* remove the aassign op and the lhs */
12514 op_null(oleft_pushmark);
12515 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12516 op_null(cUNOPx(oleft)->op_first);
12522 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12523 * that potentially represent a series of one or more aggregate derefs
12524 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12525 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12526 * additional ops left in too).
12528 * The caller will have already verified that the first few ops in the
12529 * chain following 'start' indicate a multideref candidate, and will have
12530 * set 'orig_o' to the point further on in the chain where the first index
12531 * expression (if any) begins. 'orig_action' specifies what type of
12532 * beginning has already been determined by the ops between start..orig_o
12533 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12535 * 'hints' contains any hints flags that need adding (currently just
12536 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12540 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12544 UNOP_AUX_item *arg_buf = NULL;
12545 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12546 int index_skip = -1; /* don't output index arg on this action */
12548 /* similar to regex compiling, do two passes; the first pass
12549 * determines whether the op chain is convertible and calculates the
12550 * buffer size; the second pass populates the buffer and makes any
12551 * changes necessary to ops (such as moving consts to the pad on
12552 * threaded builds).
12554 * NB: for things like Coverity, note that both passes take the same
12555 * path through the logic tree (except for 'if (pass)' bits), since
12556 * both passes are following the same op_next chain; and in
12557 * particular, if it would return early on the second pass, it would
12558 * already have returned early on the first pass.
12560 for (pass = 0; pass < 2; pass++) {
12562 UV action = orig_action;
12563 OP *first_elem_op = NULL; /* first seen aelem/helem */
12564 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12565 int action_count = 0; /* number of actions seen so far */
12566 int action_ix = 0; /* action_count % (actions per IV) */
12567 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12568 bool is_last = FALSE; /* no more derefs to follow */
12569 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12570 UNOP_AUX_item *arg = arg_buf;
12571 UNOP_AUX_item *action_ptr = arg_buf;
12574 action_ptr->uv = 0;
12578 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12579 case MDEREF_HV_gvhv_helem:
12580 next_is_hash = TRUE;
12582 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12583 case MDEREF_AV_gvav_aelem:
12585 #ifdef USE_ITHREADS
12586 arg->pad_offset = cPADOPx(start)->op_padix;
12587 /* stop it being swiped when nulled */
12588 cPADOPx(start)->op_padix = 0;
12590 arg->sv = cSVOPx(start)->op_sv;
12591 cSVOPx(start)->op_sv = NULL;
12597 case MDEREF_HV_padhv_helem:
12598 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12599 next_is_hash = TRUE;
12601 case MDEREF_AV_padav_aelem:
12602 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12604 arg->pad_offset = start->op_targ;
12605 /* we skip setting op_targ = 0 for now, since the intact
12606 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12607 reset_start_targ = TRUE;
12612 case MDEREF_HV_pop_rv2hv_helem:
12613 next_is_hash = TRUE;
12615 case MDEREF_AV_pop_rv2av_aelem:
12619 NOT_REACHED; /* NOTREACHED */
12624 /* look for another (rv2av/hv; get index;
12625 * aelem/helem/exists/delele) sequence */
12630 UV index_type = MDEREF_INDEX_none;
12632 if (action_count) {
12633 /* if this is not the first lookup, consume the rv2av/hv */
12635 /* for N levels of aggregate lookup, we normally expect
12636 * that the first N-1 [ah]elem ops will be flagged as
12637 * /DEREF (so they autovivifiy if necessary), and the last
12638 * lookup op not to be.
12639 * For other things (like @{$h{k1}{k2}}) extra scope or
12640 * leave ops can appear, so abandon the effort in that
12642 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12645 /* rv2av or rv2hv sKR/1 */
12647 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12648 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12649 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12652 /* at this point, we wouldn't expect any of these
12653 * possible private flags:
12654 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12655 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12657 ASSUME(!(o->op_private &
12658 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12660 hints = (o->op_private & OPpHINT_STRICT_REFS);
12662 /* make sure the type of the previous /DEREF matches the
12663 * type of the next lookup */
12664 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12667 action = next_is_hash
12668 ? MDEREF_HV_vivify_rv2hv_helem
12669 : MDEREF_AV_vivify_rv2av_aelem;
12673 /* if this is the second pass, and we're at the depth where
12674 * previously we encountered a non-simple index expression,
12675 * stop processing the index at this point */
12676 if (action_count != index_skip) {
12678 /* look for one or more simple ops that return an array
12679 * index or hash key */
12681 switch (o->op_type) {
12683 /* it may be a lexical var index */
12684 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12685 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12686 ASSUME(!(o->op_private &
12687 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12689 if ( OP_GIMME(o,0) == G_SCALAR
12690 && !(o->op_flags & (OPf_REF|OPf_MOD))
12691 && o->op_private == 0)
12694 arg->pad_offset = o->op_targ;
12696 index_type = MDEREF_INDEX_padsv;
12702 if (next_is_hash) {
12703 /* it's a constant hash index */
12704 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12705 /* "use constant foo => FOO; $h{+foo}" for
12706 * some weird FOO, can leave you with constants
12707 * that aren't simple strings. It's not worth
12708 * the extra hassle for those edge cases */
12713 OP * helem_op = o->op_next;
12715 ASSUME( helem_op->op_type == OP_HELEM
12716 || helem_op->op_type == OP_NULL);
12717 if (helem_op->op_type == OP_HELEM) {
12718 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12719 if ( helem_op->op_private & OPpLVAL_INTRO
12720 || rop->op_type != OP_RV2HV
12724 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12726 #ifdef USE_ITHREADS
12727 /* Relocate sv to the pad for thread safety */
12728 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12729 arg->pad_offset = o->op_targ;
12732 arg->sv = cSVOPx_sv(o);
12737 /* it's a constant array index */
12739 SV *ix_sv = cSVOPo->op_sv;
12744 if ( action_count == 0
12747 && ( action == MDEREF_AV_padav_aelem
12748 || action == MDEREF_AV_gvav_aelem)
12750 maybe_aelemfast = TRUE;
12754 SvREFCNT_dec_NN(cSVOPo->op_sv);
12758 /* we've taken ownership of the SV */
12759 cSVOPo->op_sv = NULL;
12761 index_type = MDEREF_INDEX_const;
12766 /* it may be a package var index */
12768 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12769 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12770 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12771 || o->op_private != 0
12776 if (kid->op_type != OP_RV2SV)
12779 ASSUME(!(kid->op_flags &
12780 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12781 |OPf_SPECIAL|OPf_PARENS)));
12782 ASSUME(!(kid->op_private &
12784 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12785 |OPpDEREF|OPpLVAL_INTRO)));
12786 if( (kid->op_flags &~ OPf_PARENS)
12787 != (OPf_WANT_SCALAR|OPf_KIDS)
12788 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12793 #ifdef USE_ITHREADS
12794 arg->pad_offset = cPADOPx(o)->op_padix;
12795 /* stop it being swiped when nulled */
12796 cPADOPx(o)->op_padix = 0;
12798 arg->sv = cSVOPx(o)->op_sv;
12799 cSVOPo->op_sv = NULL;
12803 index_type = MDEREF_INDEX_gvsv;
12808 } /* action_count != index_skip */
12810 action |= index_type;
12813 /* at this point we have either:
12814 * * detected what looks like a simple index expression,
12815 * and expect the next op to be an [ah]elem, or
12816 * an nulled [ah]elem followed by a delete or exists;
12817 * * found a more complex expression, so something other
12818 * than the above follows.
12821 /* possibly an optimised away [ah]elem (where op_next is
12822 * exists or delete) */
12823 if (o->op_type == OP_NULL)
12826 /* at this point we're looking for an OP_AELEM, OP_HELEM,
12827 * OP_EXISTS or OP_DELETE */
12829 /* if something like arybase (a.k.a $[ ) is in scope,
12830 * abandon optimisation attempt */
12831 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12832 && PL_check[o->op_type] != Perl_ck_null)
12835 if ( o->op_type != OP_AELEM
12836 || (o->op_private &
12837 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12839 maybe_aelemfast = FALSE;
12841 /* look for aelem/helem/exists/delete. If it's not the last elem
12842 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12843 * flags; if it's the last, then it mustn't have
12844 * OPpDEREF_AV/HV, but may have lots of other flags, like
12845 * OPpLVAL_INTRO etc
12848 if ( index_type == MDEREF_INDEX_none
12849 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
12850 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12854 /* we have aelem/helem/exists/delete with valid simple index */
12856 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12857 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
12858 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12861 ASSUME(!(o->op_flags &
12862 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12863 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12865 ok = (o->op_flags &~ OPf_PARENS)
12866 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12867 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12869 else if (o->op_type == OP_EXISTS) {
12870 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12871 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12872 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12873 ok = !(o->op_private & ~OPpARG1_MASK);
12875 else if (o->op_type == OP_DELETE) {
12876 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12877 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12878 ASSUME(!(o->op_private &
12879 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12880 /* don't handle slices or 'local delete'; the latter
12881 * is fairly rare, and has a complex runtime */
12882 ok = !(o->op_private & ~OPpARG1_MASK);
12883 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12884 /* skip handling run-tome error */
12885 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12888 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12889 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12890 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12891 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12892 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12893 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12898 if (!first_elem_op)
12902 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12907 action |= MDEREF_FLAG_last;
12911 /* at this point we have something that started
12912 * promisingly enough (with rv2av or whatever), but failed
12913 * to find a simple index followed by an
12914 * aelem/helem/exists/delete. If this is the first action,
12915 * give up; but if we've already seen at least one
12916 * aelem/helem, then keep them and add a new action with
12917 * MDEREF_INDEX_none, which causes it to do the vivify
12918 * from the end of the previous lookup, and do the deref,
12919 * but stop at that point. So $a[0][expr] will do one
12920 * av_fetch, vivify and deref, then continue executing at
12925 index_skip = action_count;
12926 action |= MDEREF_FLAG_last;
12930 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12933 /* if there's no space for the next action, create a new slot
12934 * for it *before* we start adding args for that action */
12935 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12942 } /* while !is_last */
12950 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12951 if (index_skip == -1) {
12952 mderef->op_flags = o->op_flags
12953 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12954 if (o->op_type == OP_EXISTS)
12955 mderef->op_private = OPpMULTIDEREF_EXISTS;
12956 else if (o->op_type == OP_DELETE)
12957 mderef->op_private = OPpMULTIDEREF_DELETE;
12959 mderef->op_private = o->op_private
12960 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12962 /* accumulate strictness from every level (although I don't think
12963 * they can actually vary) */
12964 mderef->op_private |= hints;
12966 /* integrate the new multideref op into the optree and the
12969 * In general an op like aelem or helem has two child
12970 * sub-trees: the aggregate expression (a_expr) and the
12971 * index expression (i_expr):
12977 * The a_expr returns an AV or HV, while the i-expr returns an
12978 * index. In general a multideref replaces most or all of a
12979 * multi-level tree, e.g.
12995 * With multideref, all the i_exprs will be simple vars or
12996 * constants, except that i_expr1 may be arbitrary in the case
12997 * of MDEREF_INDEX_none.
12999 * The bottom-most a_expr will be either:
13000 * 1) a simple var (so padXv or gv+rv2Xv);
13001 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
13002 * so a simple var with an extra rv2Xv;
13003 * 3) or an arbitrary expression.
13005 * 'start', the first op in the execution chain, will point to
13006 * 1),2): the padXv or gv op;
13007 * 3): the rv2Xv which forms the last op in the a_expr
13008 * execution chain, and the top-most op in the a_expr
13011 * For all cases, the 'start' node is no longer required,
13012 * but we can't free it since one or more external nodes
13013 * may point to it. E.g. consider
13014 * $h{foo} = $a ? $b : $c
13015 * Here, both the op_next and op_other branches of the
13016 * cond_expr point to the gv[*h] of the hash expression, so
13017 * we can't free the 'start' op.
13019 * For expr->[...], we need to save the subtree containing the
13020 * expression; for the other cases, we just need to save the
13022 * So in all cases, we null the start op and keep it around by
13023 * making it the child of the multideref op; for the expr->
13024 * case, the expr will be a subtree of the start node.
13026 * So in the simple 1,2 case the optree above changes to
13032 * ex-gv (or ex-padxv)
13034 * with the op_next chain being
13036 * -> ex-gv -> multideref -> op-following-ex-exists ->
13038 * In the 3 case, we have
13051 * -> rest-of-a_expr subtree ->
13052 * ex-rv2xv -> multideref -> op-following-ex-exists ->
13055 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13056 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13057 * multideref attached as the child, e.g.
13063 * ex-rv2av - i_expr1
13071 /* if we free this op, don't free the pad entry */
13072 if (reset_start_targ)
13073 start->op_targ = 0;
13076 /* Cut the bit we need to save out of the tree and attach to
13077 * the multideref op, then free the rest of the tree */
13079 /* find parent of node to be detached (for use by splice) */
13081 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
13082 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13084 /* there is an arbitrary expression preceding us, e.g.
13085 * expr->[..]? so we need to save the 'expr' subtree */
13086 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13087 p = cUNOPx(p)->op_first;
13088 ASSUME( start->op_type == OP_RV2AV
13089 || start->op_type == OP_RV2HV);
13092 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13093 * above for exists/delete. */
13094 while ( (p->op_flags & OPf_KIDS)
13095 && cUNOPx(p)->op_first != start
13097 p = cUNOPx(p)->op_first;
13099 ASSUME(cUNOPx(p)->op_first == start);
13101 /* detach from main tree, and re-attach under the multideref */
13102 op_sibling_splice(mderef, NULL, 0,
13103 op_sibling_splice(p, NULL, 1, NULL));
13106 start->op_next = mderef;
13108 mderef->op_next = index_skip == -1 ? o->op_next : o;
13110 /* excise and free the original tree, and replace with
13111 * the multideref op */
13112 p = op_sibling_splice(top_op, NULL, -1, mderef);
13121 Size_t size = arg - arg_buf;
13123 if (maybe_aelemfast && action_count == 1)
13126 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13127 sizeof(UNOP_AUX_item) * (size + 1));
13128 /* for dumping etc: store the length in a hidden first slot;
13129 * we set the op_aux pointer to the second slot */
13130 arg_buf->uv = size;
13133 } /* for (pass = ...) */
13138 /* mechanism for deferring recursion in rpeep() */
13140 #define MAX_DEFERRED 4
13144 if (defer_ix == (MAX_DEFERRED-1)) { \
13145 OP **defer = defer_queue[defer_base]; \
13146 CALL_RPEEP(*defer); \
13147 S_prune_chain_head(defer); \
13148 defer_base = (defer_base + 1) % MAX_DEFERRED; \
13151 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13154 #define IS_AND_OP(o) (o->op_type == OP_AND)
13155 #define IS_OR_OP(o) (o->op_type == OP_OR)
13158 /* A peephole optimizer. We visit the ops in the order they're to execute.
13159 * See the comments at the top of this file for more details about when
13160 * peep() is called */
13163 Perl_rpeep(pTHX_ OP *o)
13167 OP* oldoldop = NULL;
13168 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13169 int defer_base = 0;
13174 if (!o || o->op_opt)
13178 SAVEVPTR(PL_curcop);
13179 for (;; o = o->op_next) {
13180 if (o && o->op_opt)
13183 while (defer_ix >= 0) {
13185 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13186 CALL_RPEEP(*defer);
13187 S_prune_chain_head(defer);
13194 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13195 assert(!oldoldop || oldoldop->op_next == oldop);
13196 assert(!oldop || oldop->op_next == o);
13198 /* By default, this op has now been optimised. A couple of cases below
13199 clear this again. */
13203 /* look for a series of 1 or more aggregate derefs, e.g.
13204 * $a[1]{foo}[$i]{$k}
13205 * and replace with a single OP_MULTIDEREF op.
13206 * Each index must be either a const, or a simple variable,
13208 * First, look for likely combinations of starting ops,
13209 * corresponding to (global and lexical variants of)
13211 * $r->[...] $r->{...}
13212 * (preceding expression)->[...]
13213 * (preceding expression)->{...}
13214 * and if so, call maybe_multideref() to do a full inspection
13215 * of the op chain and if appropriate, replace with an
13223 switch (o2->op_type) {
13225 /* $pkg[..] : gv[*pkg]
13226 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
13228 /* Fail if there are new op flag combinations that we're
13229 * not aware of, rather than:
13230 * * silently failing to optimise, or
13231 * * silently optimising the flag away.
13232 * If this ASSUME starts failing, examine what new flag
13233 * has been added to the op, and decide whether the
13234 * optimisation should still occur with that flag, then
13235 * update the code accordingly. This applies to all the
13236 * other ASSUMEs in the block of code too.
13238 ASSUME(!(o2->op_flags &
13239 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13240 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13244 if (o2->op_type == OP_RV2AV) {
13245 action = MDEREF_AV_gvav_aelem;
13249 if (o2->op_type == OP_RV2HV) {
13250 action = MDEREF_HV_gvhv_helem;
13254 if (o2->op_type != OP_RV2SV)
13257 /* at this point we've seen gv,rv2sv, so the only valid
13258 * construct left is $pkg->[] or $pkg->{} */
13260 ASSUME(!(o2->op_flags & OPf_STACKED));
13261 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13262 != (OPf_WANT_SCALAR|OPf_MOD))
13265 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13266 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13267 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13269 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
13270 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13274 if (o2->op_type == OP_RV2AV) {
13275 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13278 if (o2->op_type == OP_RV2HV) {
13279 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13285 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13287 ASSUME(!(o2->op_flags &
13288 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13289 if ((o2->op_flags &
13290 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13291 != (OPf_WANT_SCALAR|OPf_MOD))
13294 ASSUME(!(o2->op_private &
13295 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13296 /* skip if state or intro, or not a deref */
13297 if ( o2->op_private != OPpDEREF_AV
13298 && o2->op_private != OPpDEREF_HV)
13302 if (o2->op_type == OP_RV2AV) {
13303 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13306 if (o2->op_type == OP_RV2HV) {
13307 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13314 /* $lex[..]: padav[@lex:1,2] sR *
13315 * or $lex{..}: padhv[%lex:1,2] sR */
13316 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13317 OPf_REF|OPf_SPECIAL)));
13318 if ((o2->op_flags &
13319 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13320 != (OPf_WANT_SCALAR|OPf_REF))
13322 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13324 /* OPf_PARENS isn't currently used in this case;
13325 * if that changes, let us know! */
13326 ASSUME(!(o2->op_flags & OPf_PARENS));
13328 /* at this point, we wouldn't expect any of the remaining
13329 * possible private flags:
13330 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13331 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13333 * OPpSLICEWARNING shouldn't affect runtime
13335 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13337 action = o2->op_type == OP_PADAV
13338 ? MDEREF_AV_padav_aelem
13339 : MDEREF_HV_padhv_helem;
13341 S_maybe_multideref(aTHX_ o, o2, action, 0);
13347 action = o2->op_type == OP_RV2AV
13348 ? MDEREF_AV_pop_rv2av_aelem
13349 : MDEREF_HV_pop_rv2hv_helem;
13352 /* (expr)->[...]: rv2av sKR/1;
13353 * (expr)->{...}: rv2hv sKR/1; */
13355 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13357 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13358 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13359 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13362 /* at this point, we wouldn't expect any of these
13363 * possible private flags:
13364 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13365 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13367 ASSUME(!(o2->op_private &
13368 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13370 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13374 S_maybe_multideref(aTHX_ o, o2, action, hints);
13383 switch (o->op_type) {
13385 PL_curcop = ((COP*)o); /* for warnings */
13388 PL_curcop = ((COP*)o); /* for warnings */
13390 /* Optimise a "return ..." at the end of a sub to just be "...".
13391 * This saves 2 ops. Before:
13392 * 1 <;> nextstate(main 1 -e:1) v ->2
13393 * 4 <@> return K ->5
13394 * 2 <0> pushmark s ->3
13395 * - <1> ex-rv2sv sK/1 ->4
13396 * 3 <#> gvsv[*cat] s ->4
13399 * - <@> return K ->-
13400 * - <0> pushmark s ->2
13401 * - <1> ex-rv2sv sK/1 ->-
13402 * 2 <$> gvsv(*cat) s ->3
13405 OP *next = o->op_next;
13406 OP *sibling = OpSIBLING(o);
13407 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13408 && OP_TYPE_IS(sibling, OP_RETURN)
13409 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13410 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13411 ||OP_TYPE_IS(sibling->op_next->op_next,
13413 && cUNOPx(sibling)->op_first == next
13414 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13417 /* Look through the PUSHMARK's siblings for one that
13418 * points to the RETURN */
13419 OP *top = OpSIBLING(next);
13420 while (top && top->op_next) {
13421 if (top->op_next == sibling) {
13422 top->op_next = sibling->op_next;
13423 o->op_next = next->op_next;
13426 top = OpSIBLING(top);
13431 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13433 * This latter form is then suitable for conversion into padrange
13434 * later on. Convert:
13436 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13440 * nextstate1 -> listop -> nextstate3
13442 * pushmark -> padop1 -> padop2
13444 if (o->op_next && (
13445 o->op_next->op_type == OP_PADSV
13446 || o->op_next->op_type == OP_PADAV
13447 || o->op_next->op_type == OP_PADHV
13449 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13450 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13451 && o->op_next->op_next->op_next && (
13452 o->op_next->op_next->op_next->op_type == OP_PADSV
13453 || o->op_next->op_next->op_next->op_type == OP_PADAV
13454 || o->op_next->op_next->op_next->op_type == OP_PADHV
13456 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13457 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13458 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13459 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13461 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13464 ns2 = pad1->op_next;
13465 pad2 = ns2->op_next;
13466 ns3 = pad2->op_next;
13468 /* we assume here that the op_next chain is the same as
13469 * the op_sibling chain */
13470 assert(OpSIBLING(o) == pad1);
13471 assert(OpSIBLING(pad1) == ns2);
13472 assert(OpSIBLING(ns2) == pad2);
13473 assert(OpSIBLING(pad2) == ns3);
13475 /* excise and delete ns2 */
13476 op_sibling_splice(NULL, pad1, 1, NULL);
13479 /* excise pad1 and pad2 */
13480 op_sibling_splice(NULL, o, 2, NULL);
13482 /* create new listop, with children consisting of:
13483 * a new pushmark, pad1, pad2. */
13484 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13485 newop->op_flags |= OPf_PARENS;
13486 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13488 /* insert newop between o and ns3 */
13489 op_sibling_splice(NULL, o, 0, newop);
13491 /*fixup op_next chain */
13492 newpm = cUNOPx(newop)->op_first; /* pushmark */
13493 o ->op_next = newpm;
13494 newpm->op_next = pad1;
13495 pad1 ->op_next = pad2;
13496 pad2 ->op_next = newop; /* listop */
13497 newop->op_next = ns3;
13499 /* Ensure pushmark has this flag if padops do */
13500 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13501 newpm->op_flags |= OPf_MOD;
13507 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13508 to carry two labels. For now, take the easier option, and skip
13509 this optimisation if the first NEXTSTATE has a label. */
13510 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13511 OP *nextop = o->op_next;
13512 while (nextop && nextop->op_type == OP_NULL)
13513 nextop = nextop->op_next;
13515 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13518 oldop->op_next = nextop;
13520 /* Skip (old)oldop assignment since the current oldop's
13521 op_next already points to the next op. */
13528 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13529 if (o->op_next->op_private & OPpTARGET_MY) {
13530 if (o->op_flags & OPf_STACKED) /* chained concats */
13531 break; /* ignore_optimization */
13533 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13534 o->op_targ = o->op_next->op_targ;
13535 o->op_next->op_targ = 0;
13536 o->op_private |= OPpTARGET_MY;
13539 op_null(o->op_next);
13543 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13544 break; /* Scalar stub must produce undef. List stub is noop */
13548 if (o->op_targ == OP_NEXTSTATE
13549 || o->op_targ == OP_DBSTATE)
13551 PL_curcop = ((COP*)o);
13553 /* XXX: We avoid setting op_seq here to prevent later calls
13554 to rpeep() from mistakenly concluding that optimisation
13555 has already occurred. This doesn't fix the real problem,
13556 though (See 20010220.007). AMS 20010719 */
13557 /* op_seq functionality is now replaced by op_opt */
13565 oldop->op_next = o->op_next;
13579 convert repeat into a stub with no kids.
13581 if (o->op_next->op_type == OP_CONST
13582 || ( o->op_next->op_type == OP_PADSV
13583 && !(o->op_next->op_private & OPpLVAL_INTRO))
13584 || ( o->op_next->op_type == OP_GV
13585 && o->op_next->op_next->op_type == OP_RV2SV
13586 && !(o->op_next->op_next->op_private
13587 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13589 const OP *kid = o->op_next->op_next;
13590 if (o->op_next->op_type == OP_GV)
13591 kid = kid->op_next;
13592 /* kid is now the ex-list. */
13593 if (kid->op_type == OP_NULL
13594 && (kid = kid->op_next)->op_type == OP_CONST
13595 /* kid is now the repeat count. */
13596 && kid->op_next->op_type == OP_REPEAT
13597 && kid->op_next->op_private & OPpREPEAT_DOLIST
13598 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13599 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13601 o = kid->op_next; /* repeat */
13603 oldop->op_next = o;
13604 op_free(cBINOPo->op_first);
13605 op_free(cBINOPo->op_last );
13606 o->op_flags &=~ OPf_KIDS;
13607 /* stub is a baseop; repeat is a binop */
13608 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13609 OpTYPE_set(o, OP_STUB);
13615 /* Convert a series of PAD ops for my vars plus support into a
13616 * single padrange op. Basically
13618 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13620 * becomes, depending on circumstances, one of
13622 * padrange ----------------------------------> (list) -> rest
13623 * padrange --------------------------------------------> rest
13625 * where all the pad indexes are sequential and of the same type
13627 * We convert the pushmark into a padrange op, then skip
13628 * any other pad ops, and possibly some trailing ops.
13629 * Note that we don't null() the skipped ops, to make it
13630 * easier for Deparse to undo this optimisation (and none of
13631 * the skipped ops are holding any resourses). It also makes
13632 * it easier for find_uninit_var(), as it can just ignore
13633 * padrange, and examine the original pad ops.
13637 OP *followop = NULL; /* the op that will follow the padrange op */
13640 PADOFFSET base = 0; /* init only to stop compiler whining */
13641 bool gvoid = 0; /* init only to stop compiler whining */
13642 bool defav = 0; /* seen (...) = @_ */
13643 bool reuse = 0; /* reuse an existing padrange op */
13645 /* look for a pushmark -> gv[_] -> rv2av */
13650 if ( p->op_type == OP_GV
13651 && cGVOPx_gv(p) == PL_defgv
13652 && (rv2av = p->op_next)
13653 && rv2av->op_type == OP_RV2AV
13654 && !(rv2av->op_flags & OPf_REF)
13655 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13656 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13658 q = rv2av->op_next;
13659 if (q->op_type == OP_NULL)
13661 if (q->op_type == OP_PUSHMARK) {
13671 /* scan for PAD ops */
13673 for (p = p->op_next; p; p = p->op_next) {
13674 if (p->op_type == OP_NULL)
13677 if (( p->op_type != OP_PADSV
13678 && p->op_type != OP_PADAV
13679 && p->op_type != OP_PADHV
13681 /* any private flag other than INTRO? e.g. STATE */
13682 || (p->op_private & ~OPpLVAL_INTRO)
13686 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13688 if ( p->op_type == OP_PADAV
13690 && p->op_next->op_type == OP_CONST
13691 && p->op_next->op_next
13692 && p->op_next->op_next->op_type == OP_AELEM
13696 /* for 1st padop, note what type it is and the range
13697 * start; for the others, check that it's the same type
13698 * and that the targs are contiguous */
13700 intro = (p->op_private & OPpLVAL_INTRO);
13702 gvoid = OP_GIMME(p,0) == G_VOID;
13705 if ((p->op_private & OPpLVAL_INTRO) != intro)
13707 /* Note that you'd normally expect targs to be
13708 * contiguous in my($a,$b,$c), but that's not the case
13709 * when external modules start doing things, e.g.
13710 * Function::Parameters */
13711 if (p->op_targ != base + count)
13713 assert(p->op_targ == base + count);
13714 /* Either all the padops or none of the padops should
13715 be in void context. Since we only do the optimisa-
13716 tion for av/hv when the aggregate itself is pushed
13717 on to the stack (one item), there is no need to dis-
13718 tinguish list from scalar context. */
13719 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13723 /* for AV, HV, only when we're not flattening */
13724 if ( p->op_type != OP_PADSV
13726 && !(p->op_flags & OPf_REF)
13730 if (count >= OPpPADRANGE_COUNTMASK)
13733 /* there's a biggest base we can fit into a
13734 * SAVEt_CLEARPADRANGE in pp_padrange.
13735 * (The sizeof() stuff will be constant-folded, and is
13736 * intended to avoid getting "comparison is always false"
13737 * compiler warnings. See the comments above
13738 * MEM_WRAP_CHECK for more explanation on why we do this
13739 * in a weird way to avoid compiler warnings.)
13742 && (8*sizeof(base) >
13743 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13745 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13747 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13751 /* Success! We've got another valid pad op to optimise away */
13753 followop = p->op_next;
13756 if (count < 1 || (count == 1 && !defav))
13759 /* pp_padrange in specifically compile-time void context
13760 * skips pushing a mark and lexicals; in all other contexts
13761 * (including unknown till runtime) it pushes a mark and the
13762 * lexicals. We must be very careful then, that the ops we
13763 * optimise away would have exactly the same effect as the
13765 * In particular in void context, we can only optimise to
13766 * a padrange if we see the complete sequence
13767 * pushmark, pad*v, ...., list
13768 * which has the net effect of leaving the markstack as it
13769 * was. Not pushing onto the stack (whereas padsv does touch
13770 * the stack) makes no difference in void context.
13774 if (followop->op_type == OP_LIST
13775 && OP_GIMME(followop,0) == G_VOID
13778 followop = followop->op_next; /* skip OP_LIST */
13780 /* consolidate two successive my(...);'s */
13783 && oldoldop->op_type == OP_PADRANGE
13784 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13785 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13786 && !(oldoldop->op_flags & OPf_SPECIAL)
13789 assert(oldoldop->op_next == oldop);
13790 assert( oldop->op_type == OP_NEXTSTATE
13791 || oldop->op_type == OP_DBSTATE);
13792 assert(oldop->op_next == o);
13795 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13797 /* Do not assume pad offsets for $c and $d are con-
13802 if ( oldoldop->op_targ + old_count == base
13803 && old_count < OPpPADRANGE_COUNTMASK - count) {
13804 base = oldoldop->op_targ;
13805 count += old_count;
13810 /* if there's any immediately following singleton
13811 * my var's; then swallow them and the associated
13813 * my ($a,$b); my $c; my $d;
13815 * my ($a,$b,$c,$d);
13818 while ( ((p = followop->op_next))
13819 && ( p->op_type == OP_PADSV
13820 || p->op_type == OP_PADAV
13821 || p->op_type == OP_PADHV)
13822 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13823 && (p->op_private & OPpLVAL_INTRO) == intro
13824 && !(p->op_private & ~OPpLVAL_INTRO)
13826 && ( p->op_next->op_type == OP_NEXTSTATE
13827 || p->op_next->op_type == OP_DBSTATE)
13828 && count < OPpPADRANGE_COUNTMASK
13829 && base + count == p->op_targ
13832 followop = p->op_next;
13840 assert(oldoldop->op_type == OP_PADRANGE);
13841 oldoldop->op_next = followop;
13842 oldoldop->op_private = (intro | count);
13848 /* Convert the pushmark into a padrange.
13849 * To make Deparse easier, we guarantee that a padrange was
13850 * *always* formerly a pushmark */
13851 assert(o->op_type == OP_PUSHMARK);
13852 o->op_next = followop;
13853 OpTYPE_set(o, OP_PADRANGE);
13855 /* bit 7: INTRO; bit 6..0: count */
13856 o->op_private = (intro | count);
13857 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13858 | gvoid * OPf_WANT_VOID
13859 | (defav ? OPf_SPECIAL : 0));
13867 /* Skip over state($x) in void context. */
13868 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13869 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13871 oldop->op_next = o->op_next;
13872 goto redo_nextstate;
13874 if (o->op_type != OP_PADAV)
13878 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13879 OP* const pop = (o->op_type == OP_PADAV) ?
13880 o->op_next : o->op_next->op_next;
13882 if (pop && pop->op_type == OP_CONST &&
13883 ((PL_op = pop->op_next)) &&
13884 pop->op_next->op_type == OP_AELEM &&
13885 !(pop->op_next->op_private &
13886 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13887 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13890 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13891 no_bareword_allowed(pop);
13892 if (o->op_type == OP_GV)
13893 op_null(o->op_next);
13894 op_null(pop->op_next);
13896 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13897 o->op_next = pop->op_next->op_next;
13898 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13899 o->op_private = (U8)i;
13900 if (o->op_type == OP_GV) {
13903 o->op_type = OP_AELEMFAST;
13906 o->op_type = OP_AELEMFAST_LEX;
13908 if (o->op_type != OP_GV)
13912 /* Remove $foo from the op_next chain in void context. */
13914 && ( o->op_next->op_type == OP_RV2SV
13915 || o->op_next->op_type == OP_RV2AV
13916 || o->op_next->op_type == OP_RV2HV )
13917 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13918 && !(o->op_next->op_private & OPpLVAL_INTRO))
13920 oldop->op_next = o->op_next->op_next;
13921 /* Reprocess the previous op if it is a nextstate, to
13922 allow double-nextstate optimisation. */
13924 if (oldop->op_type == OP_NEXTSTATE) {
13931 o = oldop->op_next;
13934 else if (o->op_next->op_type == OP_RV2SV) {
13935 if (!(o->op_next->op_private & OPpDEREF)) {
13936 op_null(o->op_next);
13937 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13939 o->op_next = o->op_next->op_next;
13940 OpTYPE_set(o, OP_GVSV);
13943 else if (o->op_next->op_type == OP_READLINE
13944 && o->op_next->op_next->op_type == OP_CONCAT
13945 && (o->op_next->op_next->op_flags & OPf_STACKED))
13947 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13948 OpTYPE_set(o, OP_RCATLINE);
13949 o->op_flags |= OPf_STACKED;
13950 op_null(o->op_next->op_next);
13951 op_null(o->op_next);
13956 #define HV_OR_SCALARHV(op) \
13957 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13959 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13960 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
13961 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
13962 ? cUNOPx(op)->op_first \
13966 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13967 fop->op_private |= OPpTRUEBOOL;
13973 fop = cLOGOP->op_first;
13974 sop = OpSIBLING(fop);
13975 while (cLOGOP->op_other->op_type == OP_NULL)
13976 cLOGOP->op_other = cLOGOP->op_other->op_next;
13977 while (o->op_next && ( o->op_type == o->op_next->op_type
13978 || o->op_next->op_type == OP_NULL))
13979 o->op_next = o->op_next->op_next;
13981 /* If we're an OR and our next is an AND in void context, we'll
13982 follow its op_other on short circuit, same for reverse.
13983 We can't do this with OP_DOR since if it's true, its return
13984 value is the underlying value which must be evaluated
13988 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13989 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13991 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13993 o->op_next = ((LOGOP*)o->op_next)->op_other;
13995 DEFER(cLOGOP->op_other);
13998 fop = HV_OR_SCALARHV(fop);
13999 if (sop) sop = HV_OR_SCALARHV(sop);
14004 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
14005 while (nop && nop->op_next) {
14006 switch (nop->op_next->op_type) {
14011 lop = nop = nop->op_next;
14014 nop = nop->op_next;
14023 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14024 || o->op_type == OP_AND )
14025 fop->op_private |= OPpTRUEBOOL;
14026 else if (!(lop->op_flags & OPf_WANT))
14027 fop->op_private |= OPpMAYBE_TRUEBOOL;
14029 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14031 sop->op_private |= OPpTRUEBOOL;
14038 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
14039 fop->op_private |= OPpTRUEBOOL;
14040 #undef HV_OR_SCALARHV
14041 /* GERONIMO! */ /* FALLTHROUGH */
14050 while (cLOGOP->op_other->op_type == OP_NULL)
14051 cLOGOP->op_other = cLOGOP->op_other->op_next;
14052 DEFER(cLOGOP->op_other);
14057 while (cLOOP->op_redoop->op_type == OP_NULL)
14058 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14059 while (cLOOP->op_nextop->op_type == OP_NULL)
14060 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14061 while (cLOOP->op_lastop->op_type == OP_NULL)
14062 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14063 /* a while(1) loop doesn't have an op_next that escapes the
14064 * loop, so we have to explicitly follow the op_lastop to
14065 * process the rest of the code */
14066 DEFER(cLOOP->op_lastop);
14070 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14071 DEFER(cLOGOPo->op_other);
14075 assert(!(cPMOP->op_pmflags & PMf_ONCE));
14076 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14077 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14078 cPMOP->op_pmstashstartu.op_pmreplstart
14079 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14080 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14086 if (o->op_flags & OPf_SPECIAL) {
14087 /* first arg is a code block */
14088 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14089 OP * kid = cUNOPx(nullop)->op_first;
14091 assert(nullop->op_type == OP_NULL);
14092 assert(kid->op_type == OP_SCOPE
14093 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14094 /* since OP_SORT doesn't have a handy op_other-style
14095 * field that can point directly to the start of the code
14096 * block, store it in the otherwise-unused op_next field
14097 * of the top-level OP_NULL. This will be quicker at
14098 * run-time, and it will also allow us to remove leading
14099 * OP_NULLs by just messing with op_nexts without
14100 * altering the basic op_first/op_sibling layout. */
14101 kid = kLISTOP->op_first;
14103 (kid->op_type == OP_NULL
14104 && ( kid->op_targ == OP_NEXTSTATE
14105 || kid->op_targ == OP_DBSTATE ))
14106 || kid->op_type == OP_STUB
14107 || kid->op_type == OP_ENTER);
14108 nullop->op_next = kLISTOP->op_next;
14109 DEFER(nullop->op_next);
14112 /* check that RHS of sort is a single plain array */
14113 oright = cUNOPo->op_first;
14114 if (!oright || oright->op_type != OP_PUSHMARK)
14117 if (o->op_private & OPpSORT_INPLACE)
14120 /* reverse sort ... can be optimised. */
14121 if (!OpHAS_SIBLING(cUNOPo)) {
14122 /* Nothing follows us on the list. */
14123 OP * const reverse = o->op_next;
14125 if (reverse->op_type == OP_REVERSE &&
14126 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14127 OP * const pushmark = cUNOPx(reverse)->op_first;
14128 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14129 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14130 /* reverse -> pushmark -> sort */
14131 o->op_private |= OPpSORT_REVERSE;
14133 pushmark->op_next = oright->op_next;
14143 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14145 LISTOP *enter, *exlist;
14147 if (o->op_private & OPpSORT_INPLACE)
14150 enter = (LISTOP *) o->op_next;
14153 if (enter->op_type == OP_NULL) {
14154 enter = (LISTOP *) enter->op_next;
14158 /* for $a (...) will have OP_GV then OP_RV2GV here.
14159 for (...) just has an OP_GV. */
14160 if (enter->op_type == OP_GV) {
14161 gvop = (OP *) enter;
14162 enter = (LISTOP *) enter->op_next;
14165 if (enter->op_type == OP_RV2GV) {
14166 enter = (LISTOP *) enter->op_next;
14172 if (enter->op_type != OP_ENTERITER)
14175 iter = enter->op_next;
14176 if (!iter || iter->op_type != OP_ITER)
14179 expushmark = enter->op_first;
14180 if (!expushmark || expushmark->op_type != OP_NULL
14181 || expushmark->op_targ != OP_PUSHMARK)
14184 exlist = (LISTOP *) OpSIBLING(expushmark);
14185 if (!exlist || exlist->op_type != OP_NULL
14186 || exlist->op_targ != OP_LIST)
14189 if (exlist->op_last != o) {
14190 /* Mmm. Was expecting to point back to this op. */
14193 theirmark = exlist->op_first;
14194 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14197 if (OpSIBLING(theirmark) != o) {
14198 /* There's something between the mark and the reverse, eg
14199 for (1, reverse (...))
14204 ourmark = ((LISTOP *)o)->op_first;
14205 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14208 ourlast = ((LISTOP *)o)->op_last;
14209 if (!ourlast || ourlast->op_next != o)
14212 rv2av = OpSIBLING(ourmark);
14213 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14214 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14215 /* We're just reversing a single array. */
14216 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14217 enter->op_flags |= OPf_STACKED;
14220 /* We don't have control over who points to theirmark, so sacrifice
14222 theirmark->op_next = ourmark->op_next;
14223 theirmark->op_flags = ourmark->op_flags;
14224 ourlast->op_next = gvop ? gvop : (OP *) enter;
14227 enter->op_private |= OPpITER_REVERSED;
14228 iter->op_private |= OPpITER_REVERSED;
14232 o = oldop->op_next;
14240 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14241 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14246 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14247 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14250 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14252 sv = newRV((SV *)PL_compcv);
14256 OpTYPE_set(o, OP_CONST);
14257 o->op_flags |= OPf_SPECIAL;
14258 cSVOPo->op_sv = sv;
14263 if (OP_GIMME(o,0) == G_VOID
14264 || ( o->op_next->op_type == OP_LINESEQ
14265 && ( o->op_next->op_next->op_type == OP_LEAVESUB
14266 || ( o->op_next->op_next->op_type == OP_RETURN
14267 && !CvLVALUE(PL_compcv)))))
14269 OP *right = cBINOP->op_first;
14288 OP *left = OpSIBLING(right);
14289 if (left->op_type == OP_SUBSTR
14290 && (left->op_private & 7) < 4) {
14292 /* cut out right */
14293 op_sibling_splice(o, NULL, 1, NULL);
14294 /* and insert it as second child of OP_SUBSTR */
14295 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14297 left->op_private |= OPpSUBSTR_REPL_FIRST;
14299 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14306 int l, r, lr, lscalars, rscalars;
14308 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14309 Note that we do this now rather than in newASSIGNOP(),
14310 since only by now are aliased lexicals flagged as such
14312 See the essay "Common vars in list assignment" above for
14313 the full details of the rationale behind all the conditions
14316 PL_generation sorcery:
14317 To detect whether there are common vars, the global var
14318 PL_generation is incremented for each assign op we scan.
14319 Then we run through all the lexical variables on the LHS,
14320 of the assignment, setting a spare slot in each of them to
14321 PL_generation. Then we scan the RHS, and if any lexicals
14322 already have that value, we know we've got commonality.
14323 Also, if the generation number is already set to
14324 PERL_INT_MAX, then the variable is involved in aliasing, so
14325 we also have potential commonality in that case.
14331 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
14334 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14338 /* After looking for things which are *always* safe, this main
14339 * if/else chain selects primarily based on the type of the
14340 * LHS, gradually working its way down from the more dangerous
14341 * to the more restrictive and thus safer cases */
14343 if ( !l /* () = ....; */
14344 || !r /* .... = (); */
14345 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14346 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14347 || (lscalars < 2) /* ($x, undef) = ... */
14349 NOOP; /* always safe */
14351 else if (l & AAS_DANGEROUS) {
14352 /* always dangerous */
14353 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14354 o->op_private |= OPpASSIGN_COMMON_AGG;
14356 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14357 /* package vars are always dangerous - too many
14358 * aliasing possibilities */
14359 if (l & AAS_PKG_SCALAR)
14360 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14361 if (l & AAS_PKG_AGG)
14362 o->op_private |= OPpASSIGN_COMMON_AGG;
14364 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14365 |AAS_LEX_SCALAR|AAS_LEX_AGG))
14367 /* LHS contains only lexicals and safe ops */
14369 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14370 o->op_private |= OPpASSIGN_COMMON_AGG;
14372 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14373 if (lr & AAS_LEX_SCALAR_COMM)
14374 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14375 else if ( !(l & AAS_LEX_SCALAR)
14376 && (r & AAS_DEFAV))
14380 * as scalar-safe for performance reasons.
14381 * (it will still have been marked _AGG if necessary */
14384 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14385 o->op_private |= OPpASSIGN_COMMON_RC1;
14390 * may have to handle aggregate on LHS, but we can't
14391 * have common scalars. */
14394 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14400 Perl_cpeep_t cpeep =
14401 XopENTRYCUSTOM(o, xop_peep);
14403 cpeep(aTHX_ o, oldop);
14408 /* did we just null the current op? If so, re-process it to handle
14409 * eliding "empty" ops from the chain */
14410 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14423 Perl_peep(pTHX_ OP *o)
14429 =head1 Custom Operators
14431 =for apidoc Ao||custom_op_xop
14432 Return the XOP structure for a given custom op. This macro should be
14433 considered internal to C<OP_NAME> and the other access macros: use them instead.
14434 This macro does call a function. Prior
14435 to 5.19.6, this was implemented as a
14442 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14448 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14450 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14451 assert(o->op_type == OP_CUSTOM);
14453 /* This is wrong. It assumes a function pointer can be cast to IV,
14454 * which isn't guaranteed, but this is what the old custom OP code
14455 * did. In principle it should be safer to Copy the bytes of the
14456 * pointer into a PV: since the new interface is hidden behind
14457 * functions, this can be changed later if necessary. */
14458 /* Change custom_op_xop if this ever happens */
14459 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14462 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14464 /* assume noone will have just registered a desc */
14465 if (!he && PL_custom_op_names &&
14466 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14471 /* XXX does all this need to be shared mem? */
14472 Newxz(xop, 1, XOP);
14473 pv = SvPV(HeVAL(he), l);
14474 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14475 if (PL_custom_op_descs &&
14476 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14478 pv = SvPV(HeVAL(he), l);
14479 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14481 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14485 xop = (XOP *)&xop_null;
14487 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14491 if(field == XOPe_xop_ptr) {
14494 const U32 flags = XopFLAGS(xop);
14495 if(flags & field) {
14497 case XOPe_xop_name:
14498 any.xop_name = xop->xop_name;
14500 case XOPe_xop_desc:
14501 any.xop_desc = xop->xop_desc;
14503 case XOPe_xop_class:
14504 any.xop_class = xop->xop_class;
14506 case XOPe_xop_peep:
14507 any.xop_peep = xop->xop_peep;
14510 NOT_REACHED; /* NOTREACHED */
14515 case XOPe_xop_name:
14516 any.xop_name = XOPd_xop_name;
14518 case XOPe_xop_desc:
14519 any.xop_desc = XOPd_xop_desc;
14521 case XOPe_xop_class:
14522 any.xop_class = XOPd_xop_class;
14524 case XOPe_xop_peep:
14525 any.xop_peep = XOPd_xop_peep;
14528 NOT_REACHED; /* NOTREACHED */
14533 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14534 * op.c: In function 'Perl_custom_op_get_field':
14535 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14536 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14537 * expands to assert(0), which expands to ((0) ? (void)0 :
14538 * __assert(...)), and gcc doesn't know that __assert can never return. */
14544 =for apidoc Ao||custom_op_register
14545 Register a custom op. See L<perlguts/"Custom Operators">.
14551 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14555 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14557 /* see the comment in custom_op_xop */
14558 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14560 if (!PL_custom_ops)
14561 PL_custom_ops = newHV();
14563 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14564 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14569 =for apidoc core_prototype
14571 This function assigns the prototype of the named core function to C<sv>, or
14572 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
14573 C<NULL> if the core function has no prototype. C<code> is a code as returned
14574 by C<keyword()>. It must not be equal to 0.
14580 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14583 int i = 0, n = 0, seen_question = 0, defgv = 0;
14585 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14586 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14587 bool nullret = FALSE;
14589 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14593 if (!sv) sv = sv_newmortal();
14595 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14597 switch (code < 0 ? -code : code) {
14598 case KEY_and : case KEY_chop: case KEY_chomp:
14599 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14600 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14601 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14602 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14603 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14604 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14605 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14606 case KEY_x : case KEY_xor :
14607 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14608 case KEY_glob: retsetpvs("_;", OP_GLOB);
14609 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
14610 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
14611 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
14612 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14613 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14615 case KEY_evalbytes:
14616 name = "entereval"; break;
14624 while (i < MAXO) { /* The slow way. */
14625 if (strEQ(name, PL_op_name[i])
14626 || strEQ(name, PL_op_desc[i]))
14628 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14635 defgv = PL_opargs[i] & OA_DEFGV;
14636 oa = PL_opargs[i] >> OASHIFT;
14638 if (oa & OA_OPTIONAL && !seen_question && (
14639 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14644 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14645 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14646 /* But globs are already references (kinda) */
14647 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14651 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14652 && !scalar_mod_type(NULL, i)) {
14657 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14661 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14662 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14663 str[n-1] = '_'; defgv = 0;
14667 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14669 sv_setpvn(sv, str, n - 1);
14670 if (opnum) *opnum = i;
14675 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14678 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14681 PERL_ARGS_ASSERT_CORESUB_OP;
14685 return op_append_elem(OP_LINESEQ,
14688 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14692 case OP_SELECT: /* which represents OP_SSELECT as well */
14697 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14698 newSVOP(OP_CONST, 0, newSVuv(1))
14700 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14702 coresub_op(coreargssv, 0, OP_SELECT)
14706 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14708 return op_append_elem(
14711 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14712 ? OPpOFFBYONE << 8 : 0)
14714 case OA_BASEOP_OR_UNOP:
14715 if (opnum == OP_ENTEREVAL) {
14716 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14717 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14719 else o = newUNOP(opnum,0,argop);
14720 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14723 if (is_handle_constructor(o, 1))
14724 argop->op_private |= OPpCOREARGS_DEREF1;
14725 if (scalar_mod_type(NULL, opnum))
14726 argop->op_private |= OPpCOREARGS_SCALARMOD;
14730 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14731 if (is_handle_constructor(o, 2))
14732 argop->op_private |= OPpCOREARGS_DEREF2;
14733 if (opnum == OP_SUBSTR) {
14734 o->op_private |= OPpMAYBE_LVSUB;
14743 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14744 SV * const *new_const_svp)
14746 const char *hvname;
14747 bool is_const = !!CvCONST(old_cv);
14748 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14750 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14752 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14754 /* They are 2 constant subroutines generated from
14755 the same constant. This probably means that
14756 they are really the "same" proxy subroutine
14757 instantiated in 2 places. Most likely this is
14758 when a constant is exported twice. Don't warn.
14761 (ckWARN(WARN_REDEFINE)
14763 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14764 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14765 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14766 strEQ(hvname, "autouse"))
14770 && ckWARN_d(WARN_REDEFINE)
14771 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14774 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14776 ? "Constant subroutine %"SVf" redefined"
14777 : "Subroutine %"SVf" redefined",
14782 =head1 Hook manipulation
14784 These functions provide convenient and thread-safe means of manipulating
14791 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14793 Puts a C function into the chain of check functions for a specified op
14794 type. This is the preferred way to manipulate the L</PL_check> array.
14795 C<opcode> specifies which type of op is to be affected. C<new_checker>
14796 is a pointer to the C function that is to be added to that opcode's
14797 check chain, and C<old_checker_p> points to the storage location where a
14798 pointer to the next function in the chain will be stored. The value of
14799 C<new_pointer> is written into the L</PL_check> array, while the value
14800 previously stored there is written to C<*old_checker_p>.
14802 The function should be defined like this:
14804 static OP *new_checker(pTHX_ OP *op) { ... }
14806 It is intended to be called in this manner:
14808 new_checker(aTHX_ op)
14810 C<old_checker_p> should be defined like this:
14812 static Perl_check_t old_checker_p;
14814 L</PL_check> is global to an entire process, and a module wishing to
14815 hook op checking may find itself invoked more than once per process,
14816 typically in different threads. To handle that situation, this function
14817 is idempotent. The location C<*old_checker_p> must initially (once
14818 per process) contain a null pointer. A C variable of static duration
14819 (declared at file scope, typically also marked C<static> to give
14820 it internal linkage) will be implicitly initialised appropriately,
14821 if it does not have an explicit initialiser. This function will only
14822 actually modify the check chain if it finds C<*old_checker_p> to be null.
14823 This function is also thread safe on the small scale. It uses appropriate
14824 locking to avoid race conditions in accessing L</PL_check>.
14826 When this function is called, the function referenced by C<new_checker>
14827 must be ready to be called, except for C<*old_checker_p> being unfilled.
14828 In a threading situation, C<new_checker> may be called immediately,
14829 even before this function has returned. C<*old_checker_p> will always
14830 be appropriately set before C<new_checker> is called. If C<new_checker>
14831 decides not to do anything special with an op that it is given (which
14832 is the usual case for most uses of op check hooking), it must chain the
14833 check function referenced by C<*old_checker_p>.
14835 If you want to influence compilation of calls to a specific subroutine,
14836 then use L</cv_set_call_checker> rather than hooking checking of all
14843 Perl_wrap_op_checker(pTHX_ Optype opcode,
14844 Perl_check_t new_checker, Perl_check_t *old_checker_p)
14848 PERL_UNUSED_CONTEXT;
14849 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14850 if (*old_checker_p) return;
14851 OP_CHECK_MUTEX_LOCK;
14852 if (!*old_checker_p) {
14853 *old_checker_p = PL_check[opcode];
14854 PL_check[opcode] = new_checker;
14856 OP_CHECK_MUTEX_UNLOCK;
14861 /* Efficient sub that returns a constant scalar value. */
14863 const_sv_xsub(pTHX_ CV* cv)
14866 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14867 PERL_UNUSED_ARG(items);
14877 const_av_xsub(pTHX_ CV* cv)
14880 AV * const av = MUTABLE_AV(XSANY.any_ptr);
14888 if (SvRMAGICAL(av))
14889 Perl_croak(aTHX_ "Magical list constants are not supported");
14890 if (GIMME_V != G_ARRAY) {
14892 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14895 EXTEND(SP, AvFILLp(av)+1);
14896 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14897 XSRETURN(AvFILLp(av)+1);
14901 * ex: set ts=8 sts=4 sw=4 et: