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 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1538 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1539 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1540 if (ckWARN(WARN_SYNTAX)) {
1541 const line_t oldline = CopLINE(PL_curcop);
1543 if (PL_parser && PL_parser->copline != NOLINE) {
1544 /* This ensures that warnings are reported at the first line
1545 of the conditional, not the last. */
1546 CopLINE_set(PL_curcop, PL_parser->copline);
1548 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1549 CopLINE_set(PL_curcop, oldline);
1556 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1559 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1560 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1562 const char funny = o->op_type == OP_PADAV
1563 || o->op_type == OP_RV2AV ? '@' : '%';
1564 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1566 if (cUNOPo->op_first->op_type != OP_GV
1567 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1569 return varname(gv, funny, 0, NULL, 0, subscript_type);
1572 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1577 S_op_varname(pTHX_ const OP *o)
1579 return S_op_varname_subscript(aTHX_ o, 1);
1583 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1584 { /* or not so pretty :-) */
1585 if (o->op_type == OP_CONST) {
1587 if (SvPOK(*retsv)) {
1589 *retsv = sv_newmortal();
1590 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1591 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1593 else if (!SvOK(*retsv))
1596 else *retpv = "...";
1600 S_scalar_slice_warning(pTHX_ const OP *o)
1604 o->op_type == OP_HSLICE ? '{' : '[';
1606 o->op_type == OP_HSLICE ? '}' : ']';
1608 SV *keysv = NULL; /* just to silence compiler warnings */
1609 const char *key = NULL;
1611 if (!(o->op_private & OPpSLICEWARNING))
1613 if (PL_parser && PL_parser->error_count)
1614 /* This warning can be nonsensical when there is a syntax error. */
1617 kid = cLISTOPo->op_first;
1618 kid = OpSIBLING(kid); /* get past pushmark */
1619 /* weed out false positives: any ops that can return lists */
1620 switch (kid->op_type) {
1646 /* Don't warn if we have a nulled list either. */
1647 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1650 assert(OpSIBLING(kid));
1651 name = S_op_varname(aTHX_ OpSIBLING(kid));
1652 if (!name) /* XS module fiddling with the op tree */
1654 S_op_pretty(aTHX_ kid, &keysv, &key);
1655 assert(SvPOK(name));
1656 sv_chop(name,SvPVX(name)+1);
1658 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1659 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1660 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1662 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1663 lbrack, key, rbrack);
1665 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1666 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1667 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1669 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1670 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1674 Perl_scalar(pTHX_ OP *o)
1678 /* assumes no premature commitment */
1679 if (!o || (PL_parser && PL_parser->error_count)
1680 || (o->op_flags & OPf_WANT)
1681 || o->op_type == OP_RETURN)
1686 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1688 switch (o->op_type) {
1690 scalar(cBINOPo->op_first);
1691 if (o->op_private & OPpREPEAT_DOLIST) {
1692 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1693 assert(kid->op_type == OP_PUSHMARK);
1694 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1695 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1696 o->op_private &=~ OPpREPEAT_DOLIST;
1703 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1713 if (o->op_flags & OPf_KIDS) {
1714 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1720 kid = cLISTOPo->op_first;
1722 kid = OpSIBLING(kid);
1725 OP *sib = OpSIBLING(kid);
1726 if (sib && kid->op_type != OP_LEAVEWHEN
1727 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1728 || ( sib->op_targ != OP_NEXTSTATE
1729 && sib->op_targ != OP_DBSTATE )))
1735 PL_curcop = &PL_compiling;
1740 kid = cLISTOPo->op_first;
1743 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1748 /* Warn about scalar context */
1749 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1750 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1753 const char *key = NULL;
1755 /* This warning can be nonsensical when there is a syntax error. */
1756 if (PL_parser && PL_parser->error_count)
1759 if (!ckWARN(WARN_SYNTAX)) break;
1761 kid = cLISTOPo->op_first;
1762 kid = OpSIBLING(kid); /* get past pushmark */
1763 assert(OpSIBLING(kid));
1764 name = S_op_varname(aTHX_ OpSIBLING(kid));
1765 if (!name) /* XS module fiddling with the op tree */
1767 S_op_pretty(aTHX_ kid, &keysv, &key);
1768 assert(SvPOK(name));
1769 sv_chop(name,SvPVX(name)+1);
1771 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1772 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1773 "%%%"SVf"%c%s%c in scalar context better written "
1775 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1776 lbrack, key, rbrack);
1778 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1779 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1780 "%%%"SVf"%c%"SVf"%c in scalar context better "
1781 "written as $%"SVf"%c%"SVf"%c",
1782 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1783 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1790 Perl_scalarvoid(pTHX_ OP *arg)
1796 SSize_t defer_stack_alloc = 0;
1797 SSize_t defer_ix = -1;
1798 OP **defer_stack = NULL;
1801 PERL_ARGS_ASSERT_SCALARVOID;
1804 SV *useless_sv = NULL;
1805 const char* useless = NULL;
1807 if (o->op_type == OP_NEXTSTATE
1808 || o->op_type == OP_DBSTATE
1809 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1810 || o->op_targ == OP_DBSTATE)))
1811 PL_curcop = (COP*)o; /* for warning below */
1813 /* assumes no premature commitment */
1814 want = o->op_flags & OPf_WANT;
1815 if ((want && want != OPf_WANT_SCALAR)
1816 || (PL_parser && PL_parser->error_count)
1817 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1822 if ((o->op_private & OPpTARGET_MY)
1823 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1825 /* newASSIGNOP has already applied scalar context, which we
1826 leave, as if this op is inside SASSIGN. */
1830 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1832 switch (o->op_type) {
1834 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1838 if (o->op_flags & OPf_STACKED)
1840 if (o->op_type == OP_REPEAT)
1841 scalar(cBINOPo->op_first);
1844 if (o->op_private == 4)
1879 case OP_GETSOCKNAME:
1880 case OP_GETPEERNAME:
1885 case OP_GETPRIORITY:
1910 useless = OP_DESC(o);
1920 case OP_AELEMFAST_LEX:
1924 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1925 /* Otherwise it's "Useless use of grep iterator" */
1926 useless = OP_DESC(o);
1930 kid = cLISTOPo->op_first;
1931 if (kid && kid->op_type == OP_PUSHRE
1933 && !(o->op_flags & OPf_STACKED)
1935 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1937 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1940 useless = OP_DESC(o);
1944 kid = cUNOPo->op_first;
1945 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1946 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1949 useless = "negative pattern binding (!~)";
1953 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1954 useless = "non-destructive substitution (s///r)";
1958 useless = "non-destructive transliteration (tr///r)";
1965 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1966 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1967 useless = "a variable";
1972 if (cSVOPo->op_private & OPpCONST_STRICT)
1973 no_bareword_allowed(o);
1975 if (ckWARN(WARN_VOID)) {
1977 /* don't warn on optimised away booleans, eg
1978 * use constant Foo, 5; Foo || print; */
1979 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1981 /* the constants 0 and 1 are permitted as they are
1982 conventionally used as dummies in constructs like
1983 1 while some_condition_with_side_effects; */
1984 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1986 else if (SvPOK(sv)) {
1987 SV * const dsv = newSVpvs("");
1989 = Perl_newSVpvf(aTHX_
1991 pv_pretty(dsv, SvPVX_const(sv),
1992 SvCUR(sv), 32, NULL, NULL,
1994 | PERL_PV_ESCAPE_NOCLEAR
1995 | PERL_PV_ESCAPE_UNI_DETECT));
1996 SvREFCNT_dec_NN(dsv);
1998 else if (SvOK(sv)) {
1999 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
2002 useless = "a constant (undef)";
2005 op_null(o); /* don't execute or even remember it */
2009 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2013 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2017 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2021 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2026 UNOP *refgen, *rv2cv;
2029 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2032 rv2gv = ((BINOP *)o)->op_last;
2033 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2036 refgen = (UNOP *)((BINOP *)o)->op_first;
2038 if (!refgen || (refgen->op_type != OP_REFGEN
2039 && refgen->op_type != OP_SREFGEN))
2042 exlist = (LISTOP *)refgen->op_first;
2043 if (!exlist || exlist->op_type != OP_NULL
2044 || exlist->op_targ != OP_LIST)
2047 if (exlist->op_first->op_type != OP_PUSHMARK
2048 && exlist->op_first != exlist->op_last)
2051 rv2cv = (UNOP*)exlist->op_last;
2053 if (rv2cv->op_type != OP_RV2CV)
2056 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2057 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2058 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2060 o->op_private |= OPpASSIGN_CV_TO_GV;
2061 rv2gv->op_private |= OPpDONT_INIT_GV;
2062 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2074 kid = cLOGOPo->op_first;
2075 if (kid->op_type == OP_NOT
2076 && (kid->op_flags & OPf_KIDS)) {
2077 if (o->op_type == OP_AND) {
2078 OpTYPE_set(o, OP_OR);
2080 OpTYPE_set(o, OP_AND);
2090 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2091 if (!(kid->op_flags & OPf_KIDS))
2098 if (o->op_flags & OPf_STACKED)
2105 if (!(o->op_flags & OPf_KIDS))
2116 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2117 if (!(kid->op_flags & OPf_KIDS))
2123 /* If the first kid after pushmark is something that the padrange
2124 optimisation would reject, then null the list and the pushmark.
2126 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2127 && ( !(kid = OpSIBLING(kid))
2128 || ( kid->op_type != OP_PADSV
2129 && kid->op_type != OP_PADAV
2130 && kid->op_type != OP_PADHV)
2131 || kid->op_private & ~OPpLVAL_INTRO
2132 || !(kid = OpSIBLING(kid))
2133 || ( kid->op_type != OP_PADSV
2134 && kid->op_type != OP_PADAV
2135 && kid->op_type != OP_PADHV)
2136 || kid->op_private & ~OPpLVAL_INTRO)
2138 op_null(cUNOPo->op_first); /* NULL the pushmark */
2139 op_null(o); /* NULL the list */
2151 /* mortalise it, in case warnings are fatal. */
2152 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2153 "Useless use of %"SVf" in void context",
2154 SVfARG(sv_2mortal(useless_sv)));
2157 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2158 "Useless use of %s in void context",
2161 } while ( (o = POP_DEFERRED_OP()) );
2163 Safefree(defer_stack);
2169 S_listkids(pTHX_ OP *o)
2171 if (o && o->op_flags & OPf_KIDS) {
2173 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2180 Perl_list(pTHX_ OP *o)
2184 /* assumes no premature commitment */
2185 if (!o || (o->op_flags & OPf_WANT)
2186 || (PL_parser && PL_parser->error_count)
2187 || o->op_type == OP_RETURN)
2192 if ((o->op_private & OPpTARGET_MY)
2193 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2195 return o; /* As if inside SASSIGN */
2198 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2200 switch (o->op_type) {
2202 list(cBINOPo->op_first);
2205 if (o->op_private & OPpREPEAT_DOLIST
2206 && !(o->op_flags & OPf_STACKED))
2208 list(cBINOPo->op_first);
2209 kid = cBINOPo->op_last;
2210 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2211 && SvIVX(kSVOP_sv) == 1)
2213 op_null(o); /* repeat */
2214 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2216 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2223 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2231 if (!(o->op_flags & OPf_KIDS))
2233 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2234 list(cBINOPo->op_first);
2235 return gen_constant_list(o);
2241 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2242 op_null(cUNOPo->op_first); /* NULL the pushmark */
2243 op_null(o); /* NULL the list */
2248 kid = cLISTOPo->op_first;
2250 kid = OpSIBLING(kid);
2253 OP *sib = OpSIBLING(kid);
2254 if (sib && kid->op_type != OP_LEAVEWHEN)
2260 PL_curcop = &PL_compiling;
2264 kid = cLISTOPo->op_first;
2271 S_scalarseq(pTHX_ OP *o)
2274 const OPCODE type = o->op_type;
2276 if (type == OP_LINESEQ || type == OP_SCOPE ||
2277 type == OP_LEAVE || type == OP_LEAVETRY)
2280 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2281 if ((sib = OpSIBLING(kid))
2282 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2283 || ( sib->op_targ != OP_NEXTSTATE
2284 && sib->op_targ != OP_DBSTATE )))
2289 PL_curcop = &PL_compiling;
2291 o->op_flags &= ~OPf_PARENS;
2292 if (PL_hints & HINT_BLOCK_SCOPE)
2293 o->op_flags |= OPf_PARENS;
2296 o = newOP(OP_STUB, 0);
2301 S_modkids(pTHX_ OP *o, I32 type)
2303 if (o && o->op_flags & OPf_KIDS) {
2305 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2306 op_lvalue(kid, type);
2312 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2313 * const fields. Also, convert CONST keys to HEK-in-SVs.
2314 * rop is the op that retrieves the hash;
2315 * key_op is the first key
2319 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2325 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2327 if (rop->op_first->op_type == OP_PADSV)
2328 /* @$hash{qw(keys here)} */
2329 rop = (UNOP*)rop->op_first;
2331 /* @{$hash}{qw(keys here)} */
2332 if (rop->op_first->op_type == OP_SCOPE
2333 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2335 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2342 lexname = NULL; /* just to silence compiler warnings */
2343 fields = NULL; /* just to silence compiler warnings */
2347 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2348 SvPAD_TYPED(lexname))
2349 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2350 && isGV(*fields) && GvHV(*fields);
2352 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2354 if (key_op->op_type != OP_CONST)
2356 svp = cSVOPx_svp(key_op);
2358 /* make sure it's not a bareword under strict subs */
2359 if (key_op->op_private & OPpCONST_BARE &&
2360 key_op->op_private & OPpCONST_STRICT)
2362 no_bareword_allowed((OP*)key_op);
2365 /* Make the CONST have a shared SV */
2366 if ( !SvIsCOW_shared_hash(sv = *svp)
2367 && SvTYPE(sv) < SVt_PVMG
2372 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2373 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2374 SvREFCNT_dec_NN(sv);
2379 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2381 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2382 "in variable %"PNf" of type %"HEKf,
2383 SVfARG(*svp), PNfARG(lexname),
2384 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2391 =for apidoc finalize_optree
2393 This function finalizes the optree. Should be called directly after
2394 the complete optree is built. It does some additional
2395 checking which can't be done in the normal C<ck_>xxx functions and makes
2396 the tree thread-safe.
2401 Perl_finalize_optree(pTHX_ OP* o)
2403 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2406 SAVEVPTR(PL_curcop);
2414 /* Relocate sv to the pad for thread safety.
2415 * Despite being a "constant", the SV is written to,
2416 * for reference counts, sv_upgrade() etc. */
2417 PERL_STATIC_INLINE void
2418 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2421 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2423 ix = pad_alloc(OP_CONST, SVf_READONLY);
2424 SvREFCNT_dec(PAD_SVl(ix));
2425 PAD_SETSV(ix, *svp);
2426 /* XXX I don't know how this isn't readonly already. */
2427 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2435 S_finalize_op(pTHX_ OP* o)
2437 PERL_ARGS_ASSERT_FINALIZE_OP;
2440 switch (o->op_type) {
2443 PL_curcop = ((COP*)o); /* for warnings */
2446 if (OpHAS_SIBLING(o)) {
2447 OP *sib = OpSIBLING(o);
2448 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2449 && ckWARN(WARN_EXEC)
2450 && OpHAS_SIBLING(sib))
2452 const OPCODE type = OpSIBLING(sib)->op_type;
2453 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2454 const line_t oldline = CopLINE(PL_curcop);
2455 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2456 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2457 "Statement unlikely to be reached");
2458 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2459 "\t(Maybe you meant system() when you said exec()?)\n");
2460 CopLINE_set(PL_curcop, oldline);
2467 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2468 GV * const gv = cGVOPo_gv;
2469 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2470 /* XXX could check prototype here instead of just carping */
2471 SV * const sv = sv_newmortal();
2472 gv_efullname3(sv, gv, NULL);
2473 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2474 "%"SVf"() called too early to check prototype",
2481 if (cSVOPo->op_private & OPpCONST_STRICT)
2482 no_bareword_allowed(o);
2486 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2491 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2492 case OP_METHOD_NAMED:
2493 case OP_METHOD_SUPER:
2494 case OP_METHOD_REDIR:
2495 case OP_METHOD_REDIR_SUPER:
2496 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2505 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2508 rop = (UNOP*)((BINOP*)o)->op_first;
2513 S_scalar_slice_warning(aTHX_ o);
2517 kid = OpSIBLING(cLISTOPo->op_first);
2518 if (/* I bet there's always a pushmark... */
2519 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2520 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2525 key_op = (SVOP*)(kid->op_type == OP_CONST
2527 : OpSIBLING(kLISTOP->op_first));
2529 rop = (UNOP*)((LISTOP*)o)->op_last;
2532 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2534 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2538 S_scalar_slice_warning(aTHX_ o);
2542 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2543 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2550 if (o->op_flags & OPf_KIDS) {
2554 /* check that op_last points to the last sibling, and that
2555 * the last op_sibling/op_sibparent field points back to the
2556 * parent, and that the only ops with KIDS are those which are
2557 * entitled to them */
2558 U32 type = o->op_type;
2562 if (type == OP_NULL) {
2564 /* ck_glob creates a null UNOP with ex-type GLOB
2565 * (which is a list op. So pretend it wasn't a listop */
2566 if (type == OP_GLOB)
2569 family = PL_opargs[type] & OA_CLASS_MASK;
2571 has_last = ( family == OA_BINOP
2572 || family == OA_LISTOP
2573 || family == OA_PMOP
2574 || family == OA_LOOP
2576 assert( has_last /* has op_first and op_last, or ...
2577 ... has (or may have) op_first: */
2578 || family == OA_UNOP
2579 || family == OA_UNOP_AUX
2580 || family == OA_LOGOP
2581 || family == OA_BASEOP_OR_UNOP
2582 || family == OA_FILESTATOP
2583 || family == OA_LOOPEXOP
2584 || family == OA_METHOP
2585 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2586 || type == OP_SASSIGN
2587 || type == OP_CUSTOM
2588 || type == OP_NULL /* new_logop does this */
2591 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2592 # ifdef PERL_OP_PARENT
2593 if (!OpHAS_SIBLING(kid)) {
2595 assert(kid == cLISTOPo->op_last);
2596 assert(kid->op_sibparent == o);
2599 if (has_last && !OpHAS_SIBLING(kid))
2600 assert(kid == cLISTOPo->op_last);
2605 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2611 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2613 Propagate lvalue ("modifiable") context to an op and its children.
2614 C<type> represents the context type, roughly based on the type of op that
2615 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2616 because it has no op type of its own (it is signalled by a flag on
2619 This function detects things that can't be modified, such as C<$x+1>, and
2620 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2621 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2623 It also flags things that need to behave specially in an lvalue context,
2624 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2630 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2633 PadnameLVALUE_on(pn);
2634 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2636 /* RT #127786: cv can be NULL due to an eval within the DB package
2637 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2638 * unless they contain an eval, but calling eval within DB
2639 * pretends the eval was done in the caller's scope.
2643 assert(CvPADLIST(cv));
2645 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2646 assert(PadnameLEN(pn));
2647 PadnameLVALUE_on(pn);
2652 S_vivifies(const OPCODE type)
2655 case OP_RV2AV: case OP_ASLICE:
2656 case OP_RV2HV: case OP_KVASLICE:
2657 case OP_RV2SV: case OP_HSLICE:
2658 case OP_AELEMFAST: case OP_KVHSLICE:
2667 S_lvref(pTHX_ OP *o, I32 type)
2671 switch (o->op_type) {
2673 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2674 kid = OpSIBLING(kid))
2675 S_lvref(aTHX_ kid, type);
2680 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2681 o->op_flags |= OPf_STACKED;
2682 if (o->op_flags & OPf_PARENS) {
2683 if (o->op_private & OPpLVAL_INTRO) {
2684 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2685 "localized parenthesized array in list assignment"));
2689 OpTYPE_set(o, OP_LVAVREF);
2690 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2691 o->op_flags |= OPf_MOD|OPf_REF;
2694 o->op_private |= OPpLVREF_AV;
2697 kid = cUNOPo->op_first;
2698 if (kid->op_type == OP_NULL)
2699 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2701 o->op_private = OPpLVREF_CV;
2702 if (kid->op_type == OP_GV)
2703 o->op_flags |= OPf_STACKED;
2704 else if (kid->op_type == OP_PADCV) {
2705 o->op_targ = kid->op_targ;
2707 op_free(cUNOPo->op_first);
2708 cUNOPo->op_first = NULL;
2709 o->op_flags &=~ OPf_KIDS;
2714 if (o->op_flags & OPf_PARENS) {
2716 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2717 "parenthesized hash in list assignment"));
2720 o->op_private |= OPpLVREF_HV;
2724 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2725 o->op_flags |= OPf_STACKED;
2728 if (o->op_flags & OPf_PARENS) goto parenhash;
2729 o->op_private |= OPpLVREF_HV;
2732 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2735 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2736 if (o->op_flags & OPf_PARENS) goto slurpy;
2737 o->op_private |= OPpLVREF_AV;
2741 o->op_private |= OPpLVREF_ELEM;
2742 o->op_flags |= OPf_STACKED;
2746 OpTYPE_set(o, OP_LVREFSLICE);
2747 o->op_private &= OPpLVAL_INTRO;
2750 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2752 else if (!(o->op_flags & OPf_KIDS))
2754 if (o->op_targ != OP_LIST) {
2755 S_lvref(aTHX_ cBINOPo->op_first, type);
2760 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2761 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2762 S_lvref(aTHX_ kid, type);
2766 if (o->op_flags & OPf_PARENS)
2771 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2772 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2773 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2778 OpTYPE_set(o, OP_LVREF);
2780 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2781 if (type == OP_ENTERLOOP)
2782 o->op_private |= OPpLVREF_ITER;
2785 PERL_STATIC_INLINE bool
2786 S_potential_mod_type(I32 type)
2788 /* Types that only potentially result in modification. */
2789 return type == OP_GREPSTART || type == OP_ENTERSUB
2790 || type == OP_REFGEN || type == OP_LEAVESUBLV;
2794 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2798 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2801 if (!o || (PL_parser && PL_parser->error_count))
2804 if ((o->op_private & OPpTARGET_MY)
2805 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2810 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2812 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2814 switch (o->op_type) {
2819 if ((o->op_flags & OPf_PARENS))
2823 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2824 !(o->op_flags & OPf_STACKED)) {
2825 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
2826 assert(cUNOPo->op_first->op_type == OP_NULL);
2827 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2830 else { /* lvalue subroutine call */
2831 o->op_private |= OPpLVAL_INTRO;
2832 PL_modcount = RETURN_UNLIMITED_NUMBER;
2833 if (S_potential_mod_type(type)) {
2834 o->op_private |= OPpENTERSUB_INARGS;
2837 else { /* Compile-time error message: */
2838 OP *kid = cUNOPo->op_first;
2843 if (kid->op_type != OP_PUSHMARK) {
2844 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2846 "panic: unexpected lvalue entersub "
2847 "args: type/targ %ld:%"UVuf,
2848 (long)kid->op_type, (UV)kid->op_targ);
2849 kid = kLISTOP->op_first;
2851 while (OpHAS_SIBLING(kid))
2852 kid = OpSIBLING(kid);
2853 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2854 break; /* Postpone until runtime */
2857 kid = kUNOP->op_first;
2858 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2859 kid = kUNOP->op_first;
2860 if (kid->op_type == OP_NULL)
2862 "Unexpected constant lvalue entersub "
2863 "entry via type/targ %ld:%"UVuf,
2864 (long)kid->op_type, (UV)kid->op_targ);
2865 if (kid->op_type != OP_GV) {
2872 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2873 ? MUTABLE_CV(SvRV(gv))
2879 if (flags & OP_LVALUE_NO_CROAK)
2882 namesv = cv_name(cv, NULL, 0);
2883 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2884 "subroutine call of &%"SVf" in %s",
2885 SVfARG(namesv), PL_op_desc[type]),
2893 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2894 /* grep, foreach, subcalls, refgen */
2895 if (S_potential_mod_type(type))
2897 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2898 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2901 type ? PL_op_desc[type] : "local"));
2914 case OP_RIGHT_SHIFT:
2923 if (!(o->op_flags & OPf_STACKED))
2929 if (o->op_flags & OPf_STACKED) {
2933 if (!(o->op_private & OPpREPEAT_DOLIST))
2936 const I32 mods = PL_modcount;
2937 modkids(cBINOPo->op_first, type);
2938 if (type != OP_AASSIGN)
2940 kid = cBINOPo->op_last;
2941 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2942 const IV iv = SvIV(kSVOP_sv);
2943 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2945 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2948 PL_modcount = RETURN_UNLIMITED_NUMBER;
2954 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2955 op_lvalue(kid, type);
2960 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2961 PL_modcount = RETURN_UNLIMITED_NUMBER;
2962 return o; /* Treat \(@foo) like ordinary list. */
2966 if (scalar_mod_type(o, type))
2968 ref(cUNOPo->op_first, o->op_type);
2975 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2976 if (type == OP_LEAVESUBLV && (
2977 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2978 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2980 o->op_private |= OPpMAYBE_LVSUB;
2984 PL_modcount = RETURN_UNLIMITED_NUMBER;
2989 if (type == OP_LEAVESUBLV)
2990 o->op_private |= OPpMAYBE_LVSUB;
2993 if (type == OP_LEAVESUBLV
2994 && (o->op_private & 3) + OP_EACH == OP_KEYS)
2995 o->op_private |= OPpMAYBE_LVSUB;
2998 PL_hints |= HINT_BLOCK_SCOPE;
2999 if (type == OP_LEAVESUBLV)
3000 o->op_private |= OPpMAYBE_LVSUB;
3004 ref(cUNOPo->op_first, o->op_type);
3008 PL_hints |= HINT_BLOCK_SCOPE;
3018 case OP_AELEMFAST_LEX:
3025 PL_modcount = RETURN_UNLIMITED_NUMBER;
3026 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3027 return o; /* Treat \(@foo) like ordinary list. */
3028 if (scalar_mod_type(o, type))
3030 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3031 && type == OP_LEAVESUBLV)
3032 o->op_private |= OPpMAYBE_LVSUB;
3036 if (!type) /* local() */
3037 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3038 PNfARG(PAD_COMPNAME(o->op_targ)));
3039 if (!(o->op_private & OPpLVAL_INTRO)
3040 || ( type != OP_SASSIGN && type != OP_AASSIGN
3041 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3042 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3050 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3054 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3060 if (type == OP_LEAVESUBLV)
3061 o->op_private |= OPpMAYBE_LVSUB;
3062 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3063 /* substr and vec */
3064 /* If this op is in merely potential (non-fatal) modifiable
3065 context, then apply OP_ENTERSUB context to
3066 the kid op (to avoid croaking). Other-
3067 wise pass this op’s own type so the correct op is mentioned
3068 in error messages. */
3069 op_lvalue(OpSIBLING(cBINOPo->op_first),
3070 S_potential_mod_type(type)
3078 ref(cBINOPo->op_first, o->op_type);
3079 if (type == OP_ENTERSUB &&
3080 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3081 o->op_private |= OPpLVAL_DEFER;
3082 if (type == OP_LEAVESUBLV)
3083 o->op_private |= OPpMAYBE_LVSUB;
3090 o->op_private |= OPpLVALUE;
3096 if (o->op_flags & OPf_KIDS)
3097 op_lvalue(cLISTOPo->op_last, type);
3102 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3104 else if (!(o->op_flags & OPf_KIDS))
3106 if (o->op_targ != OP_LIST) {
3107 op_lvalue(cBINOPo->op_first, type);
3113 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3114 /* elements might be in void context because the list is
3115 in scalar context or because they are attribute sub calls */
3116 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3117 op_lvalue(kid, type);
3125 if (type == OP_LEAVESUBLV
3126 || !S_vivifies(cLOGOPo->op_first->op_type))
3127 op_lvalue(cLOGOPo->op_first, type);
3128 if (type == OP_LEAVESUBLV
3129 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3130 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3134 if (type != OP_AASSIGN && type != OP_SASSIGN
3135 && type != OP_ENTERLOOP)
3137 /* Don’t bother applying lvalue context to the ex-list. */
3138 kid = cUNOPx(cUNOPo->op_first)->op_first;
3139 assert (!OpHAS_SIBLING(kid));
3142 if (type != OP_AASSIGN) goto nomod;
3143 kid = cUNOPo->op_first;
3146 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3147 S_lvref(aTHX_ kid, type);
3148 if (!PL_parser || PL_parser->error_count == ec) {
3149 if (!FEATURE_REFALIASING_IS_ENABLED)
3151 "Experimental aliasing via reference not enabled");
3152 Perl_ck_warner_d(aTHX_
3153 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3154 "Aliasing via reference is experimental");
3157 if (o->op_type == OP_REFGEN)
3158 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3163 kid = cLISTOPo->op_first;
3164 if (kid && kid->op_type == OP_PUSHRE &&
3166 || o->op_flags & OPf_STACKED
3168 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3170 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3173 /* This is actually @array = split. */
3174 PL_modcount = RETURN_UNLIMITED_NUMBER;
3180 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3184 /* [20011101.069] File test operators interpret OPf_REF to mean that
3185 their argument is a filehandle; thus \stat(".") should not set
3187 if (type == OP_REFGEN &&
3188 PL_check[o->op_type] == Perl_ck_ftst)
3191 if (type != OP_LEAVESUBLV)
3192 o->op_flags |= OPf_MOD;
3194 if (type == OP_AASSIGN || type == OP_SASSIGN)
3195 o->op_flags |= OPf_SPECIAL|OPf_REF;
3196 else if (!type) { /* local() */
3199 o->op_private |= OPpLVAL_INTRO;
3200 o->op_flags &= ~OPf_SPECIAL;
3201 PL_hints |= HINT_BLOCK_SCOPE;
3206 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3207 "Useless localization of %s", OP_DESC(o));
3210 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3211 && type != OP_LEAVESUBLV)
3212 o->op_flags |= OPf_REF;
3217 S_scalar_mod_type(const OP *o, I32 type)
3222 if (o && o->op_type == OP_RV2GV)
3246 case OP_RIGHT_SHIFT:
3275 S_is_handle_constructor(const OP *o, I32 numargs)
3277 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3279 switch (o->op_type) {
3287 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3300 S_refkids(pTHX_ OP *o, I32 type)
3302 if (o && o->op_flags & OPf_KIDS) {
3304 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3311 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3316 PERL_ARGS_ASSERT_DOREF;
3318 if (PL_parser && PL_parser->error_count)
3321 switch (o->op_type) {
3323 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3324 !(o->op_flags & OPf_STACKED)) {
3325 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3326 assert(cUNOPo->op_first->op_type == OP_NULL);
3327 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3328 o->op_flags |= OPf_SPECIAL;
3330 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3331 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3332 : type == OP_RV2HV ? OPpDEREF_HV
3334 o->op_flags |= OPf_MOD;
3340 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3341 doref(kid, type, set_op_ref);
3344 if (type == OP_DEFINED)
3345 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3346 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3349 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3350 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3351 : type == OP_RV2HV ? OPpDEREF_HV
3353 o->op_flags |= OPf_MOD;
3360 o->op_flags |= OPf_REF;
3363 if (type == OP_DEFINED)
3364 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3365 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3371 o->op_flags |= OPf_REF;
3376 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3378 doref(cBINOPo->op_first, type, set_op_ref);
3382 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3383 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3384 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3385 : type == OP_RV2HV ? OPpDEREF_HV
3387 o->op_flags |= OPf_MOD;
3397 if (!(o->op_flags & OPf_KIDS))
3399 doref(cLISTOPo->op_last, type, set_op_ref);
3409 S_dup_attrlist(pTHX_ OP *o)
3413 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3415 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3416 * where the first kid is OP_PUSHMARK and the remaining ones
3417 * are OP_CONST. We need to push the OP_CONST values.
3419 if (o->op_type == OP_CONST)
3420 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3422 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3424 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3425 if (o->op_type == OP_CONST)
3426 rop = op_append_elem(OP_LIST, rop,
3427 newSVOP(OP_CONST, o->op_flags,
3428 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3435 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3437 PERL_ARGS_ASSERT_APPLY_ATTRS;
3439 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3441 /* fake up C<use attributes $pkg,$rv,@attrs> */
3443 #define ATTRSMODULE "attributes"
3444 #define ATTRSMODULE_PM "attributes.pm"
3447 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3448 newSVpvs(ATTRSMODULE),
3450 op_prepend_elem(OP_LIST,
3451 newSVOP(OP_CONST, 0, stashsv),
3452 op_prepend_elem(OP_LIST,
3453 newSVOP(OP_CONST, 0,
3455 dup_attrlist(attrs))));
3460 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3462 OP *pack, *imop, *arg;
3463 SV *meth, *stashsv, **svp;
3465 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3470 assert(target->op_type == OP_PADSV ||
3471 target->op_type == OP_PADHV ||
3472 target->op_type == OP_PADAV);
3474 /* Ensure that attributes.pm is loaded. */
3475 /* Don't force the C<use> if we don't need it. */
3476 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3477 if (svp && *svp != &PL_sv_undef)
3478 NOOP; /* already in %INC */
3480 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3481 newSVpvs(ATTRSMODULE), NULL);
3483 /* Need package name for method call. */
3484 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3486 /* Build up the real arg-list. */
3487 stashsv = newSVhek(HvNAME_HEK(stash));
3489 arg = newOP(OP_PADSV, 0);
3490 arg->op_targ = target->op_targ;
3491 arg = op_prepend_elem(OP_LIST,
3492 newSVOP(OP_CONST, 0, stashsv),
3493 op_prepend_elem(OP_LIST,
3494 newUNOP(OP_REFGEN, 0,
3496 dup_attrlist(attrs)));
3498 /* Fake up a method call to import */
3499 meth = newSVpvs_share("import");
3500 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3501 op_append_elem(OP_LIST,
3502 op_prepend_elem(OP_LIST, pack, arg),
3503 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3505 /* Combine the ops. */
3506 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3510 =notfor apidoc apply_attrs_string
3512 Attempts to apply a list of attributes specified by the C<attrstr> and
3513 C<len> arguments to the subroutine identified by the C<cv> argument which
3514 is expected to be associated with the package identified by the C<stashpv>
3515 argument (see L<attributes>). It gets this wrong, though, in that it
3516 does not correctly identify the boundaries of the individual attribute
3517 specifications within C<attrstr>. This is not really intended for the
3518 public API, but has to be listed here for systems such as AIX which
3519 need an explicit export list for symbols. (It's called from XS code
3520 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3521 to respect attribute syntax properly would be welcome.
3527 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3528 const char *attrstr, STRLEN len)
3532 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3535 len = strlen(attrstr);
3539 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3541 const char * const sstr = attrstr;
3542 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3543 attrs = op_append_elem(OP_LIST, attrs,
3544 newSVOP(OP_CONST, 0,
3545 newSVpvn(sstr, attrstr-sstr)));
3549 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3550 newSVpvs(ATTRSMODULE),
3551 NULL, op_prepend_elem(OP_LIST,
3552 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3553 op_prepend_elem(OP_LIST,
3554 newSVOP(OP_CONST, 0,
3555 newRV(MUTABLE_SV(cv))),
3560 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3562 OP *new_proto = NULL;
3567 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3573 if (o->op_type == OP_CONST) {
3574 pv = SvPV(cSVOPo_sv, pvlen);
3575 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3576 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3577 SV ** const tmpo = cSVOPx_svp(o);
3578 SvREFCNT_dec(cSVOPo_sv);
3583 } else if (o->op_type == OP_LIST) {
3585 assert(o->op_flags & OPf_KIDS);
3586 lasto = cLISTOPo->op_first;
3587 assert(lasto->op_type == OP_PUSHMARK);
3588 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3589 if (o->op_type == OP_CONST) {
3590 pv = SvPV(cSVOPo_sv, pvlen);
3591 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3592 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3593 SV ** const tmpo = cSVOPx_svp(o);
3594 SvREFCNT_dec(cSVOPo_sv);
3596 if (new_proto && ckWARN(WARN_MISC)) {
3598 const char * newp = SvPV(cSVOPo_sv, new_len);
3599 Perl_warner(aTHX_ packWARN(WARN_MISC),
3600 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3601 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3607 /* excise new_proto from the list */
3608 op_sibling_splice(*attrs, lasto, 1, NULL);
3615 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3616 would get pulled in with no real need */
3617 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3626 svname = sv_newmortal();
3627 gv_efullname3(svname, name, NULL);
3629 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3630 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3632 svname = (SV *)name;
3633 if (ckWARN(WARN_ILLEGALPROTO))
3634 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3635 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3636 STRLEN old_len, new_len;
3637 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3638 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3640 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3641 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3643 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3644 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3654 S_cant_declare(pTHX_ OP *o)
3656 if (o->op_type == OP_NULL
3657 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3658 o = cUNOPo->op_first;
3659 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3660 o->op_type == OP_NULL
3661 && o->op_flags & OPf_SPECIAL
3664 PL_parser->in_my == KEY_our ? "our" :
3665 PL_parser->in_my == KEY_state ? "state" :
3670 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3673 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3675 PERL_ARGS_ASSERT_MY_KID;
3677 if (!o || (PL_parser && PL_parser->error_count))
3682 if (type == OP_LIST) {
3684 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3685 my_kid(kid, attrs, imopsp);
3687 } else if (type == OP_UNDEF || type == OP_STUB) {
3689 } else if (type == OP_RV2SV || /* "our" declaration */
3692 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3693 S_cant_declare(aTHX_ o);
3695 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3697 PL_parser->in_my = FALSE;
3698 PL_parser->in_my_stash = NULL;
3699 apply_attrs(GvSTASH(gv),
3700 (type == OP_RV2SV ? GvSV(gv) :
3701 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3702 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3705 o->op_private |= OPpOUR_INTRO;
3708 else if (type != OP_PADSV &&
3711 type != OP_PUSHMARK)
3713 S_cant_declare(aTHX_ o);
3716 else if (attrs && type != OP_PUSHMARK) {
3720 PL_parser->in_my = FALSE;
3721 PL_parser->in_my_stash = NULL;
3723 /* check for C<my Dog $spot> when deciding package */
3724 stash = PAD_COMPNAME_TYPE(o->op_targ);
3726 stash = PL_curstash;
3727 apply_attrs_my(stash, o, attrs, imopsp);
3729 o->op_flags |= OPf_MOD;
3730 o->op_private |= OPpLVAL_INTRO;
3732 o->op_private |= OPpPAD_STATE;
3737 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3740 int maybe_scalar = 0;
3742 PERL_ARGS_ASSERT_MY_ATTRS;
3744 /* [perl #17376]: this appears to be premature, and results in code such as
3745 C< our(%x); > executing in list mode rather than void mode */
3747 if (o->op_flags & OPf_PARENS)
3757 o = my_kid(o, attrs, &rops);
3759 if (maybe_scalar && o->op_type == OP_PADSV) {
3760 o = scalar(op_append_list(OP_LIST, rops, o));
3761 o->op_private |= OPpLVAL_INTRO;
3764 /* The listop in rops might have a pushmark at the beginning,
3765 which will mess up list assignment. */
3766 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3767 if (rops->op_type == OP_LIST &&
3768 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3770 OP * const pushmark = lrops->op_first;
3771 /* excise pushmark */
3772 op_sibling_splice(rops, NULL, 1, NULL);
3775 o = op_append_list(OP_LIST, o, rops);
3778 PL_parser->in_my = FALSE;
3779 PL_parser->in_my_stash = NULL;
3784 Perl_sawparens(pTHX_ OP *o)
3786 PERL_UNUSED_CONTEXT;
3788 o->op_flags |= OPf_PARENS;
3793 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3797 const OPCODE ltype = left->op_type;
3798 const OPCODE rtype = right->op_type;
3800 PERL_ARGS_ASSERT_BIND_MATCH;
3802 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3803 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3805 const char * const desc
3807 rtype == OP_SUBST || rtype == OP_TRANS
3808 || rtype == OP_TRANSR
3810 ? (int)rtype : OP_MATCH];
3811 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3813 S_op_varname(aTHX_ left);
3815 Perl_warner(aTHX_ packWARN(WARN_MISC),
3816 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3817 desc, SVfARG(name), SVfARG(name));
3819 const char * const sample = (isary
3820 ? "@array" : "%hash");
3821 Perl_warner(aTHX_ packWARN(WARN_MISC),
3822 "Applying %s to %s will act on scalar(%s)",
3823 desc, sample, sample);
3827 if (rtype == OP_CONST &&
3828 cSVOPx(right)->op_private & OPpCONST_BARE &&
3829 cSVOPx(right)->op_private & OPpCONST_STRICT)
3831 no_bareword_allowed(right);
3834 /* !~ doesn't make sense with /r, so error on it for now */
3835 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3837 /* diag_listed_as: Using !~ with %s doesn't make sense */
3838 yyerror("Using !~ with s///r doesn't make sense");
3839 if (rtype == OP_TRANSR && type == OP_NOT)
3840 /* diag_listed_as: Using !~ with %s doesn't make sense */
3841 yyerror("Using !~ with tr///r doesn't make sense");
3843 ismatchop = (rtype == OP_MATCH ||
3844 rtype == OP_SUBST ||
3845 rtype == OP_TRANS || rtype == OP_TRANSR)
3846 && !(right->op_flags & OPf_SPECIAL);
3847 if (ismatchop && right->op_private & OPpTARGET_MY) {
3849 right->op_private &= ~OPpTARGET_MY;
3851 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3852 if (left->op_type == OP_PADSV
3853 && !(left->op_private & OPpLVAL_INTRO))
3855 right->op_targ = left->op_targ;
3860 right->op_flags |= OPf_STACKED;
3861 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3862 ! (rtype == OP_TRANS &&
3863 right->op_private & OPpTRANS_IDENTICAL) &&
3864 ! (rtype == OP_SUBST &&
3865 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3866 left = op_lvalue(left, rtype);
3867 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3868 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3870 o = op_prepend_elem(rtype, scalar(left), right);
3873 return newUNOP(OP_NOT, 0, scalar(o));
3877 return bind_match(type, left,
3878 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3882 Perl_invert(pTHX_ OP *o)
3886 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3890 =for apidoc Amx|OP *|op_scope|OP *o
3892 Wraps up an op tree with some additional ops so that at runtime a dynamic
3893 scope will be created. The original ops run in the new dynamic scope,
3894 and then, provided that they exit normally, the scope will be unwound.
3895 The additional ops used to create and unwind the dynamic scope will
3896 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3897 instead if the ops are simple enough to not need the full dynamic scope
3904 Perl_op_scope(pTHX_ OP *o)
3908 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3909 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3910 OpTYPE_set(o, OP_LEAVE);
3912 else if (o->op_type == OP_LINESEQ) {
3914 OpTYPE_set(o, OP_SCOPE);
3915 kid = ((LISTOP*)o)->op_first;
3916 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3919 /* The following deals with things like 'do {1 for 1}' */
3920 kid = OpSIBLING(kid);
3922 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3927 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3933 Perl_op_unscope(pTHX_ OP *o)
3935 if (o && o->op_type == OP_LINESEQ) {
3936 OP *kid = cLISTOPo->op_first;
3937 for(; kid; kid = OpSIBLING(kid))
3938 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3945 =for apidoc Am|int|block_start|int full
3947 Handles compile-time scope entry.
3948 Arranges for hints to be restored on block
3949 exit and also handles pad sequence numbers to make lexical variables scope
3950 right. Returns a savestack index for use with C<block_end>.
3956 Perl_block_start(pTHX_ int full)
3958 const int retval = PL_savestack_ix;
3960 PL_compiling.cop_seq = PL_cop_seqmax;
3962 pad_block_start(full);
3964 PL_hints &= ~HINT_BLOCK_SCOPE;
3965 SAVECOMPILEWARNINGS();
3966 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3967 SAVEI32(PL_compiling.cop_seq);
3968 PL_compiling.cop_seq = 0;
3970 CALL_BLOCK_HOOKS(bhk_start, full);
3976 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3978 Handles compile-time scope exit. C<floor>
3979 is the savestack index returned by
3980 C<block_start>, and C<seq> is the body of the block. Returns the block,
3987 Perl_block_end(pTHX_ I32 floor, OP *seq)
3989 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3990 OP* retval = scalarseq(seq);
3993 /* XXX Is the null PL_parser check necessary here? */
3994 assert(PL_parser); /* Let’s find out under debugging builds. */
3995 if (PL_parser && PL_parser->parsed_sub) {
3996 o = newSTATEOP(0, NULL, NULL);
3998 retval = op_append_elem(OP_LINESEQ, retval, o);
4001 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4005 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4009 /* pad_leavemy has created a sequence of introcv ops for all my
4010 subs declared in the block. We have to replicate that list with
4011 clonecv ops, to deal with this situation:
4016 sub s1 { state sub foo { \&s2 } }
4019 Originally, I was going to have introcv clone the CV and turn
4020 off the stale flag. Since &s1 is declared before &s2, the
4021 introcv op for &s1 is executed (on sub entry) before the one for
4022 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
4023 cloned, since it is a state sub) closes over &s2 and expects
4024 to see it in its outer CV’s pad. If the introcv op clones &s1,
4025 then &s2 is still marked stale. Since &s1 is not active, and
4026 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4027 ble will not stay shared’ warning. Because it is the same stub
4028 that will be used when the introcv op for &s2 is executed, clos-
4029 ing over it is safe. Hence, we have to turn off the stale flag
4030 on all lexical subs in the block before we clone any of them.
4031 Hence, having introcv clone the sub cannot work. So we create a
4032 list of ops like this:
4056 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4057 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4058 for (;; kid = OpSIBLING(kid)) {
4059 OP *newkid = newOP(OP_CLONECV, 0);
4060 newkid->op_targ = kid->op_targ;
4061 o = op_append_elem(OP_LINESEQ, o, newkid);
4062 if (kid == last) break;
4064 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4067 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4073 =head1 Compile-time scope hooks
4075 =for apidoc Aox||blockhook_register
4077 Register a set of hooks to be called when the Perl lexical scope changes
4078 at compile time. See L<perlguts/"Compile-time scope hooks">.
4084 Perl_blockhook_register(pTHX_ BHK *hk)
4086 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4088 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4092 Perl_newPROG(pTHX_ OP *o)
4094 PERL_ARGS_ASSERT_NEWPROG;
4101 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4102 ((PL_in_eval & EVAL_KEEPERR)
4103 ? OPf_SPECIAL : 0), o);
4106 assert(CxTYPE(cx) == CXt_EVAL);
4108 if ((cx->blk_gimme & G_WANT) == G_VOID)
4109 scalarvoid(PL_eval_root);
4110 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4113 scalar(PL_eval_root);
4115 PL_eval_start = op_linklist(PL_eval_root);
4116 PL_eval_root->op_private |= OPpREFCOUNTED;
4117 OpREFCNT_set(PL_eval_root, 1);
4118 PL_eval_root->op_next = 0;
4119 i = PL_savestack_ix;
4122 CALL_PEEP(PL_eval_start);
4123 finalize_optree(PL_eval_root);
4124 S_prune_chain_head(&PL_eval_start);
4126 PL_savestack_ix = i;
4129 if (o->op_type == OP_STUB) {
4130 /* This block is entered if nothing is compiled for the main
4131 program. This will be the case for an genuinely empty main
4132 program, or one which only has BEGIN blocks etc, so already
4135 Historically (5.000) the guard above was !o. However, commit
4136 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4137 c71fccf11fde0068, changed perly.y so that newPROG() is now
4138 called with the output of block_end(), which returns a new
4139 OP_STUB for the case of an empty optree. ByteLoader (and
4140 maybe other things) also take this path, because they set up
4141 PL_main_start and PL_main_root directly, without generating an
4144 If the parsing the main program aborts (due to parse errors,
4145 or due to BEGIN or similar calling exit), then newPROG()
4146 isn't even called, and hence this code path and its cleanups
4147 are skipped. This shouldn't make a make a difference:
4148 * a non-zero return from perl_parse is a failure, and
4149 perl_destruct() should be called immediately.
4150 * however, if exit(0) is called during the parse, then
4151 perl_parse() returns 0, and perl_run() is called. As
4152 PL_main_start will be NULL, perl_run() will return
4153 promptly, and the exit code will remain 0.
4156 PL_comppad_name = 0;
4158 S_op_destroy(aTHX_ o);
4161 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4162 PL_curcop = &PL_compiling;
4163 PL_main_start = LINKLIST(PL_main_root);
4164 PL_main_root->op_private |= OPpREFCOUNTED;
4165 OpREFCNT_set(PL_main_root, 1);
4166 PL_main_root->op_next = 0;
4167 CALL_PEEP(PL_main_start);
4168 finalize_optree(PL_main_root);
4169 S_prune_chain_head(&PL_main_start);
4170 cv_forget_slab(PL_compcv);
4173 /* Register with debugger */
4175 CV * const cv = get_cvs("DB::postponed", 0);
4179 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4181 call_sv(MUTABLE_SV(cv), G_DISCARD);
4188 Perl_localize(pTHX_ OP *o, I32 lex)
4190 PERL_ARGS_ASSERT_LOCALIZE;
4192 if (o->op_flags & OPf_PARENS)
4193 /* [perl #17376]: this appears to be premature, and results in code such as
4194 C< our(%x); > executing in list mode rather than void mode */
4201 if ( PL_parser->bufptr > PL_parser->oldbufptr
4202 && PL_parser->bufptr[-1] == ','
4203 && ckWARN(WARN_PARENTHESIS))
4205 char *s = PL_parser->bufptr;
4208 /* some heuristics to detect a potential error */
4209 while (*s && (strchr(", \t\n", *s)))
4213 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4215 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4218 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4220 while (*s && (strchr(", \t\n", *s)))
4226 if (sigil && (*s == ';' || *s == '=')) {
4227 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4228 "Parentheses missing around \"%s\" list",
4230 ? (PL_parser->in_my == KEY_our
4232 : PL_parser->in_my == KEY_state
4242 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4243 PL_parser->in_my = FALSE;
4244 PL_parser->in_my_stash = NULL;
4249 Perl_jmaybe(pTHX_ OP *o)
4251 PERL_ARGS_ASSERT_JMAYBE;
4253 if (o->op_type == OP_LIST) {
4255 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4256 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4261 PERL_STATIC_INLINE OP *
4262 S_op_std_init(pTHX_ OP *o)
4264 I32 type = o->op_type;
4266 PERL_ARGS_ASSERT_OP_STD_INIT;
4268 if (PL_opargs[type] & OA_RETSCALAR)
4270 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4271 o->op_targ = pad_alloc(type, SVs_PADTMP);
4276 PERL_STATIC_INLINE OP *
4277 S_op_integerize(pTHX_ OP *o)
4279 I32 type = o->op_type;
4281 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4283 /* integerize op. */
4284 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4287 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4290 if (type == OP_NEGATE)
4291 /* XXX might want a ck_negate() for this */
4292 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4298 S_fold_constants(pTHX_ OP *o)
4303 VOL I32 type = o->op_type;
4308 SV * const oldwarnhook = PL_warnhook;
4309 SV * const olddiehook = PL_diehook;
4311 U8 oldwarn = PL_dowarn;
4315 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4317 if (!(PL_opargs[type] & OA_FOLDCONST))
4326 #ifdef USE_LOCALE_CTYPE
4327 if (IN_LC_COMPILETIME(LC_CTYPE))
4336 #ifdef USE_LOCALE_COLLATE
4337 if (IN_LC_COMPILETIME(LC_COLLATE))
4342 /* XXX what about the numeric ops? */
4343 #ifdef USE_LOCALE_NUMERIC
4344 if (IN_LC_COMPILETIME(LC_NUMERIC))
4349 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4350 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4353 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4354 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4356 const char *s = SvPVX_const(sv);
4357 while (s < SvEND(sv)) {
4358 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4365 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4368 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4369 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4373 if (PL_parser && PL_parser->error_count)
4374 goto nope; /* Don't try to run w/ errors */
4376 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4377 switch (curop->op_type) {
4379 if ( (curop->op_private & OPpCONST_BARE)
4380 && (curop->op_private & OPpCONST_STRICT)) {
4381 no_bareword_allowed(curop);
4389 /* Foldable; move to next op in list */
4393 /* No other op types are considered foldable */
4398 curop = LINKLIST(o);
4399 old_next = o->op_next;
4403 old_cxix = cxstack_ix;
4404 create_eval_scope(NULL, G_FAKINGEVAL);
4406 /* Verify that we don't need to save it: */
4407 assert(PL_curcop == &PL_compiling);
4408 StructCopy(&PL_compiling, ¬_compiling, COP);
4409 PL_curcop = ¬_compiling;
4410 /* The above ensures that we run with all the correct hints of the
4411 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4412 assert(IN_PERL_RUNTIME);
4413 PL_warnhook = PERL_WARNHOOK_FATAL;
4417 /* Effective $^W=1. */
4418 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4419 PL_dowarn |= G_WARN_ON;
4424 sv = *(PL_stack_sp--);
4425 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4426 pad_swipe(o->op_targ, FALSE);
4428 else if (SvTEMP(sv)) { /* grab mortal temp? */
4429 SvREFCNT_inc_simple_void(sv);
4432 else { assert(SvIMMORTAL(sv)); }
4435 /* Something tried to die. Abandon constant folding. */
4436 /* Pretend the error never happened. */
4438 o->op_next = old_next;
4442 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4443 PL_warnhook = oldwarnhook;
4444 PL_diehook = olddiehook;
4445 /* XXX note that this croak may fail as we've already blown away
4446 * the stack - eg any nested evals */
4447 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4450 PL_dowarn = oldwarn;
4451 PL_warnhook = oldwarnhook;
4452 PL_diehook = olddiehook;
4453 PL_curcop = &PL_compiling;
4455 /* if we croaked, depending on how we croaked the eval scope
4456 * may or may not have already been popped */
4457 if (cxstack_ix > old_cxix) {
4458 assert(cxstack_ix == old_cxix + 1);
4459 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4460 delete_eval_scope();
4465 /* OP_STRINGIFY and constant folding are used to implement qq.
4466 Here the constant folding is an implementation detail that we
4467 want to hide. If the stringify op is itself already marked
4468 folded, however, then it is actually a folded join. */
4469 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4474 else if (!SvIMMORTAL(sv)) {
4478 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4479 if (!is_stringify) newop->op_folded = 1;
4487 S_gen_constant_list(pTHX_ OP *o)
4491 const SSize_t oldtmps_floor = PL_tmps_floor;
4496 if (PL_parser && PL_parser->error_count)
4497 return o; /* Don't attempt to run with errors */
4499 curop = LINKLIST(o);
4502 S_prune_chain_head(&curop);
4504 Perl_pp_pushmark(aTHX);
4507 assert (!(curop->op_flags & OPf_SPECIAL));
4508 assert(curop->op_type == OP_RANGE);
4509 Perl_pp_anonlist(aTHX);
4510 PL_tmps_floor = oldtmps_floor;
4512 OpTYPE_set(o, OP_RV2AV);
4513 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4514 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4515 o->op_opt = 0; /* needs to be revisited in rpeep() */
4516 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4518 /* replace subtree with an OP_CONST */
4519 curop = ((UNOP*)o)->op_first;
4520 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4523 if (AvFILLp(av) != -1)
4524 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4527 SvREADONLY_on(*svp);
4534 =head1 Optree Manipulation Functions
4537 /* List constructors */
4540 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4542 Append an item to the list of ops contained directly within a list-type
4543 op, returning the lengthened list. C<first> is the list-type op,
4544 and C<last> is the op to append to the list. C<optype> specifies the
4545 intended opcode for the list. If C<first> is not already a list of the
4546 right type, it will be upgraded into one. If either C<first> or C<last>
4547 is null, the other is returned unchanged.
4553 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4561 if (first->op_type != (unsigned)type
4562 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4564 return newLISTOP(type, 0, first, last);
4567 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4568 first->op_flags |= OPf_KIDS;
4573 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4575 Concatenate the lists of ops contained directly within two list-type ops,
4576 returning the combined list. C<first> and C<last> are the list-type ops
4577 to concatenate. C<optype> specifies the intended opcode for the list.
4578 If either C<first> or C<last> is not already a list of the right type,
4579 it will be upgraded into one. If either C<first> or C<last> is null,
4580 the other is returned unchanged.
4586 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4594 if (first->op_type != (unsigned)type)
4595 return op_prepend_elem(type, first, last);
4597 if (last->op_type != (unsigned)type)
4598 return op_append_elem(type, first, last);
4600 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4601 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4602 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4603 first->op_flags |= (last->op_flags & OPf_KIDS);
4605 S_op_destroy(aTHX_ last);
4611 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4613 Prepend an item to the list of ops contained directly within a list-type
4614 op, returning the lengthened list. C<first> is the op to prepend to the
4615 list, and C<last> is the list-type op. C<optype> specifies the intended
4616 opcode for the list. If C<last> is not already a list of the right type,
4617 it will be upgraded into one. If either C<first> or C<last> is null,
4618 the other is returned unchanged.
4624 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4632 if (last->op_type == (unsigned)type) {
4633 if (type == OP_LIST) { /* already a PUSHMARK there */
4634 /* insert 'first' after pushmark */
4635 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4636 if (!(first->op_flags & OPf_PARENS))
4637 last->op_flags &= ~OPf_PARENS;
4640 op_sibling_splice(last, NULL, 0, first);
4641 last->op_flags |= OPf_KIDS;
4645 return newLISTOP(type, 0, first, last);
4649 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4651 Converts C<o> into a list op if it is not one already, and then converts it
4652 into the specified C<type>, calling its check function, allocating a target if
4653 it needs one, and folding constants.
4655 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4656 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4657 C<op_convert_list> to make it the right type.
4663 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4666 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4667 if (!o || o->op_type != OP_LIST)
4668 o = force_list(o, 0);
4671 o->op_flags &= ~OPf_WANT;
4672 o->op_private &= ~OPpLVAL_INTRO;
4675 if (!(PL_opargs[type] & OA_MARK))
4676 op_null(cLISTOPo->op_first);
4678 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4679 if (kid2 && kid2->op_type == OP_COREARGS) {
4680 op_null(cLISTOPo->op_first);
4681 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4685 OpTYPE_set(o, type);
4686 o->op_flags |= flags;
4687 if (flags & OPf_FOLDED)
4690 o = CHECKOP(type, o);
4691 if (o->op_type != (unsigned)type)
4694 return fold_constants(op_integerize(op_std_init(o)));
4701 =head1 Optree construction
4703 =for apidoc Am|OP *|newNULLLIST
4705 Constructs, checks, and returns a new C<stub> op, which represents an
4706 empty list expression.
4712 Perl_newNULLLIST(pTHX)
4714 return newOP(OP_STUB, 0);
4717 /* promote o and any siblings to be a list if its not already; i.e.
4725 * pushmark - o - A - B
4727 * If nullit it true, the list op is nulled.
4731 S_force_list(pTHX_ OP *o, bool nullit)
4733 if (!o || o->op_type != OP_LIST) {
4736 /* manually detach any siblings then add them back later */
4737 rest = OpSIBLING(o);
4738 OpLASTSIB_set(o, NULL);
4740 o = newLISTOP(OP_LIST, 0, o, NULL);
4742 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4750 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4752 Constructs, checks, and returns an op of any list type. C<type> is
4753 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4754 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
4755 supply up to two ops to be direct children of the list op; they are
4756 consumed by this function and become part of the constructed op tree.
4758 For most list operators, the check function expects all the kid ops to be
4759 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4760 appropriate. What you want to do in that case is create an op of type
4761 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4762 See L</op_convert_list> for more information.
4769 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4774 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4775 || type == OP_CUSTOM);
4777 NewOp(1101, listop, 1, LISTOP);
4779 OpTYPE_set(listop, type);
4782 listop->op_flags = (U8)flags;
4786 else if (!first && last)
4789 OpMORESIB_set(first, last);
4790 listop->op_first = first;
4791 listop->op_last = last;
4792 if (type == OP_LIST) {
4793 OP* const pushop = newOP(OP_PUSHMARK, 0);
4794 OpMORESIB_set(pushop, first);
4795 listop->op_first = pushop;
4796 listop->op_flags |= OPf_KIDS;
4798 listop->op_last = pushop;
4800 if (listop->op_last)
4801 OpLASTSIB_set(listop->op_last, (OP*)listop);
4803 return CHECKOP(type, listop);
4807 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4809 Constructs, checks, and returns an op of any base type (any type that
4810 has no extra fields). C<type> is the opcode. C<flags> gives the
4811 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4818 Perl_newOP(pTHX_ I32 type, I32 flags)
4823 if (type == -OP_ENTEREVAL) {
4824 type = OP_ENTEREVAL;
4825 flags |= OPpEVAL_BYTES<<8;
4828 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4829 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4830 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4831 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4833 NewOp(1101, o, 1, OP);
4834 OpTYPE_set(o, type);
4835 o->op_flags = (U8)flags;
4838 o->op_private = (U8)(0 | (flags >> 8));
4839 if (PL_opargs[type] & OA_RETSCALAR)
4841 if (PL_opargs[type] & OA_TARGET)
4842 o->op_targ = pad_alloc(type, SVs_PADTMP);
4843 return CHECKOP(type, o);
4847 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4849 Constructs, checks, and returns an op of any unary type. C<type> is
4850 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4851 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4852 bits, the eight bits of C<op_private>, except that the bit with value 1
4853 is automatically set. C<first> supplies an optional op to be the direct
4854 child of the unary op; it is consumed by this function and become part
4855 of the constructed op tree.
4861 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4866 if (type == -OP_ENTEREVAL) {
4867 type = OP_ENTEREVAL;
4868 flags |= OPpEVAL_BYTES<<8;
4871 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4872 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4873 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4874 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4875 || type == OP_SASSIGN
4876 || type == OP_ENTERTRY
4877 || type == OP_CUSTOM
4878 || type == OP_NULL );
4881 first = newOP(OP_STUB, 0);
4882 if (PL_opargs[type] & OA_MARK)
4883 first = force_list(first, 1);
4885 NewOp(1101, unop, 1, UNOP);
4886 OpTYPE_set(unop, type);
4887 unop->op_first = first;
4888 unop->op_flags = (U8)(flags | OPf_KIDS);
4889 unop->op_private = (U8)(1 | (flags >> 8));
4891 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4892 OpLASTSIB_set(first, (OP*)unop);
4894 unop = (UNOP*) CHECKOP(type, unop);
4898 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4902 =for apidoc newUNOP_AUX
4904 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4905 initialised to C<aux>
4911 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4916 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4917 || type == OP_CUSTOM);
4919 NewOp(1101, unop, 1, UNOP_AUX);
4920 unop->op_type = (OPCODE)type;
4921 unop->op_ppaddr = PL_ppaddr[type];
4922 unop->op_first = first;
4923 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4924 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4927 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4928 OpLASTSIB_set(first, (OP*)unop);
4930 unop = (UNOP_AUX*) CHECKOP(type, unop);
4932 return op_std_init((OP *) unop);
4936 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4938 Constructs, checks, and returns an op of method type with a method name
4939 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
4940 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4941 and, shifted up eight bits, the eight bits of C<op_private>, except that
4942 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
4943 op which evaluates method name; it is consumed by this function and
4944 become part of the constructed op tree.
4945 Supported optypes: C<OP_METHOD>.
4951 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4955 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4956 || type == OP_CUSTOM);
4958 NewOp(1101, methop, 1, METHOP);
4960 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4961 methop->op_flags = (U8)(flags | OPf_KIDS);
4962 methop->op_u.op_first = dynamic_meth;
4963 methop->op_private = (U8)(1 | (flags >> 8));
4965 if (!OpHAS_SIBLING(dynamic_meth))
4966 OpLASTSIB_set(dynamic_meth, (OP*)methop);
4970 methop->op_flags = (U8)(flags & ~OPf_KIDS);
4971 methop->op_u.op_meth_sv = const_meth;
4972 methop->op_private = (U8)(0 | (flags >> 8));
4973 methop->op_next = (OP*)methop;
4977 methop->op_rclass_targ = 0;
4979 methop->op_rclass_sv = NULL;
4982 OpTYPE_set(methop, type);
4983 return CHECKOP(type, methop);
4987 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4988 PERL_ARGS_ASSERT_NEWMETHOP;
4989 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4993 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4995 Constructs, checks, and returns an op of method type with a constant
4996 method name. C<type> is the opcode. C<flags> gives the eight bits of
4997 C<op_flags>, and, shifted up eight bits, the eight bits of
4998 C<op_private>. C<const_meth> supplies a constant method name;
4999 it must be a shared COW string.
5000 Supported optypes: C<OP_METHOD_NAMED>.
5006 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5007 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5008 return newMETHOP_internal(type, flags, NULL, const_meth);
5012 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
5014 Constructs, checks, and returns an op of any binary type. C<type>
5015 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
5016 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5017 the eight bits of C<op_private>, except that the bit with value 1 or
5018 2 is automatically set as required. C<first> and C<last> supply up to
5019 two ops to be the direct children of the binary op; they are consumed
5020 by this function and become part of the constructed op tree.
5026 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5031 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5032 || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
5034 NewOp(1101, binop, 1, BINOP);
5037 first = newOP(OP_NULL, 0);
5039 OpTYPE_set(binop, type);
5040 binop->op_first = first;
5041 binop->op_flags = (U8)(flags | OPf_KIDS);
5044 binop->op_private = (U8)(1 | (flags >> 8));
5047 binop->op_private = (U8)(2 | (flags >> 8));
5048 OpMORESIB_set(first, last);
5051 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5052 OpLASTSIB_set(last, (OP*)binop);
5054 binop->op_last = OpSIBLING(binop->op_first);
5056 OpLASTSIB_set(binop->op_last, (OP*)binop);
5058 binop = (BINOP*)CHECKOP(type, binop);
5059 if (binop->op_next || binop->op_type != (OPCODE)type)
5062 return fold_constants(op_integerize(op_std_init((OP *)binop)));
5065 static int uvcompare(const void *a, const void *b)
5066 __attribute__nonnull__(1)
5067 __attribute__nonnull__(2)
5068 __attribute__pure__;
5069 static int uvcompare(const void *a, const void *b)
5071 if (*((const UV *)a) < (*(const UV *)b))
5073 if (*((const UV *)a) > (*(const UV *)b))
5075 if (*((const UV *)a+1) < (*(const UV *)b+1))
5077 if (*((const UV *)a+1) > (*(const UV *)b+1))
5083 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5085 SV * const tstr = ((SVOP*)expr)->op_sv;
5087 ((SVOP*)repl)->op_sv;
5090 const U8 *t = (U8*)SvPV_const(tstr, tlen);
5091 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5097 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5098 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5099 I32 del = o->op_private & OPpTRANS_DELETE;
5102 PERL_ARGS_ASSERT_PMTRANS;
5104 PL_hints |= HINT_BLOCK_SCOPE;
5107 o->op_private |= OPpTRANS_FROM_UTF;
5110 o->op_private |= OPpTRANS_TO_UTF;
5112 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5113 SV* const listsv = newSVpvs("# comment\n");
5115 const U8* tend = t + tlen;
5116 const U8* rend = r + rlen;
5132 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5133 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5136 const U32 flags = UTF8_ALLOW_DEFAULT;
5140 t = tsave = bytes_to_utf8(t, &len);
5143 if (!to_utf && rlen) {
5145 r = rsave = bytes_to_utf8(r, &len);
5149 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5150 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5154 U8 tmpbuf[UTF8_MAXBYTES+1];
5157 Newx(cp, 2*tlen, UV);
5159 transv = newSVpvs("");
5161 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5163 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5165 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5169 cp[2*i+1] = cp[2*i];
5173 qsort(cp, i, 2*sizeof(UV), uvcompare);
5174 for (j = 0; j < i; j++) {
5176 diff = val - nextmin;
5178 t = uvchr_to_utf8(tmpbuf,nextmin);
5179 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5181 U8 range_mark = ILLEGAL_UTF8_BYTE;
5182 t = uvchr_to_utf8(tmpbuf, val - 1);
5183 sv_catpvn(transv, (char *)&range_mark, 1);
5184 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5191 t = uvchr_to_utf8(tmpbuf,nextmin);
5192 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5194 U8 range_mark = ILLEGAL_UTF8_BYTE;
5195 sv_catpvn(transv, (char *)&range_mark, 1);
5197 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5198 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5199 t = (const U8*)SvPVX_const(transv);
5200 tlen = SvCUR(transv);
5204 else if (!rlen && !del) {
5205 r = t; rlen = tlen; rend = tend;
5208 if ((!rlen && !del) || t == r ||
5209 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5211 o->op_private |= OPpTRANS_IDENTICAL;
5215 while (t < tend || tfirst <= tlast) {
5216 /* see if we need more "t" chars */
5217 if (tfirst > tlast) {
5218 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5220 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5222 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5229 /* now see if we need more "r" chars */
5230 if (rfirst > rlast) {
5232 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5234 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5236 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5245 rfirst = rlast = 0xffffffff;
5249 /* now see which range will peter out first, if either. */
5250 tdiff = tlast - tfirst;
5251 rdiff = rlast - rfirst;
5252 tcount += tdiff + 1;
5253 rcount += rdiff + 1;
5260 if (rfirst == 0xffffffff) {
5261 diff = tdiff; /* oops, pretend rdiff is infinite */
5263 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5264 (long)tfirst, (long)tlast);
5266 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5270 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5271 (long)tfirst, (long)(tfirst + diff),
5274 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5275 (long)tfirst, (long)rfirst);
5277 if (rfirst + diff > max)
5278 max = rfirst + diff;
5280 grows = (tfirst < rfirst &&
5281 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5293 else if (max > 0xff)
5298 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5300 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5301 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5302 PAD_SETSV(cPADOPo->op_padix, swash);
5304 SvREADONLY_on(swash);
5306 cSVOPo->op_sv = swash;
5308 SvREFCNT_dec(listsv);
5309 SvREFCNT_dec(transv);
5311 if (!del && havefinal && rlen)
5312 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5313 newSVuv((UV)final), 0);
5322 else if (rlast == 0xffffffff)
5328 tbl = (short*)PerlMemShared_calloc(
5329 (o->op_private & OPpTRANS_COMPLEMENT) &&
5330 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5332 cPVOPo->op_pv = (char*)tbl;
5334 for (i = 0; i < (I32)tlen; i++)
5336 for (i = 0, j = 0; i < 256; i++) {
5338 if (j >= (I32)rlen) {
5347 if (i < 128 && r[j] >= 128)
5357 o->op_private |= OPpTRANS_IDENTICAL;
5359 else if (j >= (I32)rlen)
5364 PerlMemShared_realloc(tbl,
5365 (0x101+rlen-j) * sizeof(short));
5366 cPVOPo->op_pv = (char*)tbl;
5368 tbl[0x100] = (short)(rlen - j);
5369 for (i=0; i < (I32)rlen - j; i++)
5370 tbl[0x101+i] = r[j+i];
5374 if (!rlen && !del) {
5377 o->op_private |= OPpTRANS_IDENTICAL;
5379 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5380 o->op_private |= OPpTRANS_IDENTICAL;
5382 for (i = 0; i < 256; i++)
5384 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5385 if (j >= (I32)rlen) {
5387 if (tbl[t[i]] == -1)
5393 if (tbl[t[i]] == -1) {
5394 if (t[i] < 128 && r[j] >= 128)
5402 if(del && rlen == tlen) {
5403 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5404 } else if(rlen > tlen && !complement) {
5405 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5409 o->op_private |= OPpTRANS_GROWS;
5417 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5419 Constructs, checks, and returns an op of any pattern matching type.
5420 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
5421 and, shifted up eight bits, the eight bits of C<op_private>.
5427 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5432 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5433 || type == OP_CUSTOM);
5435 NewOp(1101, pmop, 1, PMOP);
5436 OpTYPE_set(pmop, type);
5437 pmop->op_flags = (U8)flags;
5438 pmop->op_private = (U8)(0 | (flags >> 8));
5439 if (PL_opargs[type] & OA_RETSCALAR)
5442 if (PL_hints & HINT_RE_TAINT)
5443 pmop->op_pmflags |= PMf_RETAINT;
5444 #ifdef USE_LOCALE_CTYPE
5445 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5446 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5451 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5453 if (PL_hints & HINT_RE_FLAGS) {
5454 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5455 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5457 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5458 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5459 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5461 if (reflags && SvOK(reflags)) {
5462 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5468 assert(SvPOK(PL_regex_pad[0]));
5469 if (SvCUR(PL_regex_pad[0])) {
5470 /* Pop off the "packed" IV from the end. */
5471 SV *const repointer_list = PL_regex_pad[0];
5472 const char *p = SvEND(repointer_list) - sizeof(IV);
5473 const IV offset = *((IV*)p);
5475 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5477 SvEND_set(repointer_list, p);
5479 pmop->op_pmoffset = offset;
5480 /* This slot should be free, so assert this: */
5481 assert(PL_regex_pad[offset] == &PL_sv_undef);
5483 SV * const repointer = &PL_sv_undef;
5484 av_push(PL_regex_padav, repointer);
5485 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5486 PL_regex_pad = AvARRAY(PL_regex_padav);
5490 return CHECKOP(type, pmop);
5498 /* Any pad names in scope are potentially lvalues. */
5499 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5500 PADNAME *pn = PAD_COMPNAME_SV(i);
5501 if (!pn || !PadnameLEN(pn))
5503 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5504 S_mark_padname_lvalue(aTHX_ pn);
5508 /* Given some sort of match op o, and an expression expr containing a
5509 * pattern, either compile expr into a regex and attach it to o (if it's
5510 * constant), or convert expr into a runtime regcomp op sequence (if it's
5513 * isreg indicates that the pattern is part of a regex construct, eg
5514 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5515 * split "pattern", which aren't. In the former case, expr will be a list
5516 * if the pattern contains more than one term (eg /a$b/).
5518 * When the pattern has been compiled within a new anon CV (for
5519 * qr/(?{...})/ ), then floor indicates the savestack level just before
5520 * the new sub was created
5524 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5528 I32 repl_has_vars = 0;
5529 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5530 bool is_compiletime;
5533 PERL_ARGS_ASSERT_PMRUNTIME;
5536 return pmtrans(o, expr, repl);
5539 /* find whether we have any runtime or code elements;
5540 * at the same time, temporarily set the op_next of each DO block;
5541 * then when we LINKLIST, this will cause the DO blocks to be excluded
5542 * from the op_next chain (and from having LINKLIST recursively
5543 * applied to them). We fix up the DOs specially later */
5547 if (expr->op_type == OP_LIST) {
5549 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5550 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5552 assert(!o->op_next);
5553 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5554 assert(PL_parser && PL_parser->error_count);
5555 /* This can happen with qr/ (?{(^{})/. Just fake up
5556 the op we were expecting to see, to avoid crashing
5558 op_sibling_splice(expr, o, 0,
5559 newSVOP(OP_CONST, 0, &PL_sv_no));
5561 o->op_next = OpSIBLING(o);
5563 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5567 else if (expr->op_type != OP_CONST)
5572 /* fix up DO blocks; treat each one as a separate little sub;
5573 * also, mark any arrays as LIST/REF */
5575 if (expr->op_type == OP_LIST) {
5577 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5579 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5580 assert( !(o->op_flags & OPf_WANT));
5581 /* push the array rather than its contents. The regex
5582 * engine will retrieve and join the elements later */
5583 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5587 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5589 o->op_next = NULL; /* undo temporary hack from above */
5592 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5593 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5595 assert(leaveop->op_first->op_type == OP_ENTER);
5596 assert(OpHAS_SIBLING(leaveop->op_first));
5597 o->op_next = OpSIBLING(leaveop->op_first);
5599 assert(leaveop->op_flags & OPf_KIDS);
5600 assert(leaveop->op_last->op_next == (OP*)leaveop);
5601 leaveop->op_next = NULL; /* stop on last op */
5602 op_null((OP*)leaveop);
5606 OP *scope = cLISTOPo->op_first;
5607 assert(scope->op_type == OP_SCOPE);
5608 assert(scope->op_flags & OPf_KIDS);
5609 scope->op_next = NULL; /* stop on last op */
5612 /* have to peep the DOs individually as we've removed it from
5613 * the op_next chain */
5615 S_prune_chain_head(&(o->op_next));
5617 /* runtime finalizes as part of finalizing whole tree */
5621 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5622 assert( !(expr->op_flags & OPf_WANT));
5623 /* push the array rather than its contents. The regex
5624 * engine will retrieve and join the elements later */
5625 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5628 PL_hints |= HINT_BLOCK_SCOPE;
5630 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5632 if (is_compiletime) {
5633 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5634 regexp_engine const *eng = current_re_engine();
5636 if (o->op_flags & OPf_SPECIAL)
5637 rx_flags |= RXf_SPLIT;
5639 if (!has_code || !eng->op_comp) {
5640 /* compile-time simple constant pattern */
5642 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5643 /* whoops! we guessed that a qr// had a code block, but we
5644 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5645 * that isn't required now. Note that we have to be pretty
5646 * confident that nothing used that CV's pad while the
5647 * regex was parsed, except maybe op targets for \Q etc.
5648 * If there were any op targets, though, they should have
5649 * been stolen by constant folding.
5653 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5654 while (++i <= AvFILLp(PL_comppad)) {
5655 assert(!PL_curpad[i]);
5658 /* But we know that one op is using this CV's slab. */
5659 cv_forget_slab(PL_compcv);
5661 pm->op_pmflags &= ~PMf_HAS_CV;
5666 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5667 rx_flags, pm->op_pmflags)
5668 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5669 rx_flags, pm->op_pmflags)
5674 /* compile-time pattern that includes literal code blocks */
5675 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5678 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5681 if (pm->op_pmflags & PMf_HAS_CV) {
5683 /* this QR op (and the anon sub we embed it in) is never
5684 * actually executed. It's just a placeholder where we can
5685 * squirrel away expr in op_code_list without the peephole
5686 * optimiser etc processing it for a second time */
5687 OP *qr = newPMOP(OP_QR, 0);
5688 ((PMOP*)qr)->op_code_list = expr;
5690 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5691 SvREFCNT_inc_simple_void(PL_compcv);
5692 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5693 ReANY(re)->qr_anoncv = cv;
5695 /* attach the anon CV to the pad so that
5696 * pad_fixup_inner_anons() can find it */
5697 (void)pad_add_anon(cv, o->op_type);
5698 SvREFCNT_inc_simple_void(cv);
5701 pm->op_code_list = expr;
5706 /* runtime pattern: build chain of regcomp etc ops */
5708 PADOFFSET cv_targ = 0;
5710 reglist = isreg && expr->op_type == OP_LIST;
5715 pm->op_code_list = expr;
5716 /* don't free op_code_list; its ops are embedded elsewhere too */
5717 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5720 if (o->op_flags & OPf_SPECIAL)
5721 pm->op_pmflags |= PMf_SPLIT;
5723 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5724 * to allow its op_next to be pointed past the regcomp and
5725 * preceding stacking ops;
5726 * OP_REGCRESET is there to reset taint before executing the
5728 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5729 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5731 if (pm->op_pmflags & PMf_HAS_CV) {
5732 /* we have a runtime qr with literal code. This means
5733 * that the qr// has been wrapped in a new CV, which
5734 * means that runtime consts, vars etc will have been compiled
5735 * against a new pad. So... we need to execute those ops
5736 * within the environment of the new CV. So wrap them in a call
5737 * to a new anon sub. i.e. for
5741 * we build an anon sub that looks like
5743 * sub { "a", $b, '(?{...})' }
5745 * and call it, passing the returned list to regcomp.
5746 * Or to put it another way, the list of ops that get executed
5750 * ------ -------------------
5751 * pushmark (for regcomp)
5752 * pushmark (for entersub)
5756 * regcreset regcreset
5758 * const("a") const("a")
5760 * const("(?{...})") const("(?{...})")
5765 SvREFCNT_inc_simple_void(PL_compcv);
5766 CvLVALUE_on(PL_compcv);
5767 /* these lines are just an unrolled newANONATTRSUB */
5768 expr = newSVOP(OP_ANONCODE, 0,
5769 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5770 cv_targ = expr->op_targ;
5771 expr = newUNOP(OP_REFGEN, 0, expr);
5773 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5776 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5777 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5778 | (reglist ? OPf_STACKED : 0);
5779 rcop->op_targ = cv_targ;
5781 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5782 if (PL_hints & HINT_RE_EVAL)
5783 S_set_haseval(aTHX);
5785 /* establish postfix order */
5786 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5788 rcop->op_next = expr;
5789 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5792 rcop->op_next = LINKLIST(expr);
5793 expr->op_next = (OP*)rcop;
5796 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5802 /* If we are looking at s//.../e with a single statement, get past
5803 the implicit do{}. */
5804 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5805 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5806 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5809 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5810 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5811 && !OpHAS_SIBLING(sib))
5814 if (curop->op_type == OP_CONST)
5816 else if (( (curop->op_type == OP_RV2SV ||
5817 curop->op_type == OP_RV2AV ||
5818 curop->op_type == OP_RV2HV ||
5819 curop->op_type == OP_RV2GV)
5820 && cUNOPx(curop)->op_first
5821 && cUNOPx(curop)->op_first->op_type == OP_GV )
5822 || curop->op_type == OP_PADSV
5823 || curop->op_type == OP_PADAV
5824 || curop->op_type == OP_PADHV
5825 || curop->op_type == OP_PADANY) {
5833 || !RX_PRELEN(PM_GETRE(pm))
5834 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5836 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5837 op_prepend_elem(o->op_type, scalar(repl), o);
5840 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5841 rcop->op_private = 1;
5843 /* establish postfix order */
5844 rcop->op_next = LINKLIST(repl);
5845 repl->op_next = (OP*)rcop;
5847 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5848 assert(!(pm->op_pmflags & PMf_ONCE));
5849 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5858 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5860 Constructs, checks, and returns an op of any type that involves an
5861 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
5862 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
5863 takes ownership of one reference to it.
5869 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5874 PERL_ARGS_ASSERT_NEWSVOP;
5876 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5877 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5878 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5879 || type == OP_CUSTOM);
5881 NewOp(1101, svop, 1, SVOP);
5882 OpTYPE_set(svop, type);
5884 svop->op_next = (OP*)svop;
5885 svop->op_flags = (U8)flags;
5886 svop->op_private = (U8)(0 | (flags >> 8));
5887 if (PL_opargs[type] & OA_RETSCALAR)
5889 if (PL_opargs[type] & OA_TARGET)
5890 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5891 return CHECKOP(type, svop);
5895 =for apidoc Am|OP *|newDEFSVOP|
5897 Constructs and returns an op to access C<$_>.
5903 Perl_newDEFSVOP(pTHX)
5905 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5911 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5913 Constructs, checks, and returns an op of any type that involves a
5914 reference to a pad element. C<type> is the opcode. C<flags> gives the
5915 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5916 is populated with C<sv>; this function takes ownership of one reference
5919 This function only exists if Perl has been compiled to use ithreads.
5925 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5930 PERL_ARGS_ASSERT_NEWPADOP;
5932 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5933 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5934 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5935 || type == OP_CUSTOM);
5937 NewOp(1101, padop, 1, PADOP);
5938 OpTYPE_set(padop, type);
5940 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5941 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5942 PAD_SETSV(padop->op_padix, sv);
5944 padop->op_next = (OP*)padop;
5945 padop->op_flags = (U8)flags;
5946 if (PL_opargs[type] & OA_RETSCALAR)
5948 if (PL_opargs[type] & OA_TARGET)
5949 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5950 return CHECKOP(type, padop);
5953 #endif /* USE_ITHREADS */
5956 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5958 Constructs, checks, and returns an op of any type that involves an
5959 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
5960 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
5961 reference; calling this function does not transfer ownership of any
5968 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5970 PERL_ARGS_ASSERT_NEWGVOP;
5973 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5975 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5980 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5982 Constructs, checks, and returns an op of any type that involves an
5983 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
5984 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
5985 must have been allocated using C<PerlMemShared_malloc>; the memory will
5986 be freed when the op is destroyed.
5992 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5995 const bool utf8 = cBOOL(flags & SVf_UTF8);
6000 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6001 || type == OP_RUNCV || type == OP_CUSTOM
6002 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6004 NewOp(1101, pvop, 1, PVOP);
6005 OpTYPE_set(pvop, type);
6007 pvop->op_next = (OP*)pvop;
6008 pvop->op_flags = (U8)flags;
6009 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
6010 if (PL_opargs[type] & OA_RETSCALAR)
6012 if (PL_opargs[type] & OA_TARGET)
6013 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
6014 return CHECKOP(type, pvop);
6018 Perl_package(pTHX_ OP *o)
6020 SV *const sv = cSVOPo->op_sv;
6022 PERL_ARGS_ASSERT_PACKAGE;
6024 SAVEGENERICSV(PL_curstash);
6025 save_item(PL_curstname);
6027 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
6029 sv_setsv(PL_curstname, sv);
6031 PL_hints |= HINT_BLOCK_SCOPE;
6032 PL_parser->copline = NOLINE;
6038 Perl_package_version( pTHX_ OP *v )
6040 U32 savehints = PL_hints;
6041 PERL_ARGS_ASSERT_PACKAGE_VERSION;
6042 PL_hints &= ~HINT_STRICT_VARS;
6043 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6044 PL_hints = savehints;
6049 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6054 SV *use_version = NULL;
6056 PERL_ARGS_ASSERT_UTILIZE;
6058 if (idop->op_type != OP_CONST)
6059 Perl_croak(aTHX_ "Module name must be constant");
6064 SV * const vesv = ((SVOP*)version)->op_sv;
6066 if (!arg && !SvNIOKp(vesv)) {
6073 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6074 Perl_croak(aTHX_ "Version number must be a constant number");
6076 /* Make copy of idop so we don't free it twice */
6077 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6079 /* Fake up a method call to VERSION */
6080 meth = newSVpvs_share("VERSION");
6081 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6082 op_append_elem(OP_LIST,
6083 op_prepend_elem(OP_LIST, pack, version),
6084 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6088 /* Fake up an import/unimport */
6089 if (arg && arg->op_type == OP_STUB) {
6090 imop = arg; /* no import on explicit () */
6092 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6093 imop = NULL; /* use 5.0; */
6095 use_version = ((SVOP*)idop)->op_sv;
6097 idop->op_private |= OPpCONST_NOVER;
6102 /* Make copy of idop so we don't free it twice */
6103 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6105 /* Fake up a method call to import/unimport */
6107 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6108 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6109 op_append_elem(OP_LIST,
6110 op_prepend_elem(OP_LIST, pack, arg),
6111 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6115 /* Fake up the BEGIN {}, which does its thing immediately. */
6117 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6120 op_append_elem(OP_LINESEQ,
6121 op_append_elem(OP_LINESEQ,
6122 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6123 newSTATEOP(0, NULL, veop)),
6124 newSTATEOP(0, NULL, imop) ));
6128 * feature bundle that corresponds to the required version. */
6129 use_version = sv_2mortal(new_version(use_version));
6130 S_enable_feature_bundle(aTHX_ use_version);
6132 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6133 if (vcmp(use_version,
6134 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6135 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6136 PL_hints |= HINT_STRICT_REFS;
6137 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6138 PL_hints |= HINT_STRICT_SUBS;
6139 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6140 PL_hints |= HINT_STRICT_VARS;
6142 /* otherwise they are off */
6144 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6145 PL_hints &= ~HINT_STRICT_REFS;
6146 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6147 PL_hints &= ~HINT_STRICT_SUBS;
6148 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6149 PL_hints &= ~HINT_STRICT_VARS;
6153 /* The "did you use incorrect case?" warning used to be here.
6154 * The problem is that on case-insensitive filesystems one
6155 * might get false positives for "use" (and "require"):
6156 * "use Strict" or "require CARP" will work. This causes
6157 * portability problems for the script: in case-strict
6158 * filesystems the script will stop working.
6160 * The "incorrect case" warning checked whether "use Foo"
6161 * imported "Foo" to your namespace, but that is wrong, too:
6162 * there is no requirement nor promise in the language that
6163 * a Foo.pm should or would contain anything in package "Foo".
6165 * There is very little Configure-wise that can be done, either:
6166 * the case-sensitivity of the build filesystem of Perl does not
6167 * help in guessing the case-sensitivity of the runtime environment.
6170 PL_hints |= HINT_BLOCK_SCOPE;
6171 PL_parser->copline = NOLINE;
6172 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6176 =head1 Embedding Functions
6178 =for apidoc load_module
6180 Loads the module whose name is pointed to by the string part of name.
6181 Note that the actual module name, not its filename, should be given.
6182 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
6183 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6184 (or 0 for no flags). ver, if specified
6185 and not NULL, provides version semantics
6186 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
6187 arguments can be used to specify arguments to the module's C<import()>
6188 method, similar to C<use Foo::Bar VERSION LIST>. They must be
6189 terminated with a final C<NULL> pointer. Note that this list can only
6190 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6191 Otherwise at least a single C<NULL> pointer to designate the default
6192 import list is required.
6194 The reference count for each specified C<SV*> parameter is decremented.
6199 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6203 PERL_ARGS_ASSERT_LOAD_MODULE;
6205 va_start(args, ver);
6206 vload_module(flags, name, ver, &args);
6210 #ifdef PERL_IMPLICIT_CONTEXT
6212 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6216 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6217 va_start(args, ver);
6218 vload_module(flags, name, ver, &args);
6224 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6227 OP * const modname = newSVOP(OP_CONST, 0, name);
6229 PERL_ARGS_ASSERT_VLOAD_MODULE;
6231 modname->op_private |= OPpCONST_BARE;
6233 veop = newSVOP(OP_CONST, 0, ver);
6237 if (flags & PERL_LOADMOD_NOIMPORT) {
6238 imop = sawparens(newNULLLIST());
6240 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6241 imop = va_arg(*args, OP*);
6246 sv = va_arg(*args, SV*);
6248 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6249 sv = va_arg(*args, SV*);
6253 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6254 * that it has a PL_parser to play with while doing that, and also
6255 * that it doesn't mess with any existing parser, by creating a tmp
6256 * new parser with lex_start(). This won't actually be used for much,
6257 * since pp_require() will create another parser for the real work.
6258 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6261 SAVEVPTR(PL_curcop);
6262 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6263 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6264 veop, modname, imop);
6268 PERL_STATIC_INLINE OP *
6269 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6271 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6272 newLISTOP(OP_LIST, 0, arg,
6273 newUNOP(OP_RV2CV, 0,
6274 newGVOP(OP_GV, 0, gv))));
6278 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6283 PERL_ARGS_ASSERT_DOFILE;
6285 if (!force_builtin && (gv = gv_override("do", 2))) {
6286 doop = S_new_entersubop(aTHX_ gv, term);
6289 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6295 =head1 Optree construction
6297 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6299 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
6300 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6301 be set automatically, and, shifted up eight bits, the eight bits of
6302 C<op_private>, except that the bit with value 1 or 2 is automatically
6303 set as required. C<listval> and C<subscript> supply the parameters of
6304 the slice; they are consumed by this function and become part of the
6305 constructed op tree.
6311 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6313 return newBINOP(OP_LSLICE, flags,
6314 list(force_list(subscript, 1)),
6315 list(force_list(listval, 1)) );
6318 #define ASSIGN_LIST 1
6319 #define ASSIGN_REF 2
6322 S_assignment_type(pTHX_ const OP *o)
6331 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6332 o = cUNOPo->op_first;
6334 flags = o->op_flags;
6336 if (type == OP_COND_EXPR) {
6337 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6338 const I32 t = assignment_type(sib);
6339 const I32 f = assignment_type(OpSIBLING(sib));
6341 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6343 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6344 yyerror("Assignment to both a list and a scalar");
6348 if (type == OP_SREFGEN)
6350 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6351 type = kid->op_type;
6352 flags |= kid->op_flags;
6353 if (!(flags & OPf_PARENS)
6354 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6355 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6361 if (type == OP_LIST &&
6362 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6363 o->op_private & OPpLVAL_INTRO)
6366 if (type == OP_LIST || flags & OPf_PARENS ||
6367 type == OP_RV2AV || type == OP_RV2HV ||
6368 type == OP_ASLICE || type == OP_HSLICE ||
6369 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6372 if (type == OP_PADAV || type == OP_PADHV)
6375 if (type == OP_RV2SV)
6383 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6385 Constructs, checks, and returns an assignment op. C<left> and C<right>
6386 supply the parameters of the assignment; they are consumed by this
6387 function and become part of the constructed op tree.
6389 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6390 a suitable conditional optree is constructed. If C<optype> is the opcode
6391 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6392 performs the binary operation and assigns the result to the left argument.
6393 Either way, if C<optype> is non-zero then C<flags> has no effect.
6395 If C<optype> is zero, then a plain scalar or list assignment is
6396 constructed. Which type of assignment it is is automatically determined.
6397 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6398 will be set automatically, and, shifted up eight bits, the eight bits
6399 of C<op_private>, except that the bit with value 1 or 2 is automatically
6406 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6412 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6413 return newLOGOP(optype, 0,
6414 op_lvalue(scalar(left), optype),
6415 newUNOP(OP_SASSIGN, 0, scalar(right)));
6418 return newBINOP(optype, OPf_STACKED,
6419 op_lvalue(scalar(left), optype), scalar(right));
6423 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6424 static const char no_list_state[] = "Initialization of state variables"
6425 " in list context currently forbidden";
6428 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6429 left->op_private &= ~ OPpSLICEWARNING;
6432 left = op_lvalue(left, OP_AASSIGN);
6433 curop = list(force_list(left, 1));
6434 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6435 o->op_private = (U8)(0 | (flags >> 8));
6437 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6439 OP* lop = ((LISTOP*)left)->op_first;
6441 if ((lop->op_type == OP_PADSV ||
6442 lop->op_type == OP_PADAV ||
6443 lop->op_type == OP_PADHV ||
6444 lop->op_type == OP_PADANY)
6445 && (lop->op_private & OPpPAD_STATE)
6447 yyerror(no_list_state);
6448 lop = OpSIBLING(lop);
6451 else if ( (left->op_private & OPpLVAL_INTRO)
6452 && (left->op_private & OPpPAD_STATE)
6453 && ( left->op_type == OP_PADSV
6454 || left->op_type == OP_PADAV
6455 || left->op_type == OP_PADHV
6456 || left->op_type == OP_PADANY)
6458 /* All single variable list context state assignments, hence
6468 yyerror(no_list_state);
6471 if (right && right->op_type == OP_SPLIT
6472 && !(right->op_flags & OPf_STACKED)) {
6473 OP* tmpop = ((LISTOP*)right)->op_first;
6474 PMOP * const pm = (PMOP*)tmpop;
6475 assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6478 !pm->op_pmreplrootu.op_pmtargetoff
6480 !pm->op_pmreplrootu.op_pmtargetgv
6484 if (!(left->op_private & OPpLVAL_INTRO) &&
6485 ( (left->op_type == OP_RV2AV &&
6486 (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6487 || left->op_type == OP_PADAV )
6489 if (tmpop != (OP *)pm) {
6491 pm->op_pmreplrootu.op_pmtargetoff
6492 = cPADOPx(tmpop)->op_padix;
6493 cPADOPx(tmpop)->op_padix = 0; /* steal it */
6495 pm->op_pmreplrootu.op_pmtargetgv
6496 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6497 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
6499 right->op_private |=
6500 left->op_private & OPpOUR_INTRO;
6503 pm->op_targ = left->op_targ;
6504 left->op_targ = 0; /* filch it */
6507 tmpop = cUNOPo->op_first; /* to list (nulled) */
6508 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6509 /* detach rest of siblings from o subtree,
6510 * and free subtree */
6511 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6512 op_free(o); /* blow off assign */
6513 right->op_flags &= ~OPf_WANT;
6514 /* "I don't know and I don't care." */
6517 else if (left->op_type == OP_RV2AV
6518 || left->op_type == OP_PADAV)
6520 /* Detach the array. */
6524 op_sibling_splice(cBINOPo->op_last,
6525 cUNOPx(cBINOPo->op_last)
6526 ->op_first, 1, NULL);
6527 assert(ary == left);
6528 /* Attach it to the split. */
6529 op_sibling_splice(right, cLISTOPx(right)->op_last,
6531 right->op_flags |= OPf_STACKED;
6532 /* Detach split and expunge aassign as above. */
6535 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6536 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6539 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6540 SV * const sv = *svp;
6541 if (SvIOK(sv) && SvIVX(sv) == 0)
6543 if (right->op_private & OPpSPLIT_IMPLIM) {
6544 /* our own SV, created in ck_split */
6546 sv_setiv(sv, PL_modcount+1);
6549 /* SV may belong to someone else */
6551 *svp = newSViv(PL_modcount+1);
6559 if (assign_type == ASSIGN_REF)
6560 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6562 right = newOP(OP_UNDEF, 0);
6563 if (right->op_type == OP_READLINE) {
6564 right->op_flags |= OPf_STACKED;
6565 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6569 o = newBINOP(OP_SASSIGN, flags,
6570 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6576 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6578 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6579 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6580 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6581 If C<label> is non-null, it supplies the name of a label to attach to
6582 the state op; this function takes ownership of the memory pointed at by
6583 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
6586 If C<o> is null, the state op is returned. Otherwise the state op is
6587 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
6588 is consumed by this function and becomes part of the returned op tree.
6594 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6597 const U32 seq = intro_my();
6598 const U32 utf8 = flags & SVf_UTF8;
6601 PL_parser->parsed_sub = 0;
6605 NewOp(1101, cop, 1, COP);
6606 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6607 OpTYPE_set(cop, OP_DBSTATE);
6610 OpTYPE_set(cop, OP_NEXTSTATE);
6612 cop->op_flags = (U8)flags;
6613 CopHINTS_set(cop, PL_hints);
6615 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6617 cop->op_next = (OP*)cop;
6620 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6621 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6623 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6625 PL_hints |= HINT_BLOCK_SCOPE;
6626 /* It seems that we need to defer freeing this pointer, as other parts
6627 of the grammar end up wanting to copy it after this op has been
6632 if (PL_parser->preambling != NOLINE) {
6633 CopLINE_set(cop, PL_parser->preambling);
6634 PL_parser->copline = NOLINE;
6636 else if (PL_parser->copline == NOLINE)
6637 CopLINE_set(cop, CopLINE(PL_curcop));
6639 CopLINE_set(cop, PL_parser->copline);
6640 PL_parser->copline = NOLINE;
6643 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6645 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6647 CopSTASH_set(cop, PL_curstash);
6649 if (cop->op_type == OP_DBSTATE) {
6650 /* this line can have a breakpoint - store the cop in IV */
6651 AV *av = CopFILEAVx(PL_curcop);
6653 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6654 if (svp && *svp != &PL_sv_undef ) {
6655 (void)SvIOK_on(*svp);
6656 SvIV_set(*svp, PTR2IV(cop));
6661 if (flags & OPf_SPECIAL)
6663 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6667 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6669 Constructs, checks, and returns a logical (flow control) op. C<type>
6670 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6671 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6672 the eight bits of C<op_private>, except that the bit with value 1 is
6673 automatically set. C<first> supplies the expression controlling the
6674 flow, and C<other> supplies the side (alternate) chain of ops; they are
6675 consumed by this function and become part of the constructed op tree.
6681 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6683 PERL_ARGS_ASSERT_NEWLOGOP;
6685 return new_logop(type, flags, &first, &other);
6689 S_search_const(pTHX_ OP *o)
6691 PERL_ARGS_ASSERT_SEARCH_CONST;
6693 switch (o->op_type) {
6697 if (o->op_flags & OPf_KIDS)
6698 return search_const(cUNOPo->op_first);
6705 if (!(o->op_flags & OPf_KIDS))
6707 kid = cLISTOPo->op_first;
6709 switch (kid->op_type) {
6713 kid = OpSIBLING(kid);
6716 if (kid != cLISTOPo->op_last)
6722 kid = cLISTOPo->op_last;
6724 return search_const(kid);
6732 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6740 int prepend_not = 0;
6742 PERL_ARGS_ASSERT_NEW_LOGOP;
6747 /* [perl #59802]: Warn about things like "return $a or $b", which
6748 is parsed as "(return $a) or $b" rather than "return ($a or
6749 $b)". NB: This also applies to xor, which is why we do it
6752 switch (first->op_type) {
6756 /* XXX: Perhaps we should emit a stronger warning for these.
6757 Even with the high-precedence operator they don't seem to do
6760 But until we do, fall through here.
6766 /* XXX: Currently we allow people to "shoot themselves in the
6767 foot" by explicitly writing "(return $a) or $b".
6769 Warn unless we are looking at the result from folding or if
6770 the programmer explicitly grouped the operators like this.
6771 The former can occur with e.g.
6773 use constant FEATURE => ( $] >= ... );
6774 sub { not FEATURE and return or do_stuff(); }
6776 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6777 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6778 "Possible precedence issue with control flow operator");
6779 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6785 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6786 return newBINOP(type, flags, scalar(first), scalar(other));
6788 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6789 || type == OP_CUSTOM);
6791 scalarboolean(first);
6793 /* search for a constant op that could let us fold the test */
6794 if ((cstop = search_const(first))) {
6795 if (cstop->op_private & OPpCONST_STRICT)
6796 no_bareword_allowed(cstop);
6797 else if ((cstop->op_private & OPpCONST_BARE))
6798 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6799 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6800 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6801 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6802 /* Elide the (constant) lhs, since it can't affect the outcome */
6804 if (other->op_type == OP_CONST)
6805 other->op_private |= OPpCONST_SHORTCIRCUIT;
6807 if (other->op_type == OP_LEAVE)
6808 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6809 else if (other->op_type == OP_MATCH
6810 || other->op_type == OP_SUBST
6811 || other->op_type == OP_TRANSR
6812 || other->op_type == OP_TRANS)
6813 /* Mark the op as being unbindable with =~ */
6814 other->op_flags |= OPf_SPECIAL;
6816 other->op_folded = 1;
6820 /* Elide the rhs, since the outcome is entirely determined by
6821 * the (constant) lhs */
6823 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6824 const OP *o2 = other;
6825 if ( ! (o2->op_type == OP_LIST
6826 && (( o2 = cUNOPx(o2)->op_first))
6827 && o2->op_type == OP_PUSHMARK
6828 && (( o2 = OpSIBLING(o2))) )
6831 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6832 || o2->op_type == OP_PADHV)
6833 && o2->op_private & OPpLVAL_INTRO
6834 && !(o2->op_private & OPpPAD_STATE))
6836 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6837 "Deprecated use of my() in false conditional");
6841 if (cstop->op_type == OP_CONST)
6842 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6847 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6848 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6850 const OP * const k1 = ((UNOP*)first)->op_first;
6851 const OP * const k2 = OpSIBLING(k1);
6853 switch (first->op_type)
6856 if (k2 && k2->op_type == OP_READLINE
6857 && (k2->op_flags & OPf_STACKED)
6858 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6860 warnop = k2->op_type;
6865 if (k1->op_type == OP_READDIR
6866 || k1->op_type == OP_GLOB
6867 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6868 || k1->op_type == OP_EACH
6869 || k1->op_type == OP_AEACH)
6871 warnop = ((k1->op_type == OP_NULL)
6872 ? (OPCODE)k1->op_targ : k1->op_type);
6877 const line_t oldline = CopLINE(PL_curcop);
6878 /* This ensures that warnings are reported at the first line
6879 of the construction, not the last. */
6880 CopLINE_set(PL_curcop, PL_parser->copline);
6881 Perl_warner(aTHX_ packWARN(WARN_MISC),
6882 "Value of %s%s can be \"0\"; test with defined()",
6884 ((warnop == OP_READLINE || warnop == OP_GLOB)
6885 ? " construct" : "() operator"));
6886 CopLINE_set(PL_curcop, oldline);
6890 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6891 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6893 /* optimize AND and OR ops that have NOTs as children */
6894 if (first->op_type == OP_NOT
6895 && (first->op_flags & OPf_KIDS)
6896 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6897 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6899 if (type == OP_AND || type == OP_OR) {
6905 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6907 prepend_not = 1; /* prepend a NOT op later */
6912 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6913 logop->op_flags |= (U8)flags;
6914 logop->op_private = (U8)(1 | (flags >> 8));
6916 /* establish postfix order */
6917 logop->op_next = LINKLIST(first);
6918 first->op_next = (OP*)logop;
6919 assert(!OpHAS_SIBLING(first));
6920 op_sibling_splice((OP*)logop, first, 0, other);
6922 CHECKOP(type,logop);
6924 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
6925 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
6933 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6935 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6936 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6937 will be set automatically, and, shifted up eight bits, the eight bits of
6938 C<op_private>, except that the bit with value 1 is automatically set.
6939 C<first> supplies the expression selecting between the two branches,
6940 and C<trueop> and C<falseop> supply the branches; they are consumed by
6941 this function and become part of the constructed op tree.
6947 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6955 PERL_ARGS_ASSERT_NEWCONDOP;
6958 return newLOGOP(OP_AND, 0, first, trueop);
6960 return newLOGOP(OP_OR, 0, first, falseop);
6962 scalarboolean(first);
6963 if ((cstop = search_const(first))) {
6964 /* Left or right arm of the conditional? */
6965 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6966 OP *live = left ? trueop : falseop;
6967 OP *const dead = left ? falseop : trueop;
6968 if (cstop->op_private & OPpCONST_BARE &&
6969 cstop->op_private & OPpCONST_STRICT) {
6970 no_bareword_allowed(cstop);
6974 if (live->op_type == OP_LEAVE)
6975 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6976 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6977 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6978 /* Mark the op as being unbindable with =~ */
6979 live->op_flags |= OPf_SPECIAL;
6980 live->op_folded = 1;
6983 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6984 logop->op_flags |= (U8)flags;
6985 logop->op_private = (U8)(1 | (flags >> 8));
6986 logop->op_next = LINKLIST(falseop);
6988 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6991 /* establish postfix order */
6992 start = LINKLIST(first);
6993 first->op_next = (OP*)logop;
6995 /* make first, trueop, falseop siblings */
6996 op_sibling_splice((OP*)logop, first, 0, trueop);
6997 op_sibling_splice((OP*)logop, trueop, 0, falseop);
6999 o = newUNOP(OP_NULL, 0, (OP*)logop);
7001 trueop->op_next = falseop->op_next = o;
7008 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7010 Constructs and returns a C<range> op, with subordinate C<flip> and
7011 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
7012 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7013 for both the C<flip> and C<range> ops, except that the bit with value
7014 1 is automatically set. C<left> and C<right> supply the expressions
7015 controlling the endpoints of the range; they are consumed by this function
7016 and become part of the constructed op tree.
7022 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7030 PERL_ARGS_ASSERT_NEWRANGE;
7032 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
7033 range->op_flags = OPf_KIDS;
7034 leftstart = LINKLIST(left);
7035 range->op_private = (U8)(1 | (flags >> 8));
7037 /* make left and right siblings */
7038 op_sibling_splice((OP*)range, left, 0, right);
7040 range->op_next = (OP*)range;
7041 flip = newUNOP(OP_FLIP, flags, (OP*)range);
7042 flop = newUNOP(OP_FLOP, 0, flip);
7043 o = newUNOP(OP_NULL, 0, flop);
7045 range->op_next = leftstart;
7047 left->op_next = flip;
7048 right->op_next = flop;
7051 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7052 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7054 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7055 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7056 SvPADTMP_on(PAD_SV(flip->op_targ));
7058 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7059 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7061 /* check barewords before they might be optimized aways */
7062 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7063 no_bareword_allowed(left);
7064 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7065 no_bareword_allowed(right);
7068 if (!flip->op_private || !flop->op_private)
7069 LINKLIST(o); /* blow off optimizer unless constant */
7075 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7077 Constructs, checks, and returns an op tree expressing a loop. This is
7078 only a loop in the control flow through the op tree; it does not have
7079 the heavyweight loop structure that allows exiting the loop by C<last>
7080 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
7081 top-level op, except that some bits will be set automatically as required.
7082 C<expr> supplies the expression controlling loop iteration, and C<block>
7083 supplies the body of the loop; they are consumed by this function and
7084 become part of the constructed op tree. C<debuggable> is currently
7085 unused and should always be 1.
7091 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7095 const bool once = block && block->op_flags & OPf_SPECIAL &&
7096 block->op_type == OP_NULL;
7098 PERL_UNUSED_ARG(debuggable);
7102 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7103 || ( expr->op_type == OP_NOT
7104 && cUNOPx(expr)->op_first->op_type == OP_CONST
7105 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7108 /* Return the block now, so that S_new_logop does not try to
7110 return block; /* do {} while 0 does once */
7111 if (expr->op_type == OP_READLINE
7112 || expr->op_type == OP_READDIR
7113 || expr->op_type == OP_GLOB
7114 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7115 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7116 expr = newUNOP(OP_DEFINED, 0,
7117 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7118 } else if (expr->op_flags & OPf_KIDS) {
7119 const OP * const k1 = ((UNOP*)expr)->op_first;
7120 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7121 switch (expr->op_type) {
7123 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7124 && (k2->op_flags & OPf_STACKED)
7125 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7126 expr = newUNOP(OP_DEFINED, 0, expr);
7130 if (k1 && (k1->op_type == OP_READDIR
7131 || k1->op_type == OP_GLOB
7132 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7133 || k1->op_type == OP_EACH
7134 || k1->op_type == OP_AEACH))
7135 expr = newUNOP(OP_DEFINED, 0, expr);
7141 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7142 * op, in listop. This is wrong. [perl #27024] */
7144 block = newOP(OP_NULL, 0);
7145 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7146 o = new_logop(OP_AND, 0, &expr, &listop);
7153 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7155 if (once && o != listop)
7157 assert(cUNOPo->op_first->op_type == OP_AND
7158 || cUNOPo->op_first->op_type == OP_OR);
7159 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7163 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7165 o->op_flags |= flags;
7167 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7172 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7174 Constructs, checks, and returns an op tree expressing a C<while> loop.
7175 This is a heavyweight loop, with structure that allows exiting the loop
7176 by C<last> and suchlike.
7178 C<loop> is an optional preconstructed C<enterloop> op to use in the
7179 loop; if it is null then a suitable op will be constructed automatically.
7180 C<expr> supplies the loop's controlling expression. C<block> supplies the
7181 main body of the loop, and C<cont> optionally supplies a C<continue> block
7182 that operates as a second half of the body. All of these optree inputs
7183 are consumed by this function and become part of the constructed op tree.
7185 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7186 op and, shifted up eight bits, the eight bits of C<op_private> for
7187 the C<leaveloop> op, except that (in both cases) some bits will be set
7188 automatically. C<debuggable> is currently unused and should always be 1.
7189 C<has_my> can be supplied as true to force the
7190 loop body to be enclosed in its own scope.
7196 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7197 OP *expr, OP *block, OP *cont, I32 has_my)
7206 PERL_UNUSED_ARG(debuggable);
7209 if (expr->op_type == OP_READLINE
7210 || expr->op_type == OP_READDIR
7211 || expr->op_type == OP_GLOB
7212 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7213 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7214 expr = newUNOP(OP_DEFINED, 0,
7215 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7216 } else if (expr->op_flags & OPf_KIDS) {
7217 const OP * const k1 = ((UNOP*)expr)->op_first;
7218 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7219 switch (expr->op_type) {
7221 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7222 && (k2->op_flags & OPf_STACKED)
7223 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7224 expr = newUNOP(OP_DEFINED, 0, expr);
7228 if (k1 && (k1->op_type == OP_READDIR
7229 || k1->op_type == OP_GLOB
7230 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7231 || k1->op_type == OP_EACH
7232 || k1->op_type == OP_AEACH))
7233 expr = newUNOP(OP_DEFINED, 0, expr);
7240 block = newOP(OP_NULL, 0);
7241 else if (cont || has_my) {
7242 block = op_scope(block);
7246 next = LINKLIST(cont);
7249 OP * const unstack = newOP(OP_UNSTACK, 0);
7252 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7256 listop = op_append_list(OP_LINESEQ, block, cont);
7258 redo = LINKLIST(listop);
7262 o = new_logop(OP_AND, 0, &expr, &listop);
7263 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7265 return expr; /* listop already freed by new_logop */
7268 ((LISTOP*)listop)->op_last->op_next =
7269 (o == listop ? redo : LINKLIST(o));
7275 NewOp(1101,loop,1,LOOP);
7276 OpTYPE_set(loop, OP_ENTERLOOP);
7277 loop->op_private = 0;
7278 loop->op_next = (OP*)loop;
7281 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7283 loop->op_redoop = redo;
7284 loop->op_lastop = o;
7285 o->op_private |= loopflags;
7288 loop->op_nextop = next;
7290 loop->op_nextop = o;
7292 o->op_flags |= flags;
7293 o->op_private |= (flags >> 8);
7298 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7300 Constructs, checks, and returns an op tree expressing a C<foreach>
7301 loop (iteration through a list of values). This is a heavyweight loop,
7302 with structure that allows exiting the loop by C<last> and suchlike.
7304 C<sv> optionally supplies the variable that will be aliased to each
7305 item in turn; if null, it defaults to C<$_>.
7306 C<expr> supplies the list of values to iterate over. C<block> supplies
7307 the main body of the loop, and C<cont> optionally supplies a C<continue>
7308 block that operates as a second half of the body. All of these optree
7309 inputs are consumed by this function and become part of the constructed
7312 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7313 op and, shifted up eight bits, the eight bits of C<op_private> for
7314 the C<leaveloop> op, except that (in both cases) some bits will be set
7321 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7326 PADOFFSET padoff = 0;
7330 PERL_ARGS_ASSERT_NEWFOROP;
7333 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7334 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7335 OpTYPE_set(sv, OP_RV2GV);
7337 /* The op_type check is needed to prevent a possible segfault
7338 * if the loop variable is undeclared and 'strict vars' is in
7339 * effect. This is illegal but is nonetheless parsed, so we
7340 * may reach this point with an OP_CONST where we're expecting
7343 if (cUNOPx(sv)->op_first->op_type == OP_GV
7344 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7345 iterpflags |= OPpITER_DEF;
7347 else if (sv->op_type == OP_PADSV) { /* private variable */
7348 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7349 padoff = sv->op_targ;
7353 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7355 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7358 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7360 PADNAME * const pn = PAD_COMPNAME(padoff);
7361 const char * const name = PadnamePV(pn);
7363 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7364 iterpflags |= OPpITER_DEF;
7368 sv = newGVOP(OP_GV, 0, PL_defgv);
7369 iterpflags |= OPpITER_DEF;
7372 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7373 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7374 iterflags |= OPf_STACKED;
7376 else if (expr->op_type == OP_NULL &&
7377 (expr->op_flags & OPf_KIDS) &&
7378 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7380 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7381 * set the STACKED flag to indicate that these values are to be
7382 * treated as min/max values by 'pp_enteriter'.
7384 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7385 LOGOP* const range = (LOGOP*) flip->op_first;
7386 OP* const left = range->op_first;
7387 OP* const right = OpSIBLING(left);
7390 range->op_flags &= ~OPf_KIDS;
7391 /* detach range's children */
7392 op_sibling_splice((OP*)range, NULL, -1, NULL);
7394 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7395 listop->op_first->op_next = range->op_next;
7396 left->op_next = range->op_other;
7397 right->op_next = (OP*)listop;
7398 listop->op_next = listop->op_first;
7401 expr = (OP*)(listop);
7403 iterflags |= OPf_STACKED;
7406 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7409 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7410 op_append_elem(OP_LIST, list(expr),
7412 assert(!loop->op_next);
7413 /* for my $x () sets OPpLVAL_INTRO;
7414 * for our $x () sets OPpOUR_INTRO */
7415 loop->op_private = (U8)iterpflags;
7416 if (loop->op_slabbed
7417 && DIFF(loop, OpSLOT(loop)->opslot_next)
7418 < SIZE_TO_PSIZE(sizeof(LOOP)))
7421 NewOp(1234,tmp,1,LOOP);
7422 Copy(loop,tmp,1,LISTOP);
7423 #ifdef PERL_OP_PARENT
7424 assert(loop->op_last->op_sibparent == (OP*)loop);
7425 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7427 S_op_destroy(aTHX_ (OP*)loop);
7430 else if (!loop->op_slabbed)
7432 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7433 #ifdef PERL_OP_PARENT
7434 OpLASTSIB_set(loop->op_last, (OP*)loop);
7437 loop->op_targ = padoff;
7438 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7443 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7445 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7446 or C<last>). C<type> is the opcode. C<label> supplies the parameter
7447 determining the target of the op; it is consumed by this function and
7448 becomes part of the constructed op tree.
7454 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7458 PERL_ARGS_ASSERT_NEWLOOPEX;
7460 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7461 || type == OP_CUSTOM);
7463 if (type != OP_GOTO) {
7464 /* "last()" means "last" */
7465 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7466 o = newOP(type, OPf_SPECIAL);
7470 /* Check whether it's going to be a goto &function */
7471 if (label->op_type == OP_ENTERSUB
7472 && !(label->op_flags & OPf_STACKED))
7473 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7476 /* Check for a constant argument */
7477 if (label->op_type == OP_CONST) {
7478 SV * const sv = ((SVOP *)label)->op_sv;
7480 const char *s = SvPV_const(sv,l);
7481 if (l == strlen(s)) {
7483 SvUTF8(((SVOP*)label)->op_sv),
7485 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7489 /* If we have already created an op, we do not need the label. */
7492 else o = newUNOP(type, OPf_STACKED, label);
7494 PL_hints |= HINT_BLOCK_SCOPE;
7498 /* if the condition is a literal array or hash
7499 (or @{ ... } etc), make a reference to it.
7502 S_ref_array_or_hash(pTHX_ OP *cond)
7505 && (cond->op_type == OP_RV2AV
7506 || cond->op_type == OP_PADAV
7507 || cond->op_type == OP_RV2HV
7508 || cond->op_type == OP_PADHV))
7510 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7513 && (cond->op_type == OP_ASLICE
7514 || cond->op_type == OP_KVASLICE
7515 || cond->op_type == OP_HSLICE
7516 || cond->op_type == OP_KVHSLICE)) {
7518 /* anonlist now needs a list from this op, was previously used in
7520 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7521 cond->op_flags |= OPf_WANT_LIST;
7523 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7530 /* These construct the optree fragments representing given()
7533 entergiven and enterwhen are LOGOPs; the op_other pointer
7534 points up to the associated leave op. We need this so we
7535 can put it in the context and make break/continue work.
7536 (Also, of course, pp_enterwhen will jump straight to
7537 op_other if the match fails.)
7541 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7542 I32 enter_opcode, I32 leave_opcode,
7543 PADOFFSET entertarg)
7549 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7550 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7552 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7553 enterop->op_targ = 0;
7554 enterop->op_private = 0;
7556 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7559 /* prepend cond if we have one */
7560 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7562 o->op_next = LINKLIST(cond);
7563 cond->op_next = (OP *) enterop;
7566 /* This is a default {} block */
7567 enterop->op_flags |= OPf_SPECIAL;
7568 o ->op_flags |= OPf_SPECIAL;
7570 o->op_next = (OP *) enterop;
7573 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7574 entergiven and enterwhen both
7577 enterop->op_next = LINKLIST(block);
7578 block->op_next = enterop->op_other = o;
7583 /* Does this look like a boolean operation? For these purposes
7584 a boolean operation is:
7585 - a subroutine call [*]
7586 - a logical connective
7587 - a comparison operator
7588 - a filetest operator, with the exception of -s -M -A -C
7589 - defined(), exists() or eof()
7590 - /$re/ or $foo =~ /$re/
7592 [*] possibly surprising
7595 S_looks_like_bool(pTHX_ const OP *o)
7597 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7599 switch(o->op_type) {
7602 return looks_like_bool(cLOGOPo->op_first);
7606 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7609 looks_like_bool(cLOGOPo->op_first)
7610 && looks_like_bool(sibl));
7616 o->op_flags & OPf_KIDS
7617 && looks_like_bool(cUNOPo->op_first));
7621 case OP_NOT: case OP_XOR:
7623 case OP_EQ: case OP_NE: case OP_LT:
7624 case OP_GT: case OP_LE: case OP_GE:
7626 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7627 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7629 case OP_SEQ: case OP_SNE: case OP_SLT:
7630 case OP_SGT: case OP_SLE: case OP_SGE:
7634 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7635 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7636 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7637 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7638 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7639 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7640 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7641 case OP_FTTEXT: case OP_FTBINARY:
7643 case OP_DEFINED: case OP_EXISTS:
7644 case OP_MATCH: case OP_EOF:
7651 /* Detect comparisons that have been optimized away */
7652 if (cSVOPo->op_sv == &PL_sv_yes
7653 || cSVOPo->op_sv == &PL_sv_no)
7666 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7668 Constructs, checks, and returns an op tree expressing a C<given> block.
7669 C<cond> supplies the expression that will be locally assigned to a lexical
7670 variable, and C<block> supplies the body of the C<given> construct; they
7671 are consumed by this function and become part of the constructed op tree.
7672 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7678 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7680 PERL_ARGS_ASSERT_NEWGIVENOP;
7681 PERL_UNUSED_ARG(defsv_off);
7684 return newGIVWHENOP(
7685 ref_array_or_hash(cond),
7687 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7692 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7694 Constructs, checks, and returns an op tree expressing a C<when> block.
7695 C<cond> supplies the test expression, and C<block> supplies the block
7696 that will be executed if the test evaluates to true; they are consumed
7697 by this function and become part of the constructed op tree. C<cond>
7698 will be interpreted DWIMically, often as a comparison against C<$_>,
7699 and may be null to generate a C<default> block.
7705 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7707 const bool cond_llb = (!cond || looks_like_bool(cond));
7710 PERL_ARGS_ASSERT_NEWWHENOP;
7715 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7717 scalar(ref_array_or_hash(cond)));
7720 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7723 /* must not conflict with SVf_UTF8 */
7724 #define CV_CKPROTO_CURSTASH 0x1
7727 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7728 const STRLEN len, const U32 flags)
7730 SV *name = NULL, *msg;
7731 const char * cvp = SvROK(cv)
7732 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7733 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7736 STRLEN clen = CvPROTOLEN(cv), plen = len;
7738 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7740 if (p == NULL && cvp == NULL)
7743 if (!ckWARN_d(WARN_PROTOTYPE))
7747 p = S_strip_spaces(aTHX_ p, &plen);
7748 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7749 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7750 if (plen == clen && memEQ(cvp, p, plen))
7753 if (flags & SVf_UTF8) {
7754 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7758 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7764 msg = sv_newmortal();
7769 gv_efullname3(name = sv_newmortal(), gv, NULL);
7770 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7771 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7772 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7773 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7774 sv_catpvs(name, "::");
7776 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7777 assert (CvNAMED(SvRV_const(gv)));
7778 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7780 else sv_catsv(name, (SV *)gv);
7782 else name = (SV *)gv;
7784 sv_setpvs(msg, "Prototype mismatch:");
7786 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7788 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7789 UTF8fARG(SvUTF8(cv),clen,cvp)
7792 sv_catpvs(msg, ": none");
7793 sv_catpvs(msg, " vs ");
7795 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7797 sv_catpvs(msg, "none");
7798 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7801 static void const_sv_xsub(pTHX_ CV* cv);
7802 static void const_av_xsub(pTHX_ CV* cv);
7806 =head1 Optree Manipulation Functions
7808 =for apidoc cv_const_sv
7810 If C<cv> is a constant sub eligible for inlining, returns the constant
7811 value returned by the sub. Otherwise, returns C<NULL>.
7813 Constant subs can be created with C<newCONSTSUB> or as described in
7814 L<perlsub/"Constant Functions">.
7819 Perl_cv_const_sv(const CV *const cv)
7824 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7826 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7827 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7832 Perl_cv_const_sv_or_av(const CV * const cv)
7836 if (SvROK(cv)) return SvRV((SV *)cv);
7837 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7838 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7841 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7842 * Can be called in 2 ways:
7845 * look for a single OP_CONST with attached value: return the value
7847 * allow_lex && !CvCONST(cv);
7849 * examine the clone prototype, and if contains only a single
7850 * OP_CONST, return the value; or if it contains a single PADSV ref-
7851 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7852 * a candidate for "constizing" at clone time, and return NULL.
7856 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7864 for (; o; o = o->op_next) {
7865 const OPCODE type = o->op_type;
7867 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7869 || type == OP_PUSHMARK)
7871 if (type == OP_DBSTATE)
7873 if (type == OP_LEAVESUB)
7877 if (type == OP_CONST && cSVOPo->op_sv)
7879 else if (type == OP_UNDEF && !o->op_private) {
7883 else if (allow_lex && type == OP_PADSV) {
7884 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7886 sv = &PL_sv_undef; /* an arbitrary non-null value */
7904 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7905 PADNAME * const name, SV ** const const_svp)
7912 if (CvFLAGS(PL_compcv)) {
7913 /* might have had built-in attrs applied */
7914 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7915 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7916 && ckWARN(WARN_MISC))
7918 /* protect against fatal warnings leaking compcv */
7919 SAVEFREESV(PL_compcv);
7920 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7921 SvREFCNT_inc_simple_void_NN(PL_compcv);
7924 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7925 & ~(CVf_LVALUE * pureperl));
7930 /* redundant check for speed: */
7931 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7932 const line_t oldline = CopLINE(PL_curcop);
7935 : sv_2mortal(newSVpvn_utf8(
7936 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7938 if (PL_parser && PL_parser->copline != NOLINE)
7939 /* This ensures that warnings are reported at the first
7940 line of a redefinition, not the last. */
7941 CopLINE_set(PL_curcop, PL_parser->copline);
7942 /* protect against fatal warnings leaking compcv */
7943 SAVEFREESV(PL_compcv);
7944 report_redefined_cv(namesv, cv, const_svp);
7945 SvREFCNT_inc_simple_void_NN(PL_compcv);
7946 CopLINE_set(PL_curcop, oldline);
7953 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7958 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7961 CV *compcv = PL_compcv;
7964 PADOFFSET pax = o->op_targ;
7965 CV *outcv = CvOUTSIDE(PL_compcv);
7968 bool reusable = FALSE;
7970 #ifdef PERL_DEBUG_READONLY_OPS
7971 OPSLAB *slab = NULL;
7974 PERL_ARGS_ASSERT_NEWMYSUB;
7976 /* Find the pad slot for storing the new sub.
7977 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7978 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7979 ing sub. And then we need to dig deeper if this is a lexical from
7981 my sub foo; sub { sub foo { } }
7984 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7985 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7986 pax = PARENT_PAD_INDEX(name);
7987 outcv = CvOUTSIDE(outcv);
7992 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7993 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7994 spot = (CV **)svspot;
7996 if (!(PL_parser && PL_parser->error_count))
7997 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8000 assert(proto->op_type == OP_CONST);
8001 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8002 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8012 if (PL_parser && PL_parser->error_count) {
8014 SvREFCNT_dec(PL_compcv);
8019 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8021 svspot = (SV **)(spot = &clonee);
8023 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8026 assert (SvTYPE(*spot) == SVt_PVCV);
8028 hek = CvNAME_HEK(*spot);
8032 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8033 CvNAME_HEK_set(*spot, hek =
8036 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8040 CvLEXICAL_on(*spot);
8042 cv = PadnamePROTOCV(name);
8043 svspot = (SV **)(spot = &PadnamePROTOCV(name));
8047 /* This makes sub {}; work as expected. */
8048 if (block->op_type == OP_STUB) {
8049 const line_t l = PL_parser->copline;
8051 block = newSTATEOP(0, NULL, 0);
8052 PL_parser->copline = l;
8054 block = CvLVALUE(compcv)
8055 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8056 ? newUNOP(OP_LEAVESUBLV, 0,
8057 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8058 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8059 start = LINKLIST(block);
8061 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8062 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8070 const bool exists = CvROOT(cv) || CvXSUB(cv);
8072 /* if the subroutine doesn't exist and wasn't pre-declared
8073 * with a prototype, assume it will be AUTOLOADed,
8074 * skipping the prototype check
8076 if (exists || SvPOK(cv))
8077 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8079 /* already defined? */
8081 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8084 if (attrs) goto attrs;
8085 /* just a "sub foo;" when &foo is already defined */
8090 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8096 SvREFCNT_inc_simple_void_NN(const_sv);
8097 SvFLAGS(const_sv) |= SVs_PADTMP;
8099 assert(!CvROOT(cv) && !CvCONST(cv));
8103 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8104 CvFILE_set_from_cop(cv, PL_curcop);
8105 CvSTASH_set(cv, PL_curstash);
8108 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8109 CvXSUBANY(cv).any_ptr = const_sv;
8110 CvXSUB(cv) = const_sv_xsub;
8114 CvFLAGS(cv) |= CvMETHOD(compcv);
8116 SvREFCNT_dec(compcv);
8120 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8121 determine whether this sub definition is in the same scope as its
8122 declaration. If this sub definition is inside an inner named pack-
8123 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8124 the package sub. So check PadnameOUTER(name) too.
8126 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8127 assert(!CvWEAKOUTSIDE(compcv));
8128 SvREFCNT_dec(CvOUTSIDE(compcv));
8129 CvWEAKOUTSIDE_on(compcv);
8131 /* XXX else do we have a circular reference? */
8132 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8133 /* transfer PL_compcv to cv */
8136 cv_flags_t preserved_flags =
8137 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8138 PADLIST *const temp_padl = CvPADLIST(cv);
8139 CV *const temp_cv = CvOUTSIDE(cv);
8140 const cv_flags_t other_flags =
8141 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8142 OP * const cvstart = CvSTART(cv);
8146 CvFLAGS(compcv) | preserved_flags;
8147 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8148 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8149 CvPADLIST_set(cv, CvPADLIST(compcv));
8150 CvOUTSIDE(compcv) = temp_cv;
8151 CvPADLIST_set(compcv, temp_padl);
8152 CvSTART(cv) = CvSTART(compcv);
8153 CvSTART(compcv) = cvstart;
8154 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8155 CvFLAGS(compcv) |= other_flags;
8157 if (CvFILE(cv) && CvDYNFILE(cv)) {
8158 Safefree(CvFILE(cv));
8161 /* inner references to compcv must be fixed up ... */
8162 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8163 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8164 ++PL_sub_generation;
8167 /* Might have had built-in attributes applied -- propagate them. */
8168 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8170 /* ... before we throw it away */
8171 SvREFCNT_dec(compcv);
8172 PL_compcv = compcv = cv;
8180 if (!CvNAME_HEK(cv)) {
8181 if (hek) (void)share_hek_hek(hek);
8185 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8186 hek = share_hek(PadnamePV(name)+1,
8187 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8190 CvNAME_HEK_set(cv, hek);
8192 if (const_sv) goto clone;
8194 CvFILE_set_from_cop(cv, PL_curcop);
8195 CvSTASH_set(cv, PL_curstash);
8198 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8199 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8205 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8206 the debugger could be able to set a breakpoint in, so signal to
8207 pp_entereval that it should not throw away any saved lines at scope
8210 PL_breakable_sub_gen++;
8212 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8213 OpREFCNT_set(CvROOT(cv), 1);
8214 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8215 itself has a refcount. */
8217 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8218 #ifdef PERL_DEBUG_READONLY_OPS
8219 slab = (OPSLAB *)CvSTART(cv);
8221 CvSTART(cv) = start;
8223 finalize_optree(CvROOT(cv));
8224 S_prune_chain_head(&CvSTART(cv));
8226 /* now that optimizer has done its work, adjust pad values */
8228 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8232 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8233 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8237 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8238 SV * const tmpstr = sv_newmortal();
8239 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8240 GV_ADDMULTI, SVt_PVHV);
8242 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8245 (long)CopLINE(PL_curcop));
8246 if (HvNAME_HEK(PL_curstash)) {
8247 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8248 sv_catpvs(tmpstr, "::");
8250 else sv_setpvs(tmpstr, "__ANON__::");
8251 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8252 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8253 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8254 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8255 hv = GvHVn(db_postponed);
8256 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8257 CV * const pcv = GvCV(db_postponed);
8263 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8271 assert(CvDEPTH(outcv));
8273 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8274 if (reusable) cv_clone_into(clonee, *spot);
8275 else *spot = cv_clone(clonee);
8276 SvREFCNT_dec_NN(clonee);
8279 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8280 PADOFFSET depth = CvDEPTH(outcv);
8283 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8285 *svspot = SvREFCNT_inc_simple_NN(cv);
8286 SvREFCNT_dec(oldcv);
8292 PL_parser->copline = NOLINE;
8294 #ifdef PERL_DEBUG_READONLY_OPS
8304 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8305 OP *block, bool o_is_gv)
8309 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8313 const bool ec = PL_parser && PL_parser->error_count;
8314 /* If the subroutine has no body, no attributes, and no builtin attributes
8315 then it's just a sub declaration, and we may be able to get away with
8316 storing with a placeholder scalar in the symbol table, rather than a
8317 full CV. If anything is present then it will take a full CV to
8319 const I32 gv_fetch_flags
8320 = ec ? GV_NOADD_NOINIT :
8321 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8322 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8324 const char * const name =
8325 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8327 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8328 bool evanescent = FALSE;
8330 #ifdef PERL_DEBUG_READONLY_OPS
8331 OPSLAB *slab = NULL;
8339 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8340 hek and CvSTASH pointer together can imply the GV. If the name
8341 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8342 CvSTASH, so forego the optimisation if we find any.
8343 Also, we may be called from load_module at run time, so
8344 PL_curstash (which sets CvSTASH) may not point to the stash the
8345 sub is stored in. */
8347 ec ? GV_NOADD_NOINIT
8348 : PL_curstash != CopSTASH(PL_curcop)
8349 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8351 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8352 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8354 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8355 SV * const sv = sv_newmortal();
8356 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8357 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8358 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8359 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8361 } else if (PL_curstash) {
8362 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8365 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8370 move_proto_attr(&proto, &attrs, gv);
8373 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8378 assert(proto->op_type == OP_CONST);
8379 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8380 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8394 if (name) SvREFCNT_dec(PL_compcv);
8395 else cv = PL_compcv;
8397 if (name && block) {
8398 const char *s = strrchr(name, ':');
8400 if (strEQ(s, "BEGIN")) {
8401 if (PL_in_eval & EVAL_KEEPERR)
8402 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8404 SV * const errsv = ERRSV;
8405 /* force display of errors found but not reported */
8406 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8407 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8414 if (!block && SvTYPE(gv) != SVt_PVGV) {
8415 /* If we are not defining a new sub and the existing one is not a
8417 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8418 /* We are applying attributes to an existing sub, so we need it
8419 upgraded if it is a constant. */
8420 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8421 gv_init_pvn(gv, PL_curstash, name, namlen,
8422 SVf_UTF8 * name_is_utf8);
8424 else { /* Maybe prototype now, and had at maximum
8425 a prototype or const/sub ref before. */
8426 if (SvTYPE(gv) > SVt_NULL) {
8427 cv_ckproto_len_flags((const CV *)gv,
8428 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8433 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8434 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8437 sv_setiv(MUTABLE_SV(gv), -1);
8440 SvREFCNT_dec(PL_compcv);
8441 cv = PL_compcv = NULL;
8446 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8450 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8456 /* This makes sub {}; work as expected. */
8457 if (block->op_type == OP_STUB) {
8458 const line_t l = PL_parser->copline;
8460 block = newSTATEOP(0, NULL, 0);
8461 PL_parser->copline = l;
8463 block = CvLVALUE(PL_compcv)
8464 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8465 && (!isGV(gv) || !GvASSUMECV(gv)))
8466 ? newUNOP(OP_LEAVESUBLV, 0,
8467 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8468 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8469 start = LINKLIST(block);
8471 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8473 S_op_const_sv(aTHX_ start, PL_compcv,
8474 cBOOL(CvCLONE(PL_compcv)));
8481 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8482 cv_ckproto_len_flags((const CV *)gv,
8483 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8484 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8486 /* All the other code for sub redefinition warnings expects the
8487 clobbered sub to be a CV. Instead of making all those code
8488 paths more complex, just inline the RV version here. */
8489 const line_t oldline = CopLINE(PL_curcop);
8490 assert(IN_PERL_COMPILETIME);
8491 if (PL_parser && PL_parser->copline != NOLINE)
8492 /* This ensures that warnings are reported at the first
8493 line of a redefinition, not the last. */
8494 CopLINE_set(PL_curcop, PL_parser->copline);
8495 /* protect against fatal warnings leaking compcv */
8496 SAVEFREESV(PL_compcv);
8498 if (ckWARN(WARN_REDEFINE)
8499 || ( ckWARN_d(WARN_REDEFINE)
8500 && ( !const_sv || SvRV(gv) == const_sv
8501 || sv_cmp(SvRV(gv), const_sv) ))) {
8503 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8504 "Constant subroutine %"SVf" redefined",
8505 SVfARG(cSVOPo->op_sv));
8508 SvREFCNT_inc_simple_void_NN(PL_compcv);
8509 CopLINE_set(PL_curcop, oldline);
8510 SvREFCNT_dec(SvRV(gv));
8515 const bool exists = CvROOT(cv) || CvXSUB(cv);
8517 /* if the subroutine doesn't exist and wasn't pre-declared
8518 * with a prototype, assume it will be AUTOLOADed,
8519 * skipping the prototype check
8521 if (exists || SvPOK(cv))
8522 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8523 /* already defined (or promised)? */
8524 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8525 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8528 if (attrs) goto attrs;
8529 /* just a "sub foo;" when &foo is already defined */
8530 SAVEFREESV(PL_compcv);
8536 SvREFCNT_inc_simple_void_NN(const_sv);
8537 SvFLAGS(const_sv) |= SVs_PADTMP;
8539 assert(!CvROOT(cv) && !CvCONST(cv));
8541 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8542 CvXSUBANY(cv).any_ptr = const_sv;
8543 CvXSUB(cv) = const_sv_xsub;
8547 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8550 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8551 if (name && isGV(gv))
8553 cv = newCONSTSUB_flags(
8554 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8557 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8561 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8562 prepare_SV_for_RV((SV *)gv);
8566 SvRV_set(gv, const_sv);
8570 SvREFCNT_dec(PL_compcv);
8574 if (cv) { /* must reuse cv if autoloaded */
8575 /* transfer PL_compcv to cv */
8578 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8579 PADLIST *const temp_av = CvPADLIST(cv);
8580 CV *const temp_cv = CvOUTSIDE(cv);
8581 const cv_flags_t other_flags =
8582 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8583 OP * const cvstart = CvSTART(cv);
8587 assert(!CvCVGV_RC(cv));
8588 assert(CvGV(cv) == gv);
8593 PERL_HASH(hash, name, namlen);
8603 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8605 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8606 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8607 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8608 CvOUTSIDE(PL_compcv) = temp_cv;
8609 CvPADLIST_set(PL_compcv, temp_av);
8610 CvSTART(cv) = CvSTART(PL_compcv);
8611 CvSTART(PL_compcv) = cvstart;
8612 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8613 CvFLAGS(PL_compcv) |= other_flags;
8615 if (CvFILE(cv) && CvDYNFILE(cv)) {
8616 Safefree(CvFILE(cv));
8618 CvFILE_set_from_cop(cv, PL_curcop);
8619 CvSTASH_set(cv, PL_curstash);
8621 /* inner references to PL_compcv must be fixed up ... */
8622 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8623 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8624 ++PL_sub_generation;
8627 /* Might have had built-in attributes applied -- propagate them. */
8628 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8630 /* ... before we throw it away */
8631 SvREFCNT_dec(PL_compcv);
8636 if (name && isGV(gv)) {
8639 if (HvENAME_HEK(GvSTASH(gv)))
8640 /* sub Foo::bar { (shift)+1 } */
8641 gv_method_changed(gv);
8645 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8646 prepare_SV_for_RV((SV *)gv);
8650 SvRV_set(gv, (SV *)cv);
8654 if (isGV(gv)) CvGV_set(cv, gv);
8658 PERL_HASH(hash, name, namlen);
8659 CvNAME_HEK_set(cv, share_hek(name,
8665 CvFILE_set_from_cop(cv, PL_curcop);
8666 CvSTASH_set(cv, PL_curstash);
8670 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8671 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8677 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8678 the debugger could be able to set a breakpoint in, so signal to
8679 pp_entereval that it should not throw away any saved lines at scope
8682 PL_breakable_sub_gen++;
8684 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8685 OpREFCNT_set(CvROOT(cv), 1);
8686 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8687 itself has a refcount. */
8689 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8690 #ifdef PERL_DEBUG_READONLY_OPS
8691 slab = (OPSLAB *)CvSTART(cv);
8693 CvSTART(cv) = start;
8695 finalize_optree(CvROOT(cv));
8696 S_prune_chain_head(&CvSTART(cv));
8698 /* now that optimizer has done its work, adjust pad values */
8700 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8704 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8705 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8708 if (!name) SAVEFREESV(cv);
8709 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8710 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8713 if (block && has_name) {
8714 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8715 SV * const tmpstr = cv_name(cv,NULL,0);
8716 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8717 GV_ADDMULTI, SVt_PVHV);
8719 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8722 (long)CopLINE(PL_curcop));
8723 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8724 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8725 hv = GvHVn(db_postponed);
8726 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8727 CV * const pcv = GvCV(db_postponed);
8733 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8739 if (PL_parser && PL_parser->error_count)
8740 clear_special_blocks(name, gv, cv);
8743 process_special_blocks(floor, name, gv, cv);
8749 PL_parser->copline = NOLINE;
8752 #ifdef PERL_DEBUG_READONLY_OPS
8756 if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8757 pad_add_weakref(cv);
8763 S_clear_special_blocks(pTHX_ const char *const fullname,
8764 GV *const gv, CV *const cv) {
8768 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8770 colon = strrchr(fullname,':');
8771 name = colon ? colon + 1 : fullname;
8773 if ((*name == 'B' && strEQ(name, "BEGIN"))
8774 || (*name == 'E' && strEQ(name, "END"))
8775 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8776 || (*name == 'C' && strEQ(name, "CHECK"))
8777 || (*name == 'I' && strEQ(name, "INIT"))) {
8783 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8787 /* Returns true if the sub has been freed. */
8789 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8793 const char *const colon = strrchr(fullname,':');
8794 const char *const name = colon ? colon + 1 : fullname;
8796 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8799 if (strEQ(name, "BEGIN")) {
8800 const I32 oldscope = PL_scopestack_ix;
8803 if (floor) LEAVE_SCOPE(floor);
8805 PUSHSTACKi(PERLSI_REQUIRE);
8806 SAVECOPFILE(&PL_compiling);
8807 SAVECOPLINE(&PL_compiling);
8808 SAVEVPTR(PL_curcop);
8810 DEBUG_x( dump_sub(gv) );
8811 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8812 GvCV_set(gv,0); /* cv has been hijacked */
8813 call_list(oldscope, PL_beginav);
8817 return !PL_savebegin;
8823 if strEQ(name, "END") {
8824 DEBUG_x( dump_sub(gv) );
8825 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8828 } else if (*name == 'U') {
8829 if (strEQ(name, "UNITCHECK")) {
8830 /* It's never too late to run a unitcheck block */
8831 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8835 } else if (*name == 'C') {
8836 if (strEQ(name, "CHECK")) {
8838 /* diag_listed_as: Too late to run %s block */
8839 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8840 "Too late to run CHECK block");
8841 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8845 } else if (*name == 'I') {
8846 if (strEQ(name, "INIT")) {
8848 /* diag_listed_as: Too late to run %s block */
8849 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8850 "Too late to run INIT block");
8851 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8857 DEBUG_x( dump_sub(gv) );
8859 GvCV_set(gv,0); /* cv has been hijacked */
8865 =for apidoc newCONSTSUB
8867 See L</newCONSTSUB_flags>.
8873 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8875 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8879 =for apidoc newCONSTSUB_flags
8881 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
8882 eligible for inlining at compile-time.
8884 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
8886 The newly created subroutine takes ownership of a reference to the passed in
8889 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
8890 which won't be called if used as a destructor, but will suppress the overhead
8891 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8898 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8902 const char *const file = CopFILE(PL_curcop);
8906 if (IN_PERL_RUNTIME) {
8907 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8908 * an op shared between threads. Use a non-shared COP for our
8910 SAVEVPTR(PL_curcop);
8911 SAVECOMPILEWARNINGS();
8912 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8913 PL_curcop = &PL_compiling;
8915 SAVECOPLINE(PL_curcop);
8916 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8919 PL_hints &= ~HINT_BLOCK_SCOPE;
8922 SAVEGENERICSV(PL_curstash);
8923 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8926 /* Protect sv against leakage caused by fatal warnings. */
8927 if (sv) SAVEFREESV(sv);
8929 /* file becomes the CvFILE. For an XS, it's usually static storage,
8930 and so doesn't get free()d. (It's expected to be from the C pre-
8931 processor __FILE__ directive). But we need a dynamically allocated one,
8932 and we need it to get freed. */
8933 cv = newXS_len_flags(name, len,
8934 sv && SvTYPE(sv) == SVt_PVAV
8937 file ? file : "", "",
8938 &sv, XS_DYNAMIC_FILENAME | flags);
8939 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8948 =for apidoc U||newXS
8950 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
8951 static storage, as it is used directly as CvFILE(), without a copy being made.
8957 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8959 PERL_ARGS_ASSERT_NEWXS;
8960 return newXS_len_flags(
8961 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8966 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8967 const char *const filename, const char *const proto,
8970 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8971 return newXS_len_flags(
8972 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8977 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
8979 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
8980 return newXS_len_flags(
8981 name, strlen(name), subaddr, NULL, NULL, NULL, 0
8986 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8987 XSUBADDR_t subaddr, const char *const filename,
8988 const char *const proto, SV **const_svp,
8992 bool interleave = FALSE;
8994 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8997 GV * const gv = gv_fetchpvn(
8998 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8999 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9000 sizeof("__ANON__::__ANON__") - 1,
9001 GV_ADDMULTI | flags, SVt_PVCV);
9003 if ((cv = (name ? GvCV(gv) : NULL))) {
9005 /* just a cached method */
9009 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9010 /* already defined (or promised) */
9011 /* Redundant check that allows us to avoid creating an SV
9012 most of the time: */
9013 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9014 report_redefined_cv(newSVpvn_flags(
9015 name,len,(flags&SVf_UTF8)|SVs_TEMP
9026 if (cv) /* must reuse cv if autoloaded */
9029 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9033 if (HvENAME_HEK(GvSTASH(gv)))
9034 gv_method_changed(gv); /* newXS */
9040 /* XSUBs can't be perl lang/perl5db.pl debugged
9041 if (PERLDB_LINE_OR_SAVESRC)
9042 (void)gv_fetchfile(filename); */
9043 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9044 if (flags & XS_DYNAMIC_FILENAME) {
9046 CvFILE(cv) = savepv(filename);
9048 /* NOTE: not copied, as it is expected to be an external constant string */
9049 CvFILE(cv) = (char *)filename;
9052 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9053 CvFILE(cv) = (char*)PL_xsubfilename;
9056 CvXSUB(cv) = subaddr;
9057 #ifndef PERL_IMPLICIT_CONTEXT
9058 CvHSCXT(cv) = &PL_stack_sp;
9064 process_special_blocks(0, name, gv, cv);
9067 } /* <- not a conditional branch */
9070 sv_setpv(MUTABLE_SV(cv), proto);
9071 if (interleave) LEAVE;
9076 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9078 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9080 PERL_ARGS_ASSERT_NEWSTUB;
9084 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
9085 gv_method_changed(gv);
9087 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9092 CvFILE_set_from_cop(cv, PL_curcop);
9093 CvSTASH_set(cv, PL_curstash);
9099 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9105 if (PL_parser && PL_parser->error_count) {
9111 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9112 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9115 if ((cv = GvFORM(gv))) {
9116 if (ckWARN(WARN_REDEFINE)) {
9117 const line_t oldline = CopLINE(PL_curcop);
9118 if (PL_parser && PL_parser->copline != NOLINE)
9119 CopLINE_set(PL_curcop, PL_parser->copline);
9121 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9122 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9124 /* diag_listed_as: Format %s redefined */
9125 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9126 "Format STDOUT redefined");
9128 CopLINE_set(PL_curcop, oldline);
9133 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9135 CvFILE_set_from_cop(cv, PL_curcop);
9138 pad_tidy(padtidy_FORMAT);
9139 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9140 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9141 OpREFCNT_set(CvROOT(cv), 1);
9142 CvSTART(cv) = LINKLIST(CvROOT(cv));
9143 CvROOT(cv)->op_next = 0;
9144 CALL_PEEP(CvSTART(cv));
9145 finalize_optree(CvROOT(cv));
9146 S_prune_chain_head(&CvSTART(cv));
9152 PL_parser->copline = NOLINE;
9154 PL_compiling.cop_seq = 0;
9158 Perl_newANONLIST(pTHX_ OP *o)
9160 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9164 Perl_newANONHASH(pTHX_ OP *o)
9166 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9170 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9172 return newANONATTRSUB(floor, proto, NULL, block);
9176 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9178 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9180 newSVOP(OP_ANONCODE, 0,
9182 if (CvANONCONST(cv))
9183 anoncode = newUNOP(OP_ANONCONST, 0,
9184 op_convert_list(OP_ENTERSUB,
9185 OPf_STACKED|OPf_WANT_SCALAR,
9187 return newUNOP(OP_REFGEN, 0, anoncode);
9191 Perl_oopsAV(pTHX_ OP *o)
9195 PERL_ARGS_ASSERT_OOPSAV;
9197 switch (o->op_type) {
9200 OpTYPE_set(o, OP_PADAV);
9201 return ref(o, OP_RV2AV);
9205 OpTYPE_set(o, OP_RV2AV);
9210 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9217 Perl_oopsHV(pTHX_ OP *o)
9221 PERL_ARGS_ASSERT_OOPSHV;
9223 switch (o->op_type) {
9226 OpTYPE_set(o, OP_PADHV);
9227 return ref(o, OP_RV2HV);
9231 OpTYPE_set(o, OP_RV2HV);
9236 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9243 Perl_newAVREF(pTHX_ OP *o)
9247 PERL_ARGS_ASSERT_NEWAVREF;
9249 if (o->op_type == OP_PADANY) {
9250 OpTYPE_set(o, OP_PADAV);
9253 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9254 Perl_croak(aTHX_ "Can't use an array as a reference");
9256 return newUNOP(OP_RV2AV, 0, scalar(o));
9260 Perl_newGVREF(pTHX_ I32 type, OP *o)
9262 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9263 return newUNOP(OP_NULL, 0, o);
9264 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9268 Perl_newHVREF(pTHX_ OP *o)
9272 PERL_ARGS_ASSERT_NEWHVREF;
9274 if (o->op_type == OP_PADANY) {
9275 OpTYPE_set(o, OP_PADHV);
9278 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9279 Perl_croak(aTHX_ "Can't use a hash as a reference");
9281 return newUNOP(OP_RV2HV, 0, scalar(o));
9285 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9287 if (o->op_type == OP_PADANY) {
9289 OpTYPE_set(o, OP_PADCV);
9291 return newUNOP(OP_RV2CV, flags, scalar(o));
9295 Perl_newSVREF(pTHX_ OP *o)
9299 PERL_ARGS_ASSERT_NEWSVREF;
9301 if (o->op_type == OP_PADANY) {
9302 OpTYPE_set(o, OP_PADSV);
9306 return newUNOP(OP_RV2SV, 0, scalar(o));
9309 /* Check routines. See the comments at the top of this file for details
9310 * on when these are called */
9313 Perl_ck_anoncode(pTHX_ OP *o)
9315 PERL_ARGS_ASSERT_CK_ANONCODE;
9317 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9318 cSVOPo->op_sv = NULL;
9323 S_io_hints(pTHX_ OP *o)
9325 #if O_BINARY != 0 || O_TEXT != 0
9327 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9329 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9332 const char *d = SvPV_const(*svp, len);
9333 const I32 mode = mode_from_discipline(d, len);
9334 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9336 if (mode & O_BINARY)
9337 o->op_private |= OPpOPEN_IN_RAW;
9341 o->op_private |= OPpOPEN_IN_CRLF;
9345 svp = hv_fetchs(table, "open_OUT", FALSE);
9348 const char *d = SvPV_const(*svp, len);
9349 const I32 mode = mode_from_discipline(d, len);
9350 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9352 if (mode & O_BINARY)
9353 o->op_private |= OPpOPEN_OUT_RAW;
9357 o->op_private |= OPpOPEN_OUT_CRLF;
9362 PERL_UNUSED_CONTEXT;
9368 Perl_ck_backtick(pTHX_ OP *o)
9373 PERL_ARGS_ASSERT_CK_BACKTICK;
9374 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9375 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9376 && (gv = gv_override("readpipe",8)))
9378 /* detach rest of siblings from o and its first child */
9379 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9380 newop = S_new_entersubop(aTHX_ gv, sibl);
9382 else if (!(o->op_flags & OPf_KIDS))
9383 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9388 S_io_hints(aTHX_ o);
9393 Perl_ck_bitop(pTHX_ OP *o)
9395 PERL_ARGS_ASSERT_CK_BITOP;
9397 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9399 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9400 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9401 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9402 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9403 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9404 "The bitwise feature is experimental");
9405 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9406 && OP_IS_INFIX_BIT(o->op_type))
9408 const OP * const left = cBINOPo->op_first;
9409 const OP * const right = OpSIBLING(left);
9410 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9411 (left->op_flags & OPf_PARENS) == 0) ||
9412 (OP_IS_NUMCOMPARE(right->op_type) &&
9413 (right->op_flags & OPf_PARENS) == 0))
9414 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9415 "Possible precedence problem on bitwise %s operator",
9416 o->op_type == OP_BIT_OR
9417 ||o->op_type == OP_NBIT_OR ? "|"
9418 : o->op_type == OP_BIT_AND
9419 ||o->op_type == OP_NBIT_AND ? "&"
9420 : o->op_type == OP_BIT_XOR
9421 ||o->op_type == OP_NBIT_XOR ? "^"
9422 : o->op_type == OP_SBIT_OR ? "|."
9423 : o->op_type == OP_SBIT_AND ? "&." : "^."
9429 PERL_STATIC_INLINE bool
9430 is_dollar_bracket(pTHX_ const OP * const o)
9433 PERL_UNUSED_CONTEXT;
9434 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9435 && (kid = cUNOPx(o)->op_first)
9436 && kid->op_type == OP_GV
9437 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9441 Perl_ck_cmp(pTHX_ OP *o)
9443 PERL_ARGS_ASSERT_CK_CMP;
9444 if (ckWARN(WARN_SYNTAX)) {
9445 const OP *kid = cUNOPo->op_first;
9448 ( is_dollar_bracket(aTHX_ kid)
9449 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9451 || ( kid->op_type == OP_CONST
9452 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9456 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9457 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9463 Perl_ck_concat(pTHX_ OP *o)
9465 const OP * const kid = cUNOPo->op_first;
9467 PERL_ARGS_ASSERT_CK_CONCAT;
9468 PERL_UNUSED_CONTEXT;
9470 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9471 !(kUNOP->op_first->op_flags & OPf_MOD))
9472 o->op_flags |= OPf_STACKED;
9477 Perl_ck_spair(pTHX_ OP *o)
9481 PERL_ARGS_ASSERT_CK_SPAIR;
9483 if (o->op_flags & OPf_KIDS) {
9487 const OPCODE type = o->op_type;
9488 o = modkids(ck_fun(o), type);
9489 kid = cUNOPo->op_first;
9490 kidkid = kUNOP->op_first;
9491 newop = OpSIBLING(kidkid);
9493 const OPCODE type = newop->op_type;
9494 if (OpHAS_SIBLING(newop))
9496 if (o->op_type == OP_REFGEN
9497 && ( type == OP_RV2CV
9498 || ( !(newop->op_flags & OPf_PARENS)
9499 && ( type == OP_RV2AV || type == OP_PADAV
9500 || type == OP_RV2HV || type == OP_PADHV))))
9501 NOOP; /* OK (allow srefgen for \@a and \%h) */
9502 else if (OP_GIMME(newop,0) != G_SCALAR)
9505 /* excise first sibling */
9506 op_sibling_splice(kid, NULL, 1, NULL);
9509 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9510 * and OP_CHOMP into OP_SCHOMP */
9511 o->op_ppaddr = PL_ppaddr[++o->op_type];
9516 Perl_ck_delete(pTHX_ OP *o)
9518 PERL_ARGS_ASSERT_CK_DELETE;
9522 if (o->op_flags & OPf_KIDS) {
9523 OP * const kid = cUNOPo->op_first;
9524 switch (kid->op_type) {
9526 o->op_flags |= OPf_SPECIAL;
9529 o->op_private |= OPpSLICE;
9532 o->op_flags |= OPf_SPECIAL;
9537 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9538 " use array slice");
9540 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9543 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9544 "element or slice");
9546 if (kid->op_private & OPpLVAL_INTRO)
9547 o->op_private |= OPpLVAL_INTRO;
9554 Perl_ck_eof(pTHX_ OP *o)
9556 PERL_ARGS_ASSERT_CK_EOF;
9558 if (o->op_flags & OPf_KIDS) {
9560 if (cLISTOPo->op_first->op_type == OP_STUB) {
9562 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9567 kid = cLISTOPo->op_first;
9568 if (kid->op_type == OP_RV2GV)
9569 kid->op_private |= OPpALLOW_FAKE;
9575 Perl_ck_eval(pTHX_ OP *o)
9579 PERL_ARGS_ASSERT_CK_EVAL;
9581 PL_hints |= HINT_BLOCK_SCOPE;
9582 if (o->op_flags & OPf_KIDS) {
9583 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9586 if (o->op_type == OP_ENTERTRY) {
9589 /* cut whole sibling chain free from o */
9590 op_sibling_splice(o, NULL, -1, NULL);
9593 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9595 /* establish postfix order */
9596 enter->op_next = (OP*)enter;
9598 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9599 OpTYPE_set(o, OP_LEAVETRY);
9600 enter->op_other = o;
9605 S_set_haseval(aTHX);
9609 const U8 priv = o->op_private;
9611 /* the newUNOP will recursively call ck_eval(), which will handle
9612 * all the stuff at the end of this function, like adding
9615 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9617 o->op_targ = (PADOFFSET)PL_hints;
9618 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9619 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9620 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9621 /* Store a copy of %^H that pp_entereval can pick up. */
9622 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9623 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9624 /* append hhop to only child */
9625 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9627 o->op_private |= OPpEVAL_HAS_HH;
9629 if (!(o->op_private & OPpEVAL_BYTES)
9630 && FEATURE_UNIEVAL_IS_ENABLED)
9631 o->op_private |= OPpEVAL_UNICODE;
9636 Perl_ck_exec(pTHX_ OP *o)
9638 PERL_ARGS_ASSERT_CK_EXEC;
9640 if (o->op_flags & OPf_STACKED) {
9643 kid = OpSIBLING(cUNOPo->op_first);
9644 if (kid->op_type == OP_RV2GV)
9653 Perl_ck_exists(pTHX_ OP *o)
9655 PERL_ARGS_ASSERT_CK_EXISTS;
9658 if (o->op_flags & OPf_KIDS) {
9659 OP * const kid = cUNOPo->op_first;
9660 if (kid->op_type == OP_ENTERSUB) {
9661 (void) ref(kid, o->op_type);
9662 if (kid->op_type != OP_RV2CV
9663 && !(PL_parser && PL_parser->error_count))
9665 "exists argument is not a subroutine name");
9666 o->op_private |= OPpEXISTS_SUB;
9668 else if (kid->op_type == OP_AELEM)
9669 o->op_flags |= OPf_SPECIAL;
9670 else if (kid->op_type != OP_HELEM)
9671 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9672 "element or a subroutine");
9679 Perl_ck_rvconst(pTHX_ OP *o)
9682 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9684 PERL_ARGS_ASSERT_CK_RVCONST;
9686 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9688 if (kid->op_type == OP_CONST) {
9691 SV * const kidsv = kid->op_sv;
9693 /* Is it a constant from cv_const_sv()? */
9694 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9697 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9698 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9699 const char *badthing;
9700 switch (o->op_type) {
9702 badthing = "a SCALAR";
9705 badthing = "an ARRAY";
9708 badthing = "a HASH";
9716 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9717 SVfARG(kidsv), badthing);
9720 * This is a little tricky. We only want to add the symbol if we
9721 * didn't add it in the lexer. Otherwise we get duplicate strict
9722 * warnings. But if we didn't add it in the lexer, we must at
9723 * least pretend like we wanted to add it even if it existed before,
9724 * or we get possible typo warnings. OPpCONST_ENTERED says
9725 * whether the lexer already added THIS instance of this symbol.
9727 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9728 gv = gv_fetchsv(kidsv,
9729 o->op_type == OP_RV2CV
9730 && o->op_private & OPpMAY_RETURN_CONSTANT
9732 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9735 : o->op_type == OP_RV2SV
9737 : o->op_type == OP_RV2AV
9739 : o->op_type == OP_RV2HV
9746 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9747 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9748 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9750 OpTYPE_set(kid, OP_GV);
9751 SvREFCNT_dec(kid->op_sv);
9753 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9754 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9755 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9756 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9757 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9759 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9761 kid->op_private = 0;
9762 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9770 Perl_ck_ftst(pTHX_ OP *o)
9773 const I32 type = o->op_type;
9775 PERL_ARGS_ASSERT_CK_FTST;
9777 if (o->op_flags & OPf_REF) {
9780 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9781 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9782 const OPCODE kidtype = kid->op_type;
9784 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9785 && !kid->op_folded) {
9786 OP * const newop = newGVOP(type, OPf_REF,
9787 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9792 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
9793 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
9795 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9796 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
9797 array_passed_to_stat, name);
9800 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9801 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
9805 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9806 o->op_private |= OPpFT_ACCESS;
9807 if (type != OP_STAT && type != OP_LSTAT
9808 && PL_check[kidtype] == Perl_ck_ftst
9809 && kidtype != OP_STAT && kidtype != OP_LSTAT
9811 o->op_private |= OPpFT_STACKED;
9812 kid->op_private |= OPpFT_STACKING;
9813 if (kidtype == OP_FTTTY && (
9814 !(kid->op_private & OPpFT_STACKED)
9815 || kid->op_private & OPpFT_AFTER_t
9817 o->op_private |= OPpFT_AFTER_t;
9822 if (type == OP_FTTTY)
9823 o = newGVOP(type, OPf_REF, PL_stdingv);
9825 o = newUNOP(type, 0, newDEFSVOP());
9831 Perl_ck_fun(pTHX_ OP *o)
9833 const int type = o->op_type;
9834 I32 oa = PL_opargs[type] >> OASHIFT;
9836 PERL_ARGS_ASSERT_CK_FUN;
9838 if (o->op_flags & OPf_STACKED) {
9839 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9842 return no_fh_allowed(o);
9845 if (o->op_flags & OPf_KIDS) {
9846 OP *prev_kid = NULL;
9847 OP *kid = cLISTOPo->op_first;
9849 bool seen_optional = FALSE;
9851 if (kid->op_type == OP_PUSHMARK ||
9852 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9855 kid = OpSIBLING(kid);
9857 if (kid && kid->op_type == OP_COREARGS) {
9858 bool optional = FALSE;
9861 if (oa & OA_OPTIONAL) optional = TRUE;
9864 if (optional) o->op_private |= numargs;
9869 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9870 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9872 /* append kid to chain */
9873 op_sibling_splice(o, prev_kid, 0, kid);
9875 seen_optional = TRUE;
9882 /* list seen where single (scalar) arg expected? */
9883 if (numargs == 1 && !(oa >> 4)
9884 && kid->op_type == OP_LIST && type != OP_SCALAR)
9886 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9888 if (type != OP_DELETE) scalar(kid);
9899 if ((type == OP_PUSH || type == OP_UNSHIFT)
9900 && !OpHAS_SIBLING(kid))
9901 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9902 "Useless use of %s with no values",
9905 if (kid->op_type == OP_CONST
9906 && ( !SvROK(cSVOPx_sv(kid))
9907 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9909 bad_type_pv(numargs, "array", o, kid);
9910 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9911 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9912 PL_op_desc[type]), 0);
9915 op_lvalue(kid, type);
9919 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9920 bad_type_pv(numargs, "hash", o, kid);
9921 op_lvalue(kid, type);
9925 /* replace kid with newop in chain */
9927 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9928 newop->op_next = newop;
9933 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9934 if (kid->op_type == OP_CONST &&
9935 (kid->op_private & OPpCONST_BARE))
9937 OP * const newop = newGVOP(OP_GV, 0,
9938 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9939 /* replace kid with newop in chain */
9940 op_sibling_splice(o, prev_kid, 1, newop);
9944 else if (kid->op_type == OP_READLINE) {
9945 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9946 bad_type_pv(numargs, "HANDLE", o, kid);
9949 I32 flags = OPf_SPECIAL;
9953 /* is this op a FH constructor? */
9954 if (is_handle_constructor(o,numargs)) {
9955 const char *name = NULL;
9958 bool want_dollar = TRUE;
9961 /* Set a flag to tell rv2gv to vivify
9962 * need to "prove" flag does not mean something
9963 * else already - NI-S 1999/05/07
9966 if (kid->op_type == OP_PADSV) {
9968 = PAD_COMPNAME_SV(kid->op_targ);
9969 name = PadnamePV (pn);
9970 len = PadnameLEN(pn);
9971 name_utf8 = PadnameUTF8(pn);
9973 else if (kid->op_type == OP_RV2SV
9974 && kUNOP->op_first->op_type == OP_GV)
9976 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9978 len = GvNAMELEN(gv);
9979 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9981 else if (kid->op_type == OP_AELEM
9982 || kid->op_type == OP_HELEM)
9985 OP *op = ((BINOP*)kid)->op_first;
9989 const char * const a =
9990 kid->op_type == OP_AELEM ?
9992 if (((op->op_type == OP_RV2AV) ||
9993 (op->op_type == OP_RV2HV)) &&
9994 (firstop = ((UNOP*)op)->op_first) &&
9995 (firstop->op_type == OP_GV)) {
9996 /* packagevar $a[] or $h{} */
9997 GV * const gv = cGVOPx_gv(firstop);
10000 Perl_newSVpvf(aTHX_
10005 else if (op->op_type == OP_PADAV
10006 || op->op_type == OP_PADHV) {
10007 /* lexicalvar $a[] or $h{} */
10008 const char * const padname =
10009 PAD_COMPNAME_PV(op->op_targ);
10012 Perl_newSVpvf(aTHX_
10018 name = SvPV_const(tmpstr, len);
10019 name_utf8 = SvUTF8(tmpstr);
10020 sv_2mortal(tmpstr);
10024 name = "__ANONIO__";
10026 want_dollar = FALSE;
10028 op_lvalue(kid, type);
10032 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10033 namesv = PAD_SVl(targ);
10034 if (want_dollar && *name != '$')
10035 sv_setpvs(namesv, "$");
10037 sv_setpvs(namesv, "");
10038 sv_catpvn(namesv, name, len);
10039 if ( name_utf8 ) SvUTF8_on(namesv);
10043 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10045 kid->op_targ = targ;
10046 kid->op_private |= priv;
10052 if ((type == OP_UNDEF || type == OP_POS)
10053 && numargs == 1 && !(oa >> 4)
10054 && kid->op_type == OP_LIST)
10055 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10056 op_lvalue(scalar(kid), type);
10061 kid = OpSIBLING(kid);
10063 /* FIXME - should the numargs or-ing move after the too many
10064 * arguments check? */
10065 o->op_private |= numargs;
10067 return too_many_arguments_pv(o,OP_DESC(o), 0);
10070 else if (PL_opargs[type] & OA_DEFGV) {
10071 /* Ordering of these two is important to keep f_map.t passing. */
10073 return newUNOP(type, 0, newDEFSVOP());
10077 while (oa & OA_OPTIONAL)
10079 if (oa && oa != OA_LIST)
10080 return too_few_arguments_pv(o,OP_DESC(o), 0);
10086 Perl_ck_glob(pTHX_ OP *o)
10090 PERL_ARGS_ASSERT_CK_GLOB;
10093 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10094 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10096 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10100 * \ null - const(wildcard)
10105 * \ mark - glob - rv2cv
10106 * | \ gv(CORE::GLOBAL::glob)
10108 * \ null - const(wildcard)
10110 o->op_flags |= OPf_SPECIAL;
10111 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10112 o = S_new_entersubop(aTHX_ gv, o);
10113 o = newUNOP(OP_NULL, 0, o);
10114 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10117 else o->op_flags &= ~OPf_SPECIAL;
10118 #if !defined(PERL_EXTERNAL_GLOB)
10119 if (!PL_globhook) {
10121 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10122 newSVpvs("File::Glob"), NULL, NULL, NULL);
10125 #endif /* !PERL_EXTERNAL_GLOB */
10126 gv = (GV *)newSV(0);
10127 gv_init(gv, 0, "", 0, 0);
10129 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10130 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10136 Perl_ck_grep(pTHX_ OP *o)
10140 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10142 PERL_ARGS_ASSERT_CK_GREP;
10144 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10146 if (o->op_flags & OPf_STACKED) {
10147 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10148 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10149 return no_fh_allowed(o);
10150 o->op_flags &= ~OPf_STACKED;
10152 kid = OpSIBLING(cLISTOPo->op_first);
10153 if (type == OP_MAPWHILE)
10158 if (PL_parser && PL_parser->error_count)
10160 kid = OpSIBLING(cLISTOPo->op_first);
10161 if (kid->op_type != OP_NULL)
10162 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10163 kid = kUNOP->op_first;
10165 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10166 kid->op_next = (OP*)gwop;
10167 o->op_private = gwop->op_private = 0;
10168 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10170 kid = OpSIBLING(cLISTOPo->op_first);
10171 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10172 op_lvalue(kid, OP_GREPSTART);
10178 Perl_ck_index(pTHX_ OP *o)
10180 PERL_ARGS_ASSERT_CK_INDEX;
10182 if (o->op_flags & OPf_KIDS) {
10183 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10185 kid = OpSIBLING(kid); /* get past "big" */
10186 if (kid && kid->op_type == OP_CONST) {
10187 const bool save_taint = TAINT_get;
10188 SV *sv = kSVOP->op_sv;
10189 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10191 sv_copypv(sv, kSVOP->op_sv);
10192 SvREFCNT_dec_NN(kSVOP->op_sv);
10195 if (SvOK(sv)) fbm_compile(sv, 0);
10196 TAINT_set(save_taint);
10197 #ifdef NO_TAINT_SUPPORT
10198 PERL_UNUSED_VAR(save_taint);
10206 Perl_ck_lfun(pTHX_ OP *o)
10208 const OPCODE type = o->op_type;
10210 PERL_ARGS_ASSERT_CK_LFUN;
10212 return modkids(ck_fun(o), type);
10216 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10218 PERL_ARGS_ASSERT_CK_DEFINED;
10220 if ((o->op_flags & OPf_KIDS)) {
10221 switch (cUNOPo->op_first->op_type) {
10224 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10225 " (Maybe you should just omit the defined()?)");
10229 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10230 " (Maybe you should just omit the defined()?)");
10241 Perl_ck_readline(pTHX_ OP *o)
10243 PERL_ARGS_ASSERT_CK_READLINE;
10245 if (o->op_flags & OPf_KIDS) {
10246 OP *kid = cLISTOPo->op_first;
10247 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10251 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10259 Perl_ck_rfun(pTHX_ OP *o)
10261 const OPCODE type = o->op_type;
10263 PERL_ARGS_ASSERT_CK_RFUN;
10265 return refkids(ck_fun(o), type);
10269 Perl_ck_listiob(pTHX_ OP *o)
10273 PERL_ARGS_ASSERT_CK_LISTIOB;
10275 kid = cLISTOPo->op_first;
10277 o = force_list(o, 1);
10278 kid = cLISTOPo->op_first;
10280 if (kid->op_type == OP_PUSHMARK)
10281 kid = OpSIBLING(kid);
10282 if (kid && o->op_flags & OPf_STACKED)
10283 kid = OpSIBLING(kid);
10284 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10285 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10286 && !kid->op_folded) {
10287 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10289 /* replace old const op with new OP_RV2GV parent */
10290 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10291 OP_RV2GV, OPf_REF);
10292 kid = OpSIBLING(kid);
10297 op_append_elem(o->op_type, o, newDEFSVOP());
10299 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10300 return listkids(o);
10304 Perl_ck_smartmatch(pTHX_ OP *o)
10307 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10308 if (0 == (o->op_flags & OPf_SPECIAL)) {
10309 OP *first = cBINOPo->op_first;
10310 OP *second = OpSIBLING(first);
10312 /* Implicitly take a reference to an array or hash */
10314 /* remove the original two siblings, then add back the
10315 * (possibly different) first and second sibs.
10317 op_sibling_splice(o, NULL, 1, NULL);
10318 op_sibling_splice(o, NULL, 1, NULL);
10319 first = ref_array_or_hash(first);
10320 second = ref_array_or_hash(second);
10321 op_sibling_splice(o, NULL, 0, second);
10322 op_sibling_splice(o, NULL, 0, first);
10324 /* Implicitly take a reference to a regular expression */
10325 if (first->op_type == OP_MATCH) {
10326 OpTYPE_set(first, OP_QR);
10328 if (second->op_type == OP_MATCH) {
10329 OpTYPE_set(second, OP_QR);
10338 S_maybe_targlex(pTHX_ OP *o)
10340 OP * const kid = cLISTOPo->op_first;
10341 /* has a disposable target? */
10342 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10343 && !(kid->op_flags & OPf_STACKED)
10344 /* Cannot steal the second time! */
10345 && !(kid->op_private & OPpTARGET_MY)
10348 OP * const kkid = OpSIBLING(kid);
10350 /* Can just relocate the target. */
10351 if (kkid && kkid->op_type == OP_PADSV
10352 && (!(kkid->op_private & OPpLVAL_INTRO)
10353 || kkid->op_private & OPpPAD_STATE))
10355 kid->op_targ = kkid->op_targ;
10357 /* Now we do not need PADSV and SASSIGN.
10358 * Detach kid and free the rest. */
10359 op_sibling_splice(o, NULL, 1, NULL);
10361 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10369 Perl_ck_sassign(pTHX_ OP *o)
10372 OP * const kid = cLISTOPo->op_first;
10374 PERL_ARGS_ASSERT_CK_SASSIGN;
10376 if (OpHAS_SIBLING(kid)) {
10377 OP *kkid = OpSIBLING(kid);
10378 /* For state variable assignment with attributes, kkid is a list op
10379 whose op_last is a padsv. */
10380 if ((kkid->op_type == OP_PADSV ||
10381 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10382 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10385 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10386 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10387 const PADOFFSET target = kkid->op_targ;
10388 OP *const other = newOP(OP_PADSV,
10390 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10391 OP *const first = newOP(OP_NULL, 0);
10393 newCONDOP(0, first, o, other);
10394 /* XXX targlex disabled for now; see ticket #124160
10395 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10397 OP *const condop = first->op_next;
10399 OpTYPE_set(condop, OP_ONCE);
10400 other->op_targ = target;
10401 nullop->op_flags |= OPf_WANT_SCALAR;
10403 /* Store the initializedness of state vars in a separate
10406 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10407 /* hijacking PADSTALE for uninitialized state variables */
10408 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10413 return S_maybe_targlex(aTHX_ o);
10417 Perl_ck_match(pTHX_ OP *o)
10419 PERL_UNUSED_CONTEXT;
10420 PERL_ARGS_ASSERT_CK_MATCH;
10422 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10423 o->op_private |= OPpRUNTIME;
10428 Perl_ck_method(pTHX_ OP *o)
10430 SV *sv, *methsv, *rclass;
10431 const char* method;
10434 STRLEN len, nsplit = 0, i;
10436 OP * const kid = cUNOPo->op_first;
10438 PERL_ARGS_ASSERT_CK_METHOD;
10439 if (kid->op_type != OP_CONST) return o;
10443 /* replace ' with :: */
10444 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10446 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10449 method = SvPVX_const(sv);
10451 utf8 = SvUTF8(sv) ? -1 : 1;
10453 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10458 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10460 if (!nsplit) { /* $proto->method() */
10462 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10465 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10467 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10470 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10471 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10472 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10473 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10475 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10476 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10478 #ifdef USE_ITHREADS
10479 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10481 cMETHOPx(new_op)->op_rclass_sv = rclass;
10488 Perl_ck_null(pTHX_ OP *o)
10490 PERL_ARGS_ASSERT_CK_NULL;
10491 PERL_UNUSED_CONTEXT;
10496 Perl_ck_open(pTHX_ OP *o)
10498 PERL_ARGS_ASSERT_CK_OPEN;
10500 S_io_hints(aTHX_ o);
10502 /* In case of three-arg dup open remove strictness
10503 * from the last arg if it is a bareword. */
10504 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10505 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10509 if ((last->op_type == OP_CONST) && /* The bareword. */
10510 (last->op_private & OPpCONST_BARE) &&
10511 (last->op_private & OPpCONST_STRICT) &&
10512 (oa = OpSIBLING(first)) && /* The fh. */
10513 (oa = OpSIBLING(oa)) && /* The mode. */
10514 (oa->op_type == OP_CONST) &&
10515 SvPOK(((SVOP*)oa)->op_sv) &&
10516 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10517 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10518 (last == OpSIBLING(oa))) /* The bareword. */
10519 last->op_private &= ~OPpCONST_STRICT;
10525 Perl_ck_prototype(pTHX_ OP *o)
10527 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10528 if (!(o->op_flags & OPf_KIDS)) {
10530 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10536 Perl_ck_refassign(pTHX_ OP *o)
10538 OP * const right = cLISTOPo->op_first;
10539 OP * const left = OpSIBLING(right);
10540 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10543 PERL_ARGS_ASSERT_CK_REFASSIGN;
10545 assert (left->op_type == OP_SREFGEN);
10548 /* we use OPpPAD_STATE in refassign to mean either of those things,
10549 * and the code assumes the two flags occupy the same bit position
10550 * in the various ops below */
10551 assert(OPpPAD_STATE == OPpOUR_INTRO);
10553 switch (varop->op_type) {
10555 o->op_private |= OPpLVREF_AV;
10558 o->op_private |= OPpLVREF_HV;
10562 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10563 o->op_targ = varop->op_targ;
10564 varop->op_targ = 0;
10565 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10569 o->op_private |= OPpLVREF_AV;
10571 NOT_REACHED; /* NOTREACHED */
10573 o->op_private |= OPpLVREF_HV;
10577 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10578 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10580 /* Point varop to its GV kid, detached. */
10581 varop = op_sibling_splice(varop, NULL, -1, NULL);
10585 OP * const kidparent =
10586 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10587 OP * const kid = cUNOPx(kidparent)->op_first;
10588 o->op_private |= OPpLVREF_CV;
10589 if (kid->op_type == OP_GV) {
10591 goto detach_and_stack;
10593 if (kid->op_type != OP_PADCV) goto bad;
10594 o->op_targ = kid->op_targ;
10600 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10601 o->op_private |= OPpLVREF_ELEM;
10604 /* Detach varop. */
10605 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10609 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10610 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10615 if (!FEATURE_REFALIASING_IS_ENABLED)
10617 "Experimental aliasing via reference not enabled");
10618 Perl_ck_warner_d(aTHX_
10619 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10620 "Aliasing via reference is experimental");
10622 o->op_flags |= OPf_STACKED;
10623 op_sibling_splice(o, right, 1, varop);
10626 o->op_flags &=~ OPf_STACKED;
10627 op_sibling_splice(o, right, 1, NULL);
10634 Perl_ck_repeat(pTHX_ OP *o)
10636 PERL_ARGS_ASSERT_CK_REPEAT;
10638 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10640 o->op_private |= OPpREPEAT_DOLIST;
10641 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10642 kids = force_list(kids, 1); /* promote it to a list */
10643 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10651 Perl_ck_require(pTHX_ OP *o)
10655 PERL_ARGS_ASSERT_CK_REQUIRE;
10657 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10658 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10663 if (kid->op_type == OP_CONST) {
10664 SV * const sv = kid->op_sv;
10665 U32 const was_readonly = SvREADONLY(sv);
10666 if (kid->op_private & OPpCONST_BARE) {
10670 if (was_readonly) {
10671 SvREADONLY_off(sv);
10673 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10678 /* treat ::foo::bar as foo::bar */
10679 if (len >= 2 && s[0] == ':' && s[1] == ':')
10680 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
10682 DIE(aTHX_ "Bareword in require maps to empty filename");
10684 for (; s < end; s++) {
10685 if (*s == ':' && s[1] == ':') {
10687 Move(s+2, s+1, end - s - 1, char);
10691 SvEND_set(sv, end);
10692 sv_catpvs(sv, ".pm");
10693 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10694 hek = share_hek(SvPVX(sv),
10695 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10697 sv_sethek(sv, hek);
10699 SvFLAGS(sv) |= was_readonly;
10701 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10704 if (SvREFCNT(sv) > 1) {
10705 kid->op_sv = newSVpvn_share(
10706 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10707 SvREFCNT_dec_NN(sv);
10711 if (was_readonly) SvREADONLY_off(sv);
10712 PERL_HASH(hash, s, len);
10714 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10716 sv_sethek(sv, hek);
10718 SvFLAGS(sv) |= was_readonly;
10724 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10725 /* handle override, if any */
10726 && (gv = gv_override("require", 7))) {
10728 if (o->op_flags & OPf_KIDS) {
10729 kid = cUNOPo->op_first;
10730 op_sibling_splice(o, NULL, -1, NULL);
10733 kid = newDEFSVOP();
10736 newop = S_new_entersubop(aTHX_ gv, kid);
10744 Perl_ck_return(pTHX_ OP *o)
10748 PERL_ARGS_ASSERT_CK_RETURN;
10750 kid = OpSIBLING(cLISTOPo->op_first);
10751 if (CvLVALUE(PL_compcv)) {
10752 for (; kid; kid = OpSIBLING(kid))
10753 op_lvalue(kid, OP_LEAVESUBLV);
10760 Perl_ck_select(pTHX_ OP *o)
10765 PERL_ARGS_ASSERT_CK_SELECT;
10767 if (o->op_flags & OPf_KIDS) {
10768 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10769 if (kid && OpHAS_SIBLING(kid)) {
10770 OpTYPE_set(o, OP_SSELECT);
10772 return fold_constants(op_integerize(op_std_init(o)));
10776 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10777 if (kid && kid->op_type == OP_RV2GV)
10778 kid->op_private &= ~HINT_STRICT_REFS;
10783 Perl_ck_shift(pTHX_ OP *o)
10785 const I32 type = o->op_type;
10787 PERL_ARGS_ASSERT_CK_SHIFT;
10789 if (!(o->op_flags & OPf_KIDS)) {
10792 if (!CvUNIQUE(PL_compcv)) {
10793 o->op_flags |= OPf_SPECIAL;
10797 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10799 return newUNOP(type, 0, scalar(argop));
10801 return scalar(ck_fun(o));
10805 Perl_ck_sort(pTHX_ OP *o)
10809 HV * const hinthv =
10810 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10813 PERL_ARGS_ASSERT_CK_SORT;
10816 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10818 const I32 sorthints = (I32)SvIV(*svp);
10819 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10820 o->op_private |= OPpSORT_QSORT;
10821 if ((sorthints & HINT_SORT_STABLE) != 0)
10822 o->op_private |= OPpSORT_STABLE;
10826 if (o->op_flags & OPf_STACKED)
10828 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10830 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10831 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10833 /* if the first arg is a code block, process it and mark sort as
10835 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10837 if (kid->op_type == OP_LEAVE)
10838 op_null(kid); /* wipe out leave */
10839 /* Prevent execution from escaping out of the sort block. */
10842 /* provide scalar context for comparison function/block */
10843 kid = scalar(firstkid);
10844 kid->op_next = kid;
10845 o->op_flags |= OPf_SPECIAL;
10847 else if (kid->op_type == OP_CONST
10848 && kid->op_private & OPpCONST_BARE) {
10852 const char * const name = SvPV(kSVOP_sv, len);
10854 assert (len < 256);
10855 Copy(name, tmpbuf+1, len, char);
10856 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10857 if (off != NOT_IN_PAD) {
10858 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10860 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10861 sv_catpvs(fq, "::");
10862 sv_catsv(fq, kSVOP_sv);
10863 SvREFCNT_dec_NN(kSVOP_sv);
10867 OP * const padop = newOP(OP_PADCV, 0);
10868 padop->op_targ = off;
10869 /* replace the const op with the pad op */
10870 op_sibling_splice(firstkid, NULL, 1, padop);
10876 firstkid = OpSIBLING(firstkid);
10879 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10880 /* provide list context for arguments */
10883 op_lvalue(kid, OP_GREPSTART);
10889 /* for sort { X } ..., where X is one of
10890 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10891 * elide the second child of the sort (the one containing X),
10892 * and set these flags as appropriate
10896 * Also, check and warn on lexical $a, $b.
10900 S_simplify_sort(pTHX_ OP *o)
10902 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10906 const char *gvname;
10909 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10911 kid = kUNOP->op_first; /* get past null */
10912 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10913 && kid->op_type != OP_LEAVE)
10915 kid = kLISTOP->op_last; /* get past scope */
10916 switch(kid->op_type) {
10920 if (!have_scopeop) goto padkids;
10925 k = kid; /* remember this node*/
10926 if (kBINOP->op_first->op_type != OP_RV2SV
10927 || kBINOP->op_last ->op_type != OP_RV2SV)
10930 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10931 then used in a comparison. This catches most, but not
10932 all cases. For instance, it catches
10933 sort { my($a); $a <=> $b }
10935 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10936 (although why you'd do that is anyone's guess).
10940 if (!ckWARN(WARN_SYNTAX)) return;
10941 kid = kBINOP->op_first;
10943 if (kid->op_type == OP_PADSV) {
10944 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
10945 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
10946 && ( PadnamePV(name)[1] == 'a'
10947 || PadnamePV(name)[1] == 'b' ))
10948 /* diag_listed_as: "my %s" used in sort comparison */
10949 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10950 "\"%s %s\" used in sort comparison",
10951 PadnameIsSTATE(name)
10956 } while ((kid = OpSIBLING(kid)));
10959 kid = kBINOP->op_first; /* get past cmp */
10960 if (kUNOP->op_first->op_type != OP_GV)
10962 kid = kUNOP->op_first; /* get past rv2sv */
10964 if (GvSTASH(gv) != PL_curstash)
10966 gvname = GvNAME(gv);
10967 if (*gvname == 'a' && gvname[1] == '\0')
10969 else if (*gvname == 'b' && gvname[1] == '\0')
10974 kid = k; /* back to cmp */
10975 /* already checked above that it is rv2sv */
10976 kid = kBINOP->op_last; /* down to 2nd arg */
10977 if (kUNOP->op_first->op_type != OP_GV)
10979 kid = kUNOP->op_first; /* get past rv2sv */
10981 if (GvSTASH(gv) != PL_curstash)
10983 gvname = GvNAME(gv);
10985 ? !(*gvname == 'a' && gvname[1] == '\0')
10986 : !(*gvname == 'b' && gvname[1] == '\0'))
10988 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10990 o->op_private |= OPpSORT_DESCEND;
10991 if (k->op_type == OP_NCMP)
10992 o->op_private |= OPpSORT_NUMERIC;
10993 if (k->op_type == OP_I_NCMP)
10994 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10995 kid = OpSIBLING(cLISTOPo->op_first);
10996 /* cut out and delete old block (second sibling) */
10997 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11002 Perl_ck_split(pTHX_ OP *o)
11007 PERL_ARGS_ASSERT_CK_SPLIT;
11009 if (o->op_flags & OPf_STACKED)
11010 return no_fh_allowed(o);
11012 kid = cLISTOPo->op_first;
11013 if (kid->op_type != OP_NULL)
11014 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
11015 /* delete leading NULL node, then add a CONST if no other nodes */
11016 op_sibling_splice(o, NULL, 1,
11017 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11019 kid = cLISTOPo->op_first;
11021 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11022 /* remove kid, and replace with new optree */
11023 op_sibling_splice(o, NULL, 1, NULL);
11024 /* OPf_SPECIAL is used to trigger split " " behavior */
11025 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
11026 op_sibling_splice(o, NULL, 0, kid);
11028 OpTYPE_set(kid, OP_PUSHRE);
11029 /* target implies @ary=..., so wipe it */
11032 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11033 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11034 "Use of /g modifier is meaningless in split");
11037 if (!OpHAS_SIBLING(kid))
11038 op_append_elem(OP_SPLIT, o, newDEFSVOP());
11040 kid = OpSIBLING(kid);
11044 if (!OpHAS_SIBLING(kid))
11046 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
11047 o->op_private |= OPpSPLIT_IMPLIM;
11049 assert(OpHAS_SIBLING(kid));
11051 kid = OpSIBLING(kid);
11054 if (OpHAS_SIBLING(kid))
11055 return too_many_arguments_pv(o,OP_DESC(o), 0);
11061 Perl_ck_stringify(pTHX_ OP *o)
11063 OP * const kid = OpSIBLING(cUNOPo->op_first);
11064 PERL_ARGS_ASSERT_CK_STRINGIFY;
11065 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11066 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
11067 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
11068 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11070 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11078 Perl_ck_join(pTHX_ OP *o)
11080 OP * const kid = OpSIBLING(cLISTOPo->op_first);
11082 PERL_ARGS_ASSERT_CK_JOIN;
11084 if (kid && kid->op_type == OP_MATCH) {
11085 if (ckWARN(WARN_SYNTAX)) {
11086 const REGEXP *re = PM_GETRE(kPMOP);
11088 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11089 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11090 : newSVpvs_flags( "STRING", SVs_TEMP );
11091 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11092 "/%"SVf"/ should probably be written as \"%"SVf"\"",
11093 SVfARG(msg), SVfARG(msg));
11097 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11098 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11099 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11100 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11102 const OP * const bairn = OpSIBLING(kid); /* the list */
11103 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11104 && OP_GIMME(bairn,0) == G_SCALAR)
11106 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11107 op_sibling_splice(o, kid, 1, NULL));
11117 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11119 Examines an op, which is expected to identify a subroutine at runtime,
11120 and attempts to determine at compile time which subroutine it identifies.
11121 This is normally used during Perl compilation to determine whether
11122 a prototype can be applied to a function call. C<cvop> is the op
11123 being considered, normally an C<rv2cv> op. A pointer to the identified
11124 subroutine is returned, if it could be determined statically, and a null
11125 pointer is returned if it was not possible to determine statically.
11127 Currently, the subroutine can be identified statically if the RV that the
11128 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11129 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11130 suitable if the constant value must be an RV pointing to a CV. Details of
11131 this process may change in future versions of Perl. If the C<rv2cv> op
11132 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11133 the subroutine statically: this flag is used to suppress compile-time
11134 magic on a subroutine call, forcing it to use default runtime behaviour.
11136 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11137 of a GV reference is modified. If a GV was examined and its CV slot was
11138 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11139 If the op is not optimised away, and the CV slot is later populated with
11140 a subroutine having a prototype, that flag eventually triggers the warning
11141 "called too early to check prototype".
11143 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11144 of returning a pointer to the subroutine it returns a pointer to the
11145 GV giving the most appropriate name for the subroutine in this context.
11146 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11147 (C<CvANON>) subroutine that is referenced through a GV it will be the
11148 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11149 A null pointer is returned as usual if there is no statically-determinable
11155 /* shared by toke.c:yylex */
11157 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11159 PADNAME *name = PAD_COMPNAME(off);
11160 CV *compcv = PL_compcv;
11161 while (PadnameOUTER(name)) {
11162 assert(PARENT_PAD_INDEX(name));
11163 compcv = CvOUTSIDE(compcv);
11164 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11165 [off = PARENT_PAD_INDEX(name)];
11167 assert(!PadnameIsOUR(name));
11168 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11169 return PadnamePROTOCV(name);
11171 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11175 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11180 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11181 if (flags & ~RV2CVOPCV_FLAG_MASK)
11182 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11183 if (cvop->op_type != OP_RV2CV)
11185 if (cvop->op_private & OPpENTERSUB_AMPER)
11187 if (!(cvop->op_flags & OPf_KIDS))
11189 rvop = cUNOPx(cvop)->op_first;
11190 switch (rvop->op_type) {
11192 gv = cGVOPx_gv(rvop);
11194 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11195 cv = MUTABLE_CV(SvRV(gv));
11199 if (flags & RV2CVOPCV_RETURN_STUB)
11205 if (flags & RV2CVOPCV_MARK_EARLY)
11206 rvop->op_private |= OPpEARLY_CV;
11211 SV *rv = cSVOPx_sv(rvop);
11214 cv = (CV*)SvRV(rv);
11218 cv = find_lexical_cv(rvop->op_targ);
11223 } NOT_REACHED; /* NOTREACHED */
11225 if (SvTYPE((SV*)cv) != SVt_PVCV)
11227 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11228 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11229 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11238 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11240 Performs the default fixup of the arguments part of an C<entersub>
11241 op tree. This consists of applying list context to each of the
11242 argument ops. This is the standard treatment used on a call marked
11243 with C<&>, or a method call, or a call through a subroutine reference,
11244 or any other call where the callee can't be identified at compile time,
11245 or a call where the callee has no prototype.
11251 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11255 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11257 aop = cUNOPx(entersubop)->op_first;
11258 if (!OpHAS_SIBLING(aop))
11259 aop = cUNOPx(aop)->op_first;
11260 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11261 /* skip the extra attributes->import() call implicitly added in
11262 * something like foo(my $x : bar)
11264 if ( aop->op_type == OP_ENTERSUB
11265 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11269 op_lvalue(aop, OP_ENTERSUB);
11275 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11277 Performs the fixup of the arguments part of an C<entersub> op tree
11278 based on a subroutine prototype. This makes various modifications to
11279 the argument ops, from applying context up to inserting C<refgen> ops,
11280 and checking the number and syntactic types of arguments, as directed by
11281 the prototype. This is the standard treatment used on a subroutine call,
11282 not marked with C<&>, where the callee can be identified at compile time
11283 and has a prototype.
11285 C<protosv> supplies the subroutine prototype to be applied to the call.
11286 It may be a normal defined scalar, of which the string value will be used.
11287 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11288 that has been cast to C<SV*>) which has a prototype. The prototype
11289 supplied, in whichever form, does not need to match the actual callee
11290 referenced by the op tree.
11292 If the argument ops disagree with the prototype, for example by having
11293 an unacceptable number of arguments, a valid op tree is returned anyway.
11294 The error is reflected in the parser state, normally resulting in a single
11295 exception at the top level of parsing which covers all the compilation
11296 errors that occurred. In the error message, the callee is referred to
11297 by the name defined by the C<namegv> parameter.
11303 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11306 const char *proto, *proto_end;
11307 OP *aop, *prev, *cvop, *parent;
11310 I32 contextclass = 0;
11311 const char *e = NULL;
11312 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11313 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11314 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11315 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11316 if (SvTYPE(protosv) == SVt_PVCV)
11317 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11318 else proto = SvPV(protosv, proto_len);
11319 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11320 proto_end = proto + proto_len;
11321 parent = entersubop;
11322 aop = cUNOPx(entersubop)->op_first;
11323 if (!OpHAS_SIBLING(aop)) {
11325 aop = cUNOPx(aop)->op_first;
11328 aop = OpSIBLING(aop);
11329 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11330 while (aop != cvop) {
11333 if (proto >= proto_end)
11335 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11336 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11337 SVfARG(namesv)), SvUTF8(namesv));
11347 /* _ must be at the end */
11348 if (proto[1] && !strchr(";@%", proto[1]))
11364 if ( o3->op_type != OP_UNDEF
11365 && (o3->op_type != OP_SREFGEN
11366 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11368 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11370 bad_type_gv(arg, namegv, o3,
11371 arg == 1 ? "block or sub {}" : "sub {}");
11374 /* '*' allows any scalar type, including bareword */
11377 if (o3->op_type == OP_RV2GV)
11378 goto wrapref; /* autoconvert GLOB -> GLOBref */
11379 else if (o3->op_type == OP_CONST)
11380 o3->op_private &= ~OPpCONST_STRICT;
11386 if (o3->op_type == OP_RV2AV ||
11387 o3->op_type == OP_PADAV ||
11388 o3->op_type == OP_RV2HV ||
11389 o3->op_type == OP_PADHV
11395 case '[': case ']':
11402 switch (*proto++) {
11404 if (contextclass++ == 0) {
11405 e = strchr(proto, ']');
11406 if (!e || e == proto)
11414 if (contextclass) {
11415 const char *p = proto;
11416 const char *const end = proto;
11418 while (*--p != '[')
11419 /* \[$] accepts any scalar lvalue */
11421 && Perl_op_lvalue_flags(aTHX_
11423 OP_READ, /* not entersub */
11426 bad_type_gv(arg, namegv, o3,
11427 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11432 if (o3->op_type == OP_RV2GV)
11435 bad_type_gv(arg, namegv, o3, "symbol");
11438 if (o3->op_type == OP_ENTERSUB
11439 && !(o3->op_flags & OPf_STACKED))
11442 bad_type_gv(arg, namegv, o3, "subroutine");
11445 if (o3->op_type == OP_RV2SV ||
11446 o3->op_type == OP_PADSV ||
11447 o3->op_type == OP_HELEM ||
11448 o3->op_type == OP_AELEM)
11450 if (!contextclass) {
11451 /* \$ accepts any scalar lvalue */
11452 if (Perl_op_lvalue_flags(aTHX_
11454 OP_READ, /* not entersub */
11457 bad_type_gv(arg, namegv, o3, "scalar");
11461 if (o3->op_type == OP_RV2AV ||
11462 o3->op_type == OP_PADAV)
11464 o3->op_flags &=~ OPf_PARENS;
11468 bad_type_gv(arg, namegv, o3, "array");
11471 if (o3->op_type == OP_RV2HV ||
11472 o3->op_type == OP_PADHV)
11474 o3->op_flags &=~ OPf_PARENS;
11478 bad_type_gv(arg, namegv, o3, "hash");
11481 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11483 if (contextclass && e) {
11488 default: goto oops;
11498 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11499 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11504 op_lvalue(aop, OP_ENTERSUB);
11506 aop = OpSIBLING(aop);
11508 if (aop == cvop && *proto == '_') {
11509 /* generate an access to $_ */
11510 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11512 if (!optional && proto_end > proto &&
11513 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11515 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11516 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11517 SVfARG(namesv)), SvUTF8(namesv));
11523 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11525 Performs the fixup of the arguments part of an C<entersub> op tree either
11526 based on a subroutine prototype or using default list-context processing.
11527 This is the standard treatment used on a subroutine call, not marked
11528 with C<&>, where the callee can be identified at compile time.
11530 C<protosv> supplies the subroutine prototype to be applied to the call,
11531 or indicates that there is no prototype. It may be a normal scalar,
11532 in which case if it is defined then the string value will be used
11533 as a prototype, and if it is undefined then there is no prototype.
11534 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11535 that has been cast to C<SV*>), of which the prototype will be used if it
11536 has one. The prototype (or lack thereof) supplied, in whichever form,
11537 does not need to match the actual callee referenced by the op tree.
11539 If the argument ops disagree with the prototype, for example by having
11540 an unacceptable number of arguments, a valid op tree is returned anyway.
11541 The error is reflected in the parser state, normally resulting in a single
11542 exception at the top level of parsing which covers all the compilation
11543 errors that occurred. In the error message, the callee is referred to
11544 by the name defined by the C<namegv> parameter.
11550 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11551 GV *namegv, SV *protosv)
11553 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11554 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11555 return ck_entersub_args_proto(entersubop, namegv, protosv);
11557 return ck_entersub_args_list(entersubop);
11561 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11563 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11564 OP *aop = cUNOPx(entersubop)->op_first;
11566 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11570 if (!OpHAS_SIBLING(aop))
11571 aop = cUNOPx(aop)->op_first;
11572 aop = OpSIBLING(aop);
11573 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11575 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11577 op_free(entersubop);
11578 switch(GvNAME(namegv)[2]) {
11579 case 'F': return newSVOP(OP_CONST, 0,
11580 newSVpv(CopFILE(PL_curcop),0));
11581 case 'L': return newSVOP(
11583 Perl_newSVpvf(aTHX_
11584 "%"IVdf, (IV)CopLINE(PL_curcop)
11587 case 'P': return newSVOP(OP_CONST, 0,
11589 ? newSVhek(HvNAME_HEK(PL_curstash))
11594 NOT_REACHED; /* NOTREACHED */
11597 OP *prev, *cvop, *first, *parent;
11600 parent = entersubop;
11601 if (!OpHAS_SIBLING(aop)) {
11603 aop = cUNOPx(aop)->op_first;
11606 first = prev = aop;
11607 aop = OpSIBLING(aop);
11608 /* find last sibling */
11610 OpHAS_SIBLING(cvop);
11611 prev = cvop, cvop = OpSIBLING(cvop))
11613 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11614 /* Usually, OPf_SPECIAL on an op with no args means that it had
11615 * parens, but these have their own meaning for that flag: */
11616 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11617 && opnum != OP_DELETE && opnum != OP_EXISTS)
11618 flags |= OPf_SPECIAL;
11619 /* excise cvop from end of sibling chain */
11620 op_sibling_splice(parent, prev, 1, NULL);
11622 if (aop == cvop) aop = NULL;
11624 /* detach remaining siblings from the first sibling, then
11625 * dispose of original optree */
11628 op_sibling_splice(parent, first, -1, NULL);
11629 op_free(entersubop);
11631 if (opnum == OP_ENTEREVAL
11632 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11633 flags |= OPpEVAL_BYTES <<8;
11635 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11637 case OA_BASEOP_OR_UNOP:
11638 case OA_FILESTATOP:
11639 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11642 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11645 return opnum == OP_RUNCV
11646 ? newPVOP(OP_RUNCV,0,NULL)
11649 return op_convert_list(opnum,0,aop);
11652 NOT_REACHED; /* NOTREACHED */
11657 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11659 Retrieves the function that will be used to fix up a call to C<cv>.
11660 Specifically, the function is applied to an C<entersub> op tree for a
11661 subroutine call, not marked with C<&>, where the callee can be identified
11662 at compile time as C<cv>.
11664 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11665 argument for it is returned in C<*ckobj_p>. The function is intended
11666 to be called in this manner:
11668 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11670 In this call, C<entersubop> is a pointer to the C<entersub> op,
11671 which may be replaced by the check function, and C<namegv> is a GV
11672 supplying the name that should be used by the check function to refer
11673 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11674 It is permitted to apply the check function in non-standard situations,
11675 such as to a call to a different subroutine or to a method call.
11677 By default, the function is
11678 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11679 and the SV parameter is C<cv> itself. This implements standard
11680 prototype processing. It can be changed, for a particular subroutine,
11681 by L</cv_set_call_checker>.
11687 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11691 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11693 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11694 *ckobj_p = callmg->mg_obj;
11695 if (flagsp) *flagsp = callmg->mg_flags;
11697 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11698 *ckobj_p = (SV*)cv;
11699 if (flagsp) *flagsp = 0;
11704 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11706 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11707 PERL_UNUSED_CONTEXT;
11708 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11712 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11714 Sets the function that will be used to fix up a call to C<cv>.
11715 Specifically, the function is applied to an C<entersub> op tree for a
11716 subroutine call, not marked with C<&>, where the callee can be identified
11717 at compile time as C<cv>.
11719 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11720 for it is supplied in C<ckobj>. The function should be defined like this:
11722 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11724 It is intended to be called in this manner:
11726 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11728 In this call, C<entersubop> is a pointer to the C<entersub> op,
11729 which may be replaced by the check function, and C<namegv> supplies
11730 the name that should be used by the check function to refer
11731 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11732 It is permitted to apply the check function in non-standard situations,
11733 such as to a call to a different subroutine or to a method call.
11735 C<namegv> may not actually be a GV. For efficiency, perl may pass a
11736 CV or other SV instead. Whatever is passed can be used as the first
11737 argument to L</cv_name>. You can force perl to pass a GV by including
11738 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11740 The current setting for a particular CV can be retrieved by
11741 L</cv_get_call_checker>.
11743 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11745 The original form of L</cv_set_call_checker_flags>, which passes it the
11746 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11752 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11754 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11755 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11759 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11760 SV *ckobj, U32 flags)
11762 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11763 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11764 if (SvMAGICAL((SV*)cv))
11765 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11768 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11769 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11771 if (callmg->mg_flags & MGf_REFCOUNTED) {
11772 SvREFCNT_dec(callmg->mg_obj);
11773 callmg->mg_flags &= ~MGf_REFCOUNTED;
11775 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11776 callmg->mg_obj = ckobj;
11777 if (ckobj != (SV*)cv) {
11778 SvREFCNT_inc_simple_void_NN(ckobj);
11779 callmg->mg_flags |= MGf_REFCOUNTED;
11781 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11782 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11787 S_entersub_alloc_targ(pTHX_ OP * const o)
11789 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11790 o->op_private |= OPpENTERSUB_HASTARG;
11794 Perl_ck_subr(pTHX_ OP *o)
11799 SV **const_class = NULL;
11801 PERL_ARGS_ASSERT_CK_SUBR;
11803 aop = cUNOPx(o)->op_first;
11804 if (!OpHAS_SIBLING(aop))
11805 aop = cUNOPx(aop)->op_first;
11806 aop = OpSIBLING(aop);
11807 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11808 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11809 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11811 o->op_private &= ~1;
11812 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11813 if (PERLDB_SUB && PL_curstash != PL_debstash)
11814 o->op_private |= OPpENTERSUB_DB;
11815 switch (cvop->op_type) {
11817 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11821 case OP_METHOD_NAMED:
11822 case OP_METHOD_SUPER:
11823 case OP_METHOD_REDIR:
11824 case OP_METHOD_REDIR_SUPER:
11825 if (aop->op_type == OP_CONST) {
11826 aop->op_private &= ~OPpCONST_STRICT;
11827 const_class = &cSVOPx(aop)->op_sv;
11829 else if (aop->op_type == OP_LIST) {
11830 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11831 if (sib && sib->op_type == OP_CONST) {
11832 sib->op_private &= ~OPpCONST_STRICT;
11833 const_class = &cSVOPx(sib)->op_sv;
11836 /* make class name a shared cow string to speedup method calls */
11837 /* constant string might be replaced with object, f.e. bigint */
11838 if (const_class && SvPOK(*const_class)) {
11840 const char* str = SvPV(*const_class, len);
11842 SV* const shared = newSVpvn_share(
11843 str, SvUTF8(*const_class)
11844 ? -(SSize_t)len : (SSize_t)len,
11847 if (SvREADONLY(*const_class))
11848 SvREADONLY_on(shared);
11849 SvREFCNT_dec(*const_class);
11850 *const_class = shared;
11857 S_entersub_alloc_targ(aTHX_ o);
11858 return ck_entersub_args_list(o);
11860 Perl_call_checker ckfun;
11863 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11864 if (CvISXSUB(cv) || !CvROOT(cv))
11865 S_entersub_alloc_targ(aTHX_ o);
11867 /* The original call checker API guarantees that a GV will be
11868 be provided with the right name. So, if the old API was
11869 used (or the REQUIRE_GV flag was passed), we have to reify
11870 the CV’s GV, unless this is an anonymous sub. This is not
11871 ideal for lexical subs, as its stringification will include
11872 the package. But it is the best we can do. */
11873 if (flags & MGf_REQUIRE_GV) {
11874 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11877 else namegv = MUTABLE_GV(cv);
11878 /* After a syntax error in a lexical sub, the cv that
11879 rv2cv_op_cv returns may be a nameless stub. */
11880 if (!namegv) return ck_entersub_args_list(o);
11883 return ckfun(aTHX_ o, namegv, ckobj);
11888 Perl_ck_svconst(pTHX_ OP *o)
11890 SV * const sv = cSVOPo->op_sv;
11891 PERL_ARGS_ASSERT_CK_SVCONST;
11892 PERL_UNUSED_CONTEXT;
11893 #ifdef PERL_COPY_ON_WRITE
11894 /* Since the read-only flag may be used to protect a string buffer, we
11895 cannot do copy-on-write with existing read-only scalars that are not
11896 already copy-on-write scalars. To allow $_ = "hello" to do COW with
11897 that constant, mark the constant as COWable here, if it is not
11898 already read-only. */
11899 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11902 # ifdef PERL_DEBUG_READONLY_COW
11912 Perl_ck_trunc(pTHX_ OP *o)
11914 PERL_ARGS_ASSERT_CK_TRUNC;
11916 if (o->op_flags & OPf_KIDS) {
11917 SVOP *kid = (SVOP*)cUNOPo->op_first;
11919 if (kid->op_type == OP_NULL)
11920 kid = (SVOP*)OpSIBLING(kid);
11921 if (kid && kid->op_type == OP_CONST &&
11922 (kid->op_private & OPpCONST_BARE) &&
11925 o->op_flags |= OPf_SPECIAL;
11926 kid->op_private &= ~OPpCONST_STRICT;
11933 Perl_ck_substr(pTHX_ OP *o)
11935 PERL_ARGS_ASSERT_CK_SUBSTR;
11938 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11939 OP *kid = cLISTOPo->op_first;
11941 if (kid->op_type == OP_NULL)
11942 kid = OpSIBLING(kid);
11944 kid->op_flags |= OPf_MOD;
11951 Perl_ck_tell(pTHX_ OP *o)
11953 PERL_ARGS_ASSERT_CK_TELL;
11955 if (o->op_flags & OPf_KIDS) {
11956 OP *kid = cLISTOPo->op_first;
11957 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
11958 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11964 Perl_ck_each(pTHX_ OP *o)
11967 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11968 const unsigned orig_type = o->op_type;
11970 PERL_ARGS_ASSERT_CK_EACH;
11973 switch (kid->op_type) {
11979 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
11980 : orig_type == OP_KEYS ? OP_AKEYS
11984 if (kid->op_private == OPpCONST_BARE
11985 || !SvROK(cSVOPx_sv(kid))
11986 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11987 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
11991 qerror(Perl_mess(aTHX_
11992 "Experimental %s on scalar is now forbidden",
11993 PL_op_desc[orig_type]));
11995 bad_type_pv(1, "hash or array", o, kid);
12003 Perl_ck_length(pTHX_ OP *o)
12005 PERL_ARGS_ASSERT_CK_LENGTH;
12009 if (ckWARN(WARN_SYNTAX)) {
12010 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12014 const bool hash = kid->op_type == OP_PADHV
12015 || kid->op_type == OP_RV2HV;
12016 switch (kid->op_type) {
12021 name = S_op_varname(aTHX_ kid);
12027 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12028 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
12030 SVfARG(name), hash ? "keys " : "", SVfARG(name)
12033 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12034 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12035 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12037 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12038 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12039 "length() used on @array (did you mean \"scalar(@array)\"?)");
12049 ---------------------------------------------------------
12051 Common vars in list assignment
12053 There now follows some enums and static functions for detecting
12054 common variables in list assignments. Here is a little essay I wrote
12055 for myself when trying to get my head around this. DAPM.
12059 First some random observations:
12061 * If a lexical var is an alias of something else, e.g.
12062 for my $x ($lex, $pkg, $a[0]) {...}
12063 then the act of aliasing will increase the reference count of the SV
12065 * If a package var is an alias of something else, it may still have a
12066 reference count of 1, depending on how the alias was created, e.g.
12067 in *a = *b, $a may have a refcount of 1 since the GP is shared
12068 with a single GvSV pointer to the SV. So If it's an alias of another
12069 package var, then RC may be 1; if it's an alias of another scalar, e.g.
12070 a lexical var or an array element, then it will have RC > 1.
12072 * There are many ways to create a package alias; ultimately, XS code
12073 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12074 run-time tracing mechanisms are unlikely to be able to catch all cases.
12076 * When the LHS is all my declarations, the same vars can't appear directly
12077 on the RHS, but they can indirectly via closures, aliasing and lvalue
12078 subs. But those techniques all involve an increase in the lexical
12079 scalar's ref count.
12081 * When the LHS is all lexical vars (but not necessarily my declarations),
12082 it is possible for the same lexicals to appear directly on the RHS, and
12083 without an increased ref count, since the stack isn't refcounted.
12084 This case can be detected at compile time by scanning for common lex
12085 vars with PL_generation.
12087 * lvalue subs defeat common var detection, but they do at least
12088 return vars with a temporary ref count increment. Also, you can't
12089 tell at compile time whether a sub call is lvalue.
12094 A: There are a few circumstances where there definitely can't be any
12097 LHS empty: () = (...);
12098 RHS empty: (....) = ();
12099 RHS contains only constants or other 'can't possibly be shared'
12100 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
12101 i.e. they only contain ops not marked as dangerous, whose children
12102 are also not dangerous;
12104 LHS contains a single scalar element: e.g. ($x) = (....); because
12105 after $x has been modified, it won't be used again on the RHS;
12106 RHS contains a single element with no aggregate on LHS: e.g.
12107 ($a,$b,$c) = ($x); again, once $a has been modified, its value
12108 won't be used again.
12110 B: If LHS are all 'my' lexical var declarations (or safe ops, which
12113 my ($a, $b, @c) = ...;
12115 Due to closure and goto tricks, these vars may already have content.
12116 For the same reason, an element on the RHS may be a lexical or package
12117 alias of one of the vars on the left, or share common elements, for
12120 my ($x,$y) = f(); # $x and $y on both sides
12121 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12126 my @a = @$ra; # elements of @a on both sides
12127 sub f { @a = 1..4; \@a }
12130 First, just consider scalar vars on LHS:
12132 RHS is safe only if (A), or in addition,
12133 * contains only lexical *scalar* vars, where neither side's
12134 lexicals have been flagged as aliases
12136 If RHS is not safe, then it's always legal to check LHS vars for
12137 RC==1, since the only RHS aliases will always be associated
12140 Note that in particular, RHS is not safe if:
12142 * it contains package scalar vars; e.g.:
12145 my ($x, $y) = (2, $x_alias);
12146 sub f { $x = 1; *x_alias = \$x; }
12148 * It contains other general elements, such as flattened or
12149 * spliced or single array or hash elements, e.g.
12152 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12156 use feature 'refaliasing';
12157 \($a[0], $a[1]) = \($y,$x);
12160 It doesn't matter if the array/hash is lexical or package.
12162 * it contains a function call that happens to be an lvalue
12163 sub which returns one or more of the above, e.g.
12174 (so a sub call on the RHS should be treated the same
12175 as having a package var on the RHS).
12177 * any other "dangerous" thing, such an op or built-in that
12178 returns one of the above, e.g. pp_preinc
12181 If RHS is not safe, what we can do however is at compile time flag
12182 that the LHS are all my declarations, and at run time check whether
12183 all the LHS have RC == 1, and if so skip the full scan.
12185 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12187 Here the issue is whether there can be elements of @a on the RHS
12188 which will get prematurely freed when @a is cleared prior to
12189 assignment. This is only a problem if the aliasing mechanism
12190 is one which doesn't increase the refcount - only if RC == 1
12191 will the RHS element be prematurely freed.
12193 Because the array/hash is being INTROed, it or its elements
12194 can't directly appear on the RHS:
12196 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12198 but can indirectly, e.g.:
12202 sub f { @a = 1..3; \@a }
12204 So if the RHS isn't safe as defined by (A), we must always
12205 mortalise and bump the ref count of any remaining RHS elements
12206 when assigning to a non-empty LHS aggregate.
12208 Lexical scalars on the RHS aren't safe if they've been involved in
12211 use feature 'refaliasing';
12214 \(my $lex) = \$pkg;
12215 my @a = ($lex,3); # equivalent to ($a[0],3)
12222 Similarly with lexical arrays and hashes on the RHS:
12236 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12237 my $a; ($a, my $b) = (....);
12239 The difference between (B) and (C) is that it is now physically
12240 possible for the LHS vars to appear on the RHS too, where they
12241 are not reference counted; but in this case, the compile-time
12242 PL_generation sweep will detect such common vars.
12244 So the rules for (C) differ from (B) in that if common vars are
12245 detected, the runtime "test RC==1" optimisation can no longer be used,
12246 and a full mark and sweep is required
12248 D: As (C), but in addition the LHS may contain package vars.
12250 Since package vars can be aliased without a corresponding refcount
12251 increase, all bets are off. It's only safe if (A). E.g.
12253 my ($x, $y) = (1,2);
12255 for $x_alias ($x) {
12256 ($x_alias, $y) = (3, $x); # whoops
12259 Ditto for LHS aggregate package vars.
12261 E: Any other dangerous ops on LHS, e.g.
12262 (f(), $a[0], @$r) = (...);
12264 this is similar to (E) in that all bets are off. In addition, it's
12265 impossible to determine at compile time whether the LHS
12266 contains a scalar or an aggregate, e.g.
12268 sub f : lvalue { @a }
12271 * ---------------------------------------------------------
12275 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12276 * that at least one of the things flagged was seen.
12280 AAS_MY_SCALAR = 0x001, /* my $scalar */
12281 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
12282 AAS_LEX_SCALAR = 0x004, /* $lexical */
12283 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
12284 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12285 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
12286 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
12287 AAS_DANGEROUS = 0x080, /* an op (other than the above)
12288 that's flagged OA_DANGEROUS */
12289 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
12290 not in any of the categories above */
12291 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
12296 /* helper function for S_aassign_scan().
12297 * check a PAD-related op for commonality and/or set its generation number.
12298 * Returns a boolean indicating whether its shared */
12301 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12303 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12304 /* lexical used in aliasing */
12308 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12310 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12317 Helper function for OPpASSIGN_COMMON* detection in rpeep().
12318 It scans the left or right hand subtree of the aassign op, and returns a
12319 set of flags indicating what sorts of things it found there.
12320 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12321 set PL_generation on lexical vars; if the latter, we see if
12322 PL_generation matches.
12323 'top' indicates whether we're recursing or at the top level.
12324 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12325 This fn will increment it by the number seen. It's not intended to
12326 be an accurate count (especially as many ops can push a variable
12327 number of SVs onto the stack); rather it's used as to test whether there
12328 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12332 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12335 bool kid_top = FALSE;
12337 /* first, look for a solitary @_ on the RHS */
12340 && (o->op_flags & OPf_KIDS)
12341 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12343 OP *kid = cUNOPo->op_first;
12344 if ( ( kid->op_type == OP_PUSHMARK
12345 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12346 && ((kid = OpSIBLING(kid)))
12347 && !OpHAS_SIBLING(kid)
12348 && kid->op_type == OP_RV2AV
12349 && !(kid->op_flags & OPf_REF)
12350 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12351 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12352 && ((kid = cUNOPx(kid)->op_first))
12353 && kid->op_type == OP_GV
12354 && cGVOPx_gv(kid) == PL_defgv
12356 flags |= AAS_DEFAV;
12359 switch (o->op_type) {
12362 return AAS_PKG_SCALAR;
12367 if (top && (o->op_flags & OPf_REF))
12368 return (o->op_private & OPpLVAL_INTRO)
12369 ? AAS_MY_AGG : AAS_LEX_AGG;
12370 return AAS_DANGEROUS;
12374 int comm = S_aassign_padcheck(aTHX_ o, rhs)
12375 ? AAS_LEX_SCALAR_COMM : 0;
12377 return (o->op_private & OPpLVAL_INTRO)
12378 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12384 if (cUNOPx(o)->op_first->op_type != OP_GV)
12385 return AAS_DANGEROUS; /* @{expr}, %{expr} */
12387 if (top && (o->op_flags & OPf_REF))
12388 return AAS_PKG_AGG;
12389 return AAS_DANGEROUS;
12393 if (cUNOPx(o)->op_first->op_type != OP_GV) {
12395 return AAS_DANGEROUS; /* ${expr} */
12397 return AAS_PKG_SCALAR; /* $pkg */
12400 if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
12401 /* "@foo = split... " optimises away the aassign and stores its
12402 * destination array in the OP_PUSHRE that precedes it.
12403 * A flattened array is always dangerous.
12406 return AAS_DANGEROUS;
12411 /* undef counts as a scalar on the RHS:
12412 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
12413 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
12417 flags = AAS_SAFE_SCALAR;
12422 /* these are all no-ops; they don't push a potentially common SV
12423 * onto the stack, so they are neither AAS_DANGEROUS nor
12424 * AAS_SAFE_SCALAR */
12427 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12432 /* these do nothing but may have children; but their children
12433 * should also be treated as top-level */
12438 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12440 flags = AAS_DANGEROUS;
12444 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
12445 && (o->op_private & OPpTARGET_MY))
12448 return S_aassign_padcheck(aTHX_ o, rhs)
12449 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12452 /* if its an unrecognised, non-dangerous op, assume that it
12453 * it the cause of at least one safe scalar */
12455 flags = AAS_SAFE_SCALAR;
12459 if (o->op_flags & OPf_KIDS) {
12461 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12462 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12468 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12469 and modify the optree to make them work inplace */
12472 S_inplace_aassign(pTHX_ OP *o) {
12474 OP *modop, *modop_pushmark;
12476 OP *oleft, *oleft_pushmark;
12478 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12480 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12482 assert(cUNOPo->op_first->op_type == OP_NULL);
12483 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12484 assert(modop_pushmark->op_type == OP_PUSHMARK);
12485 modop = OpSIBLING(modop_pushmark);
12487 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12490 /* no other operation except sort/reverse */
12491 if (OpHAS_SIBLING(modop))
12494 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12495 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12497 if (modop->op_flags & OPf_STACKED) {
12498 /* skip sort subroutine/block */
12499 assert(oright->op_type == OP_NULL);
12500 oright = OpSIBLING(oright);
12503 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12504 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12505 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12506 oleft = OpSIBLING(oleft_pushmark);
12508 /* Check the lhs is an array */
12510 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12511 || OpHAS_SIBLING(oleft)
12512 || (oleft->op_private & OPpLVAL_INTRO)
12516 /* Only one thing on the rhs */
12517 if (OpHAS_SIBLING(oright))
12520 /* check the array is the same on both sides */
12521 if (oleft->op_type == OP_RV2AV) {
12522 if (oright->op_type != OP_RV2AV
12523 || !cUNOPx(oright)->op_first
12524 || cUNOPx(oright)->op_first->op_type != OP_GV
12525 || cUNOPx(oleft )->op_first->op_type != OP_GV
12526 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12527 cGVOPx_gv(cUNOPx(oright)->op_first)
12531 else if (oright->op_type != OP_PADAV
12532 || oright->op_targ != oleft->op_targ
12536 /* This actually is an inplace assignment */
12538 modop->op_private |= OPpSORT_INPLACE;
12540 /* transfer MODishness etc from LHS arg to RHS arg */
12541 oright->op_flags = oleft->op_flags;
12543 /* remove the aassign op and the lhs */
12545 op_null(oleft_pushmark);
12546 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12547 op_null(cUNOPx(oleft)->op_first);
12553 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12554 * that potentially represent a series of one or more aggregate derefs
12555 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12556 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12557 * additional ops left in too).
12559 * The caller will have already verified that the first few ops in the
12560 * chain following 'start' indicate a multideref candidate, and will have
12561 * set 'orig_o' to the point further on in the chain where the first index
12562 * expression (if any) begins. 'orig_action' specifies what type of
12563 * beginning has already been determined by the ops between start..orig_o
12564 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12566 * 'hints' contains any hints flags that need adding (currently just
12567 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12571 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12575 UNOP_AUX_item *arg_buf = NULL;
12576 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12577 int index_skip = -1; /* don't output index arg on this action */
12579 /* similar to regex compiling, do two passes; the first pass
12580 * determines whether the op chain is convertible and calculates the
12581 * buffer size; the second pass populates the buffer and makes any
12582 * changes necessary to ops (such as moving consts to the pad on
12583 * threaded builds).
12585 * NB: for things like Coverity, note that both passes take the same
12586 * path through the logic tree (except for 'if (pass)' bits), since
12587 * both passes are following the same op_next chain; and in
12588 * particular, if it would return early on the second pass, it would
12589 * already have returned early on the first pass.
12591 for (pass = 0; pass < 2; pass++) {
12593 UV action = orig_action;
12594 OP *first_elem_op = NULL; /* first seen aelem/helem */
12595 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12596 int action_count = 0; /* number of actions seen so far */
12597 int action_ix = 0; /* action_count % (actions per IV) */
12598 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12599 bool is_last = FALSE; /* no more derefs to follow */
12600 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12601 UNOP_AUX_item *arg = arg_buf;
12602 UNOP_AUX_item *action_ptr = arg_buf;
12605 action_ptr->uv = 0;
12609 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12610 case MDEREF_HV_gvhv_helem:
12611 next_is_hash = TRUE;
12613 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12614 case MDEREF_AV_gvav_aelem:
12616 #ifdef USE_ITHREADS
12617 arg->pad_offset = cPADOPx(start)->op_padix;
12618 /* stop it being swiped when nulled */
12619 cPADOPx(start)->op_padix = 0;
12621 arg->sv = cSVOPx(start)->op_sv;
12622 cSVOPx(start)->op_sv = NULL;
12628 case MDEREF_HV_padhv_helem:
12629 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12630 next_is_hash = TRUE;
12632 case MDEREF_AV_padav_aelem:
12633 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12635 arg->pad_offset = start->op_targ;
12636 /* we skip setting op_targ = 0 for now, since the intact
12637 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12638 reset_start_targ = TRUE;
12643 case MDEREF_HV_pop_rv2hv_helem:
12644 next_is_hash = TRUE;
12646 case MDEREF_AV_pop_rv2av_aelem:
12650 NOT_REACHED; /* NOTREACHED */
12655 /* look for another (rv2av/hv; get index;
12656 * aelem/helem/exists/delele) sequence */
12661 UV index_type = MDEREF_INDEX_none;
12663 if (action_count) {
12664 /* if this is not the first lookup, consume the rv2av/hv */
12666 /* for N levels of aggregate lookup, we normally expect
12667 * that the first N-1 [ah]elem ops will be flagged as
12668 * /DEREF (so they autovivifiy if necessary), and the last
12669 * lookup op not to be.
12670 * For other things (like @{$h{k1}{k2}}) extra scope or
12671 * leave ops can appear, so abandon the effort in that
12673 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12676 /* rv2av or rv2hv sKR/1 */
12678 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12679 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12680 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12683 /* at this point, we wouldn't expect any of these
12684 * possible private flags:
12685 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12686 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12688 ASSUME(!(o->op_private &
12689 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12691 hints = (o->op_private & OPpHINT_STRICT_REFS);
12693 /* make sure the type of the previous /DEREF matches the
12694 * type of the next lookup */
12695 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12698 action = next_is_hash
12699 ? MDEREF_HV_vivify_rv2hv_helem
12700 : MDEREF_AV_vivify_rv2av_aelem;
12704 /* if this is the second pass, and we're at the depth where
12705 * previously we encountered a non-simple index expression,
12706 * stop processing the index at this point */
12707 if (action_count != index_skip) {
12709 /* look for one or more simple ops that return an array
12710 * index or hash key */
12712 switch (o->op_type) {
12714 /* it may be a lexical var index */
12715 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12716 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12717 ASSUME(!(o->op_private &
12718 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12720 if ( OP_GIMME(o,0) == G_SCALAR
12721 && !(o->op_flags & (OPf_REF|OPf_MOD))
12722 && o->op_private == 0)
12725 arg->pad_offset = o->op_targ;
12727 index_type = MDEREF_INDEX_padsv;
12733 if (next_is_hash) {
12734 /* it's a constant hash index */
12735 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12736 /* "use constant foo => FOO; $h{+foo}" for
12737 * some weird FOO, can leave you with constants
12738 * that aren't simple strings. It's not worth
12739 * the extra hassle for those edge cases */
12744 OP * helem_op = o->op_next;
12746 ASSUME( helem_op->op_type == OP_HELEM
12747 || helem_op->op_type == OP_NULL);
12748 if (helem_op->op_type == OP_HELEM) {
12749 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12750 if ( helem_op->op_private & OPpLVAL_INTRO
12751 || rop->op_type != OP_RV2HV
12755 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12757 #ifdef USE_ITHREADS
12758 /* Relocate sv to the pad for thread safety */
12759 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12760 arg->pad_offset = o->op_targ;
12763 arg->sv = cSVOPx_sv(o);
12768 /* it's a constant array index */
12770 SV *ix_sv = cSVOPo->op_sv;
12775 if ( action_count == 0
12778 && ( action == MDEREF_AV_padav_aelem
12779 || action == MDEREF_AV_gvav_aelem)
12781 maybe_aelemfast = TRUE;
12785 SvREFCNT_dec_NN(cSVOPo->op_sv);
12789 /* we've taken ownership of the SV */
12790 cSVOPo->op_sv = NULL;
12792 index_type = MDEREF_INDEX_const;
12797 /* it may be a package var index */
12799 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12800 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12801 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12802 || o->op_private != 0
12807 if (kid->op_type != OP_RV2SV)
12810 ASSUME(!(kid->op_flags &
12811 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12812 |OPf_SPECIAL|OPf_PARENS)));
12813 ASSUME(!(kid->op_private &
12815 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12816 |OPpDEREF|OPpLVAL_INTRO)));
12817 if( (kid->op_flags &~ OPf_PARENS)
12818 != (OPf_WANT_SCALAR|OPf_KIDS)
12819 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12824 #ifdef USE_ITHREADS
12825 arg->pad_offset = cPADOPx(o)->op_padix;
12826 /* stop it being swiped when nulled */
12827 cPADOPx(o)->op_padix = 0;
12829 arg->sv = cSVOPx(o)->op_sv;
12830 cSVOPo->op_sv = NULL;
12834 index_type = MDEREF_INDEX_gvsv;
12839 } /* action_count != index_skip */
12841 action |= index_type;
12844 /* at this point we have either:
12845 * * detected what looks like a simple index expression,
12846 * and expect the next op to be an [ah]elem, or
12847 * an nulled [ah]elem followed by a delete or exists;
12848 * * found a more complex expression, so something other
12849 * than the above follows.
12852 /* possibly an optimised away [ah]elem (where op_next is
12853 * exists or delete) */
12854 if (o->op_type == OP_NULL)
12857 /* at this point we're looking for an OP_AELEM, OP_HELEM,
12858 * OP_EXISTS or OP_DELETE */
12860 /* if something like arybase (a.k.a $[ ) is in scope,
12861 * abandon optimisation attempt */
12862 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12863 && PL_check[o->op_type] != Perl_ck_null)
12866 if ( o->op_type != OP_AELEM
12867 || (o->op_private &
12868 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12870 maybe_aelemfast = FALSE;
12872 /* look for aelem/helem/exists/delete. If it's not the last elem
12873 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12874 * flags; if it's the last, then it mustn't have
12875 * OPpDEREF_AV/HV, but may have lots of other flags, like
12876 * OPpLVAL_INTRO etc
12879 if ( index_type == MDEREF_INDEX_none
12880 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
12881 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12885 /* we have aelem/helem/exists/delete with valid simple index */
12887 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12888 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
12889 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12892 ASSUME(!(o->op_flags &
12893 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12894 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12896 ok = (o->op_flags &~ OPf_PARENS)
12897 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12898 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12900 else if (o->op_type == OP_EXISTS) {
12901 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12902 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12903 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12904 ok = !(o->op_private & ~OPpARG1_MASK);
12906 else if (o->op_type == OP_DELETE) {
12907 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12908 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12909 ASSUME(!(o->op_private &
12910 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12911 /* don't handle slices or 'local delete'; the latter
12912 * is fairly rare, and has a complex runtime */
12913 ok = !(o->op_private & ~OPpARG1_MASK);
12914 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12915 /* skip handling run-tome error */
12916 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12919 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12920 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12921 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12922 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12923 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12924 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12929 if (!first_elem_op)
12933 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12938 action |= MDEREF_FLAG_last;
12942 /* at this point we have something that started
12943 * promisingly enough (with rv2av or whatever), but failed
12944 * to find a simple index followed by an
12945 * aelem/helem/exists/delete. If this is the first action,
12946 * give up; but if we've already seen at least one
12947 * aelem/helem, then keep them and add a new action with
12948 * MDEREF_INDEX_none, which causes it to do the vivify
12949 * from the end of the previous lookup, and do the deref,
12950 * but stop at that point. So $a[0][expr] will do one
12951 * av_fetch, vivify and deref, then continue executing at
12956 index_skip = action_count;
12957 action |= MDEREF_FLAG_last;
12961 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12964 /* if there's no space for the next action, create a new slot
12965 * for it *before* we start adding args for that action */
12966 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12973 } /* while !is_last */
12981 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12982 if (index_skip == -1) {
12983 mderef->op_flags = o->op_flags
12984 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12985 if (o->op_type == OP_EXISTS)
12986 mderef->op_private = OPpMULTIDEREF_EXISTS;
12987 else if (o->op_type == OP_DELETE)
12988 mderef->op_private = OPpMULTIDEREF_DELETE;
12990 mderef->op_private = o->op_private
12991 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12993 /* accumulate strictness from every level (although I don't think
12994 * they can actually vary) */
12995 mderef->op_private |= hints;
12997 /* integrate the new multideref op into the optree and the
13000 * In general an op like aelem or helem has two child
13001 * sub-trees: the aggregate expression (a_expr) and the
13002 * index expression (i_expr):
13008 * The a_expr returns an AV or HV, while the i-expr returns an
13009 * index. In general a multideref replaces most or all of a
13010 * multi-level tree, e.g.
13026 * With multideref, all the i_exprs will be simple vars or
13027 * constants, except that i_expr1 may be arbitrary in the case
13028 * of MDEREF_INDEX_none.
13030 * The bottom-most a_expr will be either:
13031 * 1) a simple var (so padXv or gv+rv2Xv);
13032 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
13033 * so a simple var with an extra rv2Xv;
13034 * 3) or an arbitrary expression.
13036 * 'start', the first op in the execution chain, will point to
13037 * 1),2): the padXv or gv op;
13038 * 3): the rv2Xv which forms the last op in the a_expr
13039 * execution chain, and the top-most op in the a_expr
13042 * For all cases, the 'start' node is no longer required,
13043 * but we can't free it since one or more external nodes
13044 * may point to it. E.g. consider
13045 * $h{foo} = $a ? $b : $c
13046 * Here, both the op_next and op_other branches of the
13047 * cond_expr point to the gv[*h] of the hash expression, so
13048 * we can't free the 'start' op.
13050 * For expr->[...], we need to save the subtree containing the
13051 * expression; for the other cases, we just need to save the
13053 * So in all cases, we null the start op and keep it around by
13054 * making it the child of the multideref op; for the expr->
13055 * case, the expr will be a subtree of the start node.
13057 * So in the simple 1,2 case the optree above changes to
13063 * ex-gv (or ex-padxv)
13065 * with the op_next chain being
13067 * -> ex-gv -> multideref -> op-following-ex-exists ->
13069 * In the 3 case, we have
13082 * -> rest-of-a_expr subtree ->
13083 * ex-rv2xv -> multideref -> op-following-ex-exists ->
13086 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13087 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13088 * multideref attached as the child, e.g.
13094 * ex-rv2av - i_expr1
13102 /* if we free this op, don't free the pad entry */
13103 if (reset_start_targ)
13104 start->op_targ = 0;
13107 /* Cut the bit we need to save out of the tree and attach to
13108 * the multideref op, then free the rest of the tree */
13110 /* find parent of node to be detached (for use by splice) */
13112 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
13113 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13115 /* there is an arbitrary expression preceding us, e.g.
13116 * expr->[..]? so we need to save the 'expr' subtree */
13117 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13118 p = cUNOPx(p)->op_first;
13119 ASSUME( start->op_type == OP_RV2AV
13120 || start->op_type == OP_RV2HV);
13123 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13124 * above for exists/delete. */
13125 while ( (p->op_flags & OPf_KIDS)
13126 && cUNOPx(p)->op_first != start
13128 p = cUNOPx(p)->op_first;
13130 ASSUME(cUNOPx(p)->op_first == start);
13132 /* detach from main tree, and re-attach under the multideref */
13133 op_sibling_splice(mderef, NULL, 0,
13134 op_sibling_splice(p, NULL, 1, NULL));
13137 start->op_next = mderef;
13139 mderef->op_next = index_skip == -1 ? o->op_next : o;
13141 /* excise and free the original tree, and replace with
13142 * the multideref op */
13143 p = op_sibling_splice(top_op, NULL, -1, mderef);
13152 Size_t size = arg - arg_buf;
13154 if (maybe_aelemfast && action_count == 1)
13157 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13158 sizeof(UNOP_AUX_item) * (size + 1));
13159 /* for dumping etc: store the length in a hidden first slot;
13160 * we set the op_aux pointer to the second slot */
13161 arg_buf->uv = size;
13164 } /* for (pass = ...) */
13169 /* mechanism for deferring recursion in rpeep() */
13171 #define MAX_DEFERRED 4
13175 if (defer_ix == (MAX_DEFERRED-1)) { \
13176 OP **defer = defer_queue[defer_base]; \
13177 CALL_RPEEP(*defer); \
13178 S_prune_chain_head(defer); \
13179 defer_base = (defer_base + 1) % MAX_DEFERRED; \
13182 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13185 #define IS_AND_OP(o) (o->op_type == OP_AND)
13186 #define IS_OR_OP(o) (o->op_type == OP_OR)
13189 /* A peephole optimizer. We visit the ops in the order they're to execute.
13190 * See the comments at the top of this file for more details about when
13191 * peep() is called */
13194 Perl_rpeep(pTHX_ OP *o)
13198 OP* oldoldop = NULL;
13199 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13200 int defer_base = 0;
13205 if (!o || o->op_opt)
13209 SAVEVPTR(PL_curcop);
13210 for (;; o = o->op_next) {
13211 if (o && o->op_opt)
13214 while (defer_ix >= 0) {
13216 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13217 CALL_RPEEP(*defer);
13218 S_prune_chain_head(defer);
13225 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13226 assert(!oldoldop || oldoldop->op_next == oldop);
13227 assert(!oldop || oldop->op_next == o);
13229 /* By default, this op has now been optimised. A couple of cases below
13230 clear this again. */
13234 /* look for a series of 1 or more aggregate derefs, e.g.
13235 * $a[1]{foo}[$i]{$k}
13236 * and replace with a single OP_MULTIDEREF op.
13237 * Each index must be either a const, or a simple variable,
13239 * First, look for likely combinations of starting ops,
13240 * corresponding to (global and lexical variants of)
13242 * $r->[...] $r->{...}
13243 * (preceding expression)->[...]
13244 * (preceding expression)->{...}
13245 * and if so, call maybe_multideref() to do a full inspection
13246 * of the op chain and if appropriate, replace with an
13254 switch (o2->op_type) {
13256 /* $pkg[..] : gv[*pkg]
13257 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
13259 /* Fail if there are new op flag combinations that we're
13260 * not aware of, rather than:
13261 * * silently failing to optimise, or
13262 * * silently optimising the flag away.
13263 * If this ASSUME starts failing, examine what new flag
13264 * has been added to the op, and decide whether the
13265 * optimisation should still occur with that flag, then
13266 * update the code accordingly. This applies to all the
13267 * other ASSUMEs in the block of code too.
13269 ASSUME(!(o2->op_flags &
13270 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13271 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13275 if (o2->op_type == OP_RV2AV) {
13276 action = MDEREF_AV_gvav_aelem;
13280 if (o2->op_type == OP_RV2HV) {
13281 action = MDEREF_HV_gvhv_helem;
13285 if (o2->op_type != OP_RV2SV)
13288 /* at this point we've seen gv,rv2sv, so the only valid
13289 * construct left is $pkg->[] or $pkg->{} */
13291 ASSUME(!(o2->op_flags & OPf_STACKED));
13292 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13293 != (OPf_WANT_SCALAR|OPf_MOD))
13296 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13297 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13298 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13300 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
13301 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13305 if (o2->op_type == OP_RV2AV) {
13306 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13309 if (o2->op_type == OP_RV2HV) {
13310 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13316 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13318 ASSUME(!(o2->op_flags &
13319 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13320 if ((o2->op_flags &
13321 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13322 != (OPf_WANT_SCALAR|OPf_MOD))
13325 ASSUME(!(o2->op_private &
13326 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13327 /* skip if state or intro, or not a deref */
13328 if ( o2->op_private != OPpDEREF_AV
13329 && o2->op_private != OPpDEREF_HV)
13333 if (o2->op_type == OP_RV2AV) {
13334 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13337 if (o2->op_type == OP_RV2HV) {
13338 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13345 /* $lex[..]: padav[@lex:1,2] sR *
13346 * or $lex{..}: padhv[%lex:1,2] sR */
13347 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13348 OPf_REF|OPf_SPECIAL)));
13349 if ((o2->op_flags &
13350 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13351 != (OPf_WANT_SCALAR|OPf_REF))
13353 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13355 /* OPf_PARENS isn't currently used in this case;
13356 * if that changes, let us know! */
13357 ASSUME(!(o2->op_flags & OPf_PARENS));
13359 /* at this point, we wouldn't expect any of the remaining
13360 * possible private flags:
13361 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13362 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13364 * OPpSLICEWARNING shouldn't affect runtime
13366 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13368 action = o2->op_type == OP_PADAV
13369 ? MDEREF_AV_padav_aelem
13370 : MDEREF_HV_padhv_helem;
13372 S_maybe_multideref(aTHX_ o, o2, action, 0);
13378 action = o2->op_type == OP_RV2AV
13379 ? MDEREF_AV_pop_rv2av_aelem
13380 : MDEREF_HV_pop_rv2hv_helem;
13383 /* (expr)->[...]: rv2av sKR/1;
13384 * (expr)->{...}: rv2hv sKR/1; */
13386 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13388 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13389 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13390 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13393 /* at this point, we wouldn't expect any of these
13394 * possible private flags:
13395 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13396 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13398 ASSUME(!(o2->op_private &
13399 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13401 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13405 S_maybe_multideref(aTHX_ o, o2, action, hints);
13414 switch (o->op_type) {
13416 PL_curcop = ((COP*)o); /* for warnings */
13419 PL_curcop = ((COP*)o); /* for warnings */
13421 /* Optimise a "return ..." at the end of a sub to just be "...".
13422 * This saves 2 ops. Before:
13423 * 1 <;> nextstate(main 1 -e:1) v ->2
13424 * 4 <@> return K ->5
13425 * 2 <0> pushmark s ->3
13426 * - <1> ex-rv2sv sK/1 ->4
13427 * 3 <#> gvsv[*cat] s ->4
13430 * - <@> return K ->-
13431 * - <0> pushmark s ->2
13432 * - <1> ex-rv2sv sK/1 ->-
13433 * 2 <$> gvsv(*cat) s ->3
13436 OP *next = o->op_next;
13437 OP *sibling = OpSIBLING(o);
13438 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13439 && OP_TYPE_IS(sibling, OP_RETURN)
13440 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13441 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13442 ||OP_TYPE_IS(sibling->op_next->op_next,
13444 && cUNOPx(sibling)->op_first == next
13445 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13448 /* Look through the PUSHMARK's siblings for one that
13449 * points to the RETURN */
13450 OP *top = OpSIBLING(next);
13451 while (top && top->op_next) {
13452 if (top->op_next == sibling) {
13453 top->op_next = sibling->op_next;
13454 o->op_next = next->op_next;
13457 top = OpSIBLING(top);
13462 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13464 * This latter form is then suitable for conversion into padrange
13465 * later on. Convert:
13467 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13471 * nextstate1 -> listop -> nextstate3
13473 * pushmark -> padop1 -> padop2
13475 if (o->op_next && (
13476 o->op_next->op_type == OP_PADSV
13477 || o->op_next->op_type == OP_PADAV
13478 || o->op_next->op_type == OP_PADHV
13480 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13481 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13482 && o->op_next->op_next->op_next && (
13483 o->op_next->op_next->op_next->op_type == OP_PADSV
13484 || o->op_next->op_next->op_next->op_type == OP_PADAV
13485 || o->op_next->op_next->op_next->op_type == OP_PADHV
13487 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13488 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13489 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13490 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13492 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13495 ns2 = pad1->op_next;
13496 pad2 = ns2->op_next;
13497 ns3 = pad2->op_next;
13499 /* we assume here that the op_next chain is the same as
13500 * the op_sibling chain */
13501 assert(OpSIBLING(o) == pad1);
13502 assert(OpSIBLING(pad1) == ns2);
13503 assert(OpSIBLING(ns2) == pad2);
13504 assert(OpSIBLING(pad2) == ns3);
13506 /* excise and delete ns2 */
13507 op_sibling_splice(NULL, pad1, 1, NULL);
13510 /* excise pad1 and pad2 */
13511 op_sibling_splice(NULL, o, 2, NULL);
13513 /* create new listop, with children consisting of:
13514 * a new pushmark, pad1, pad2. */
13515 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13516 newop->op_flags |= OPf_PARENS;
13517 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13519 /* insert newop between o and ns3 */
13520 op_sibling_splice(NULL, o, 0, newop);
13522 /*fixup op_next chain */
13523 newpm = cUNOPx(newop)->op_first; /* pushmark */
13524 o ->op_next = newpm;
13525 newpm->op_next = pad1;
13526 pad1 ->op_next = pad2;
13527 pad2 ->op_next = newop; /* listop */
13528 newop->op_next = ns3;
13530 /* Ensure pushmark has this flag if padops do */
13531 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13532 newpm->op_flags |= OPf_MOD;
13538 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13539 to carry two labels. For now, take the easier option, and skip
13540 this optimisation if the first NEXTSTATE has a label. */
13541 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13542 OP *nextop = o->op_next;
13543 while (nextop && nextop->op_type == OP_NULL)
13544 nextop = nextop->op_next;
13546 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13549 oldop->op_next = nextop;
13551 /* Skip (old)oldop assignment since the current oldop's
13552 op_next already points to the next op. */
13559 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13560 if (o->op_next->op_private & OPpTARGET_MY) {
13561 if (o->op_flags & OPf_STACKED) /* chained concats */
13562 break; /* ignore_optimization */
13564 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13565 o->op_targ = o->op_next->op_targ;
13566 o->op_next->op_targ = 0;
13567 o->op_private |= OPpTARGET_MY;
13570 op_null(o->op_next);
13574 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13575 break; /* Scalar stub must produce undef. List stub is noop */
13579 if (o->op_targ == OP_NEXTSTATE
13580 || o->op_targ == OP_DBSTATE)
13582 PL_curcop = ((COP*)o);
13584 /* XXX: We avoid setting op_seq here to prevent later calls
13585 to rpeep() from mistakenly concluding that optimisation
13586 has already occurred. This doesn't fix the real problem,
13587 though (See 20010220.007). AMS 20010719 */
13588 /* op_seq functionality is now replaced by op_opt */
13596 oldop->op_next = o->op_next;
13610 convert repeat into a stub with no kids.
13612 if (o->op_next->op_type == OP_CONST
13613 || ( o->op_next->op_type == OP_PADSV
13614 && !(o->op_next->op_private & OPpLVAL_INTRO))
13615 || ( o->op_next->op_type == OP_GV
13616 && o->op_next->op_next->op_type == OP_RV2SV
13617 && !(o->op_next->op_next->op_private
13618 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13620 const OP *kid = o->op_next->op_next;
13621 if (o->op_next->op_type == OP_GV)
13622 kid = kid->op_next;
13623 /* kid is now the ex-list. */
13624 if (kid->op_type == OP_NULL
13625 && (kid = kid->op_next)->op_type == OP_CONST
13626 /* kid is now the repeat count. */
13627 && kid->op_next->op_type == OP_REPEAT
13628 && kid->op_next->op_private & OPpREPEAT_DOLIST
13629 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13630 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13632 o = kid->op_next; /* repeat */
13634 oldop->op_next = o;
13635 op_free(cBINOPo->op_first);
13636 op_free(cBINOPo->op_last );
13637 o->op_flags &=~ OPf_KIDS;
13638 /* stub is a baseop; repeat is a binop */
13639 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13640 OpTYPE_set(o, OP_STUB);
13646 /* Convert a series of PAD ops for my vars plus support into a
13647 * single padrange op. Basically
13649 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13651 * becomes, depending on circumstances, one of
13653 * padrange ----------------------------------> (list) -> rest
13654 * padrange --------------------------------------------> rest
13656 * where all the pad indexes are sequential and of the same type
13658 * We convert the pushmark into a padrange op, then skip
13659 * any other pad ops, and possibly some trailing ops.
13660 * Note that we don't null() the skipped ops, to make it
13661 * easier for Deparse to undo this optimisation (and none of
13662 * the skipped ops are holding any resourses). It also makes
13663 * it easier for find_uninit_var(), as it can just ignore
13664 * padrange, and examine the original pad ops.
13668 OP *followop = NULL; /* the op that will follow the padrange op */
13671 PADOFFSET base = 0; /* init only to stop compiler whining */
13672 bool gvoid = 0; /* init only to stop compiler whining */
13673 bool defav = 0; /* seen (...) = @_ */
13674 bool reuse = 0; /* reuse an existing padrange op */
13676 /* look for a pushmark -> gv[_] -> rv2av */
13681 if ( p->op_type == OP_GV
13682 && cGVOPx_gv(p) == PL_defgv
13683 && (rv2av = p->op_next)
13684 && rv2av->op_type == OP_RV2AV
13685 && !(rv2av->op_flags & OPf_REF)
13686 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13687 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13689 q = rv2av->op_next;
13690 if (q->op_type == OP_NULL)
13692 if (q->op_type == OP_PUSHMARK) {
13702 /* scan for PAD ops */
13704 for (p = p->op_next; p; p = p->op_next) {
13705 if (p->op_type == OP_NULL)
13708 if (( p->op_type != OP_PADSV
13709 && p->op_type != OP_PADAV
13710 && p->op_type != OP_PADHV
13712 /* any private flag other than INTRO? e.g. STATE */
13713 || (p->op_private & ~OPpLVAL_INTRO)
13717 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13719 if ( p->op_type == OP_PADAV
13721 && p->op_next->op_type == OP_CONST
13722 && p->op_next->op_next
13723 && p->op_next->op_next->op_type == OP_AELEM
13727 /* for 1st padop, note what type it is and the range
13728 * start; for the others, check that it's the same type
13729 * and that the targs are contiguous */
13731 intro = (p->op_private & OPpLVAL_INTRO);
13733 gvoid = OP_GIMME(p,0) == G_VOID;
13736 if ((p->op_private & OPpLVAL_INTRO) != intro)
13738 /* Note that you'd normally expect targs to be
13739 * contiguous in my($a,$b,$c), but that's not the case
13740 * when external modules start doing things, e.g.
13741 * Function::Parameters */
13742 if (p->op_targ != base + count)
13744 assert(p->op_targ == base + count);
13745 /* Either all the padops or none of the padops should
13746 be in void context. Since we only do the optimisa-
13747 tion for av/hv when the aggregate itself is pushed
13748 on to the stack (one item), there is no need to dis-
13749 tinguish list from scalar context. */
13750 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13754 /* for AV, HV, only when we're not flattening */
13755 if ( p->op_type != OP_PADSV
13757 && !(p->op_flags & OPf_REF)
13761 if (count >= OPpPADRANGE_COUNTMASK)
13764 /* there's a biggest base we can fit into a
13765 * SAVEt_CLEARPADRANGE in pp_padrange.
13766 * (The sizeof() stuff will be constant-folded, and is
13767 * intended to avoid getting "comparison is always false"
13768 * compiler warnings. See the comments above
13769 * MEM_WRAP_CHECK for more explanation on why we do this
13770 * in a weird way to avoid compiler warnings.)
13773 && (8*sizeof(base) >
13774 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13776 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13778 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13782 /* Success! We've got another valid pad op to optimise away */
13784 followop = p->op_next;
13787 if (count < 1 || (count == 1 && !defav))
13790 /* pp_padrange in specifically compile-time void context
13791 * skips pushing a mark and lexicals; in all other contexts
13792 * (including unknown till runtime) it pushes a mark and the
13793 * lexicals. We must be very careful then, that the ops we
13794 * optimise away would have exactly the same effect as the
13796 * In particular in void context, we can only optimise to
13797 * a padrange if we see the complete sequence
13798 * pushmark, pad*v, ...., list
13799 * which has the net effect of leaving the markstack as it
13800 * was. Not pushing onto the stack (whereas padsv does touch
13801 * the stack) makes no difference in void context.
13805 if (followop->op_type == OP_LIST
13806 && OP_GIMME(followop,0) == G_VOID
13809 followop = followop->op_next; /* skip OP_LIST */
13811 /* consolidate two successive my(...);'s */
13814 && oldoldop->op_type == OP_PADRANGE
13815 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13816 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13817 && !(oldoldop->op_flags & OPf_SPECIAL)
13820 assert(oldoldop->op_next == oldop);
13821 assert( oldop->op_type == OP_NEXTSTATE
13822 || oldop->op_type == OP_DBSTATE);
13823 assert(oldop->op_next == o);
13826 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13828 /* Do not assume pad offsets for $c and $d are con-
13833 if ( oldoldop->op_targ + old_count == base
13834 && old_count < OPpPADRANGE_COUNTMASK - count) {
13835 base = oldoldop->op_targ;
13836 count += old_count;
13841 /* if there's any immediately following singleton
13842 * my var's; then swallow them and the associated
13844 * my ($a,$b); my $c; my $d;
13846 * my ($a,$b,$c,$d);
13849 while ( ((p = followop->op_next))
13850 && ( p->op_type == OP_PADSV
13851 || p->op_type == OP_PADAV
13852 || p->op_type == OP_PADHV)
13853 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13854 && (p->op_private & OPpLVAL_INTRO) == intro
13855 && !(p->op_private & ~OPpLVAL_INTRO)
13857 && ( p->op_next->op_type == OP_NEXTSTATE
13858 || p->op_next->op_type == OP_DBSTATE)
13859 && count < OPpPADRANGE_COUNTMASK
13860 && base + count == p->op_targ
13863 followop = p->op_next;
13871 assert(oldoldop->op_type == OP_PADRANGE);
13872 oldoldop->op_next = followop;
13873 oldoldop->op_private = (intro | count);
13879 /* Convert the pushmark into a padrange.
13880 * To make Deparse easier, we guarantee that a padrange was
13881 * *always* formerly a pushmark */
13882 assert(o->op_type == OP_PUSHMARK);
13883 o->op_next = followop;
13884 OpTYPE_set(o, OP_PADRANGE);
13886 /* bit 7: INTRO; bit 6..0: count */
13887 o->op_private = (intro | count);
13888 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13889 | gvoid * OPf_WANT_VOID
13890 | (defav ? OPf_SPECIAL : 0));
13898 /* Skip over state($x) in void context. */
13899 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13900 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13902 oldop->op_next = o->op_next;
13903 goto redo_nextstate;
13905 if (o->op_type != OP_PADAV)
13909 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13910 OP* const pop = (o->op_type == OP_PADAV) ?
13911 o->op_next : o->op_next->op_next;
13913 if (pop && pop->op_type == OP_CONST &&
13914 ((PL_op = pop->op_next)) &&
13915 pop->op_next->op_type == OP_AELEM &&
13916 !(pop->op_next->op_private &
13917 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13918 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13921 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13922 no_bareword_allowed(pop);
13923 if (o->op_type == OP_GV)
13924 op_null(o->op_next);
13925 op_null(pop->op_next);
13927 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13928 o->op_next = pop->op_next->op_next;
13929 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13930 o->op_private = (U8)i;
13931 if (o->op_type == OP_GV) {
13934 o->op_type = OP_AELEMFAST;
13937 o->op_type = OP_AELEMFAST_LEX;
13939 if (o->op_type != OP_GV)
13943 /* Remove $foo from the op_next chain in void context. */
13945 && ( o->op_next->op_type == OP_RV2SV
13946 || o->op_next->op_type == OP_RV2AV
13947 || o->op_next->op_type == OP_RV2HV )
13948 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13949 && !(o->op_next->op_private & OPpLVAL_INTRO))
13951 oldop->op_next = o->op_next->op_next;
13952 /* Reprocess the previous op if it is a nextstate, to
13953 allow double-nextstate optimisation. */
13955 if (oldop->op_type == OP_NEXTSTATE) {
13962 o = oldop->op_next;
13965 else if (o->op_next->op_type == OP_RV2SV) {
13966 if (!(o->op_next->op_private & OPpDEREF)) {
13967 op_null(o->op_next);
13968 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13970 o->op_next = o->op_next->op_next;
13971 OpTYPE_set(o, OP_GVSV);
13974 else if (o->op_next->op_type == OP_READLINE
13975 && o->op_next->op_next->op_type == OP_CONCAT
13976 && (o->op_next->op_next->op_flags & OPf_STACKED))
13978 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13979 OpTYPE_set(o, OP_RCATLINE);
13980 o->op_flags |= OPf_STACKED;
13981 op_null(o->op_next->op_next);
13982 op_null(o->op_next);
13987 #define HV_OR_SCALARHV(op) \
13988 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13990 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13991 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
13992 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
13993 ? cUNOPx(op)->op_first \
13997 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13998 fop->op_private |= OPpTRUEBOOL;
14004 fop = cLOGOP->op_first;
14005 sop = OpSIBLING(fop);
14006 while (cLOGOP->op_other->op_type == OP_NULL)
14007 cLOGOP->op_other = cLOGOP->op_other->op_next;
14008 while (o->op_next && ( o->op_type == o->op_next->op_type
14009 || o->op_next->op_type == OP_NULL))
14010 o->op_next = o->op_next->op_next;
14012 /* If we're an OR and our next is an AND in void context, we'll
14013 follow its op_other on short circuit, same for reverse.
14014 We can't do this with OP_DOR since if it's true, its return
14015 value is the underlying value which must be evaluated
14019 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
14020 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
14022 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14024 o->op_next = ((LOGOP*)o->op_next)->op_other;
14026 DEFER(cLOGOP->op_other);
14029 fop = HV_OR_SCALARHV(fop);
14030 if (sop) sop = HV_OR_SCALARHV(sop);
14035 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
14036 while (nop && nop->op_next) {
14037 switch (nop->op_next->op_type) {
14042 lop = nop = nop->op_next;
14045 nop = nop->op_next;
14054 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14055 || o->op_type == OP_AND )
14056 fop->op_private |= OPpTRUEBOOL;
14057 else if (!(lop->op_flags & OPf_WANT))
14058 fop->op_private |= OPpMAYBE_TRUEBOOL;
14060 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14062 sop->op_private |= OPpTRUEBOOL;
14069 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
14070 fop->op_private |= OPpTRUEBOOL;
14071 #undef HV_OR_SCALARHV
14072 /* GERONIMO! */ /* FALLTHROUGH */
14081 while (cLOGOP->op_other->op_type == OP_NULL)
14082 cLOGOP->op_other = cLOGOP->op_other->op_next;
14083 DEFER(cLOGOP->op_other);
14088 while (cLOOP->op_redoop->op_type == OP_NULL)
14089 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14090 while (cLOOP->op_nextop->op_type == OP_NULL)
14091 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14092 while (cLOOP->op_lastop->op_type == OP_NULL)
14093 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14094 /* a while(1) loop doesn't have an op_next that escapes the
14095 * loop, so we have to explicitly follow the op_lastop to
14096 * process the rest of the code */
14097 DEFER(cLOOP->op_lastop);
14101 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14102 DEFER(cLOGOPo->op_other);
14106 assert(!(cPMOP->op_pmflags & PMf_ONCE));
14107 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14108 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14109 cPMOP->op_pmstashstartu.op_pmreplstart
14110 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14111 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14117 if (o->op_flags & OPf_SPECIAL) {
14118 /* first arg is a code block */
14119 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14120 OP * kid = cUNOPx(nullop)->op_first;
14122 assert(nullop->op_type == OP_NULL);
14123 assert(kid->op_type == OP_SCOPE
14124 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14125 /* since OP_SORT doesn't have a handy op_other-style
14126 * field that can point directly to the start of the code
14127 * block, store it in the otherwise-unused op_next field
14128 * of the top-level OP_NULL. This will be quicker at
14129 * run-time, and it will also allow us to remove leading
14130 * OP_NULLs by just messing with op_nexts without
14131 * altering the basic op_first/op_sibling layout. */
14132 kid = kLISTOP->op_first;
14134 (kid->op_type == OP_NULL
14135 && ( kid->op_targ == OP_NEXTSTATE
14136 || kid->op_targ == OP_DBSTATE ))
14137 || kid->op_type == OP_STUB
14138 || kid->op_type == OP_ENTER);
14139 nullop->op_next = kLISTOP->op_next;
14140 DEFER(nullop->op_next);
14143 /* check that RHS of sort is a single plain array */
14144 oright = cUNOPo->op_first;
14145 if (!oright || oright->op_type != OP_PUSHMARK)
14148 if (o->op_private & OPpSORT_INPLACE)
14151 /* reverse sort ... can be optimised. */
14152 if (!OpHAS_SIBLING(cUNOPo)) {
14153 /* Nothing follows us on the list. */
14154 OP * const reverse = o->op_next;
14156 if (reverse->op_type == OP_REVERSE &&
14157 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14158 OP * const pushmark = cUNOPx(reverse)->op_first;
14159 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14160 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14161 /* reverse -> pushmark -> sort */
14162 o->op_private |= OPpSORT_REVERSE;
14164 pushmark->op_next = oright->op_next;
14174 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14176 LISTOP *enter, *exlist;
14178 if (o->op_private & OPpSORT_INPLACE)
14181 enter = (LISTOP *) o->op_next;
14184 if (enter->op_type == OP_NULL) {
14185 enter = (LISTOP *) enter->op_next;
14189 /* for $a (...) will have OP_GV then OP_RV2GV here.
14190 for (...) just has an OP_GV. */
14191 if (enter->op_type == OP_GV) {
14192 gvop = (OP *) enter;
14193 enter = (LISTOP *) enter->op_next;
14196 if (enter->op_type == OP_RV2GV) {
14197 enter = (LISTOP *) enter->op_next;
14203 if (enter->op_type != OP_ENTERITER)
14206 iter = enter->op_next;
14207 if (!iter || iter->op_type != OP_ITER)
14210 expushmark = enter->op_first;
14211 if (!expushmark || expushmark->op_type != OP_NULL
14212 || expushmark->op_targ != OP_PUSHMARK)
14215 exlist = (LISTOP *) OpSIBLING(expushmark);
14216 if (!exlist || exlist->op_type != OP_NULL
14217 || exlist->op_targ != OP_LIST)
14220 if (exlist->op_last != o) {
14221 /* Mmm. Was expecting to point back to this op. */
14224 theirmark = exlist->op_first;
14225 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14228 if (OpSIBLING(theirmark) != o) {
14229 /* There's something between the mark and the reverse, eg
14230 for (1, reverse (...))
14235 ourmark = ((LISTOP *)o)->op_first;
14236 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14239 ourlast = ((LISTOP *)o)->op_last;
14240 if (!ourlast || ourlast->op_next != o)
14243 rv2av = OpSIBLING(ourmark);
14244 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14245 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14246 /* We're just reversing a single array. */
14247 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14248 enter->op_flags |= OPf_STACKED;
14251 /* We don't have control over who points to theirmark, so sacrifice
14253 theirmark->op_next = ourmark->op_next;
14254 theirmark->op_flags = ourmark->op_flags;
14255 ourlast->op_next = gvop ? gvop : (OP *) enter;
14258 enter->op_private |= OPpITER_REVERSED;
14259 iter->op_private |= OPpITER_REVERSED;
14263 o = oldop->op_next;
14271 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14272 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14277 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14278 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14281 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14283 sv = newRV((SV *)PL_compcv);
14287 OpTYPE_set(o, OP_CONST);
14288 o->op_flags |= OPf_SPECIAL;
14289 cSVOPo->op_sv = sv;
14294 if (OP_GIMME(o,0) == G_VOID
14295 || ( o->op_next->op_type == OP_LINESEQ
14296 && ( o->op_next->op_next->op_type == OP_LEAVESUB
14297 || ( o->op_next->op_next->op_type == OP_RETURN
14298 && !CvLVALUE(PL_compcv)))))
14300 OP *right = cBINOP->op_first;
14319 OP *left = OpSIBLING(right);
14320 if (left->op_type == OP_SUBSTR
14321 && (left->op_private & 7) < 4) {
14323 /* cut out right */
14324 op_sibling_splice(o, NULL, 1, NULL);
14325 /* and insert it as second child of OP_SUBSTR */
14326 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14328 left->op_private |= OPpSUBSTR_REPL_FIRST;
14330 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14337 int l, r, lr, lscalars, rscalars;
14339 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14340 Note that we do this now rather than in newASSIGNOP(),
14341 since only by now are aliased lexicals flagged as such
14343 See the essay "Common vars in list assignment" above for
14344 the full details of the rationale behind all the conditions
14347 PL_generation sorcery:
14348 To detect whether there are common vars, the global var
14349 PL_generation is incremented for each assign op we scan.
14350 Then we run through all the lexical variables on the LHS,
14351 of the assignment, setting a spare slot in each of them to
14352 PL_generation. Then we scan the RHS, and if any lexicals
14353 already have that value, we know we've got commonality.
14354 Also, if the generation number is already set to
14355 PERL_INT_MAX, then the variable is involved in aliasing, so
14356 we also have potential commonality in that case.
14362 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
14365 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14369 /* After looking for things which are *always* safe, this main
14370 * if/else chain selects primarily based on the type of the
14371 * LHS, gradually working its way down from the more dangerous
14372 * to the more restrictive and thus safer cases */
14374 if ( !l /* () = ....; */
14375 || !r /* .... = (); */
14376 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14377 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14378 || (lscalars < 2) /* ($x, undef) = ... */
14380 NOOP; /* always safe */
14382 else if (l & AAS_DANGEROUS) {
14383 /* always dangerous */
14384 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14385 o->op_private |= OPpASSIGN_COMMON_AGG;
14387 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14388 /* package vars are always dangerous - too many
14389 * aliasing possibilities */
14390 if (l & AAS_PKG_SCALAR)
14391 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14392 if (l & AAS_PKG_AGG)
14393 o->op_private |= OPpASSIGN_COMMON_AGG;
14395 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14396 |AAS_LEX_SCALAR|AAS_LEX_AGG))
14398 /* LHS contains only lexicals and safe ops */
14400 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14401 o->op_private |= OPpASSIGN_COMMON_AGG;
14403 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14404 if (lr & AAS_LEX_SCALAR_COMM)
14405 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14406 else if ( !(l & AAS_LEX_SCALAR)
14407 && (r & AAS_DEFAV))
14411 * as scalar-safe for performance reasons.
14412 * (it will still have been marked _AGG if necessary */
14415 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14416 o->op_private |= OPpASSIGN_COMMON_RC1;
14421 * may have to handle aggregate on LHS, but we can't
14422 * have common scalars. */
14425 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14431 Perl_cpeep_t cpeep =
14432 XopENTRYCUSTOM(o, xop_peep);
14434 cpeep(aTHX_ o, oldop);
14439 /* did we just null the current op? If so, re-process it to handle
14440 * eliding "empty" ops from the chain */
14441 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14454 Perl_peep(pTHX_ OP *o)
14460 =head1 Custom Operators
14462 =for apidoc Ao||custom_op_xop
14463 Return the XOP structure for a given custom op. This macro should be
14464 considered internal to C<OP_NAME> and the other access macros: use them instead.
14465 This macro does call a function. Prior
14466 to 5.19.6, this was implemented as a
14473 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14479 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14481 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14482 assert(o->op_type == OP_CUSTOM);
14484 /* This is wrong. It assumes a function pointer can be cast to IV,
14485 * which isn't guaranteed, but this is what the old custom OP code
14486 * did. In principle it should be safer to Copy the bytes of the
14487 * pointer into a PV: since the new interface is hidden behind
14488 * functions, this can be changed later if necessary. */
14489 /* Change custom_op_xop if this ever happens */
14490 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14493 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14495 /* assume noone will have just registered a desc */
14496 if (!he && PL_custom_op_names &&
14497 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14502 /* XXX does all this need to be shared mem? */
14503 Newxz(xop, 1, XOP);
14504 pv = SvPV(HeVAL(he), l);
14505 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14506 if (PL_custom_op_descs &&
14507 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14509 pv = SvPV(HeVAL(he), l);
14510 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14512 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14516 xop = (XOP *)&xop_null;
14518 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14522 if(field == XOPe_xop_ptr) {
14525 const U32 flags = XopFLAGS(xop);
14526 if(flags & field) {
14528 case XOPe_xop_name:
14529 any.xop_name = xop->xop_name;
14531 case XOPe_xop_desc:
14532 any.xop_desc = xop->xop_desc;
14534 case XOPe_xop_class:
14535 any.xop_class = xop->xop_class;
14537 case XOPe_xop_peep:
14538 any.xop_peep = xop->xop_peep;
14541 NOT_REACHED; /* NOTREACHED */
14546 case XOPe_xop_name:
14547 any.xop_name = XOPd_xop_name;
14549 case XOPe_xop_desc:
14550 any.xop_desc = XOPd_xop_desc;
14552 case XOPe_xop_class:
14553 any.xop_class = XOPd_xop_class;
14555 case XOPe_xop_peep:
14556 any.xop_peep = XOPd_xop_peep;
14559 NOT_REACHED; /* NOTREACHED */
14564 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14565 * op.c: In function 'Perl_custom_op_get_field':
14566 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14567 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14568 * expands to assert(0), which expands to ((0) ? (void)0 :
14569 * __assert(...)), and gcc doesn't know that __assert can never return. */
14575 =for apidoc Ao||custom_op_register
14576 Register a custom op. See L<perlguts/"Custom Operators">.
14582 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14586 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14588 /* see the comment in custom_op_xop */
14589 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14591 if (!PL_custom_ops)
14592 PL_custom_ops = newHV();
14594 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14595 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14600 =for apidoc core_prototype
14602 This function assigns the prototype of the named core function to C<sv>, or
14603 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
14604 C<NULL> if the core function has no prototype. C<code> is a code as returned
14605 by C<keyword()>. It must not be equal to 0.
14611 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14614 int i = 0, n = 0, seen_question = 0, defgv = 0;
14616 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14617 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14618 bool nullret = FALSE;
14620 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14624 if (!sv) sv = sv_newmortal();
14626 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14628 switch (code < 0 ? -code : code) {
14629 case KEY_and : case KEY_chop: case KEY_chomp:
14630 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14631 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14632 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14633 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14634 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14635 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14636 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14637 case KEY_x : case KEY_xor :
14638 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14639 case KEY_glob: retsetpvs("_;", OP_GLOB);
14640 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
14641 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
14642 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
14643 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14644 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14646 case KEY_evalbytes:
14647 name = "entereval"; break;
14655 while (i < MAXO) { /* The slow way. */
14656 if (strEQ(name, PL_op_name[i])
14657 || strEQ(name, PL_op_desc[i]))
14659 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14666 defgv = PL_opargs[i] & OA_DEFGV;
14667 oa = PL_opargs[i] >> OASHIFT;
14669 if (oa & OA_OPTIONAL && !seen_question && (
14670 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14675 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14676 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14677 /* But globs are already references (kinda) */
14678 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14682 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14683 && !scalar_mod_type(NULL, i)) {
14688 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14692 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14693 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14694 str[n-1] = '_'; defgv = 0;
14698 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14700 sv_setpvn(sv, str, n - 1);
14701 if (opnum) *opnum = i;
14706 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14709 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14712 PERL_ARGS_ASSERT_CORESUB_OP;
14716 return op_append_elem(OP_LINESEQ,
14719 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14726 o = newUNOP(OP_AVHVSWITCH,0,argop);
14727 o->op_private = opnum-OP_EACH;
14729 case OP_SELECT: /* which represents OP_SSELECT as well */
14734 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14735 newSVOP(OP_CONST, 0, newSVuv(1))
14737 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14739 coresub_op(coreargssv, 0, OP_SELECT)
14743 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14745 return op_append_elem(
14748 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14749 ? OPpOFFBYONE << 8 : 0)
14751 case OA_BASEOP_OR_UNOP:
14752 if (opnum == OP_ENTEREVAL) {
14753 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14754 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14756 else o = newUNOP(opnum,0,argop);
14757 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14760 if (is_handle_constructor(o, 1))
14761 argop->op_private |= OPpCOREARGS_DEREF1;
14762 if (scalar_mod_type(NULL, opnum))
14763 argop->op_private |= OPpCOREARGS_SCALARMOD;
14767 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14768 if (is_handle_constructor(o, 2))
14769 argop->op_private |= OPpCOREARGS_DEREF2;
14770 if (opnum == OP_SUBSTR) {
14771 o->op_private |= OPpMAYBE_LVSUB;
14780 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14781 SV * const *new_const_svp)
14783 const char *hvname;
14784 bool is_const = !!CvCONST(old_cv);
14785 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14787 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14789 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14791 /* They are 2 constant subroutines generated from
14792 the same constant. This probably means that
14793 they are really the "same" proxy subroutine
14794 instantiated in 2 places. Most likely this is
14795 when a constant is exported twice. Don't warn.
14798 (ckWARN(WARN_REDEFINE)
14800 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14801 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14802 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14803 strEQ(hvname, "autouse"))
14807 && ckWARN_d(WARN_REDEFINE)
14808 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14811 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14813 ? "Constant subroutine %"SVf" redefined"
14814 : "Subroutine %"SVf" redefined",
14819 =head1 Hook manipulation
14821 These functions provide convenient and thread-safe means of manipulating
14828 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14830 Puts a C function into the chain of check functions for a specified op
14831 type. This is the preferred way to manipulate the L</PL_check> array.
14832 C<opcode> specifies which type of op is to be affected. C<new_checker>
14833 is a pointer to the C function that is to be added to that opcode's
14834 check chain, and C<old_checker_p> points to the storage location where a
14835 pointer to the next function in the chain will be stored. The value of
14836 C<new_pointer> is written into the L</PL_check> array, while the value
14837 previously stored there is written to C<*old_checker_p>.
14839 The function should be defined like this:
14841 static OP *new_checker(pTHX_ OP *op) { ... }
14843 It is intended to be called in this manner:
14845 new_checker(aTHX_ op)
14847 C<old_checker_p> should be defined like this:
14849 static Perl_check_t old_checker_p;
14851 L</PL_check> is global to an entire process, and a module wishing to
14852 hook op checking may find itself invoked more than once per process,
14853 typically in different threads. To handle that situation, this function
14854 is idempotent. The location C<*old_checker_p> must initially (once
14855 per process) contain a null pointer. A C variable of static duration
14856 (declared at file scope, typically also marked C<static> to give
14857 it internal linkage) will be implicitly initialised appropriately,
14858 if it does not have an explicit initialiser. This function will only
14859 actually modify the check chain if it finds C<*old_checker_p> to be null.
14860 This function is also thread safe on the small scale. It uses appropriate
14861 locking to avoid race conditions in accessing L</PL_check>.
14863 When this function is called, the function referenced by C<new_checker>
14864 must be ready to be called, except for C<*old_checker_p> being unfilled.
14865 In a threading situation, C<new_checker> may be called immediately,
14866 even before this function has returned. C<*old_checker_p> will always
14867 be appropriately set before C<new_checker> is called. If C<new_checker>
14868 decides not to do anything special with an op that it is given (which
14869 is the usual case for most uses of op check hooking), it must chain the
14870 check function referenced by C<*old_checker_p>.
14872 If you want to influence compilation of calls to a specific subroutine,
14873 then use L</cv_set_call_checker> rather than hooking checking of all
14880 Perl_wrap_op_checker(pTHX_ Optype opcode,
14881 Perl_check_t new_checker, Perl_check_t *old_checker_p)
14885 PERL_UNUSED_CONTEXT;
14886 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14887 if (*old_checker_p) return;
14888 OP_CHECK_MUTEX_LOCK;
14889 if (!*old_checker_p) {
14890 *old_checker_p = PL_check[opcode];
14891 PL_check[opcode] = new_checker;
14893 OP_CHECK_MUTEX_UNLOCK;
14898 /* Efficient sub that returns a constant scalar value. */
14900 const_sv_xsub(pTHX_ CV* cv)
14903 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14904 PERL_UNUSED_ARG(items);
14914 const_av_xsub(pTHX_ CV* cv)
14917 AV * const av = MUTABLE_AV(XSANY.any_ptr);
14925 if (SvRMAGICAL(av))
14926 Perl_croak(aTHX_ "Magical list constants are not supported");
14927 if (GIMME_V != G_ARRAY) {
14929 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14932 EXTEND(SP, AvFILLp(av)+1);
14933 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14934 XSRETURN(AvFILLp(av)+1);
14938 * ex: set ts=8 sts=4 sw=4 et: